packages feed

Agda 2.5.2 → 2.8.0

raw patch · 622 files changed

Files

Agda.cabal view
@@ -1,616 +1,1021 @@-name:            Agda-version:         2.5.2-cabal-version:   >= 1.10-build-type:      Custom-license:         OtherLicense-license-file:    LICENSE-author:          Ulf Norell, Andreas Abel, Nils Anders Danielsson, Makoto Takeyama, Catarina Coquand, with contributions by Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, James Chapman, Jesper Cockx, Dominique Devriese, Peter Divanski, Fredrik Nordvall Forsberg, Olle Fredriksson, Daniel Gustafsson, Philipp Hausmann, Patrik Jansson, Alan Jeffrey, Wolfram Kahl, Fredrik Lindblad, Francesco Mazzoli, Stefan Monnier, Darin Morrison, Guilhem Moulin, Nicolas Pouillard, Andrés Sicard-Ramírez, Andrea Vezzosi and many more.-maintainer:      Ulf Norell <ulfn@chalmers.se>-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, Epigram 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 library does not follow the package versioning-  policy, because it is not intended to be used by third-party-  packages.-tested-with:        GHC == 7.6.3-                    GHC == 7.8.4-                    GHC == 7.10.3-                    GHC == 8.0.1--extra-source-files: CHANGELOG.md-                    README.md-                    src/full/undefined.h-                    stack-7.8.4.yaml-                    stack-8.0.1.yaml--data-dir:           src/data-data-files:         Agda.css-                    agda.sty-                    emacs-mode/*.el-                    -- EpicInclude/AgdaPrelude.e-                    -- EpicInclude/stdagda.c-                    -- EpicInclude/stdagda.h-                    JS/agda-rts.js-                    JS/biginteger.js-                    lib/prim/Agda/Builtin/Bool.agda-                    lib/prim/Agda/Builtin/Char.agda-                    lib/prim/Agda/Builtin/Coinduction.agda-                    lib/prim/Agda/Builtin/Equality.agda-                    lib/prim/Agda/Builtin/Float.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/Nat.agda-                    lib/prim/Agda/Builtin/Reflection.agda-                    lib/prim/Agda/Builtin/Size.agda-                    lib/prim/Agda/Builtin/Strict.agda-                    lib/prim/Agda/Builtin/String.agda-                    lib/prim/Agda/Builtin/TrustMe.agda-                    lib/prim/Agda/Builtin/Unit.agda-                    lib/prim/Agda/Primitive.agda-                    MAlonzo/src/MAlonzo/*.hs-                    postprocess-latex.pl-                    uhc-agda-base/LICENSE-                    uhc-agda-base/src/UHC/Agda/*.hs-                    uhc-agda-base/src/UHC/Agda/double.c-                    uhc-agda-base/src/UHC/Agda/double.h-                    uhc-agda-base/uhc-agda-base.cabal--source-repository head-  type:     git-  location: https://github.com/agda/agda.git--source-repository this-  type:     git-  location: https://github.com/agda/agda/tree/v2.5.2.-  tag:      v2.5.2--flag cpphs-  default:     True-  manual:      True-  description: Use cpphs instead of cpp.--flag uhc-  default: False-  manual:  True-  description:-    Enable the UHC backend. For details, consult the Agda User Manual.--flag debug-  default: False-  manual: True-  description:-    Enable debugging features that may slow Agda down.--library-  hs-source-dirs:   src/full-  include-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.--    -- If your change the lower bound of cpphs also change it in the-    -- `.travis.yml` file [Issue #2315].-    build-tools: cpphs >= 1.20.2-    ghc-options: -pgmP cpphs -optP --cpp--  if flag(uhc)-    build-depends:  shuffle >= 0.1.3.3-                  , uhc-light >= 1.1.9.2 && < 1.2-                  , uhc-util >= 0.1.6.3 && < 0.1.6.7-                  , uulib >= 0.9.20-    -- we use the CPP processor to conditionally import the UHC Light-    -- modules. If UHC Light is not present, we instead create dummy-    -- definitions, see module Agda.Compiler.UHC.Bridge.-    cpp-options:    -DUHC_BACKEND--  if flag(debug)-    cpp-options:    -DDEBUG--  if os(windows)-    build-depends:  Win32 >= 2.2 && < 2.4--  build-depends:  array >= 0.4.0.1 && < 0.6-                , base >= 4.6.0.1 && < 4.10-                , binary >= 0.7.2.1 && < 0.9-                , boxes >= 0.1.3 && < 0.2-                , bytestring >= 0.10.0.2 && < 0.11-                , containers >= 0.5.0.0 && < 0.6-                , data-hash >= 0.2.0.0 && < 0.3-                , deepseq >= 1.3.0.1 && < 1.5-                , directory >= 1.2.0.1 && < 1.4-                , EdisonCore >= 1.3.1.1 && < 1.3.2-                , edit-distance >= 0.2.1.2 && < 0.3-                , equivalence >= 0.2.5 && < 0.4-                , filepath >= 1.3.0.1 && < 1.5-                , geniplate-mirror >= 0.6.0.6 && < 0.8-                , gitrev >= 1.2 && < 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.3-                -- 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.0.1.8 && < 1.2 || >= 1.2.0.2 && < 1.3-                , haskeline >= 0.7.1.3 && < 0.8-                , ieee754 >= 0.7.8 && < 0.8-                , monadplus >= 1.4 && < 1.5-                -- mtl-2.1 contains a severe bug.-                ---                -- mtl >= 2.2 && < 2.2.1 doesn't export Control.Monad.Except.-                , mtl >= 2.1.1 && <= 2.1.3.1 || >= 2.2.1 && < 2.3-                , murmur-hash >= 0.1 && < 0.2-                , parallel >= 3.2.0.4 && < 3.3-                -- pretty 1.1.1.2 and 1.1.1.3 do not follow the-                -- package versioning policy.-                , pretty >= 1.1.1.0 && < 1.1.1.2 || >= 1.1.2 && < 1.2-                , process >= 1.1.0.2 && < 1.5-                , regex-tdfa >= 1.2.2 && < 1.3-                , strict >= 0.3.2 && < 0.4-                , template-haskell >= 2.8.0.0 && < 2.12-                , text >= 0.11.3.1 && < 1.3-                , time >= 1.4.0.1 && < 1.7-                -- transformers 0.4.0.0 was deprecated.-                , transformers >= 0.3 && < 0.4 || >= 0.4.1.0 && < 0.6-                , transformers-compat >= 0.3.3.3 && < 0.6-                , unordered-containers >= 0.2.5.0 && < 0.3-                , xhtml >= 3000.2.1 && < 3000.3--  if impl(ghc < 7.8)-    build-depends: base-orphans >= 0.3.1 && < 0.5--  if impl(ghc < 7.10)-    build-depends: void >= 0.5.4 && < 0.9--  -- zlib >= 0.6.1 is broken with GHC < 7.10.3. See Issue 1518.-  if impl(ghc < 7.10.3)-    build-depends: zlib >= 0.4.0.1 && < 0.6.1-  else-    build-depends: zlib >= 0.4.0.1 && < 0.7--  if impl(ghc < 8.0)-    -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API-    -- for pre-GHC8-    build-depends:  fail == 4.9.*-                  , semigroups == 0.18.*--  -- Agda doesn't build with Alex 3.2.0.-  build-tools:  alex >= 3.1.0 && < 3.2.0 || >= 3.2.1 && < 3.3-              , happy >= 1.19.4 && < 2--  exposed-modules:  Agda.Auto.Auto-                    Agda.Auto.CaseSplit-                    Agda.Auto.Convert-                    Agda.Auto.NarrowingSearch-                    Agda.Auto.SearchControl-                    Agda.Auto.Syntax-                    Agda.Auto.Typecheck-                    Agda.Benchmarking-                    Agda.Compiler.CallCompiler-                    Agda.Compiler.Common-                    Agda.Compiler.Epic.AuxAST-                    Agda.Compiler.Epic.CaseOpts-                    Agda.Compiler.Epic.Compiler-                    Agda.Compiler.Epic.CompileState-                    Agda.Compiler.Epic.Epic-                    Agda.Compiler.Epic.Erasure-                    Agda.Compiler.Epic.ForceConstrs-                    Agda.Compiler.Epic.Forcing-                    Agda.Compiler.Epic.FromAgda-                    Agda.Compiler.Epic.Injection-                    Agda.Compiler.Epic.Interface-                    Agda.Compiler.Epic.NatDetection-                    Agda.Compiler.Epic.Primitive-                    Agda.Compiler.Epic.Smashing-                    Agda.Compiler.Epic.Static-                    Agda.Compiler.HaskellTypes-                    Agda.Compiler.JS.Compiler-                    Agda.Compiler.JS.Syntax-                    Agda.Compiler.JS.Substitution-                    Agda.Compiler.JS.Pretty-                    Agda.Compiler.MAlonzo.Compiler-                    Agda.Compiler.MAlonzo.Encode-                    Agda.Compiler.MAlonzo.Misc-                    Agda.Compiler.MAlonzo.Pretty-                    Agda.Compiler.MAlonzo.Primitives-                    Agda.Compiler.ToTreeless-                    Agda.Compiler.Treeless.AsPatterns-                    Agda.Compiler.Treeless.Builtin-                    Agda.Compiler.Treeless.Compare-                    Agda.Compiler.Treeless.DelayCoinduction-                    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.Compiler.UHC.Bridge-                    Agda.Compiler.UHC.Compiler-                    Agda.Compiler.UHC.CompileState-                    Agda.Compiler.UHC.FromAgda-                    Agda.Compiler.UHC.MagicTypes-                    Agda.Compiler.UHC.Pragmas.Base-                    Agda.Compiler.UHC.Pragmas.Parse-                    Agda.Compiler.UHC.Primitives-                    Agda.ImpossibleTest-                    Agda.Interaction.BasicOps-                    Agda.Interaction.SearchAbout-                    Agda.Interaction.CommandLine-                    Agda.Interaction.EmacsCommand-                    Agda.Interaction.EmacsTop-                    Agda.Interaction.FindFile-                    Agda.Interaction.Highlighting.Dot-                    Agda.Interaction.Highlighting.Emacs-                    Agda.Interaction.Highlighting.Generate-                    Agda.Interaction.Highlighting.HTML-                    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.Lenses-                    Agda.Main-                    Agda.Syntax.Abstract.Copatterns-                    Agda.Syntax.Abstract.Name-                    Agda.Syntax.Abstract.Pretty-                    Agda.Syntax.Abstract.Views-                    Agda.Syntax.Abstract-                    Agda.Syntax.Common-                    Agda.Syntax.Concrete.Definitions-                    Agda.Syntax.Concrete.Generic-                    Agda.Syntax.Concrete.Name-                    Agda.Syntax.Concrete.Operators.Parser-                    Agda.Syntax.Concrete.Operators.Parser.Monad-                    Agda.Syntax.Concrete.Operators-                    Agda.Syntax.Concrete.Pretty-                    Agda.Syntax.Concrete-                    Agda.Syntax.Fixity-                    Agda.Syntax.IdiomBrackets-                    Agda.Syntax.Info-                    Agda.Syntax.Internal-                    Agda.Syntax.Internal.Defs-                    Agda.Syntax.Internal.Generic-                    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.Inlining-                    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.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.Errors-                    Agda.TypeChecking.Free-                    Agda.TypeChecking.Free.Lazy-                    Agda.TypeChecking.Free.Old-                    Agda.TypeChecking.Forcing-                    Agda.TypeChecking.Implicit-                    Agda.TypeChecking.Injectivity-                    Agda.TypeChecking.InstanceArguments-                    Agda.TypeChecking.Irrelevance-                    Agda.TypeChecking.Level-                    Agda.TypeChecking.LevelConstraints-                    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.Env-                    Agda.TypeChecking.Monad.Exception-                    Agda.TypeChecking.Monad.Imports-                    Agda.TypeChecking.Monad.Local-                    Agda.TypeChecking.Monad.MetaVars-                    Agda.TypeChecking.Monad.Mutual-                    Agda.TypeChecking.Monad.Open-                    Agda.TypeChecking.Monad.Options-                    Agda.TypeChecking.Monad.Sharing-                    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.Patterns.Abstract-                    Agda.TypeChecking.Patterns.Match-                    Agda.TypeChecking.Polarity-                    Agda.TypeChecking.Positivity-                    Agda.TypeChecking.Positivity.Occurrence-                    Agda.TypeChecking.Pretty-                    Agda.TypeChecking.Primitive-                    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.NonLinMatch-                    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.AsPatterns-                    Agda.TypeChecking.Rules.LHS.Implicit-                    Agda.TypeChecking.Rules.LHS.Instantiate-                    Agda.TypeChecking.Rules.LHS.Problem-                    Agda.TypeChecking.Rules.LHS.ProblemRest-                    Agda.TypeChecking.Rules.LHS.Split-                    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.SizedTypes-                    Agda.TypeChecking.SizedTypes.Solve-                    Agda.TypeChecking.SizedTypes.Syntax-                    Agda.TypeChecking.SizedTypes.Utils-                    Agda.TypeChecking.SizedTypes.WarshallSolver-                    Agda.TypeChecking.Substitute-                    Agda.TypeChecking.Substitute.Class-                    Agda.TypeChecking.Substitute.DeBruijn-                    Agda.TypeChecking.SyntacticEquality-                    Agda.TypeChecking.Telescope-                    Agda.TypeChecking.Unquote-                    Agda.TypeChecking.With-                    Agda.Utils.AssocList-                    Agda.Utils.Bag-                    Agda.Utils.Benchmark-                    Agda.Utils.BiMap-                    Agda.Utils.Char-                    Agda.Utils.Cluster-                    Agda.Utils.Empty-                    Agda.Utils.Environment-                    Agda.Utils.Except-                    Agda.Utils.Either-                    Agda.Utils.Favorites-                    Agda.Utils.FileName-                    Agda.Utils.Functor-                    Agda.Utils.Function-                    Agda.Utils.Geniplate-                    Agda.Utils.Graph.AdjacencyMap.Unidirectional-                    Agda.Utils.Hash-                    Agda.Utils.HashMap-                    Agda.Utils.Haskell.Syntax-                    Agda.Utils.Impossible-                    Agda.Utils.IO.Binary-                    Agda.Utils.IO.Directory-                    Agda.Utils.IO.UTF8-                    Agda.Utils.IORef-                    Agda.Utils.Lens-                    Agda.Utils.Lens.Examples-                    Agda.Utils.List-                    Agda.Utils.ListT-                    Agda.Utils.Map-                    Agda.Utils.Maybe-                    Agda.Utils.Maybe.Strict-                    Agda.Utils.Memo-                    Agda.Utils.Monad-                    Agda.Utils.Null-                    Agda.Utils.Parser.MemoisedCPS-                    Agda.Utils.Parser.ReadP-                    Agda.Utils.PartialOrd-                    Agda.Utils.Permutation-                    Agda.Utils.Pointer-                    Agda.Utils.Pretty-                    Agda.Utils.SemiRing-                    Agda.Utils.Singleton-                    Agda.Utils.Size-                    Agda.Utils.String-                    Agda.Utils.Suffix-                    Agda.Utils.Time-                    Agda.Utils.Trie-                    Agda.Utils.Tuple-                    Agda.Utils.Update-                    Agda.Utils.VarSet-                    Agda.Utils.Warshall-                    Agda.Version-                    Agda.VersionCommit--  other-modules:    Paths_Agda--  -- Initially, we disable all the warnings.-  ghc-options: -w--  -- This option must be the first one after disabling the warnings. See-  -- Issue #2094.-  if impl(ghc >= 8.0)-    ghc-options: -Wunrecognised-warning-flags--  if impl(ghc >= 7.6.3)-    ghc-options: -fwarn-deprecated-flags-                 -fwarn-dodgy-exports-                 -fwarn-dodgy-foreign-imports-                 -fwarn-dodgy-imports-                 -fwarn-duplicate-exports-                 -fwarn-hi-shadowing-                 -fwarn-identities-                 -fwarn-incomplete-patterns-                 -fwarn-missing-fields-                 -fwarn-missing-methods-                 -fwarn-missing-signatures-                 -fwarn-tabs-                 -fwarn-overlapping-patterns-                 -fwarn-unrecognised-pragmas-                 -fwarn-unused-do-bind-                 -fwarn-warnings-deprecations-                 -fwarn-wrong-do-bind--  if impl(ghc >= 7.8)-    ghc-options: -fwarn-empty-enumerations-                 -fwarn-inline-rule-shadowing-                 -fwarn-typed-holes-                 -fwarn-overflowed-literals--  if impl(ghc >= 7.10)-     ghc-options: -fwarn-unticked-promoted-constructors-                  -- Enable after removing the support for GHC 7.8.-                  -- -fwarn-deriving-typeable--  -- This option is deprected in GHC 7.10.1.-  if impl(ghc >= 7.8) && impl(ghc < 7.10)-    ghc-options: -fwarn-amp--  -- This option will be removed in GHC 8.0.1.-  if impl(ghc >= 7.6) && impl(ghc < 8.0)-    ghc-options: -fwarn-pointless-pragmas--  -- This option will be deprected in GHC 8.0.1.-  if impl(ghc >= 7.8) && impl(ghc < 8.0)-    ghc-options: -fwarn-duplicate-constraints--  -- This option will be deprected in GHC 8.0.1.-  if impl(ghc >= 7.10) && impl(ghc < 8.0)-    ghc-options: -fwarn-context-quantification--  if impl(ghc >= 8.0)-    ghc-options: -Wmissing-pattern-synonym-signatures-                 -Wnoncanonical-monad-instances-                 -Wnoncanonical-monoid-instances-                 -Wsemigroup-                 -Wunused-foralls--  default-language: Haskell2010-  default-extensions: ConstraintKinds-                    , DataKinds-                    , DefaultSignatures-                    , DeriveFunctor-                    , DeriveFoldable-                    , DeriveTraversable-                    , ExistentialQuantification-                    , FlexibleContexts-                    , FlexibleInstances-                    , FunctionalDependencies-                    , LambdaCase-                    , MultiParamTypeClasses-                    , NamedFieldPuns-                    , RankNTypes-                    , RecordWildCards-                    , StandaloneDeriving-                    , TupleSections-                    , TypeSynonymInstances--executable agda-  hs-source-dirs: src/main-  main-is:        Main.hs-  build-depends:  Agda == 2.5.2-                  -- Nothing is used from the following package,-                  -- except for the prelude.-                , base >= 4.6.0.1 && < 6-  default-language: Haskell2010-  if impl(ghc >= 7)-    -- 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.-    ghc-options:  -rtsopts--executable agda-mode-  hs-source-dirs:   src/agda-mode-  main-is:          Main.hs-  other-modules:    Paths_Agda-  build-depends:    base >= 4.6.0.1 && < 4.10-                  , directory >= 1.2.0.1 && < 1.4-                  , filepath >= 1.3.0.1 && < 1.5-                  , process >= 1.1.0.2 && < 1.5-  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,8782 +1,639 @@-Release notes for Agda version 2.5.2-====================================--Installation and infrastructure----------------------------------* Modular support for literate programming--  Literate programming support has been moved out of the lexer and into the-  `Agda.Syntax.Parser.Literate` module.--  Files ending in `.lagda` are still interpreted as literate TeX.-  The extension `.lagda.tex` may now also be used for literate TeX files.--  Support for more literate code formats and extensions can be added-  modularly.--  By default, `.lagda.*` files are opened in the Emacs mode-  corresponding to their last extension.  One may switch to and from-  Agda mode manually.--* reStructuredText--  Literate Agda code can now be written in reStructuredText format, using-  the `.lagda.rst` extension.--  As a general rule, Agda will parse code following a line ending in `::`,-  as long as that line does not start with `..`. The module name must-  match the path of the file in the documentation, and must be given-  explicitly.  Several files have been converted already, for instance:--  - `language/mixfix-operators.lagda.rst`-  - `tools/compilers.lagda.rst`--  Note that:--  - Code blocks inside an rST comment block will be type-checked by Agda,-    but not rendered in the documentation.-  - Code blocks delimited by `.. code-block:: agda` will be rendered in-    the final documenation, but not type-checked by Agda.-  - All lines inside a codeblock must be further indented than the first line-    of the code block.-  - Indentation must be consistent between code blocks. In other-    words, the file as a whole must be a valid Agda file if all the-    literate text is replaced by white space.--* Documentation testing--  All documentation files in the `doc/user-manual` directory that end-  in `.lagda.rst` can be typechecked by running `make-  user-manual-test`, and also as part of the general test suite.--* Support installation through Stack--  The Agda sources now also include a configuration for the stack install tool-  (tested through continuous integration).--  It should hence be possible to repeatably build any future Agda version-  (including unreleased commits) from source by checking out that version and-  running `stack install` from the checkout directory.-  By using repeatable builds, this should keep selecting the same dependencies-  in the face of new releases on Hackage.--  For further motivation, see-  Issue [#2005](https://github.com/agda/agda/issues/2005).--* Removed the `--test` command-line option--  This option ran the internal test-suite. This test-suite was-  implemented using Cabal supports for-  test-suites. [Issue [#2083](https://github.com/agda/agda/issues/2083)].--* The `--no-default-libraries` flag has been split into two flags-  [Issue [#1937](https://github.com/agda/agda/issues/1937)]--  - `--no-default-libraries`: Ignore the defaults file but still look for local-    `.agda-lib` files-  - `--no-libraries`: Don't use any `.agda-lib` files (the previous behaviour-    of `--no-default-libraries`).--* If `agda` was built inside `git` repository, then the `--version` flag-  will display the hash of the commit used, and whether the tree was-  `-dirty` (i.e. there were uncommited changes in the working directory).-  Otherwise, only the version number is shown.--Language-----------* Dot patterns are now optional--  Consider the following program--  ```agda-  data Vec (A : Set) : Nat → Set where-    []   : Vec A zero-    cons : ∀ n → A → Vec A n → Vec A (suc n)--  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n-  vmap .zero    f []            = []-  vmap .(suc m) f (cons m x xs) = cons m (f x) (vmap m f xs)-  ```--  If we don't care about the dot patterns they can (and could previously) be-  replaced by wildcards:--  ```agda-  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n-  vmap _ f []            = []-  vmap _ f (cons m x xs) = cons m (f x) (vmap m f xs)-  ```--  Now it is also allowed to give a variable pattern in place of the dot-  pattern. In this case the variable will be bound to the value of the dot-  pattern. For our example:--  ```agda-  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n-  vmap n f []            = []-  vmap n f (cons m x xs) = cons m (f x) (vmap m f xs)-  ```--  In the first clause `n` reduces to `zero` and in the second clause-  `n` reduces to `suc m`.--* Module parameters can now be refined by pattern matching--  Previously, pattern matches that would refine a variable outside the-  current left-hand side was disallowed. For instance, the following-  would give an error, since matching on the vector would-  instantiate `n`.--  ```agda-  module _ {A : Set} {n : Nat} where-    f : Vec A n → Vec A n-    f []       = []-    f (x ∷ xs) = x ∷ xs-  ```--  Now this is no longer disallowed. Instead `n` is bound to the-  appropriate value in each clause.--* With-abstraction now abstracts also in module parameters--  The change that allows pattern matching to refine module parameters also-  allows with-abstraction to abstract in them. For instance,--  ```agda-  module _ (n : Nat) (xs : Vec Nat (n + n)) where-    f : Nat-    f with n + n-    f    | nn = ? -- xs : Vec Nat nn-  ```--  Note: Any function argument or lambda-bound variable bound outside a given-  function counts as a module parameter.--  To prevent abstraction in a parameter you can hide it inside a definition. In-  the above example,--  ```agda-  module _ (n : Nat) (xs : Vec Nat (n + n)) where--    ys : Vec Nat (n + n)-    ys = xs--    f : Nat-    f with n + n-    f    | nn = ? -- xs : Vec Nat nn, ys : Vec Nat (n + n)-  ```--* As-patterns [Issue [#78](https://github.com/agda/agda/issues/78)].--  As-patterns (`@`-patterns) are finally working and can be used to name a-  pattern. The name has the same scope as normal pattern variables (i.e. the-  right-hand side, where clause, and dot patterns). The name reduces to the-  value of the named pattern. For example::--  ```agda-  module _ {A : Set} (_<_ : A → A → Bool) where-    merge : List A → List A → List A-    merge xs [] = xs-    merge [] ys = ys-    merge xs@(x ∷ xs₁) ys@(y ∷ ys₁) =-      if x < y then x ∷ merge xs₁ ys-               else y ∷ merge xs ys₁-  ```--* Idiom brackets.--  There is new syntactic sugar for idiom brackets:--    `(| e a1 .. an |)` expands to--    `pure e <*> a1 <*> .. <*> an`--  The desugaring takes place before scope checking and only requires names-  `pure` and `_<*>_` in scope. Idiom brackets work well with operators, for-  instance--    `(| if a then b else c |)` desugars to--    `pure if_then_else_ <*> a <*> b <*> c`--  Limitations:--    - The top-level application inside idiom brackets cannot include-      implicit applications, so `(| foo {x = e} a b |)` is illegal. In-      the case `e` is pure you can write `(| (foo {x = e}) a b |)`-      which desugars to--        `pure (foo {x = e}) <*> a <*> b`--    - Binding syntax and operator sections cannot appear immediately inside-      idiom brackets.--* Layout for pattern matching lambdas.--  You can now write pattern matching lambdas using the syntax--  ```agda-  λ where false → true-          true  → false-  ```--  avoiding the need for explicit curly braces and semicolons.--* Overloaded projections-  [Issue [#1944](https://github.com/agda/agda/issues/1944)].--  Ambiguous projections are no longer a scope error.  Instead they get-  resolved based on the type of the record value they are-  eliminating.  This corresponds to constructors, which can be-  overloaded and get disambiguated based on the type they are-  introducing.  Example:--  ```agda-  module _ (A : Set) (a : A) where--  record R B : Set where-    field f : B-  open R public--  record S B : Set where-    field f : B-  open S public-  ```--  Exporting `f` twice from both `R` and `S` is now allowed.  Then,--  ```agda-  r : R A-  f r = a--  s : S A-  f s = f r-  ```--  disambiguates to:--  ```agda-  r : R A-  R.f r = a--  s : S A-  S.f s = R.f r-  ```--  If the type of the projection is known, it can also be disambiguated-  unapplied.--  ```agda-  unapplied : R A -> A-  unapplied = f-  ```--* Postfix projections-  [Issue [#1963](https://github.com/agda/agda/issues/1963)].--  Agda now supports a postfix syntax for projection application.-  This style is more in harmony with copatterns.  For example:--  ```agda-  record Stream (A : Set) : Set where-    coinductive-    field head : A-          tail : Stream A--  open Stream--  repeat : ∀{A} (a : A) → Stream A-  repeat a .head = a-  repeat a .tail = repeat a--  zipWith : ∀{A B C} (f : A → B → C) (s : Stream A) (t : Stream B) → Stream C-  zipWith f s t .head = f (s .head) (t .head)-  zipWith f s t .tail = zipWith f (s .tail) (t .tail)--  module Fib (Nat : Set) (zero one : Nat) (plus : Nat → Nat → Nat) where--    {-# TERMINATING #-}-    fib : Stream Nat-    fib .head = zero-    fib .tail .head = one-    fib .tail .tail = zipWith plus fib (fib .tail)-  ```--  The thing we eliminate with projection now is visibly the head,-  i.e., the left-most expression of the sequence (e.g. `repeat` in-  `repeat a .tail`).--  The syntax overlaps with dot patterns, but for type correct left-  hand sides there is no confusion: Dot patterns eliminate function-  types, while (postfix) projection patterns eliminate record types.--  By default, Agda prints system-generated projections (such as by-  eta-expansion or case splitting) prefix.  This can be changed with-  the new option:--  ```agda-  {-# OPTIONS --postfix-projections #-}-  ```--  Result splitting in extended lambdas (aka pattern lambdas) always-  produces postfix projections, as prefix projection pattern do not-  work here: a prefix projection needs to go left of the head, but the-  head is omitted in extended lambdas.--  ```agda-  dup : ∀{A : Set}(a : A) → A × A-  dup = λ{ a → ? }-  ```--  Result splitting (`C-c C-c RET`) here will yield:--  ```agda-  dup = λ{ a .proj₁ → ? ; a .proj₂ → ? }-  ```--* Projection parameters-  [Issue [#1954](https://github.com/agda/agda/issues/1954)].--  When copying a module, projection parameters will now stay hidden-  arguments, even if the module parameters are visible.-  This matches the situation we had for constructors since long.-  Example:--  ```agda-  module P (A : Set) where-    record R : Set where-      field f : A--  open module Q A = P A-  ```--  Parameter `A` is now hidden in `R.f`:--  ```agda-  test : ∀{A} → R A → A-  test r = R.f r-  ```--  Note that a module parameter that corresponds to the record value-  argument of a projection will not be hidden.--  ```agda-  module M (A : Set) (r : R A) where-    open R A r public--  test' : ∀{A} → R A → A-  test' r = M.f r-  ```--* Eager insertion of implicit arguments-  [Issue [#2001](https://github.com/agda/agda/issues/2001)]--  Implicit arguments are now (again) eagerly inserted in left-hand sides. The-  previous behaviour of inserting implicits for where blocks, but not-  right-hand sides was not type safe.--* Module applications can now be eta expanded/contracted without-  changing their behaviour-  [Issue #[1985](https://github.com/agda/agda/issues/1985)]--  Previously definitions exported using `open public` got the-  incorrect type for underapplied module applications.--  Example:--  ```agda-  module A where-    postulate A : Set--  module B (X : Set) where-    open A public--  module C₁ = B-  module C₂ (X : Set) = B X-  ```--  Here both `C₁.A` and `C₂.A` have type `(X : Set) → Set`.--* Polarity pragmas.--  Polarity pragmas can be attached to postulates. The polarities express-  how the postulate's arguments are used. The following polarities-  are available:--  `_`:  Unused.--  `++`: Strictly positive.--  `+`:  Positive.--  `-`:  Negative.--  `*`:  Unknown/mixed.--  Polarity pragmas have the form--  ```-  {-# POLARITY name <zero or more polarities> #-}-  ```--  and can be given wherever fixity declarations can be given. The-  listed polarities apply to the given postulate's arguments-  (explicit/implicit/instance), from left to right. Polarities-  currently cannot be given for module parameters. If the postulate-  takes n arguments (excluding module parameters), then the number of-  polarities given must be between 0 and n (inclusive).--  Polarity pragmas make it possible to use postulated type formers in-  recursive types in the following way:--  ```agda-  postulate-    ∥_∥ : Set → Set--  {-# POLARITY ∥_∥ ++ #-}--  data D : Set where-    c : ∥ D ∥ → D-  ```--  Note that one can use postulates that may seem benign, together with-  polarity pragmas, to prove that the empty type is inhabited:--  ```agda-  postulate-    _⇒_    : Set → Set → Set-    lambda : {A B : Set} → (A → B) → A ⇒ B-    apply  : {A B : Set} → A ⇒ B → A → B--  {-# POLARITY _⇒_ ++ #-}--  data ⊥ : Set where--  data D : Set where-    c : D ⇒ ⊥ → D--  not-inhabited : D → ⊥-  not-inhabited (c f) = apply f (c f)--  inhabited : D-  inhabited = c (lambda not-inhabited)--  bad : ⊥-  bad = not-inhabited inhabited-  ```--  Polarity pragmas are not allowed in safe mode.--* Declarations in a `where`-block are now-  private. [Issue [#2101](https://github.com/agda/agda/issues/2101)]-  This means that--  ```agda-  f ps = body where-    decls-  ```--  is now equivalent to--  ```agda-  f ps = body where-    private-      decls-  ```--  This changes little, since the `decls` were anyway not in scope-  outside `body`.  However, it makes a difference for abstract-  definitions, because private type signatures can see through-  abstract definitions.  Consider:--  ```agda-  record Wrap (A : Set) : Set where-    field unwrap : A--  postulate-    P : ∀{A : Set} → A → Set--  abstract--    unnamedWhere : (A : Set) → Set-    unnamedWhere A = A-      where  -- the following definitions are private!-      B : Set-      B = Wrap A--      postulate-        b : B-        test : P (Wrap.unwrap b)  -- succeeds-  ```--  The `abstract` is inherited in `where`-blocks from the parent (here:-  function `unnamedWhere`).  Thus, the definition of `B` is opaque and-  the type equation `B = Wrap A` cannot be used to check type-  signatures, not even of abstract definitions.  Thus, checking the-  type  `P (Wrap.unwrap b)` would fail.  However, if `test` is-  private, abstract definitions are translucent in its type, and-  checking succeeds.  With the implemented change, all-  `where`-definitions are private, in this case `B`, `b`, and `test`,-  and the example succeeds.--  Nothing changes for the named forms of `where`,--  ```agda-  module M where-  module _ where-  ```--  For instance, this still fails:--  ```agda-  abstract--    unnamedWhere : (A : Set) → Set-    unnamedWhere A = A-      module M where-      B : Set-      B = Wrap A--      postulate-        b : B-        test : P (Wrap.unwrap b)  -- fails-  ```--* Private anonymous modules now work as expected-  [Issue [#2199](https://github.com/agda/agda/issues/2199)]--  Previously the `private` was ignored for anonymous modules causing-  its definitions to be visible outside the module containing the-  anonymous module.  This is no longer the case. For instance,--  ```agda-  module M where-    private-      module _ (A : Set) where-        Id : Set-        Id = A--    foo : Set → Set-    foo = Id--  open M--  bar : Set → Set-  bar = Id -- Id is no longer in scope here-  ```--* Pattern synonyms are now expanded on left hand sides of DISPLAY-  pragmas [Issue [#2132](https://github.com/agda/agda/issues/2132)].-  Example:--  ```agda-  data D : Set where-    C c : D-    g : D → D--  pattern C′ = C--  {-# DISPLAY C′ = C′ #-}-  {-# DISPLAY g C′ = c #-}-  ```--  This now behaves as:--  ```agda-  {-# DISPLAY C = C′ #-}-  {-# DISPLAY g C = c #-}-  ```--  Expected error for--  ```agda-  test : C ≡ g C-  test = refl-  ```--  is thus:--  ```-  C′ != c of type D-  ```--* The built-in floats have new semantics to fix inconsistencies-  and to improve cross-platform portability.--  - Float equality has been split into two primitives.-    ``primFloatEquality`` is designed to establish-    decidable propositional equality while-    ``primFloatNumericalEquality`` is intended for numerical-    computations. They behave as follows:--    ```-    primFloatEquality NaN NaN = True-    primFloatEquality 0.0 -0.0 = False--    primFloatNumericalEquality NaN NaN = False-    primFloatNumericalEquality 0.0 -0.0 = True-    ```--    This change fixes an inconsistency, see [Issue [#2169](https://github.com/agda/agda/issues/2169)].-    For further detail see the [user manual](http://agda.readthedocs.io/en/latest/language/built-ins.html#floats).--  - Floats now have only one `NaN` value. This is necessary-    for proper Float support in the JavaScript backend,-    as JavaScript (and some other platforms) only support-    one `NaN` value.--  - The primitive function `primFloatLess` was renamed-    `primFloatNumericalLess`.--* Added new primitives to built-in floats:--  - `primFloatNegate : Float → Float`-    [Issue [#2194](https://github.com/agda/agda/issues/2194)]--  - Trigonometric primitives-    [Issue [#2200](https://github.com/agda/agda/issues/2200)]:--    ```agda-    primCos   : Float → Float-    primTan   : Float → Float-    primASin  : Float → Float-    primACos  : Float → Float-    primATan  : Float → Float-    primATan2 : Float → Float → Float-    ```--* Anonymous declarations-  [Issue [#1465](https://github.com/agda/agda/issues/1465)].--  A module can contain an arbitrary number of declarations-  named `_` which will scoped-checked and type-checked but-  won't be made available in the scope (nor exported). They-  cannot introduce arguments on the LHS (but one can use-  lambda-abstractions on the RHS) and they cannot be defined-  by recursion.--  ```agda-  _ : Set → Set-  _ = λ x → x-  ```--### Rewriting--* The REWRITE pragma can now handle several names.  E.g.:-  ```agda-  {-# REWRITE eq1 eq2 #-}-  ```--### Reflection--* You can now use macros in reflected terms-  [Issue [#2130](https://github.com/agda/agda/issues/2130)].--  For instance, given a macro--  ```agda-  macro-    some-tactic : Term → TC ⊤-    some-tactic = ...-  ```--  the term `def (quote some-tactic) []` represents a call to the-  macro. This makes it a lot easier to compose tactics.--* The reflection machinery now uses normalisation less often:--  * Macros no longer normalise the (automatically quoted) term-    arguments.--  * The TC primitives `inferType`, `checkType` and `quoteTC` no longer-    normalise their arguments.--  * The following deprecated constructions may also have been changed:-    `quoteGoal`, `quoteTerm`, `quoteContext` and `tactic`.--* New TC primitive: `withNormalisation`.--  To recover the old normalising behaviour of `inferType`, `checkType`,-  `quoteTC` and `getContext`, you can wrap them inside a call to-  `withNormalisation true`:--  ```agda-    withNormalisation : ∀ {a} {A : Set a} → Bool → TC A → TC A-  ```--* New TC primitive: `reduce`.--  ```agda-  reduce : Term → TC Term-  ```--  Reduces its argument to weak head normal form.--* Added new TC primitive: `isMacro`-  [Issue [#2182](https://github.com/agda/agda/issues/2182)]--  ```agda-  isMacro : Name → TC Bool-  ```--  Returns `true` if the name refers to a macro, otherwise `false`.--Type checking----------------* Files with open metas can be imported now-  [Issue [#964](https://github.com/agda/agda/issues/964)].  This-  should make simultaneous interactive development on several modules-  more pleasant.--  Requires option: `--allow-unsolved-metas`--  Internally, before serialization, open metas are turned into postulates named--  ```-    unsolved#meta.<nnn>-  ```--  where `<nnn>` is the internal meta variable number.--* The performance of the compile-time evaluator has been greatly improved.--  - Fixed a memory leak in evaluator-    (Issue [#2147](https://github.com/agda/agda/issues/2147)).--  - Reduction speed improved by an order of magnitude and is now-    comparable to the performance of GHCi. Still call-by-name though.--* The detection of types that satisfy K added in Agda 2.5.1 has been-  rolled back (see-  Issue [#2003](https://github.com/agda/agda/issues/2003)).--* Eta-equality for record types is now only on after the positivity-  checker has confirmed it is safe to have it.  Eta-equality for-  unguarded inductive records previously lead to looping of the type-  checker.-  [See Issue [#2197](https://github.com/agda/agda/issues/2197)]--  ```agda-  record R : Set where-    inductive-    field r : R--    loops : R-    loops = ?-  ```--  As a consequence of this change, the following example does not-  type-check any more:--  ```agda-  mutual-    record ⊤ : Set where--    test : ∀ {x y : ⊤} → x ≡ y-    test = refl-  ```--  It fails because the positivity checker is only run after the mutual-  block, thus, eta-equality for `⊤` is not available when checking-  test.--  One can declare eta-equality explicitly, though, to make this-  example work.--  ```agda-  mutual-    record ⊤ : Set where-      eta-equality--    test : ∀ {x y : ⊤} → x ≡ y-    test = refl-  ```--* Records with instance fields are now eta expanded before instance search.--  For instance, assuming `Eq` and `Ord` with boolean functions `_==_` and `_<_`-  respectively,--  ```agda-    record EqAndOrd (A : Set) : Set where-      field {{eq}}  : Eq A-            {{ord}} : Ord A---    leq : {A : Set} {{_ : EqAndOrd A}} → A → A → Bool-    leq x y = x == y || x < y-  ```--  Here the `EqAndOrd` record is automatically unpacked before instance search,-  revealing the component `Eq` and `Ord` instances.--  This can be used to simulate superclass dependencies.--* Overlappable record instance fields.--  Instance fields in records can be marked as overlappable using the new-  `overlap` keyword:--  ```agda-    record Ord (A : Set) : Set where-      field-        _<_ : A → A → Bool-        overlap {{eqA}} : Eq A-  ```--  When instance search finds multiple candidates for a given instance goal and-  they are **all** overlappable it will pick the left-most candidate instead of-  refusing to solve the instance goal.--  This can be use to solve the problem arising from shared "superclass"-  dependencies. For instance, if you have, in addition to `Ord` above, a `Num`-  record that also has an `Eq` field and want to write a function requiring-  both `Ord` and `Num`, any `Eq` constraint will be solved by the `Eq` instance-  from whichever argument that comes first.--  ```agda-    record Num (A : Set) : Set where-      field-        fromNat : Nat → A-        overlap {{eqA}} : Eq A--    lessOrEqualFive : {A : Set} {{NumA : Num A}} {{OrdA : Ord A}} → A → Bool-    lessOrEqualFive x = x == fromNat 5 || x < fromNat 5-  ```--  In this example the call to `_==_` will use the `eqA` field from `NumA`-  rather than the one from `OrdA`. Note that these may well be different.--* Instance fields can be left out of copattern matches-  [Issue [#2288](https://github.com/agda/agda/issues/2288)]--  Missing cases for instance fields (marked `{{` `}}`) in copattern matches-  will be solved using instance search. This makes defining instances with-  superclass fields much nicer. For instance, we can define `Nat` instances of-  `Eq`, `Ord` and `Num` from above as follows:--  ```agda-    instance-      EqNat : Eq Nat-      _==_ {{EqNat}} n m = eqNat n m--      OrdNat : Ord Nat-      _<_ {{OrdNat}} n m = lessNat n m--      NumNat : Num Nat-      fromNat {{NumNat}} n = n-  ```--  The `eqA` fields of `Ord` and `Num` are filled in using instance search (with-  `EqNat` in this case).--* Limited instance search depth-  [Issue [#2269](https://github.com/agda/agda/issues/2269)]--  To prevent instance search from looping on bad instances-  (see [Issue #1743](https://github.com/agda/agda/issues/1743)) the search-  depth of instance search is now limited. The maximum depth can be set with-  the `--instance-search-depth` flag and the default value is `500`.--Emacs mode-------------* New command `C-u C-u C-c C-n`: Use `show` to display the result of-  normalisation.--  Calling `C-u C-u C-c C-n` on an expression `e` (in a hole or at top level)-  normalises `show e` and prints the resulting string, or an error message if-  the expression does not normalise to a literal string.--  This is useful when working with complex data structures for which you have-  defined a nice `Show` instance.--  Note that the name `show` is hardwired into the command.--* Changed feature: Interactively split result.--  Make-case (`C-c C-c`) with no variables will now *either* introduce-  function arguments *or* do a copattern split (or fail).--  This is as before:--  ```agda-  test : {A B : Set} (a : A) (b : B) → A × B-  test a b = ?--  -- expected:-  -- proj₁ (test a b) = {!!}-  -- proj₂ (test a b) = {!!}--  testFun : {A B : Set} (a : A) (b : B) → A × B-  testFun = ?--  -- expected:-  -- testFun a b = {!!}-  ```--  This is has changed:--  ```agda-  record FunRec A : Set where-    field funField : A → A-  open FunRec--  testFunRec : ∀{A} → FunRec A-  testFunRec = ?--  -- expected (since 2016-05-03):-  -- funField testFunRec = {!!}--  -- used to be:-  -- funField testFunRec x = {!!}-  ```--* Changed feature: Split on hidden variables.--  Make-case (`C-c C-c`) will no longer split on the given hidden-  variables, but only make them visible. (Splitting can then be-  performed in a second go.)--  ```agda-  test : ∀{N M : Nat} → Nat → Nat → Nat-  test N M = {!.N N .M!}-  ```--  Invoking splitting will result in:--  ```agda-  test {N} {M} zero M₁ = ?-  test {N} {M} (suc N₁) M₁ = ?-  ```--  The hidden `.N` and `.M` have been brought into scope, the-  visible `N` has been split upon.--* Non-fatal errors/warnings.--  Non-fatal errors and warnings are now displayed in the info buffer-  and do not interrupt the typechecking of the file.--  Currently termination errors, unsolved metavariables, unsolved-  constraints, positivity errors, deprecated BUILTINs, and empty-  REWRITING pragmas are non-fatal errors.--* Highlighting for positivity check failures--  Negative occurences of a datatype in its definition are now-  highlighted in a way similar to termination errors.--* The abbrev for codata was replaced by an abbrev for code-  environments.--  If you type `c C-x '` (on a suitably standard setup), then Emacs-  will insert the following text:--  ```agda-  \begin{code}<newline>  <cursor><newline>\end{code}<newline>.-  ```--* The LaTeX backend can now be invoked from the Emacs mode.--  Using the compilation command (`C-c C-x C-c`).--  The flag `--latex-dir` can be used to set the output directory (by-  default: `latex`). Note that if this directory is a relative path,-  then it is interpreted relative to the "project root". (When the-  LaTeX backend is invoked from the command line the path is-  interpreted relative to the current working directory.) Example: If-  the module `A.B.C` is located in the file `/foo/A/B/C.agda`, then-  the project root is `/foo/`, and the default output directory is-  `/foo/latex/`.--* The compilation command (`C-c C-x C-c`) now by default asks for a-  backend.--  To avoid this question, set the customisation variable-  `agda2-backend` to an appropriate value.--* The command `agda2-measure-load-time` no longer "touches" the file,-  and the optional argument `DONT-TOUCH` has been removed.--* New command `C-u (C-u) C-c C-s`: Simplify or normalise the solution `C-c C-s` produces--  When writing examples, it is nice to have the hole filled in with-  a normalised version of the solution. Calling `C-c C-s` on--  ```agda-  _ : reverse (0 ∷ 1 ∷ []) ≡ ?-  _ = refl-  ```--  used to yield the non informative `reverse (0 ∷ 1 ∷ [])` when we would-  have hopped to get `1 ∷ 0 ∷ []` instead. We can now control finely the-  degree to which the solution is simplified.--* Changed feature: Solving the hole at point--  Calling `C-c C-s` inside a specific goal does not solve *all* the goals-  already instantiated internally anymore: it only solves the one at hand-  (if possible).--* New bindings: All the blackboard bold letters are now available-  [Pull Request [#2305](https://github.com/agda/agda/pull/2305)]--  The Agda input method only bound a handful of the blackboard bold letters-  but programmers were actually using more than these. They are now all-  available: lowercase and uppercase. Some previous bindings had to be-  modified for consistency. The naming scheme is as follows:--  * \bx for lowercase blackboard bold-  * \bX for uppercase blackboard bold-  * \bGx for lowercase greek blackboard bold (similar to \Gx for greeks)-  * \bGX for uppercase greek blackboard bold (similar to \GX for uppercase greeks)--* Replaced binding for go back--  Use `M-,` (instead of `M-*`) for go back in Emacs ≥ 25.1 (and-  continue using `M-*` with previous versions of Emacs).--Compiler backends--------------------* JS compiler backend--  The JavaScript backend has been (partially) rewritten. The-  JavaScript backend now supports most Agda features, notably-  copatterns can now be compiled to JavaScript. Furthermore, the-  existing optimizations from the other backends now apply to the-  JavaScript backend as well.--* GHC, JS and UHC compiler backends--  Added new primitives to built-in floats-  [Issues [#2194](https://github.com/agda/agda/issues/2194) and-  [#2200](https://github.com/agda/agda/issues/2200)]:--  ```agda-  primFloatNegate : Float → Float-  primCos         : Float → Float-  primTan         : Float → Float-  primASin        : Float → Float-  primACos        : Float → Float-  primATan        : Float → Float-  primATan2       : Float → Float → Float-  ```--LaTeX backend----------------* Code blocks are now (by default) surrounded by vertical space.-  [Issue [#2198](https://github.com/agda/agda/issues/2198)]--  Use `\AgdaNoSpaceAroundCode{}` to avoid this vertical space, and-  `\AgdaSpaceAroundCode{}` to reenable it.--  Note that, if `\AgdaNoSpaceAroundCode{}` is used, then empty lines-  before or after a code block will not necessarily lead to empty-  lines in the generated document. However, empty lines *inside* the-  code block do (by default) lead to empty lines in the output.--  If you prefer the previous behaviour, then you can use the `agda.sty`-  file that came with the previous version of Agda.--* `\AgdaHide{...}` now eats trailing spaces (using `\ignorespaces`).--* New environments: `AgdaAlign`, `AgdaSuppressSpace` and-  `AgdaMultiCode`.--  Sometimes one might want to break up a code block into multiple-  pieces, but keep code in different blocks aligned with respect to-  each other. Then one can use the `AgdaAlign` environment. Example-  usage:-  ```latex-    \begin{AgdaAlign}-    \begin{code}-      code-        code  (more code)-    \end{code}-    Explanation...-    \begin{code}-      aligned with "code"-        code  (aligned with (more code))-    \end{code}-    \end{AgdaAlign}-  ```-  Note that `AgdaAlign` environments should not be nested.--  Sometimes one might also want to hide code in the middle of a code-  block. This can be accomplished in the following way:-  ```latex-    \begin{AgdaAlign}-    \begin{code}-      visible-    \end{code}-    \AgdaHide{-    \begin{code}-      hidden-    \end{code}}-    \begin{code}-      visible-    \end{code}-    \end{AgdaAlign}-  ```-  However, the result may be ugly: extra space is perhaps inserted-  around the code blocks.--  The `AgdaSuppressSpace` environment ensures that extra space is only-  inserted before the first code block, and after the last one (but-  not if `\AgdaNoSpaceAroundCode{}` is used).--  The environment takes one argument, the number of wrapped code-  blocks (excluding hidden ones). Example usage:-  ```latex-    \begin{AgdaAlign}-    \begin{code}-      code-        more code-    \end{code}-    Explanation...-    \begin{AgdaSuppressSpace}{2}-    \begin{code}-      aligned with "code"-        aligned with "more code"-    \end{code}-    \AgdaHide{-    \begin{code}-      hidden code-    \end{code}}-    \begin{code}-        also aligned with "more code"-    \end{code}-    \end{AgdaSuppressSpace}-    \end{AgdaAlign}-  ```--  Note that `AgdaSuppressSpace` environments should not be nested.--  There is also a combined environment, `AgdaMultiCode`, that combines-  the effects of `AgdaAlign` and `AgdaSuppressSpace`.--Tools--------### agda-ghc-names--The `agda-ghc-names` now has its own repository at--  https://github.com/agda/agda-ghc-names--and is no longer distributed with Agda.--Release notes for Agda version 2.5.1.2-======================================--* Fixed broken type signatures that were incorrectly accepted due to-  [GHC #12784](https://ghc.haskell.org/trac/ghc/ticket/12784).--Release notes for Agda version 2.5.1.1-======================================--Installation and infrastructure----------------------------------* Added support for GHC 8.0.1.--* Documentation is now built with Python >=3.3, as done by-  [readthedocs.org](https://readthedocs.org/).--Bug fixes------------* Fixed a serious performance problem with instance search--  Issues [#1952](https://github.com/agda/agda/issues/1952) and-  [#1998](https://github.com/agda/agda/issues/1998). Also related:-  [#1955](https://github.com/agda/agda/issues/1955) and-  [#2025](https://github.com/agda/agda/issues/2025)--* Interactively splitting variable with `C-c C-c` no longer introduces-  new trailing patterns.  This fixes-  Issue [#1950](https://github.com/agda/agda/issues/1950).--  ```agda-  data Ty : Set where-    _⇒_ : Ty → Ty → Ty--  ⟦_⟧ : Ty → Set-  ⟦ A ⇒ B ⟧ = ⟦ A ⟧ → ⟦ B ⟧--  data Term : Ty → Set where-    K : (A B : Ty) → Term (A ⇒ (B ⇒ A))--  test : (A : Ty) (a : Term A) → ⟦ A ⟧-  test A a = {!a!}-  ```--  Before change, case splitting on `a` would give--  ```agda-  test .(A ⇒ (B ⇒ A)) (K A B) x x₁ = ?-  ```--  Now, it yields--  ```agda-  test .(A ⇒ (B ⇒ A)) (K A B) = ?-  ```--* In literate TeX files, `\begin{code}` and `\end{code}` can be-  preceded (resp. followed) by TeX code on the same line. This fixes-  Issue [#2077](https://github.com/agda/agda/issues/2077).--* Other issues fixed (see-  [bug tracker](https://github.com/agda/agda/issues)):--  [#1951](https://github.com/agda/agda/issues/1951) (mixfix binders-  not working in 'syntax')--  [#1967](https://github.com/agda/agda/issues/1967) (too eager-  insteance search error)--  [#1974](https://github.com/agda/agda/issues/1974) (lost constraint-  dependencies)--  [#1982](https://github.com/agda/agda/issues/1982) (internal error in-  unifier)--  [#2034](https://github.com/agda/agda/issues/2034) (function type-  instance goals)--Compiler backends--------------------* UHC compiler backend--  Added support for UHC 1.1.9.4.--Release notes for Agda version 2.5.1-====================================--Documentation----------------* There is now an official Agda User Manual:-  http://agda.readthedocs.org/en/stable/--Installation and infrastructure----------------------------------* Builtins and primitives are now defined in a new set of modules available to-  all users, independent of any particular library. The modules are--  ```agda-  Agda.Builtin.Bool-  Agda.Builtin.Char-  Agda.Builtin.Coinduction-  Agda.Builtin.Equality-  Agda.Builtin.Float-  Agda.Builtin.FromNat-  Agda.Builtin.FromNeg-  Agda.Builtin.FromString-  Agda.Builtin.IO-  Agda.Builtin.Int-  Agda.Builtin.List-  Agda.Builtin.Nat-  Agda.Builtin.Reflection-  Agda.Builtin.Size-  Agda.Builtin.Strict-  Agda.Builtin.String-  Agda.Builtin.TrustMe-  Agda.Builtin.Unit-  ```--  The standard library reexports the primitives from the new modules.--  The `Agda.Builtin` modules are installed in the same way as-  `Agda.Primitive`, but unlike `Agda.Primitive` they are not loaded-  automatically.--Pragmas and options----------------------* Library management--  There is a new 'library' concept for managing include paths. A library-  consists of-    - a name,-    - a set of libraries it depends on, and-    - a set of include paths.--  A library is defined in a `.agda-lib` file using the following-  format:--  ```-  name: LIBRARY-NAME  -- Comment-  depend: LIB1 LIB2-    LIB3-    LIB4-  include: PATH1-    PATH2-    PATH3-  ```--  Dependencies are library names, not paths to `.agda-lib` files, and-  include paths are relative to the location of the library-file.--  To be useable, a library file has to be listed (with its full path)-  in `AGDA_DIR/libraries` (or `AGDA_DIR/libraries-VERSION`, for a-  given Agda version). `AGDA_DIR` defaults to `~/.agda` on Unix-like-  systems and `C:/Users/USERNAME/AppData/Roaming/agda` or similar on-  Windows, and can be overridden by setting the `AGDA_DIR` environment-  variable.--  Environment variables in the paths (of the form `$VAR` or `${VAR}`)-  are expanded. The location of the libraries file used can be-  overridden using the `--library-file=FILE` flag, although this is-  not expected to be very useful.--  You can find out the precise location of the 'libraries' file by-  calling `agda -l fjdsk Dummy.agda` and looking at the error message-  (assuming you don't have a library called fjdsk installed).--  There are three ways a library gets used:--    - You supply the `--library=LIB` (or `-l LIB`) option to-      Agda. This is equivalent to adding a `-iPATH` for each of the-      include paths of `LIB` and its (transitive) dependencies.--    - No explicit `--library` flag is given, and the current project-      root (of the Agda file that is being loaded) or one of its-      parent directories contains a `.agda-lib` file defining a-      library `LIB`. This library is used as if a `--librarary=LIB`-      option had been given, except that it is not necessary for the-      library to be listed in the `AGDA_DIR/libraries` file.--    - No explicit `--library` flag, and no `.agda-lib` file in the-      project root. In this case the file `AGDA_DIR/defaults` is read-      and all libraries listed are added to the path. The defaults-      file should contain a list of library names, each on a separate-      line. In this case the current directory is also added to the-      path.--      To disable default libraries, you can give the flag-      `--no-default-libraries`.--  Library names can end with a version number (for instance,-  `mylib-1.2.3`). When resolving a library name (given in a `--library`-  flag, or listed as a default library or library dependency) the-  following rules are followed:--    - If you don't give a version number, any version will do.--    - If you give a version number an exact match is required.--    - When there are multiple matches an exact match is preferred, and-      otherwise the latest matching version is chosen.--  For example, suppose you have the following libraries installed:-  `mylib`, `mylib-1.0`, `otherlib-2.1`, and `otherlib-2.3`. In this-  case, aside from the exact matches you can also say-  `--library=otherlib` to get `otherlib-2.3`.--* New Pragma `COMPILED_DECLARE_DATA` for binding recursively defined-  Haskell data types to recursively defined Agda data types.--  If you have a Haskell type like--  ```haskell-  {-# LANGUAGE GADTs #-}--  module Issue223 where--  data A where-    BA :: B -> A--  data B where-    AB :: A -> B-    BB :: B-  ```--  You can now bind it to corresponding mutual Agda inductive data-  types as follows:--  ```agda-  {-# IMPORT Issue223 #-}--  data A : Set-  {-# COMPILED_DECLARE_DATA A Issue223.A #-}-  data B : Set-  {-# COMPILED_DECLARE_DATA B Issue223.B #-}--  data A where-    BA : B → A--  {-# COMPILED_DATA A Issue223.A Issue223.BA #-}-  data B where-    AB : A → B-    BB : B--  {-# COMPILED_DATA B Issue223.B Issue223.AB Issue223.BB #-}-  ```--  This fixes Issue [#223](https://github.com/agda/agda/issues/223).--* New pragma `HASKELL` for adding inline Haskell code (GHC backend only)--  Arbitrary Haskell code can be added to a module using the `HASKELL`-  pragma. For instance,--  ```agda-  {-# HASKELL-    echo :: IO ()-    echo = getLine >>= putStrLn-  #-}--  postulate echo : IO ⊤-  {-# COMPILED echo echo #-}-  ```--* New option `--exact-split`.--  The `--exact-split` flag causes Agda to raise an error whenever a-  clause in a definition by pattern matching cannot be made to hold-  definitionally (i.e. as a reduction rule). Specific clauses can be-  excluded from this check by means of the `{-# CATCHALL #-}` pragma.--  For instance, the following definition will be rejected as the second clause-  cannot be made to hold definitionally:--  ```agda-  min : Nat → Nat → Nat-  min zero    y       = zero-  min x       zero    = zero-  min (suc x) (suc y) = suc (min x y-  ```--  Catchall clauses have to be marked as such, for instance:--  ```agda-  eq : Nat → Nat → Bool-  eq zero    zero    = true-  eq (suc m) (suc n) = eq m n-  {-# CATCHALL #-}-  eq _       _       = false-  ```--* New option: `--no-exact-split`.--  This option can be used to override a global `--exact-split` in a-  file, by adding a pragma `{-# OPTIONS --no-exact-split #-}`.--* New options: `--sharing` and `--no-sharing`.--  These options are used to enable/disable sharing and call-by-need-  evaluation.  The default is `--no-sharing`.--  Note that they cannot appear in an OPTIONS pragma, but have to be-  given as command line arguments or added to the Agda Program Args-  from Emacs with `M-x customize-group agda2`.--* New pragma `DISPLAY`.--  ```agda-  {-# DISPLAY f e1 .. en = e #-}-  ```--  This causes `f e1 .. en` to be printed in the same way as `e`, where-  `ei` can bind variables used in `e`. The expressions `ei` and `e`-  are scope checked, but not type checked.--  For example this can be used to print overloaded (instance) functions with-  the overloaded name:--  ```agda-  instance-    NumNat : Num Nat-    NumNat = record { ..; _+_ = natPlus }--  {-# DISPLAY natPlus a b = a + b #-}-  ```--  Limitations--  - Left-hand sides are restricted to variables, constructors, defined-    functions or types, and literals. In particular, lambdas are not-    allowed in left-hand sides.--  - Since `DISPLAY` pragmas are not type checked implicit argument-    insertion may not work properly if the type of `f` computes to an-    implicit function space after pattern matching.--* Removed pragma `{-# ETA R #-}`--  The pragma `{-# ETA R #-}` is replaced by the `eta-equality` directive-  inside record declarations.--* New option `--no-eta-equality`.--  The `--no-eta-equality` flag disables eta rules for declared record-  types.  It has the same effect as `no-eta-equality` inside each-  declaration of a record type `R`.--  If used with the OPTIONS pragma it will not affect records defined-  in other modules.--* The semantics of `{-# REWRITE r #-}` pragmas in parametrized modules-  has changed (see-  Issue [#1652](https://github.com/agda/agda/issues/1652)).--  Rewrite rules are no longer lifted to the top context. Instead, they-  now only apply to terms in (extensions of) the module context. If-  you want the old behaviour, you should put the `{-# REWRITE r #-}`-  pragma outside of the module (i.e. unindent it).--* New pragma `{-# INLINE f #-}` causes `f` to be inlined during-  compilation.--* The `STATIC` pragma is now taken into account during compilation.--  Calls to a function marked `STATIC` are normalised before-  compilation. The typical use case for this is to mark the-  interpreter of an embedded language as `STATIC`.--* Option `--type-in-type` no longer implies-  `--no-universe-polymorphism`, thus, it can be used with explicit-  universe-  levels. [Issue [#1764](https://github.com/agda/agda/issues/1764)] It-  simply turns off error reporting for any level mismatch now.-  Examples:--  ```agda-  {-# OPTIONS --type-in-type #-}--  Type : Set-  Type = Set--  data D {α} (A : Set α) : Set where-    d : A → D A--  data E α β : Set β where-    e : Set α → E α β-  ```--* New `NO_POSITIVITY_CHECK` pragma to switch off the positivity checker-  for data/record definitions and mutual blocks.--  The pragma must precede a data/record definition or a mutual block.--  The pragma cannot be used in `--safe` mode.--  Examples (see `Issue1614*.agda` and `Issue1760*.agda` in-  `test/Succeed/`):--  1. Skipping a single data definition.--     ```agda-     {-# NO_POSITIVITY_CHECK #-}-     data D : Set where-       lam : (D → D) → D-     ```--  2. Skipping a single record definition.--     ```agda-     {-# NO_POSITIVITY_CHECK #-}-     record U : Set where-       field ap : U → U-     ```--  3. Skipping an old-style mutual block: Somewhere within a `mutual`-     block before a data/record definition.--     ```agda-     mutual-       data D : Set where-         lam : (D → D) → D--       {-# NO_POSITIVITY_CHECK #-}-       record U : Set where-         field ap : U → U-     ```--  4. Skipping an old-style mutual block: Before the `mutual` keyword.--     ```agda-     {-# NO_POSITIVITY_CHECK #-}-     mutual-       data D : Set where-         lam : (D → D) → D--       record U : Set where-         field ap : U → U-     ```--  5. Skipping a new-style mutual block: Anywhere before the-     declaration or the definition of data/record in the block.--     ```agda-     record U : Set-     data D   : Set--     record U where-       field ap : U → U--     {-# NO_POSITIVITY_CHECK #-}-     data D where-       lam : (D → D) → D-     ```--* Removed `--no-coverage-check`-  option. [Issue [#1918](https://github.com/agda/agda/issues/1918)]--Language-----------### Operator syntax--* The default fixity for syntax declarations has changed from -666 to 20.--* Sections.--  Operators can be sectioned by replacing arguments with underscores.-  There must not be any whitespace between these underscores and the-  adjacent nameparts. Examples:--  ```agda-  pred : ℕ → ℕ-  pred = _∸ 1--  T : Bool → Set-  T = if_then ⊤ else ⊥--  if : {A : Set} (b : Bool) → A → A → A-  if b = if b then_else_-  ```--  Sections are translated into lambda expressions. Examples:--  ```agda-  _∸ 1              ↦  λ section → section ∸ 1--  if_then ⊤ else ⊥  ↦  λ section → if section then ⊤ else ⊥--  if b then_else_   ↦  λ section section₁ →-                           if b then section else section₁-  ```--  Operator sections have the same fixity as the underlying operator-  (except in cases like `if b then_else_`, in which the section is-  "closed", but the operator is not).--  Operator sections are not supported in patterns (with the exception-  of dot patterns), and notations coming from syntax declarations-  cannot be sectioned.--* A long-standing operator fixity bug has been fixed. As a consequence-  some programs that used to parse no longer do.--  Previously each precedence level was (incorrectly) split up into-  five separate ones, ordered as follows, with the earlier ones-  binding less tightly than the later ones:--    - Non-associative operators.--    - Left associative operators.--    - Right associative operators.--    - Prefix operators.--    - Postfix operators.--  Now this problem has been addressed. It is no longer possible to mix-  operators of a given precedence level but different associativity.-  However, prefix and right associative operators are seen as having-  the same associativity, and similarly for postfix and left-  associative operators.--  Examples-  ----------  The following code is no longer accepted:--  ```agda-  infixl 6 _+_-  infix  6 _∸_--  rejected : ℕ-  rejected = 1 + 0 ∸ 1-  ```--  However, the following previously rejected code is accepted:--  ```agda-  infixr 4 _,_-  infix  4 ,_--  ,_ : {A : Set} {B : A → Set} {x : A} → B x → Σ A B-  , y = _ , y--  accepted : Σ ℕ λ i → Σ ℕ λ j → Σ (i ≡ j) λ _ → Σ ℕ λ k → j ≡ k-  accepted = 5 , , refl , , refl-  ```--* The classification of notations with binders into the categories-  infix, prefix, postfix or closed has-  changed. [Issue [#1450](https://github.com/agda/agda/issues/1450)]--  The difference is that, when classifying the notation, only-  *regular* holes are taken into account, not *binding* ones.--  Example: The notation--  ```agda-  syntax m >>= (λ x → f) = x <- m , f-  ```--  was previously treated as infix, but is now treated as prefix.--* Notation can now include wildcard binders.--  Example: `syntax Σ A (λ _ → B) = A × B`--* If an overloaded operator is in scope with several distinct-  precedence levels, then several instances of this operator will be-  included in the operator grammar, possibly leading to ambiguity.-  Previously the operator was given the default fixity-  [Issue [#1436](https://github.com/agda/agda/issues/1436)].--  There is an exception to this rule: If there are multiple precedences,-  but at most one is explicitly declared, then only one instance will be-  included in the grammar. If there are no explicitly declared-  precedences, then this instance will get the default precedence, and-  otherwise it will get the declared precedence.--  If multiple occurrences of an operator are "merged" in the grammar,-  and they have distinct associativities, then they are treated as-  being non-associative.--  The three paragraphs above also apply to identical notations (coming-  from syntax declarations) for a given overloaded name.--  Examples:--  ```agda-  module A where--    infixr 5 _∷_-    infixr 5 _∙_-    infixl 3 _+_-    infix  1 bind--    syntax bind c (λ x → d) = x ← c , d--  module B where--    infix  5 _∷_-    infixr 4 _∙_-    -- No fixity declaration for _+_.-    infixl 2 bind--    syntax bind c d = c ∙ d--  module C where--    infixr 2 bind--    syntax bind c d = c ∙ d--  open A-  open B-  open C--  -- _∷_ is infix 5.-  -- _∙_ has two fixities: infixr 4 and infixr 5.-  -- _+_ is infixl 3.-  -- A.bind's notation is infix 1.-  -- B.bind and C.bind's notations are infix 2.--  -- There is one instance of "_ ∷ _" in the grammar, and one-  -- instance of "_ + _".--  -- There are three instances of "_ ∙ _" in the grammar, one-  -- corresponding to A._∙_, one corresponding to B._∙_, and one-  -- corresponding to both B.bind and C.bind.-  ```--### Reflection--* The reflection framework has received a massive overhaul.--  A new type of reflected type checking computations supplants most of-  the old reflection primitives. The `quoteGoal`, `quoteContext` and-  tactic primitives are deprecated and will be removed in the future,-  and the `unquoteDecl` and `unquote` primitives have changed-  behaviour. Furthermore the following primitive functions have been-  replaced by builtin type checking computations:--  ```agda-  - primQNameType              --> AGDATCMGETTYPE-  - primQNameDefinition        --> AGDATCMGETDEFINITION-  - primDataConstructors       --> subsumed by AGDATCMGETDEFINITION-  - primDataNumberOfParameters --> subsumed by AGDATCMGETDEFINITION-  ```--  See below for details.--* Types are no longer packaged with a sort.--  The `AGDATYPE` and `AGDATYPEEL` built-ins have been-  removed. Reflected types are now simply terms.--* Reflected definitions have more information.--  The type for reflected definitions has changed to--  ```agda-  data Definition : Set where-    fun-def     : List Clause  → Definition-    data-type   : Nat → List Name → Definition -- parameters and constructors-    record-type : Name → Definition            -- name of the data/record type-    data-con    : Name → Definition            -- name of the constructor-    axiom       : Definition-    prim-fun    : Definition-  ```--  Correspondingly the built-ins for function, data and record-  definitions (`AGDAFUNDEF`, `AGDAFUNDEFCON`, `AGDADATADEF`,-  `AGDARECORDDEF`) have been removed.--* Reflected type checking computations.--  There is a primitive `TC` monad representing type checking-  computations. The `unquote`, `unquoteDecl`, and the new `unquoteDef`-  all expect computations in this monad (see below). The interface to-  the monad is the following--  ```agda-  -- Error messages can contain embedded names and terms.-  data ErrorPart : Set where-    strErr  : String → ErrorPart-    termErr : Term → ErrorPart-    nameErr : Name → ErrorPart--  {-# BUILTIN AGDAERRORPART       ErrorPart #-}-  {-# BUILTIN AGDAERRORPARTSTRING strErr    #-}-  {-# BUILTIN AGDAERRORPARTTERM   termErr   #-}-  {-# BUILTIN AGDAERRORPARTNAME   nameErr   #-}--  postulate-    TC         : ∀ {a} → Set a → Set a-    returnTC   : ∀ {a} {A : Set a} → A → TC A-    bindTC     : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B--    -- Unify two terms, potentially solving metavariables in the process.-    unify      : Term → Term → TC ⊤--    -- Throw a type error. Can be caught by catchTC.-    typeError  : ∀ {a} {A : Set a} → List ErrorPart → TC A--    -- Block a type checking computation on a metavariable. This will abort-    -- the computation and restart it (from the beginning) when the-    -- metavariable is solved.-    blockOnMeta : ∀ {a} {A : Set a} → Meta → TC A--    -- Backtrack and try the second argument if the first argument throws a-    -- type error.-    catchTC    : ∀ {a} {A : Set a} → TC A → TC A → TC A--    -- Infer the type of a given term-    inferType  : Term → TC Type--    -- Check a term against a given type. This may resolve implicit arguments-    -- in the term, so a new refined term is returned. Can be used to create-    -- new metavariables: newMeta t = checkType unknown t-    checkType  : Term → Type → TC Term--    -- Compute the normal form of a term.-    normalise  : Term → TC Term--    -- Get the current context.-    getContext : TC (List (Arg Type))--    -- Extend the current context with a variable of the given type.-    extendContext : ∀ {a} {A : Set a} → Arg Type → TC A → TC A--    -- Set the current context.-    inContext     : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A--    -- Quote a value, returning the corresponding Term.-    quoteTC : ∀ {a} {A : Set a} → A → TC Term--    -- Unquote a Term, returning the corresponding value.-    unquoteTC : ∀ {a} {A : Set a} → Term → TC A--    -- Create a fresh name.-    freshName  : String → TC QName--    -- Declare a new function of the given type. The function must be defined-    -- later using 'defineFun'. Takes an Arg Name to allow declaring instances-    -- and irrelevant functions. The Visibility of the Arg must not be hidden.-    declareDef : Arg QName → Type → TC ⊤--    -- Define a declared function. The function may have been declared using-    -- 'declareDef' or with an explicit type signature in the program.-    defineFun  : QName → List Clause → TC ⊤--    -- Get the type of a defined name. Replaces 'primQNameType'.-    getType    : QName → TC Type--    -- Get the definition of a defined name. Replaces 'primQNameDefinition'.-    getDefinition : QName → TC Definition--  {-# BUILTIN AGDATCM                   TC                 #-}-  {-# BUILTIN AGDATCMRETURN             returnTC           #-}-  {-# BUILTIN AGDATCMBIND               bindTC             #-}-  {-# BUILTIN AGDATCMUNIFY              unify              #-}-  {-# BUILTIN AGDATCMNEWMETA            newMeta            #-}-  {-# BUILTIN AGDATCMTYPEERROR          typeError          #-}-  {-# BUILTIN AGDATCMBLOCKONMETA        blockOnMeta        #-}-  {-# BUILTIN AGDATCMCATCHERROR         catchTC            #-}-  {-# BUILTIN AGDATCMINFERTYPE          inferType          #-}-  {-# BUILTIN AGDATCMCHECKTYPE          checkType          #-}-  {-# BUILTIN AGDATCMNORMALISE          normalise          #-}-  {-# BUILTIN AGDATCMGETCONTEXT         getContext         #-}-  {-# BUILTIN AGDATCMEXTENDCONTEXT      extendContext      #-}-  {-# BUILTIN AGDATCMINCONTEXT          inContext          #-}-  {-# BUILTIN AGDATCMQUOTETERM          quoteTC            #-}-  {-# BUILTIN AGDATCMUNQUOTETERM        unquoteTC          #-}-  {-# BUILTIN AGDATCMFRESHNAME          freshName          #-}-  {-# BUILTIN AGDATCMDECLAREDEF         declareDef         #-}-  {-# BUILTIN AGDATCMDEFINEFUN          defineFun          #-}-  {-# BUILTIN AGDATCMGETTYPE            getType            #-}-  {-# BUILTIN AGDATCMGETDEFINITION      getDefinition      #-}-  ```--* Builtin type for metavariables--  There is a new builtin type for metavariables used by the new reflection-  framework. It is declared as follows and comes with primitive equality,-  ordering and show.--  ```agda-  postulate Meta : Set-  {-# BUILTIN AGDAMETA Meta #-}-  primitive primMetaEquality : Meta → Meta → Bool-  primitive primMetaLess : Meta → Meta → Bool-  primitive primShowMeta : Meta → String-  ```--  There are corresponding new constructors in the `Term` and `Literal`-  data types:--  ```agda-  data Term : Set where-    ...-    meta : Meta → List (Arg Term) → Term--  {-# BUILTIN AGDATERMMETA meta #-}--  data Literal : Set where-    ...-    meta : Meta → Literal--  {-# BUILTIN AGDALITMETA meta #-}-  ```--* Builtin unit type--  The type checker needs to know about the unit type, which you can-  allow by--  ```agda-  record ⊤ : Set where-  {-# BUILTIN UNIT ⊤ #-}-  ```--* Changed behaviour of `unquote`--  The `unquote` primitive now expects a type checking computation-  instead of a pure term. In particular `unquote e` requires--  ```agda-  e : Term → TC ⊤-  ```--  where the argument is the representation of the hole in which the-  result should go. The old `unquote` behaviour (where `unquote`-  expected a `Term` argument) can be recovered by--  ```agda-  OLD: unquote v-  NEW: unquote λ hole → unify hole v-  ```--* Changed behaviour of `unquoteDecl`--  The `unquoteDecl` primitive now expects a type checking computation-  instead of a pure function definition. It is possible to define-  multiple (mutually recursive) functions at the same time. More-  specifically--  ```agda-  unquoteDecl x₁ .. xₙ = m-  ```--  requires `m : TC ⊤` and that `x₁ .. xₙ` are defined (using-  `declareDef` and `defineFun`) after executing `m`. As before `x₁-  .. xₙ : QName` in `m`, but have their declared types outside the-  `unquoteDecl`.--* New primitive `unquoteDef`--  There is a new declaration--  ```agda-  unquoteDef x₁ .. xₙ = m-  ```--  This works exactly as `unquoteDecl` (see above) with the exception-  that `x₁ ..  xₙ` are required to already be declared.--  The main advantage of `unquoteDef` over `unquoteDecl` is that-  `unquoteDef` is allowed in mutual blocks, allowing mutually-  recursion between generated definitions and hand-written-  definitions.--* The reflection interface now exposes the name hint (as a string)-  for variables. As before, the actual binding structure is with-  de Bruijn indices. The String value is just a hint used as a prefix-  to help display the variable. The type `Abs` is a new builtin type used-  for the constructors `Term.lam`, `Term.pi`, `Pattern.var`-  (bultins `AGDATERMLAM`, `AGDATERMPI` and `AGDAPATVAR`).--  ```agda-  data Abs (A : Set) : Set where-    abs : (s : String) (x : A) → Abs A-  {-# BUILTIN ABS    Abs #-}-  {-# BUILTIN ABSABS abs #-}-  ```--  Updated constructor types:--  ```agda-  Term.lam    : Hiding   → Abs Term → Term-  Term.pi     : Arg Type → Abs Type → Term-  Pattern.var : String   → Pattern-  ```--* Reflection-based macros--  Macros are functions of type `t1 → t2 → .. → Term → TC ⊤` that are-  defined in a `macro` block. Macro application is guided by the type-  of the macro, where `Term` arguments desugar into the `quoteTerm`-  syntax and `Name` arguments into the `quote` syntax. Arguments of-  any other type are preserved as-is. The last `Term` argument is the-  hole term given to `unquote` computation (see above).--  For example, the macro application `f u v w` where the macro `f` has-  the type `Term → Name → Bool → Term → TC ⊤` desugars into `unquote-  (f (quoteTerm u) (quote v) w)`--  Limitations:--    - Macros cannot be recursive. This can be worked around by defining the-      recursive function outside the macro block and have the macro call the-      recursive function.--  Silly example:--  ```agda-  macro-    plus-to-times : Term → Term → TC ⊤-    plus-to-times (def (quote _+_) (a ∷ b ∷ [])) hole = unify hole (def (quote _*_) (a ∷ b ∷ []))-    plus-to-times v hole = unify hole v--  thm : (a b : Nat) → plus-to-times (a + b) ≡ a * b-  thm a b = refl-  ```--  Macros are most useful when writing tactics, since they let you hide the-  reflection machinery. For instance, suppose you have a solver--  ```agda-  magic : Type → Term-  ```--  that takes a reflected goal and outputs a proof (when successful). You can-  then define the following macro--  ```agda-  macro-    by-magic : Term → TC ⊤-    by-magic hole =-      bindTC (inferType hole) λ goal →-      unify hole (magic goal)-  ```--  This lets you apply the magic tactic without any syntactic noise at all:--  ```agda-  thm : ¬ P ≡ NP-  thm = by-magic-  ```--### Literals and built-ins--* Overloaded number literals.--  You can now overload natural number literals using the new builtin-  `FROMNAT`:--  ```agda-  {-# BUILTIN FROMNAT fromNat #-}-  ```--  The target of the builtin should be a defined name. Typically you would do-  something like--  ```agda-  record Number (A : Set) : Set where-    field fromNat : Nat → A--  open Number {{...}} public--  {-# BUILTIN FROMNAT fromNat #-}-  ```--  This will cause number literals `n` to be desugared to `fromNat n`-  before type checking.--* Negative number literals.--  Number literals can now be negative. For floating point literals it-  works as expected. For integer literals there is a new builtin-  `FROMNEG` that enables negative integer literals:--  ```agda-  {-# BUILTIN FROMNEG fromNeg #-}-  ```--  This causes negative literals `-n` to be desugared to `fromNeg n`.--* Overloaded string literals.--  String literals can be overladed using the `FROMSTRING` builtin:--  ```agda-  {-# BUILTIN FROMSTRING fromString #-}-  ```--  The will cause string literals `s` to be desugared to `fromString s`-  before type checking.--* Change to builtin integers.--  The `INTEGER` builtin now needs to be bound to a datatype with two-  constructors that should be bound to the new builtins `INTEGERPOS`-  and `INTEGERNEGSUC` as follows:--  ```agda-  data Int : Set where-    pos    : Nat -> Int-    negsuc : Nat -> Int-  {-# BUILTIN INTEGER       Int    #-}-  {-# BUILTIN INTEGERPOS    pos    #-}-  {-# BUILTIN INTEGERNEGSUC negsuc #-}-  ```--  where `negsuc n` represents the integer `-n - 1`. For instance, `-5`-  is represented as `negsuc 4`. All primitive functions on integers-  except `primShowInteger` have been removed, since these can be-  defined without too much trouble on the above representation using-  the corresponding functions on natural numbers.--  The primitives that have been removed are--  ```agda-  primIntegerPlus-  primIntegerMinus-  primIntegerTimes-  primIntegerDiv-  primIntegerMod-  primIntegerEquality-  primIntegerLess-  primIntegerAbs-  primNatToInteger-  ```--* New primitives for strict evaluation--  ```agda-  primitive-    primForce      : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) → (∀ x → B x) → B x-    primForceLemma : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) (f : ∀ x → B x) → primForce x f ≡ f x-  ```--  `primForce x f` evaluates to `f x` if x is in weak head normal form,-  and `primForceLemma x f` evaluates to `refl` in the same-  situation. The following values are considered to be in weak head-  normal form:--    - constructor applications-    - literals-    - lambda abstractions-    - type constructor (data/record types) applications-    - function types-    - Set a--### Modules--* Modules in import directives--  When you use `using`/`hiding`/`renaming` on a name it now-  automatically applies to any module of the same name, unless you-  explicitly mention the module. For instance,--  ```agda-  open M using (D)-  ```--  is equivalent to--  ```agda-  open M using (D; module D)-  ```--  if `M` defines a module `D`. This is most useful for record and data-  types where you always get a module of the same name as the type.--  With this feature there is no longer useful to be able to qualify a-  constructor (or field) by the name of the data type even when it-  differs from the name of the corresponding module. The follow-  (weird) code used to work, but doesn't work anymore:--  ```agda-  module M where-    data D where-      c : D-  open M using (D) renaming (module D to MD)-  foo : D-  foo = D.c-  ```--  If you want to import only the type name and not the module you have to hide-  it explicitly:--  ```agda-  open M using (D) hiding (module D)-  ```--  See discussion on-  Issue [#836](https://github.com/agda/agda/issues/836).--* Private definitions of a module are no longer in scope at the Emacs-  mode top-level.--  The reason for this change is that `.agdai-files` are stripped of-  unused private definitions (which can yield significant performance-  improvements for module-heavy code).--  To test private definitions you can create a hole at the bottom of-  the module, in which private definitions will be visible.--### Records--* New record directives `eta-equality`/`no-eta-equality`--  The keywords `eta-equality`/`no-eta-equality` enable/disable eta-  rules for the (inductive) record type being declared.--  ```agda-  record Σ (A : Set) (B : A -> Set) : Set where-    no-eta-equality-    constructor _,_-    field-      fst : A-      snd : B fst-  open Σ--  -- fail : ∀ {A : Set}{B : A -> Set} → (x : Σ A B) → x ≡ (fst x , snd x)-  -- fail x = refl-  ---  -- x != fst x , snd x of type Σ .A .B-  -- when checking that the expression refl has type x ≡ (fst x , snd x)-  ```--* Building records from modules.--  The `record { <fields> }` syntax is now extended to accept module-  names as well. Fields are thus defined using the corresponding-  definitions from the given module.--  For instance assuming this record type `R` and module `M`:--  ```agda-  record R : Set where-    field-      x : X-      y : Y-      z : Z--  module M where-    x = {! ... !}-    y = {! ... !}--  r : R-  r = record { M; z = {! ... !} }-  ```--  Previously one had to write `record { x = M.x; y = M.y; z = {! ... !} }`.--  More precisely this construction now supports any combination of explicit-  field definitions and applied modules.--  If a field is both given explicitly and available in one of the modules,-  then the explicit one takes precedence.--  If a field is available in more than one module then this is ambiguous-  and therefore rejected. As a consequence the order of assignments does-  not matter.--  The modules can be both applied to arguments and have import directives-  such as `hiding`, `using`, and `renaming`. In particular this construct-  subsumes the record update construction.--  Here is an example of record update:--  ```agda-  -- Record update. Same as: record r { y = {! ... !} }-  r2 : R-  r2 = record { R r; y = {! ... !} }-  ```--  A contrived example showing the use of `hiding`/`renaming`:--  ```agda-  module M2 (a : A) where-    w = {! ... !}-    z = {! ... !}--  r3 : A → R-  r3 a = record { M hiding (y); M2 a renaming (w to y) }-  ```--* Record patterns are now accepted.--  Examples:--  ```agda-  swap : {A B : Set} (p : A × B) → B × A-  swap record{ proj₁ = a; proj₂ = b } = record{ proj₁ = b; proj₂ = a }--  thd3 : ...-  thd3 record{ proj₂ = record { proj₂ = c }} = c-  ```--* Record modules now properly hide all their parameters-  [Issue [#1759](https://github.com/agda/agda/issues/1759)]--  Previously parameters to parent modules were not hidden in the record-  module, resulting in different behaviour between--  ```agda-  module M (A : Set) where-    record R (B : Set) : Set where-  ```--  and--  ```agda-  module M where-    record R (A B : Set) : Set where-  ```--  where in the former case, `A` would be an explicit argument to the module-  `M.R`, but implicit in the latter case. Now `A` is implicit in both cases.--### Instance search--* Performance has been improved, recursive instance search which was-  previously exponential in the depth is now only quadratic.--* Constructors of records and datatypes are not anymore automatically-  considered as instances, you have to do so explicitely, for-  instance:--  ```agda-  -- only [b] is an instance of D-  data D : Set where-    a : D-    instance-      b : D-    c : D--  -- the constructor is now an instance-  record tt : Set where-    instance constructor tt-  ```--* Lambda-bound variables are no longer automatically considered-  instances.--  Lambda-bound variables need to be bound as instance arguments to be-  considered for instance search. For example,--  ```agda-  _==_ : {A : Set} {{_ : Eq A}} → A → A → Bool--  fails : {A : Set} → Eq A → A → Bool-  fails eqA x = x == x--  works : {A : Set} {{_ : Eq A}} → A → Bool-  works x = x == x-  ```--* Let-bound variables are no longer automatically considered-  instances.--  To make a let-bound variable available as an instance it needs to be-  declared with the `instance` keyword, just like top-level-  instances. For example,--  ```agda-  mkEq : {A : Set} → (A → A → Bool) → Eq A--  fails : {A : Set} → (A → A → Bool) → A → Bool-  fails eq x = let eqA = mkEq eq in x == x--  works : {A : Set} → (A → A → Bool) → A → Bool-  works eq x = let instance eqA = mkEq eq in x == x-  ```--* Record fields can be declared instances.--  For example,--  ```agda-  record EqSet : Set₁ where-    field-      set : Set-      instance eq : Eq set-  ```--  This causes the projection function `eq : (E : EqSet) → Eq (set E)`-  to be considered for instance search.--* Instance search can now find arguments in variable types (but such-  candidates can only be lambda-bound variables, they can’t be-  declared as instances)--  ```agda-  module _ {A : Set} (P : A → Set) where--    postulate-      bla : {x : A} {{_ : P x}} → Set → Set--    -- Works, the instance argument is found in the context-    test :  {x : A} {{_ : P x}} → Set → Set-    test B = bla B--    -- Still forbidden, because [P] could be instantiated later to anything-    instance-     postulate-      forbidden : {x : A} → P x-  ```--* Instance search now refuses to solve constraints with unconstrained-  metavariables, since this can lead to non-termination.--  See [Issue [#1532](https://github.com/agda/agda/issues/1523)] for an-  example.--* Top-level instances are now only considered if they are in-  scope. [Issue [#1913](https://github.com/agda/agda/issues/1913)]--  Note that lambda-bound instances need not be in scope.--### Other changes--* Unicode ellipsis character is allowed for the ellipsis token `...`-  in `with` expressions.--* `Prop` is no longer a reserved word.--Type checking----------------* Large indices.--  Force constructor arguments no longer count towards the size of a datatype.-  For instance, the definition of equality below is accepted.--  ```agda-  data _≡_ {a} {A : Set a} : A → A → Set where-    refl : ∀ x → x ≡ x-  ```--  This gets rid of the asymmetry that the version of equality which indexes-  only on the second argument could be small, but not the version above which-  indexes on both arguments.--* Detection of datatypes that satisfy K (i.e. sets)--  Agda will now try to detect datatypes that satisfy K when-  `--without-K` is enabled. A datatype satisfies K when it follows-  these three rules:--  - The types of all non-recursive constructor arguments should satisfy K.--  - All recursive constructor arguments should be first-order.--  - The types of all indices should satisfy K.--  For example, the types `Nat`, `List Nat`, and `x ≡ x` (where `x :-  Nat`) are all recognized by Agda as satisfying K.--* New unifier for case splitting--  The unifier used by Agda for case splitting has been completely-  rewritten. The new unifier takes a much more type-directed approach-  in order to avoid the problems in issues-  [#1406](https://github.com/agda/agda/issues/1406),-  [#1408](https://github.com/agda/agda/issues/1408),-  [#1427](https://github.com/agda/agda/issues/1427), and-  [#1435](https://github.com/agda/agda/issues/1435).--  The new unifier also has eta-equality for record types-  built-in. This should avoid unnecessary case splitting on record-  constructors and improve the performance of Agda on code that-  contains deeply nested record patterns (see issues-  [#473](https://github.com/agda/agda/issues/473),-  [#635](https://github.com/agda/agda/issues/635),-  [#1575](https://github.com/agda/agda/issues/1575),-  [#1603](https://github.com/agda/agda/issues/1603),-  [#1613](https://github.com/agda/agda/issues/1613), and-  [#1645](https://github.com/agda/agda/issues/1645)).--  In some cases, the locations of the dot patterns computed by the-  unifier did not correspond to the locations given by the user (see-  Issue [#1608](https://github.com/agda/agda/issues/1608)). This has-  now been fixed by adding an extra step after case splitting that-  checks whether the user-written patterns are compatible with the-  computed ones.--  In some rare cases, the new unifier is still too restrictive when-  `--without-K` is enabled because it cannot generalize over the-  datatype indices (yet). For example, the following code is rejected:--  ```agda-  data Bar : Set₁ where-    bar : Bar-    baz : (A : Set) → Bar--  data Foo : Bar → Set where-    foo : Foo bar--  test : foo ≡ foo → Set₁-  test refl = Set-  ```--* The aggressive behaviour of `with` introduced in 2.4.2.5 has been-  rolled back-  [Issue [#1692](https://github.com/agda/agda/issues/1692)]. With no-  longer abstracts in the types of variables appearing in the-  with-expressions. [Issue [#745](https://github.com/agda/agda/issues/745)]--  This means that the following example no longer works:--  ```agda-  fails : (f : (x : A) → a ≡ x) (b : A) → b ≡ a-  fails f b with a | f b-  fails f b | .b | refl = f b-  ```--  The `with` no longer abstracts the type of `f` over `a`, since `f`-  appears in the second with-expression `f b`. You can use a nested-  `with` to make this example work.--  This example does work again:--  ```agda-  test : ∀{A : Set}{a : A}{f : A → A} (p : f a ≡ a) → f (f a) ≡ a-  test p rewrite p = p-  ```--  After `rewrite p` the goal has changed to `f a ≡ a`, but the type-  of `p` has not been rewritten, thus, the final `p` solves the goal.--  The following, which worked in 2.4.2.5, no longer works:--  ```agda-  fails : (f : (x : A) → a ≡ x) (b : A) → b ≡ a-  fails f b rewrite f b = f b-  ```--  The rewrite with `f b : a ≡ b` is not applied to `f` as-  the latter is part of the rewrite expression `f b`.  Thus,-  the type of `f` remains untouched, and the changed goal-  `b ≡ b` is not solved by `f b`.--* When using `rewrite` on a term `eq` of type `lhs ≡ rhs`, the `lhs`-  is no longer abstracted in `rhs`-  [Issue [#520](https://github.com/agda/agda/issues/520)].  This means-  that--  ```agda-  f pats rewrite eq = body-  ```--  is more than syntactic sugar for--  ```agda-  f pats with lhs | eq-  f pats | _ | refl = body-  ```--  In particular, the following application of `rewrite` is now-  possible--  ```agda-  id : Bool → Bool-  id true  = true-  id false = false--  is-id : ∀ x → x ≡ id x-  is-id true  = refl-  is-id false = refl--  postulate-    P : Bool → Set-    b : Bool-    p : P (id b)--  proof : P b-  proof rewrite is-id b = p-  ```--  Previously, this was desugared to--  ```agda-  proof with b | is-id b-  proof | _ | refl = p-  ```--  which did not type check as `refl` does not have type `b ≡ id b`.-  Now, Agda gets the task of checking `refl : _ ≡ id b` leading to-  instantiation of `_` to `id b`.--Compiler backends--------------------* Major Bug Fixes:--  - Function clauses with different arities are now always compiled-    correctly by the GHC/UHC-    backends. (Issue [#727](https://github.com/agda/agda/issues/727))--* Co-patterns--  - The GHC/UHC backends now support co-patterns. (Issues-    [#1567](https://github.com/agda/agda/issues/1567),-    [#1632](https://github.com/agda/agda/issues/1632))--* Optimizations--  - Builtin naturals are now represented as arbitrary-precision-    Integers. See the user manual, section-    "Agda Compilers -> Optimizations" for details.--* GHC Haskell backend (MAlonzo)--  - Pragmas--    Since builtin naturals are compiled to `Integer` you can no longer-    give a `{-# COMPILED_DATA #-}` pragma for `Nat`. The same goes for-    builtin booleans, integers, floats, characters and strings which-    are now hard-wired to appropriate Haskell types.--* UHC compiler backend--  A new backend targeting the Utrecht Haskell Compiler (UHC) is-  available.  It targets the UHC Core language, and it's design is-  inspired by the Epic backend. See the user manual, section "Agda-  Compilers -> UHC Backend" for installation instructions.--  - FFI--    The UHC backend has a FFI to Haskell similar to MAlonzo's. The-    target Haskell code also needs to be compilable using UHC, which-    does not support the Haskell base library version 4.*.--    FFI pragmas for the UHC backend are not checked in any way. If the-    pragmas are wrong, bad things will happen.--  - Imports--    Additional Haskell modules can be brought into scope with the-    `IMPORT_UHC` pragma:--    ```agda-    {-# IMPORT_UHC Data.Char #-}-    ```--    The Haskell modules `UHC.Base` and `UHC.Agda.Builtins` are always in-    scope and don't need to be imported explicitly.--  - Datatypes--    Agda datatypes can be bound to Haskell datatypes as follows:--    Haskell:-    ```haskell-    data HsData a = HsCon1 | HsCon2 (HsData a)-    ```--    Agda:-    ```agda-    data AgdaData (A : Set) : Set where-      AgdaCon1 : AgdaData A-      AgdaCon2 : AgdaData A -> AgdaData A-    {-# COMPILED_DATA_UHC AgdaData HsData HsCon1 HsCon2 #-}-    ```--    The mapping has to cover all constructors of the used Haskell-    datatype, else runtime behavior is undefined!--    There are special reserved names to bind Agda datatypes to certain-    Haskell datatypes. For example, this binds an Agda datatype to-    Haskell's list datatype:--    Agda:-    ```agda-    data AgdaList (A : Set) : Set where-      Nil : AgdaList A-      Cons : A -> AgdaList A -> AgdaList A-    {-# COMPILED_DATA_UHC AgdaList __LIST__ __NIL__ __CONS__ #-}-    ```--    The following "magic" datatypes are available:--    ```-    HS Datatype | Datatype Pragma | HS Constructor | Constructor Pragma-    ()            __UNIT__          ()               __UNIT__-    List          __LIST__          (:)              __CONS__-                                    []               __NIL__-    Bool          __BOOL__          True             __TRUE__-                                    False            __FALSE__-    ```--  - Functions--    Agda postulates can be bound to Haskell functions. Similar as in-    MAlonzo, all arguments of type `Set` need to be dropped before-    calling Haskell functions. An example calling the return function:--    Agda:-    ```agda-    postulate hs-return : {A : Set} -> A -> IO A-    {-# COMPILED_UHC hs-return (\_ -> UHC.Agda.Builtins.primReturn) #-}-    ```--Emacs mode and interaction-----------------------------* Module contents (`C-c C-o`) now also works for-  records. [See Issue [#1926](https://github.com/agda/agda/issues/1926) ]-  If you have an inferable expression of record type in an interaction-  point, you can invoke `C-c C-o` to see its fields and types.-  Example--  ```agda-  record R : Set where-    field f : A--  test : R → R-  test r = {!r!}  -- C-c C-o here-  ```--* Less aggressive error notification.--  Previously Emacs could jump to the position of an error even if the-  type-checking process was not initiated in the current buffer. Now-  this no longer happens: If the type-checking process was initiated-  in another buffer, then the cursor is moved to the position of the-  error in the buffer visiting the file (if any) and in every window-  displaying the file, but focus should not change from one file to-  another.--  In the cases where focus does change from one file to another, one-  can now use the go-back functionality to return to the previous-  position.--* Removed the `agda-include-dirs` customization parameter.--  Use `agda-program-args` with `-iDIR` or `-lLIB` instead, or add-  libraries to `~/.agda/defaults`-  (`C:/Users/USERNAME/AppData/Roaming/agda/defaults` or similar on-  Windows). See Library management, above, for more information.--Tools--------### LaTeX-backend--* The default font has been changed to XITS (which is part of TeX Live):--    http://www.ctan.org/tex-archive/fonts/xits/--  This font is more complete with respect to Unicode.--### agda-ghc-names--* New tool: The command--  ```-  agda-ghc-names fixprof <compile-dir> <ProgName>.prof-  ```--  converts `*.prof` files obtained from profiling runs of-  MAlonzo-compiled code to `*.agdaIdents.prof`, with the original Agda-  identifiers replacing the MAlonzo-generated Haskell identifiers.--  For usage and more details, see `src/agda-ghc-names/README.txt`.--Highlighting and textual backends------------------------------------* Names in import directives are now highlighted and are clickable.-  [Issue [#1714](https://github.com/agda/agda/issues/1714)] This leads-  also to nicer printing in the LaTeX and html backends.--Fixed issues---------------See-[bug tracker (milestone 2.5.1)](https://github.com/agda/agda/issues?q=milestone%3A2.5.1+is%3Aclosed)--Release notes for Agda version 2.4.2.5-======================================--Installation and infrastructure----------------------------------* Added support for GHC 7.10.3.--* Added `cpphs` Cabal flag--  Turn on/off this flag to choose cpphs/cpp as the C preprocessor.--  This flag is turn on by default.--  (This flag was added in Agda 2.4.2.1 but it was not documented)--Pragmas and options----------------------* Termination pragmas are no longer allowed inside `where` clauses-  [Issue [#1137](https://github.com/agda/agda/issues/1137)].--Type checking----------------* `with`-abstraction is more aggressive, abstracts also in types of-  variables that are used in the `with`-expressions, unless they are-  also used in the types of the-  `with`-expressions. [Issue [#1692](https://github.com/agda/agda/issues/1692)]--  Example:--  ```agda-  test : (f : (x : A) → a ≡ x) (b : A) → b ≡ a-  test f b with a | f b-  test f b | .b | refl = f b-  ```--  Previously, `with` would not abstract in types of variables that-  appear in the `with`-expressions, in this case, both `f` and `b`,-  leaving their types unchanged.  Now, it tries to abstract in `f`, as-  only `b` appears in the types of the `with`-expressions which are-  `A` (of `a`) and `a ≡ b` (of `f b`).  As a result, the type of `f`-  changes to `(x : A) → b ≡ x` and the type of the goal to `b ≡ b` (as-  previously).--  This also affects `rewrite`, which is implemented in terms of-  `with`.--  ```agda-  test : (f : (x : A) → a ≡ x) (b : A) → b ≡ a-  test f b rewrite f b = f b-  ```--  As the new `with` is not fully backwards-compatible, some parts of-  your Agda developments using `with` or `rewrite` might need-  maintenance.--Fixed issues---------------See [bug tracker](https://github.com/agda/agda/issues)--[#1407](https://github.com/agda/agda/issues/1497)--[#1518](https://github.com/agda/agda/issues/1518)--[#1670](https://github.com/agda/agda/issues/1670)--[#1677](https://github.com/agda/agda/issues/1677)--[#1698](https://github.com/agda/agda/issues/1698)--[#1701](https://github.com/agda/agda/issues/1701)--[#1710](https://github.com/agda/agda/issues/1710)--[#1718](https://github.com/agda/agda/issues/1718)--Release notes for Agda version 2.4.2.4-======================================--Installation and infrastructure----------------------------------* Removed support for GHC 7.4.2.--Pragmas and options----------------------* Option `--copatterns` is now on by default.  To switch off-  parsing of copatterns, use:--  ```agda-  {-# OPTIONS --no-copatterns #-}-  ```--* Option `--rewriting` is now needed to use `REWRITE` pragmas and-  rewriting during reduction.  Rewriting is not `--safe`.--  To use rewriting, first specify a relation symbol `R` that will-  later be used to add rewrite rules.  A canonical candidate would be-  propositional equality--  ```agda-  {-# BUILTIN REWRITE _≡_ #-}-  ```--  but any symbol `R` of type `Δ → A → A → Set i` for some `A` and `i`-  is accepted.  Then symbols `q` can be added to rewriting provided-  their type is of the form `Γ → R ds l r`.  This will add a rewrite-  rule--  ```-  Γ ⊢ l ↦ r : A[ds/Δ]-  ```--  to the signature, which fires whenever a term is an instance of `l`.-  For example, if--  ```agda-  plus0 : ∀ x → x + 0 ≡ x-  ```--  (ideally, there is a proof for `plus0`, but it could be a-  postulate), then--  ```agda-  {-# REWRITE plus0 #-}-  ```--  will prompt Agda to rewrite any well-typed term of the form `t + 0`-  to `t`.--  Some caveats: Agda accepts and applies rewrite rules naively, it is-  very easy to break consistency and termination of type checking.-  Some examples of rewrite rules that should *not* be added:--  ```agda-  refl     : ∀ x → x ≡ x             -- Agda loops-  plus-sym : ∀ x y → x + y ≡ y + x   -- Agda loops-  absurd   : true ≡ false            -- Breaks consistency-  ```--  Adding only proven equations should at least preserve consistency,-  but this is only a conjecture, so know what you are doing!  Using-  rewriting, you are entering into the wilderness, where you are on-  your own!--Language-----------* `forall` / `∀` now parses like `λ`, i.e., the following parses now-  [Issue [#1583](https://github.com/agda/agda/issues/1538)]:--  ```agda-  ⊤ × ∀ (B : Set) → B → B-  ```--* The underscore pattern `_` can now also stand for an inaccessible-  pattern (dot pattern). This alleviates the need for writing `._`.-  [Issue #[1605](https://github.com/agda/agda/issues/1605)] Instead of--  ```agda-  transVOld : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c-  transVOld _ ._ ._ refl refl = refl-  ```--  one can now write--  ```agda-    transVNew : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c-    transVNew _ _ _ refl refl = refl-  ```--  and let Agda decide where to put the dots.  This was always possible-  by using hidden arguments--  ```agda-  transH : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c-  transH refl refl = refl-  ```--  which is now equivalent to--  ```agda-  transHNew : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c-  transHNew {a = _}{b = _}{c = _} refl refl = refl-  ```--  Before, underscore `_` stood for an unnamed variable that could not-  be instantiated by an inaccessible pattern.  If one no wants to-  prevent Agda from instantiating, one needs to use a variable name-  other than underscore (however, in practice this situation seems-  unlikely).--Type checking----------------* Polarity of phantom arguments to data and record types has-  changed. [Issue [#1596](https://github.com/agda/agda/issues/1596)]-  Polarity of size arguments is Nonvariant (both monotone and-  antitone).  Polarity of other arguments is Covariant (monotone).-  Both were Invariant before (neither monotone nor antitone).--  The following example type-checks now:--  ```agda-  open import Common.Size--  -- List should be monotone in both arguments-  -- (even when `cons' is missing).--  data List (i : Size) (A : Set) : Set where-    [] : List i A--  castLL : ∀{i A} → List i (List i A) → List ∞ (List ∞ A)-  castLL x = x--  -- Stream should be antitone in the first and monotone in the second argument-  -- (even with field `tail' missing).--  record Stream (i : Size) (A : Set) : Set where-    coinductive-    field-      head : A--  castSS : ∀{i A} → Stream ∞ (Stream ∞ A) → Stream i (Stream i A)-  castSS x = x-  ```--* `SIZELT` lambdas must be consistent-  [Issue [#1523](https://github.com/agda/agda/issues/1523), see Abel-  and Pientka, ICFP 2013].  When lambda-abstracting over type (`Size<-  size`) then `size` must be non-zero, for any valid instantiation of-  size variables.--  - The good:--    ```agda-    data Nat (i : Size) : Set where-      zero : ∀ (j : Size< i) → Nat i-      suc  : ∀ (j : Size< i) → Nat j → Nat i--    {-# TERMINATING #-}-    -- This definition is fine, the termination checker is too strict at the moment.-    fix : ∀ {C : Size → Set}-       → (∀ i → (∀ (j : Size< i) → Nat j -> C j) → Nat i → C i)-       → ∀ i → Nat i → C i-    fix t i (zero j)  = t i (λ (k : Size< i) → fix t k) (zero j)-    fix t i (suc j n) = t i (λ (k : Size< i) → fix t k) (suc j n)-    ```--    The `λ (k : Size< i)` is fine in both cases, as context--    ```agda-    i : Size, j : Size< i-    ```--    guarantees that `i` is non-zero.--  - The bad:--    ```agda-    record Stream {i : Size} (A : Set) : Set where-      coinductive-      constructor _∷ˢ_-      field-        head  : A-        tail  : ∀ {j : Size< i} → Stream {j} A-    open Stream public--    _++ˢ_ : ∀ {i A} → List A → Stream {i} A → Stream {i} A-    []        ++ˢ s = s-    (a ∷ as)  ++ˢ s = a ∷ˢ (as ++ˢ s)-    ```--    This fails, maybe unjustified, at--    ```agda-    i : Size, s : Stream {i} A-      ⊢-        a ∷ˢ (λ {j : Size< i} → as ++ˢ s)-    ```--    Fixed by defining the constructor by copattern matching:--    ```agda-    record Stream {i : Size} (A : Set) : Set where-      coinductive-      field-        head  : A-        tail  : ∀ {j : Size< i} → Stream {j} A-    open Stream public--    _∷ˢ_ : ∀ {i A} → A → Stream {i} A → Stream {↑ i} A-    head  (a ∷ˢ as) = a-    tail  (a ∷ˢ as) = as--    _++ˢ_ : ∀ {i A} → List A → Stream {i} A → Stream {i} A-    []        ++ˢ s = s-    (a ∷ as)  ++ˢ s = a ∷ˢ (as ++ˢ s)-    ```--  - The ugly:--    ```agda-    fix : ∀ {C : Size → Set}-       → (∀ i → (∀ (j : Size< i) → C j) → C i)-       → ∀ i → C i-    fix t i = t i λ (j : Size< i) → fix t j-    ```--    For `i=0`, there is no such `j` at runtime, leading to looping-    behavior.--Interaction--------------* Issue [#635](https://github.com/agda/agda/issues/635) has been-  fixed.  Case splitting does not spit out implicit record patterns-  any more.--  ```agda-  record Cont : Set₁ where-    constructor _◃_-    field-      Sh  : Set-      Pos : Sh → Set--  open Cont--  data W (C : Cont) : Set where-    sup : (s : Sh C) (k : Pos C s → W C) → W C--  bogus : {C : Cont} → W C → Set-  bogus w = {!w!}-  ```--  Case splitting on `w` yielded, since the fix of-  Issue [#473](https://github.com/agda/agda/issues/473),--  ```agda-  bogus {Sh ◃ Pos} (sup s k) = ?-  ```--  Now it gives, as expected,--  ```agda-  bogus (sup s k) = ?-  ```--Performance--------------* As one result of the 21st Agda Implementor's Meeting (AIM XXI),-  serialization of the standard library is 50% faster (time reduced by-  a third), without using additional disk space for the interface-  files.---Bug fixes------------Issues fixed (see [bug tracker](https://github.com/agda/agda/issues)):--[#1546](https://github.com/agda/agda/issues/1546) (copattern matching-and with-clauses)--[#1560](https://github.com/agda/agda/issues/1560) (positivity checker-inefficiency)--[#1584](https://github.com/agda/agda/issues/1548) (let pattern with-trailing implicit)--Release notes for Agda version 2.4.2.3-======================================--Installation and infrastructure----------------------------------* Added support for GHC 7.10.1.--* Removed support for GHC 7.0.4.--Language-----------* `_ `is no longer a valid name for a definition.  The following fails-  now: [Issue [#1465](https://github.com/agda/agda/issues/1465)]--  ```agda-  postulate _ : Set-  ```--* Typed bindings can now contain hiding information-  [Issue [#1391](https://github.com/agda/agda/issues/1391)].  This-  means you can now write--  ```agda-  assoc : (xs {ys zs} : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs))-  ```--  instead of the longer--  ```agda-  assoc : (xs : List A) {ys zs : List A} → ...-  ```--  It also works with irrelevance--  ```agda-  .(xs {ys zs} : List A) → ...-  ```--  but of course does not make sense if there is hiding information already.-  Thus, this is (still) a parse error:--  ```agda-  {xs {ys zs} : List A} → ...-  ```--* The builtins for sized types no longer need accompanying postulates.-  The BUILTIN pragmas for size stuff now also declare the identifiers-  they bind to.--  ```agda-  {-# BUILTIN SIZEUNIV SizeUniv #-}  --  SizeUniv : SizeUniv-  {-# BUILTIN SIZE     Size     #-}  --  Size     : SizeUniv-  {-# BUILTIN SIZELT   Size<_   #-}  --  Size<_   : ..Size → SizeUniv-  {-# BUILTIN SIZESUC  ↑_       #-}  --  ↑_       : Size → Size-  {-# BUILTIN SIZEINF  ∞        #-}  --  ∞       : Size-  ```--  `Size` and `Size<` now live in the new universe `SizeUniv`.  It is-  forbidden to build function spaces in this universe, in order to-  prevent the malicious assumption of a size predecessor--  ```agda-  pred : (i : Size) → Size< i-  ```--  [Issue [#1428](https://github.com/agda/agda/issues/1428)].--* Unambiguous notations (coming from syntax declarations) that resolve-  to ambiguous names are now parsed unambiguously-  [Issue [#1194](https://github.com/agda/agda/issues/1194)].--* If only some instances of an overloaded name have a given associated-  notation (coming from syntax declarations), then this name can only-  be resolved to the given instances of the name, not to other-  instances [Issue [#1194](https://github.com/agda/agda/issues/1194)].--  Previously, if different instances of an overloaded name had-  *different* associated notations, then none of the notations could-  be used. Now all of them can be used.--  Note that notation identity does not only involve the right-hand-  side of the syntax declaration. For instance, the following-  notations are not seen as identical, because the implicit argument-  names are different:--  ```agda-  module A where--    data D : Set where-      c : {x y : D} → D--    syntax c {x = a} {y = b} = a ∙ b--  module B where--    data D : Set where-      c : {y x : D} → D--    syntax c {y = a} {x = b} = a ∙ b-  ```--* If an overloaded operator is in scope with at least two distinct-  fixities, then it gets the default fixity-  [Issue [#1436](https://github.com/agda/agda/issues/1436)].--  Similarly, if two or more identical notations for a given overloaded-  name are in scope, and these notations do not all have the-  same fixity, then they get the default fixity.--Type checking----------------* Functions of varying arity can now have with-clauses and use rewrite.--  Example:--  ```agda-  NPred : Nat → Set-  NPred 0       = Bool-  NPred (suc n) = Nat → NPred n--  const : Bool → ∀{n} → NPred n-  const b {0}       = b-  const b {suc n} m = const b {n}--  allOdd : ∀ n → NPred n-  allOdd 0 = true-  allOdd (suc n) m with even m-  ... | true  = const false-  ... | false = allOdd n-  ```--* Function defined by copattern matching can now have `with`-clauses-  and use `rewrite`.--  Example:--  ```agda-  {-# OPTIONS --copatterns #-}--  record Stream (A : Set) : Set where-    coinductive-    constructor delay-    field-      force : A × Stream A-  open Stream--  map : ∀{A B} → (A → B) → Stream A → Stream B-  force (map f s) with force s-  ... | a , as = f a , map f as--  record Bisim {A B} (R : A → B → Set) (s : Stream A) (t : Stream B) : Set where-    coinductive-    constructor ~delay-    field-      ~force : let a , as = force s-                   b , bs = force t-               in  R a b × Bisim R as bs-  open Bisim--  SEq : ∀{A} (s t : Stream A) → Set-  SEq = Bisim (_≡_)--  -- Slightly weird definition of symmetry to demonstrate rewrite.--  ~sym' : ∀{A} {s t : Stream A} → SEq s t → SEq t s-  ~force (~sym' {s = s} {t} p) with force s | force t | ~force p-  ... | a , as | b , bs | r , q rewrite r = refl , ~sym' q-  ```--* Instances can now be defined by copattern-  matching. [Issue [#1413](https://github.com/agda/agda/issues/1413)]-  The following example extends the one in-  [Abel, Pientka, Thibodeau, Setzer, POPL 2013, Section 2.2]:--  ```agda-  {-# OPTIONS --copatterns #-}--  -- The Monad type class--  record Monad (M : Set → Set) : Set1 where-    field-      return : {A : Set}   → A → M A-      _>>=_  : {A B : Set} → M A → (A → M B) → M B-  open Monad {{...}}--  -- The State newtype--  record State (S A : Set) : Set where-    field-      runState : S → A × S-  open State--  -- State is an instance of Monad--  instance-    stateMonad : {S : Set} → Monad (State S)-    runState (return {{stateMonad}} a  ) s  = a , s    -- NEW-    runState (_>>=_  {{stateMonad}} m k) s₀ =          -- NEW-      let a , s₁ = runState m s₀-      in  runState (k a) s₁--  -- stateMonad fulfills the monad laws--  leftId : {A B S : Set}(a : A)(k : A → State S B) →-    (return a >>= k) ≡ k a-  leftId a k = refl--  rightId : {A B S : Set}(m : State S A) →-    (m >>= return) ≡ m-  rightId m = refl--  assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →-     ((m >>= k) >>= l) ≡ (m >>= λ a → k a >>= l)-  assoc m k l = refl-  ```--Emacs mode-------------* The new menu option `Switch to another version of Agda` tries to do-  what it says.--* Changed feature: Interactively split result.--  [ This is as before: ]-  Make-case (`C-c C-c`) with no variables given tries to split on the-  result to introduce projection patterns.  The hole needs to be of-  record type, of course.--  ```agda-  test : {A B : Set} (a : A) (b : B) → A × B-  test a b = ?-  ```--  Result-splitting `?` will produce the new clauses:--  ```agda-  proj₁ (test a b) = ?-  proj₂ (test a b) = ?-  ```--  [ This has changed: ]-  If hole is of function type, `make-case` will introduce only pattern-  variables (as much as it can).--  ```agda-  testFun : {A B : Set} (a : A) (b : B) → A × B-  testFun = ?-  ```--  Result-splitting `?` will produce the new clause:--  ```agda-  testFun a b = ?-  ```--  A second invocation of `make-case` will then introduce projection-  patterns.--Error messages-----------------* Agda now suggests corrections of misspelled options, e.g.--  ```agda-  {-# OPTIONS-    --dont-termination-check-    --without-k-    --senf-gurke-    #-}-  ```--  Unrecognized options:--  ```-  --dont-termination-check (did you mean --no-termination-check ?)-  --without-k (did you mean --without-K ?)-  --senf-gurke-  ```--  Nothing close to `--senf-gurke`, I am afraid.--Compiler backends--------------------* The Epic backend has been removed-  [Issue [#1481](https://github.com/agda/agda/issues/1481)].--Bug fixes------------* Fixed bug with `unquoteDecl` not working in instance blocks-  [Issue [#1491](https://github.com/agda/agda/issues/1491)].--* Other issues fixed (see-  [bug tracker](https://github.com/agda/agda/issues)--  [#1497](https://github.com/agda/agda/issues/1497)--  [#1500](https://github.com/agda/agda/issues/1500)--Release notes for Agda version 2.4.2.2-======================================--Bug fixes------------* Compilation on Windows fixed.--* Other issues fixed (see-  [bug tracker](https://github.com/agda/agda/issues))--  [#1332](https://github.com/agda/agda/issues/1322)--  [#1353](https://github.com/agda/agda/issues/1353)--  [#1360](https://github.com/agda/agda/issues/1360)--  [#1366](https://github.com/agda/agda/issues/1366)--  [#1369](https://github.com/agda/agda/issues/1369)--Release notes for Agda version 2.4.2.1-======================================--Pragmas and options----------------------* New pragma `{-# TERMINATING #-}` replacing-  `{-# NO_TERMINATION_CHECK #-}`--  Complements the existing pragma `{-# NON_TERMINATING #-}`.  Skips-  termination check for the associated definitions and marks them as-  terminating.  Thus, it is a replacement for `{-#-  NO_TERMINATION_CHECK #-}` with the same semantics.--  You can no longer use pragma `{-# NO_TERMINATION_CHECK #-}` to skip-  the termination check, but must label your definitions as either-  `{-# TERMINATING #-}` or `{-# NON_TERMINATING #-}` instead.--  Note: `{-# OPTION --no-termination-check #-}` labels all your-  definitions as `{-# TERMINATING #-}`, putting you in the danger zone-  of a loop in the type checker.--Language-----------* Referring to a local variable shadowed by module opening is now an-  error.  Previous behavior was preferring the local over the imported-  definitions. [Issue [#1266](https://github.com/agda/agda/issues/1266)]--  Note that module parameters are locals as well as variables bound by-  λ, dependent function type, patterns, and let.--  Example:--  ```agda-  module M where-    A = Set1--  test : (A : Set) → let open M in A-  ```--  The last `A` produces an error, since it could refer to the local-  variable `A` or to the definition imported from module `M`.--* `with` on a variable bound by a module telescope or a pattern of a-  parent function is now forbidden.-  [Issue [#1342](https://github.com/agda/agda/issues/1342)]--  ```agda-  data Unit : Set where-    unit : Unit--  id : (A : Set) → A → A-  id A a = a--  module M (x : Unit) where--    dx : Unit → Unit-    dx unit = x--    g : ∀ u → x ≡ dx u-    g with x-    g | unit  = id (∀ u → unit ≡ dx u) ?-  ```--  Even though this code looks right, Agda complains about the type-  expression `∀ u → unit ≡ dx u`.  If you ask Agda what should go-  there instead, it happily tells you that it wants `∀ u → unit ≡ dx-  u`. In fact what you do not see and Agda will never show you is that-  the two expressions actually differ in the invisible first argument-  to `dx`, which is visible only outside module `M`.  What Agda wants-  is an invisible `unit` after `dx`, but all you can write is an-  invisible `x` (which is inserted behind the scenes).--  To avoid those kinds of paradoxes, `with` is now outlawed on module-  parameters.  This should ensure that the invisible arguments are-  always exactly the module parameters.--  Since a `where` block is desugared as module with pattern variables-  of the parent clause as module parameters, the same strikes you for-  uses of `with` on pattern variables of the parent function.--  ```agda-  f : Unit → Unit-  f x = unit-    where-      dx : Unit → Unit-      dx unit = x--      g : ∀ u → x ≡ dx u-      g with x-      g | unit  = id ((u : Unit) → unit ≡ dx u) ?-  ```--  The `with` on pattern variable `x` of the parent clause `f x = unit`-  is outlawed now.--Type checking----------------* Termination check failure is now a proper error.--  We no longer continue type checking after termination check-  failures.  Use pragmas `{-# NON_TERMINATING #-}` and `{-#-  NO_TERMINATION_CHECK #-}` near the offending definitions if you want-  to do so.  Or switch off the termination checker altogether with-  `{-# OPTIONS --no-termination-check #-}` (at your own risk!).--* (Since Agda 2.4.2): Termination checking `--without-K` restricts-  structural descent to arguments ending in data types or `Size`.-  Likewise, guardedness is only tracked when result type is data or-  record type.--  ```agda-  mutual-    data WOne : Set where wrap : FOne → WOne-    FOne = ⊥ → WOne--  noo : (X : Set) → (WOne ≡ X) → X → ⊥-  noo .WOne refl (wrap f) = noo FOne iso f-  ```--  `noo` is rejected since at type `X` the structural descent-  `f < wrap f` is discounted `--without-K`.--  ```agda-  data Pandora : Set where-    C : ∞ ⊥ → Pandora--  loop : (A : Set) → A ≡ Pandora → A-  loop .Pandora refl = C (♯ (loop ⊥ foo))-  ```--  `loop` is rejected since guardedness is not tracked at type `A`-  `--without-K`.--  See issues [#1023](https://github.com/agda/agda/issues/1023),-  [#1264](https://github.com/agda/agda/issues/1264),-  [#1292](https://github.com/agda/agda/issues/1292).--Termination checking-----------------------* The termination checker can now recognize simple subterms in dot-  patterns.--  ```agda-  data Subst : (d : Nat) → Set where-    c₁ : ∀ {d} → Subst d → Subst d-    c₂ : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (suc d₁ + d₂)--  postulate-    comp : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (d₁ + d₂)--  lookup : ∀ d → Nat → Subst d → Set₁-  lookup d             zero    (c₁ ρ)             = Set-  lookup d             (suc v) (c₁ ρ)             = lookup d v ρ-  lookup .(suc d₁ + d₂) v      (c₂ {d₁} {d₂} ρ σ) = lookup (d₁ + d₂) v (comp ρ σ)-  ```--  The dot pattern here is actually normalized, so it is--  ```agda-  suc (d₁ + d₂)-  ```--  and the corresponding recursive call argument is `(d₁ + d₂)`.  In-  such simple cases, Agda can now recognize that the pattern is-  constructor applied to call argument, which is valid descent.--  Note however, that Agda only looks for syntactic equality when-  identifying subterms, since it is not allowed to normalize terms on-  the rhs during termination checking.--  Actually writing the dot pattern has no effect, this works as well,-  and looks pretty magical... ;-)--  ```agda-  hidden : ∀{d} → Nat → Subst d → Set₁-  hidden zero    (c₁ ρ)   = Set-  hidden (suc v) (c₁ ρ)   = hidden v ρ-  hidden v       (c₂ ρ σ) = hidden v (comp ρ σ)-  ```--Tools--------### LaTeX-backend--* Fixed the issue of identifiers containing operators being typeset with-  excessive math spacing.--Bug fixes------------* Issue [#1194](https://github.com/agda/agda/issues/1194)--* Issue [#836](https://github.com/agda/agda/issues/836): Fields and-  constructors can be qualified by the record/data *type* as well as-  by their record/data module.  This now works also for record/data-  type imported from parametrized modules:--  ```agda-  module M (_ : Set₁) where--    record R : Set₁ where-      field-        X : Set--  open M Set using (R)  -- rather than using (module R)--  X : R → Set-  X = R.X-  ```--Release notes for Agda version 2.4.2-====================================--Pragmas and options----------------------* New option: `--with-K`--  This can be used to override a global `--without-K` in a file, by-  adding a pragma `{-# OPTIONS --with-K #-}`.--* New pragma `{-# NON_TERMINATING #-}`--  This is a safer version of `NO_TERMINATION_CHECK` which doesn't-  treat the affected functions as terminating. This means that-  `NON_TERMINATING` functions do not reduce during type checking. They-  do reduce at run-time and when invoking `C-c C-n` at top-level (but-  not in a hole).--Language-----------* Instance search is now more efficient and recursive (see-  Issue [#938](https://github.com/agda/agda/issues/938)) (but without-  termination check yet).--  A new keyword `instance` has been introduced (in the style of-  `abstract` and `private`) which must now be used for every-  definition/postulate that has to be taken into account during-  instance resolution. For example:--  ```agda-  record RawMonoid (A : Set) : Set where-    field-      nil  : A-      _++_ : A -> A -> A--  open RawMonoid {{...}}--  instance-    rawMonoidList : {A : Set} -> RawMonoid (List A)-    rawMonoidList = record { nil = []; _++_ = List._++_ }--    rawMonoidMaybe : {A : Set} {{m : RawMonoid A}} -> RawMonoid (Maybe A)-    rawMonoidMaybe {A} = record { nil = nothing ; _++_ = catMaybe }-      where-        catMaybe : Maybe A -> Maybe A -> Maybe A-        catMaybe nothing mb = mb-        catMaybe ma nothing = ma-        catMaybe (just a) (just b) = just (a ++ b)-  ```--  Moreover, each type of an instance must end in (something that reduces-  to) a named type (e.g. a record, a datatype or a postulate). This-  allows us to build a simple index structure--  ```-  data/record name  -->  possible instances-  ```--  that speeds up instance search.--  Instance search takes into account all local bindings and all global-  `instance` bindings and the search is recursive. For instance,-  searching for--  ```agda-  ? : RawMonoid (Maybe (List A))-  ```--  will consider the candidates {`rawMonoidList`, `rawMonoidMaybe`}, fail to-  unify the first one, succeeding with the second one--  ```agda-  ? = rawMonoidMaybe {A = List A} {{m = ?m}} : RawMonoid (Maybe (List A))-  ```--  and continue with goal--  ```agda-  ?m : RawMonoid (List A)-  ```--  This will then find--  ```agda-  ?m = rawMonoidList {A = A}-  ```--  and putting together we have the solution.--  Be careful that there is no termination check for now, you can-  easily make Agda loop by declaring the identity function as an-  instance. But it shouldn’t be possible to make Agda loop by only-  declaring structurally recursive instances (whatever that means).--  Additionally:--  - Uniqueness of instances is up to definitional equality (see-    Issue [#899](https://github.com/agda/agda/issues/899)).--  - Instances of the following form are allowed:--    ```agda-    EqSigma : {A : Set} {B : A → Set} {{EqA : Eq A}}-              {{EqB : {a : A} → Eq (B a)}}-              → Eq (Σ A B)-    ```--    When searching recursively for an instance of type `{a : A} → Eq-    (B a)`, a lambda will automatically be introduced and instance-    search will search for something of type `Eq (B a)` in the context-    extended by `a : A`. When searching for an instance, the `a`-    argument does not have to be implicit, but in the definition of-    `EqSigma`, instance search will only be able to use `EqB` if `a`-    is implicit.--  - There is no longer any attempt to solve irrelevant metas by instance-    search.--  - Constructors of records and datatypes are automatically added to the-    instance table.--* You can now use `quote` in patterns.--  For instance, here is a function that unquotes a (closed) natural-  number term.--  ```agda-  unquoteNat : Term → Maybe Nat-  unquoteNat (con (quote Nat.zero) [])            = just zero-  unquoteNat (con (quote Nat.suc) (arg _ n ∷ [])) = fmap suc (unquoteNat n)-  unquoteNat _                                    = nothing-  ```--* The builtin constructors `AGDATERMUNSUPPORTED` and-  `AGDASORTUNSUPPORTED` are now translated to meta variables when-  unquoting.--* New syntactic sugar `tactic e` and `tactic e | e1 | .. | en`.--  It desugars as follows and makes it less unwieldy to call-  reflection-based tactics.--  ```agda-  tactic e                --> quoteGoal g in unquote (e g)-  tactic e | e1 | .. | en --> quoteGoal g in unquote (e g) e1 .. en-  ```--  Note that in the second form the tactic function should generate a-  function from a number of new subgoals to the original goal. The-  type of `e` should be `Term -> Term` in both cases.--* New reflection builtins for literals.--  The term data type `AGDATERM` now needs an additional constructor-   `AGDATERMLIT` taking a reflected literal defined as follows (with-   appropriate builtin bindings for the types `Nat`, `Float`, etc).--  ```agda-  data Literal : Set where-    nat    : Nat    → Literal-    float  : Float  → Literal-    char   : Char   → Literal-    string : String → Literal-    qname  : QName  → Literal--  {-# BUILTIN AGDALITERAL   Literal #-}-  {-# BUILTIN AGDALITNAT    nat     #-}-  {-# BUILTIN AGDALITFLOAT  float   #-}-  {-# BUILTIN AGDALITCHAR   char    #-}-  {-# BUILTIN AGDALITSTRING string  #-}-  {-# BUILTIN AGDALITQNAME  qname   #-}-  ```--  When quoting (`quoteGoal` or `quoteTerm`) literals will be mapped to-  the `AGDATERMLIT` constructor. Previously natural number literals-  were quoted to `suc`/`zero` application and other literals were-  quoted to `AGDATERMUNSUPPORTED`.--* New reflection builtins for function definitions.--  `AGDAFUNDEF` should now map to a data type defined as follows--  (with-  ```agda-  {-# BUILTIN QNAME       QName   #-}-  {-# BUILTIN ARG         Arg     #-}-  {-# BUILTIN AGDATERM    Term    #-}-  {-# BUILTIN AGDATYPE    Type    #-}-  {-# BUILTIN AGDALITERAL Literal #-}-  ```-  ).--  ```agda-  data Pattern : Set where-    con    : QName → List (Arg Pattern) → Pattern-    dot    : Pattern-    var    : Pattern-    lit    : Literal → Pattern-    proj   : QName → Pattern-    absurd : Pattern--  {-# BUILTIN AGDAPATTERN   Pattern #-}-  {-# BUILTIN AGDAPATCON    con     #-}-  {-# BUILTIN AGDAPATDOT    dot     #-}-  {-# BUILTIN AGDAPATVAR    var     #-}-  {-# BUILTIN AGDAPATLIT    lit     #-}-  {-# BUILTIN AGDAPATPROJ   proj    #-}-  {-# BUILTIN AGDAPATABSURD absurd  #-}--  data Clause : Set where-    clause        : List (Arg Pattern) → Term → Clause-    absurd-clause : List (Arg Pattern) → Clause--  {-# BUILTIN AGDACLAUSE       Clause        #-}-  {-# BUILTIN AGDACLAUSECLAUSE clause        #-}-  {-# BUILTIN AGDACLAUSEABSURD absurd-clause #-}--  data FunDef : Set where-    fun-def : Type → List Clause → FunDef--  {-# BUILTIN AGDAFUNDEF    FunDef  #-}-  {-# BUILTIN AGDAFUNDEFCON fun-def #-}-  ```--* New reflection builtins for extended (pattern-matching) lambda.--  The `AGDATERM` data type has been augmented with a constructor--  ```agda-  AGDATERMEXTLAM : List AGDACLAUSE → List (ARG AGDATERM) → AGDATERM-  ```--  Absurd lambdas (`λ ()`) are quoted to extended lambdas with an-  absurd clause.--* Unquoting declarations.--  You can now define (recursive) functions by reflection using the new-  `unquoteDecl` declaration--  ```agda-  unquoteDecl x = e-  ```--  Here e should have type `AGDAFUNDEF` and evaluate to a closed-  value. This value is then spliced in as the definition of `x`. In-  the body `e`, `x` has type `QNAME` which lets you splice in-  recursive definitions.--  Standard modifiers, such as fixity declarations, can be applied to `x` as-  expected.--* Quoted levels--  Universe levels are now quoted properly instead of being quoted to-  `AGDASORTUNSUPPORTED`. `Setω` still gets an unsupported sort,-  however.--* Module applicants can now be operator applications.--  Example:--  ```agda-  postulate-    [_] : A -> B--  module M (b : B) where--  module N (a : A) = M [ a ]-  ```--  [See Issue [#1245](https://github.com/agda/agda/issues/1245)]--* Minor change in module application-  semantics. [Issue [#892](https://github.com/agda/agda/issues/892)]--  Previously re-exported functions were not redefined when-  instantiating a module. For instance--  ```agda-  module A where f = ...-  module B (X : Set) where-    open A public-  module C = B Nat-  ```--  In this example `C.f` would be an alias for `A.f`, so if both `A`-  and `C` were opened `f` would not be ambiguous. However, this-  behaviour is not correct when `A` and `B` share some module-  parameters-  (Issue [#892](https://github.com/agda/agda/issues/892)). To fix this-  `C` now defines its own copy of `f` (which evaluates to `A.f`),-  which means that opening `A` and `C` results in an ambiguous `f`.--Type checking----------------* Recursive records need to be declared as either `inductive` or-  `coinductive`.  `inductive` is no longer default for recursive-  records. Examples:--  ```agda-  record _×_ (A B : Set) : Set where-    constructor _,_-    field-      fst : A-      snd : B--  record Tree (A : Set) : Set where-    inductive-    constructor tree-    field-      elem     : A-      subtrees : List (Tree A)--  record Stream (A : Set) : Set where-    coinductive-    constructor _::_-    field-      head : A-      tail : Stream A-  ```--  If you are using old-style (musical) coinduction, a record may have-  to be declared as inductive, paradoxically.--  ```agda-  record Stream (A : Set) : Set where-    inductive -- YES, THIS IS INTENDED !-    constructor _∷_-    field-      head : A-      tail : ∞ (Stream A)-  ```--  This is because the "coinduction" happens in the use of `∞` and not-  in the use of `record`.--Tools--------### Emacs mode--* A new menu option `Display` can be used to display the version of-  the running Agda process.--### LaTeX-backend--* New experimental option `references` has been added. When specified,-  i.e.:--  ```latex-  \usepackage[references]{agda}-  ```--  a new command called `\AgdaRef` is provided, which lets you-  reference previously typeset commands, e.g.:--  Let us postulate `\AgdaRef{apa}`.--  ```agda-  \begin{code}-  postulate-    apa : Set-  \end{code}-  ```--  Above `apa` will be typeset (highlighted) the same in the text as in-  the code, provided that the LaTeX output is post-processed using-  `src/data/postprocess-latex.pl`, e.g.:--  ```-  cp $(dirname $(dirname $(agda-mode locate)))/postprocess-latex.pl .-  agda -i. --latex Example.lagda-  cd latex/-  perl ../postprocess-latex.pl Example.tex > Example.processed-  mv Example.processed Example.tex-  xelatex Example.tex-  ```--  Mix-fix and Unicode should work as expected (Unicode requires-  XeLaTeX/LuaLaTeX), but there are limitations:--  - Overloading identifiers should be avoided, if multiples exist-    `\AgdaRef` will typeset according to the first it finds.--  - Only the current module is used, should you need to reference-    identifiers in other modules then you need to specify which other-    module manually, i.e. `\AgdaRef[module]{identifier}`.--Release notes for Agda 2 version 2.4.0.2-========================================--* The Agda input mode now supports alphabetical super and subscripts,-  in addition to the numerical ones that were already present.-  [Issue [#1240](https://github.com/agda/agda/issues/1240)]--* New feature: Interactively split result.--  Make case (`C-c C-c`) with no variables given tries to split on the-  result to introduce projection patterns.  The hole needs to be of-  record type, of course.--  ```agda-  test : {A B : Set} (a : A) (b : B) → A × B-  test a b = ?-  ```--  Result-splitting `?` will produce the new clauses:--  ```agda-  proj₁ (test a b) = ?-  proj₂ (test a b) = ?-  ```--  If hole is of function type ending in a record type, the necessary-  pattern variables will be introduced before the split.  Thus, the-  same result can be obtained by starting from:--  ```agda-  test : {A B : Set} (a : A) (b : B) → A × B-  test = ?-  ```--* The so far undocumented `ETA` pragma now throws an error if applied to-  definitions that are not records.--  `ETA` can be used to force eta-equality at recursive record types,-  for which eta is not enabled automatically by Agda.  Here is such an-  example:--  ```agda-  mutual-    data Colist (A : Set) : Set where-      [] : Colist A-      _∷_ : A → ∞Colist A → Colist A--    record ∞Colist (A : Set) : Set where-      coinductive-      constructor delay-      field       force : Colist A--  open ∞Colist--  {-# ETA ∞Colist #-}--  test : {A : Set} (x : ∞Colist A) → x ≡ delay (force x)-  test x = refl-  ```--  Note: Unsafe use of `ETA` can make Agda loop, e.g. by triggering-  infinite eta expansion!--* Bugs fixed (see [bug tracker](https://github.com/agda/agda/issues)):--  [#1203](https://github.com/agda/agda/issues/1203)--  [#1205](https://github.com/agda/agda/issues/1205)--  [#1209](https://github.com/agda/agda/issues/1209)--  [#1213](https://github.com/agda/agda/issues/1213)--  [#1214](https://github.com/agda/agda/issues/1214)--  [#1216](https://github.com/agda/agda/issues/1216)--  [#1225](https://github.com/agda/agda/issues/1225)--  [#1226](https://github.com/agda/agda/issues/1226)--  [#1231](https://github.com/agda/agda/issues/1231)--  [#1233](https://github.com/agda/agda/issues/1233)--  [#1239](https://github.com/agda/agda/issues/1239)--  [#1241](https://github.com/agda/agda/issues/1241)--  [#1243](https://github.com/agda/agda/issues/1243)--Release notes for Agda 2 version 2.4.0.1-========================================--* The option `--compile-no-main` has been renamed to `--no-main`.--* `COMPILED_DATA` pragmas can now be given for records.--* Various bug fixes.--Release notes for Agda 2 version 2.4.0-======================================--Installation and infrastructure----------------------------------* A new module called `Agda.Primitive` has been introduced. This-  module is available to all users, even if the standard library is-  not used.  Currently the module contains level primitives and their-  representation in Haskell when compiling with MAlonzo:--  ```agda-  infixl 6 _⊔_--  postulate-    Level : Set-    lzero : Level-    lsuc  : (ℓ : Level) → Level-    _⊔_   : (ℓ₁ ℓ₂ : Level) → Level--  {-# COMPILED_TYPE Level ()      #-}-  {-# COMPILED lzero ()           #-}-  {-# COMPILED lsuc  (\_ -> ())   #-}-  {-# COMPILED _⊔_   (\_ _ -> ()) #-}--  {-# BUILTIN LEVEL     Level  #-}-  {-# BUILTIN LEVELZERO lzero  #-}-  {-# BUILTIN LEVELSUC  lsuc   #-}-  {-# BUILTIN LEVELMAX  _⊔_    #-}-  ```--  To bring these declarations into scope you can use a declaration-  like the following one:--  ```agda-  open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)-  ```--  The standard library reexports these primitives (using the names-  `zero` and `suc` instead of `lzero` and `lsuc`) from the `Level`-  module.--  Existing developments using universe polymorphism might now trigger-  the following error message:--  ```-  Duplicate binding for built-in thing LEVEL, previous binding to-    .Agda.Primitive.Level-  ```--  To fix this problem, please remove the duplicate bindings.--  Technical details (perhaps relevant to those who build Agda-  packages):--  The include path now always contains a directory-  `<DATADIR>/lib/prim`, and this directory is supposed to contain a-  subdirectory Agda containing a file `Primitive.agda`.--  The standard location of `<DATADIR>` is system- and-  installation-specific.  E.g., in a Cabal `--user` installation of-  Agda-2.3.4 on a standard single-ghc Linux system it would be-  `$HOME/.cabal/share/Agda-2.3.4` or something similar.--  The location of the `<DATADIR>` directory can be configured at-  compile-time using Cabal flags (`--datadir` and `--datasubdir`).-  The location can also be set at run-time, using the `Agda_datadir`-  environment variable.--Pragmas and options----------------------* Pragma `NO_TERMINATION_CHECK` placed within a mutual block is now-  applied to the whole mutual block (rather than being discarded-  silently).  Adding to the uses 1.-4. outlined in the release notes-  for 2.3.2 we allow:--  3a. Skipping an old-style mutual block: Somewhere within `mutual`-      block before a type signature or first function clause.--   ```agda-   mutual-     {-# NO_TERMINATION_CHECK #-}-     c : A-     c = d--     d : A-     d = c-   ```--* New option `--no-pattern-matching`--  Disables all forms of pattern matching (for the current file).-  You can still import files that use pattern matching.--* New option `-v profile:7`--  Prints some stats on which phases Agda spends how much time.-  (Number might not be very reliable, due to garbage collection-  interruptions, and maybe due to laziness of Haskell.)--* New option `--no-sized-types`--  Option `--sized-types` is now default.  `--no-sized-types` will turn-  off an extra (inexpensive) analysis on data types used for subtyping-  of sized types.--Language-----------* Experimental feature: `quoteContext`--  There is a new keyword `quoteContext` that gives users access to the-  list of names in the current local context. For instance:--  ```agda-  open import Data.Nat-  open import Data.List-  open import Reflection--  foo : ℕ → ℕ → ℕ-  foo 0 m = 0-  foo (suc n) m = quoteContext xs in ?-  ```--  In the remaining goal, the list `xs` will consist of two names, `n`-  and `m`, corresponding to the two local variables. At the moment it-  is not possible to access let bound variables (this feature may be-  added in the future).--* Experimental feature: Varying arity.-  Function clauses may now have different arity, e.g.,--  ```agda-  Sum : ℕ → Set-  Sum 0       = ℕ-  Sum (suc n) = ℕ → Sum n--  sum : (n : ℕ) → ℕ → Sum n-  sum 0       acc   = acc-  sum (suc n) acc m = sum n (m + acc)-  ```--  or,--  ```agda-  T : Bool → Set-  T true  = Bool-  T false = Bool → Bool--  f : (b : Bool) → T b-  f false true  = false-  f false false = true-  f true = true-  ```--  This feature is experimental.  Yet unsupported:-  - Varying arity and `with`.--  - Compilation of functions with varying arity to Haskell, JS, or Epic.--* Experimental feature: copatterns.  (Activated with option `--copatterns`)--  We can now define a record by explaining what happens if you project-  the record.  For instance:--  ```agda-  {-# OPTIONS --copatterns #-}--  record _×_ (A B : Set) : Set where-    constructor _,_-    field-      fst : A-      snd : B-  open _×_--  pair : {A B : Set} → A → B → A × B-  fst (pair a b) = a-  snd (pair a b) = b--  swap : {A B : Set} → A × B → B × A-  fst (swap p) = snd p-  snd (swap p) = fst p--  swap3 : {A B C : Set} → A × (B × C) → C × (B × A)-  fst (swap3 t)       = snd (snd t)-  fst (snd (swap3 t)) = fst (snd t)-  snd (snd (swap3 t)) = fst t-  ```--  Taking a projection on the left hand side (lhs) is called a-  projection pattern, applying to a pattern is called an application-  pattern.  (Alternative terms: projection/application copattern.)--  In the first example, the symbol `pair`, if applied to variable-  patterns `a` and `b` and then projected via `fst`, reduces to-  `a`. `pair` by itself does not reduce.--  A typical application are coinductive records such as streams:--  ```agda-  record Stream (A : Set) : Set where-    coinductive-    field-      head : A-      tail : Stream A-  open Stream--  repeat : {A : Set} (a : A) -> Stream A-  head (repeat a) = a-  tail (repeat a) = repeat a-  ```--  Again, `repeat a` by itself will not reduce, but you can take a-  projection (head or tail) and then it will reduce to the respective-  rhs.  This way, we get the lazy reduction behavior necessary to-  avoid looping corecursive programs.--  Application patterns do not need to be trivial (i.e., variable-  patterns), if we mix with projection patterns.  E.g., we can have--  ```agda-  nats : Nat -> Stream Nat-  head (nats zero) = zero-  tail (nats zero) = nats zero-  head (nats (suc x)) = x-  tail (nats (suc x)) = nats x-  ```--  Here is an example (not involving coinduction) which demostrates-  records with fields of function type:--  ```agda-  -- The State monad--  record State (S A : Set) : Set where-    constructor state-    field-      runState : S → A × S-  open State--  -- The Monad type class--  record Monad (M : Set → Set) : Set1 where-    constructor monad-    field-      return : {A : Set}   → A → M A-      _>>=_  : {A B : Set} → M A → (A → M B) → M B---  -- State is an instance of Monad-  -- Demonstrates the interleaving of projection and application patterns--  stateMonad : {S : Set} → Monad (State S)-  runState (Monad.return stateMonad a  ) s  = a , s-  runState (Monad._>>=_  stateMonad m k) s₀ =-    let a , s₁ = runState m s₀-    in  runState (k a) s₁--  module MonadLawsForState {S : Set} where--    open Monad (stateMonad {S})--    leftId : {A B : Set}(a : A)(k : A → State S B) →-      (return a >>= k) ≡ k a-    leftId a k = refl--    rightId : {A B : Set}(m : State S A) →-      (m >>= return) ≡ m-    rightId m = refl--    assoc : {A B C : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →-      ((m >>= k) >>= l) ≡ (m >>= λ a → (k a >>= l))-    assoc m k l = refl-  ```--  Copatterns are yet experimental and the following does not work:--  - Copatterns and `with` clauses.--  - Compilation of copatterns to Haskell, JS, or Epic.--  - Projections generated by--    ```agda-    open R {{...}}-    ```--    are not handled properly on lhss yet.--  - Conversion checking is slower in the presence of copatterns, since-    stuck definitions of record type do no longer count as neutral,-    since they can become unstuck by applying a projection. Thus,-    comparing two neutrals currently requires comparing all they-    projections, which repeats a lot of work.--* Top-level module no longer required.--  The top-level module can be omitted from an Agda file. The module-  name is then inferred from the file name by dropping the path and-  the `.agda` extension. So, a module defined in `/A/B/C.agda` would get-  the name `C`.--  You can also suppress only the module name of the top-level module-  by writing--  ```agda-  module _ where-  ```--  This works also for parameterised modules.--* Module parameters are now always hidden arguments in projections.-  For instance:--  ```agda-  module M (A : Set) where--    record Prod (B : Set) : Set where-      constructor _,_-      field-        fst : A-        snd : B-    open Prod public--  open M-  ```--  Now, the types of `fst` and `snd` are--  ```agda-  fst : {A : Set}{B : Set} → Prod A B → A-  snd : {A : Set}{B : Set} → Prod A B → B-  ```--  Until 2.3.2, they were--  ```agda-  fst : (A : Set){B : Set} → Prod A B → A-  snd : (A : Set){B : Set} → Prod A B → B-  ```--  This change is a step towards symmetry of constructors and projections.-  (Constructors always took the module parameters as hidden arguments).--* Telescoping lets: Local bindings are now accepted in telescopes-  of modules, function types, and lambda-abstractions.--  The syntax of telescopes as been extended to support `let`:--  ```agda-  id : (let ★ = Set) (A : ★) → A → A-  id A x = x-  ```--  In particular one can now `open` modules inside telescopes:--  ```agda-  module Star where-    ★ : Set₁-    ★ = Set---  module MEndo (let open Star) (A : ★) where-    Endo : ★-    Endo = A → A-  ```--  Finally a shortcut is provided for opening modules:--  ```agda-  module N (open Star) (A : ★) (open MEndo A) (f : Endo) where-    ...-  ```--  The semantics of the latter is--  ```agda-  module _ where-    open Star-    module _ (A : ★) where-      open MEndo A-      module N (f : Endo) where-        ...-  ```--  The semantics of telescoping lets in function types and lambda-  abstractions is just expanding them into ordinary lets.--* More liberal left-hand sides in lets-  [Issue [#1028](https://github.com/agda/agda/issues/1028)]:--  You can now write left-hand sides with arguments also for let-  bindings without a type signature. For instance,--  ```agda-  let f x = suc x in f zero-  ```--  Let bound functions still can't do pattern matching though.--* Ambiguous names in patterns are now optimistically resolved in favor-  of constructors. [Issue [#822](https://github.com/agda/agda/issues/822)]-  In particular, the following succeeds now:--  ```agda-  module M where--    data D : Set₁ where-      [_] : Set → D--  postulate [_] : Set → Set--  open M--  Foo : _ → Set-  Foo [ A ] = A-  ```--* Anonymous `where`-modules are opened-  public. [Issue [#848](https://github.com/agda/agda/issues/848)]--  ```-  <clauses>-  f args = rhs-    module _ telescope where-      body-  <more clauses>-  ```--  means the following (not proper Agda code, since you cannot put a-  module in-between clauses)--  ```-  <clauses>-  module _ {arg-telescope} telescope where-    body--  f args = rhs-  <more clauses>-  ```--  Example:--  ```agda-  A : Set1-  A = B module _ where-    B : Set1-    B = Set--  C : Set1-  C = B-  ```--* Builtin `ZERO` and `SUC` have been merged with `NATURAL`.--  When binding the `NATURAL` builtin, `ZERO` and `SUC` are bound to-  the appropriate constructors automatically. This means that instead-  of writing--  ```agda-  {-# BUILTIN NATURAL Nat #-}-  {-# BUILTIN ZERO zero #-}-  {-# BUILTIN SUC suc #-}-  ```--  you just write--  ```agda-  {-# BUILTIN NATURAL Nat #-}-  ```--* Pattern synonym can now have implicit-  arguments. [Issue [#860](https://github.com/agda/agda/issues/860)]--  For example,--  ```agda-  pattern tail=_ {x} xs = x ∷ xs--  len : ∀ {A} → List A → Nat-  len []         = 0-  len (tail= xs) = 1 + len xs-  ```--* Syntax declarations can now have implicit-  arguments. [Issue [#400](https://github.com/agda/agda/issues/400)]--  For example--  ```agda-  id : ∀ {a}{A : Set a} -> A -> A-  id x = x--  syntax id {A} x = x ∈ A-  ```--* Minor syntax changes--  - `-}` is now parsed as end-comment even if no comment was begun. As-    a consequence, the following definition gives a parse error--    ```agda-    f : {A- : Set} -> Set-    f {A-} = A--    ```--    because Agda now sees `ID(f) LBRACE ID(A) END-COMMENT`, and no-    longer `ID(f) LBRACE ID(A-) RBRACE`.--    The rational is that the previous lexing was to context-sensitive,-    attempting to comment-out `f` using `{-` and `-}` lead to a parse-    error.--  - Fixities (binding strengths) can now be negative numbers as-    well. [Issue [#1109](https://github.com/agda/agda/issues/1109)]--    ```agda-    infix -1 _myop_-    ```--  - Postulates are now allowed in mutual-    blocks. [Issue [#977](https://github.com/agda/agda/issues/977)]--  - Empty where blocks are now-    allowed. [Issue [#947](https://github.com/agda/agda/issues/947)]--  - Pattern synonyms are now allowed in parameterised-    modules. [Issue [#941](https://github.com/agda/agda/issues/941)]--  - Empty hiding and renaming lists in module directives are now allowed.--  - Module directives `using`, `hiding`, `renaming` and `public` can-    now appear in arbitrary order. Multiple-    `using`/`hiding`/`renaming` directives are allowed, but you still-    cannot have both using and `hiding` (because that doesn't make-    sense). [Issue [#493](https://github.com/agda/agda/issues/493)]--Goal and error display-------------------------* The error message `Refuse to construct infinite term` has been-  removed, instead one gets unsolved meta variables.  Reason: the-  error was thrown over-eagerly.-  [Issue [#795](https://github.com/agda/agda/issues/795)]--* If an interactive case split fails with message--  ```-    Since goal is solved, further case distinction is not supported;-    try `Solve constraints' instead-  ```--  then the associated interaction meta is assigned to a solution.-  Press `C-c C-=` (Show constraints) to view the solution and `C-c-  C-s` (Solve constraints) to apply it.-  [Issue [#289](https://github.com/agda/agda/issues/289)]--Type checking----------------* [ Issue [#376](https://github.com/agda/agda/issues/376) ]-  Implemented expansion of bound record variables during meta-  assignment.  Now Agda can solve for metas X that are applied to-  projected variables, e.g.:--  ```agda-  X (fst z) (snd z) = z--  X (fst z)         = fst z-  ```--  Technically, this is realized by substituting `(x , y)` for `z` with fresh-  bound variables `x` and `y`.  Here the full code for the examples:--  ```agda-  record Sigma (A : Set)(B : A -> Set) : Set where-    constructor _,_-    field-      fst : A-      snd : B fst-  open Sigma--  test : (A : Set) (B : A -> Set) ->-    let X : (x : A) (y : B x) -> Sigma A B-        X = _-    in  (z : Sigma A B) -> X (fst z) (snd z) ≡ z-  test A B z = refl--  test' : (A : Set) (B : A -> Set) ->-    let X : A -> A-        X = _-    in  (z : Sigma A B) -> X (fst z) ≡ fst z-  test' A B z = refl-  ```--  The fresh bound variables are named `fst(z)` and `snd(z)` and can appear-  in error messages, e.g.:--  ```agda-  fail : (A : Set) (B : A -> Set) ->-    let X : A -> Sigma A B-        X = _-    in  (z : Sigma A B) -> X (fst z) ≡ z-  fail A B z = refl-  ```--  results in error:--  ```-  Cannot instantiate the metavariable _7 to solution fst(z) , snd(z)-  since it contains the variable snd(z) which is not in scope of the-  metavariable or irrelevant in the metavariable but relevant in the-  solution-  when checking that the expression refl has type _7 A B (fst z) ≡ z-  ```--* Dependent record types and definitions by copatterns require-  reduction with previous function clauses while checking the current-  clause. [Issue [#907](https://github.com/agda/agda/issues/907)]--  For a simple example, consider--  ```agda-  test : ∀ {A} → Σ Nat λ n → Vec A n-  proj₁ test = zero-  proj₂ test = []-  ```--  For the second clause, the lhs and rhs are typed as--  ```agda-  proj₂ test : Vec A (proj₁ test)-  []         : Vec A zero-  ```--  In order for these types to match, we have to reduce the lhs type-  with the first function clause.--  Note that termination checking comes after type checking, so be-  careful to avoid non-termination!  Otherwise, the type checker-  might get into an infinite loop.--* The implementation of the primitive `primTrustMe` has changed.  It-  now only reduces to `REFL` if the two arguments `x` and `y` have the-  same computational normal form.  Before, it reduced when `x` and `y`-  were definitionally equal, which included type-directed equality-  laws such as eta-equality.  Yet because reduction is untyped,-  calling conversion from reduction lead to Agda crashes-  [Issue [#882](https://github.com/agda/agda/issues/882)].--  The amended description of `primTrustMe` is (cf. release notes-  for 2.2.6):--  ```agda-  primTrustMe : {A : Set} {x y : A} → x ≡ y-  ```--  Here `_≡_` is the builtin equality (see BUILTIN hooks for equality,-  above).--  If `x` and `y` have the same computational normal form, then-  `primTrustMe {x = x} {y = y}` reduces to `refl`.--  A note on `primTrustMe`'s runtime behavior: The MAlonzo compiler-  replaces all uses of `primTrustMe` with the `REFL` builtin, without-  any check for definitional equality. Incorrect uses of `primTrustMe`-  can potentially lead to segfaults or similar problems of the-  compiled code.--* Implicit patterns of record type are now only eta-expanded if there-  is a record constructor.-  [Issues [#473](https://github.com/agda/agda/issues/473),-  [#635](https://github.com/agda/agda/issues/635)]--  ```agda-  data D : Set where-    d : D--  data P : D → Set where-    p : P d--  record Rc : Set where-    constructor c-    field f : D--  works : {r : Rc} → P (Rc.f r) → Set-  works p = D-  ```--  This works since the implicit pattern `r` is eta-expanded to `c x`-  which allows the type of `p` to reduce to `P x` and `x` to be-  unified with `d`. The corresponding explicit version is:--  ```agda-  works' : (r : Rc) → P (Rc.f r) → Set-  works' (c .d) p = D-  ```--  However, if the record constructor is removed, the same example will-  fail:--  ```agda-  record R : Set where-    field f : D--  fails : {r : R} → P (R.f r) → Set-  fails p = D--  -- d != R.f r of type D-  -- when checking that the pattern p has type P (R.f r)-  ```--  The error is justified since there is no pattern we could write down-  for `r`.  It would have to look like--  ```agda-  record { f = .d }-  ```--  but anonymous record patterns are not part of the language.--* Absurd lambdas at different source locations are no longer-  different. [Issue [#857](https://github.com/agda/agda/issues/857)]-  In particular, the following code type-checks now:--  ```agda-  absurd-equality : _≡_ {A = ⊥ → ⊥} (λ()) λ()-  absurd-equality = refl-  ```--  Which is a good thing!--* Printing of named implicit function types.--  When printing terms in a context with bound variables Agda renames-  new bindings to avoid clashes with the previously bound names. For-  instance, if `A` is in scope, the type `(A : Set) → A` is printed as-  `(A₁ : Set) → A₁`. However, for implicit function types the name of-  the binding matters, since it can be used when giving implicit-  arguments.--  For this situation, the following new syntax has been introduced:-  `{x = y : A} → B` is an implicit function type whose bound variable-  (in scope in `B`) is `y`, but where the name of the argument is `x`-  for the purposes of giving it explicitly. For instance, with `A` in-  scope, the type `{A : Set} → A` is now printed as `{A = A₁ : Set} →-  A₁`.--  This syntax is only used when printing and is currently not being parsed.--* Changed the semantics of `--without-K`.-  [Issue [#712](https://github.com/agda/agda/issues/712),-  Issue [#865](https://github.com/agda/agda/issues/865),-  Issue [#1025](https://github.com/agda/agda/issues/1025)]--  New specification of `--without-K`:--  When `--without-K` is enabled, the unification of indices for-  pattern matching is restricted in two ways:--  1. Reflexive equations of the form `x == x` are no longer solved,-     instead Agda gives an error when such an equation is encountered.--  2. When unifying two same-headed constructor forms `c us` and `c vs`-     of type `D pars ixs`, the datatype indices `ixs` (but not the-     parameters) have to be *self-unifiable*, i.e. unification of-     `ixs` with itself should succeed positively. This is a nontrivial-     requirement because of point 1.--  Examples:--  - The J rule is accepted.--    ```agda-    J : {A : Set} (P : {x y : A} → x ≡ y → Set) →-        (∀ x → P (refl x)) →-        ∀ {x y} (x≡y : x ≡ y) → P x≡y-    J P p (refl x) = p x-    ```agda--    This definition is accepted since unification of `x` with `y`-    doesn't require deletion or injectivity.--  - The K rule is rejected.--    ```agda-    K : {A : Set} (P : {x : A} → x ≡ x → Set) →-        (∀ x → P (refl {x = x})) →-       ∀ {x} (x≡x : x ≡ x) → P x≡x-    K P p refl = p _-    ```--    Definition is rejected with the following error:--    ```-    Cannot eliminate reflexive equation x = x of type A because K has-    been disabled.-    when checking that the pattern refl has type x ≡ x-    ```--  - Symmetry of the new criterion.--    ```agda-    test₁ : {k l m : ℕ} → k + l ≡ m → ℕ-    test₁ refl = zero--    test₂ : {k l m : ℕ} → k ≡ l + m → ℕ-    test₂ refl = zero-    ```--    Both versions are now accepted (previously only the first one was).--  - Handling of parameters.--    ```agda-    cons-injective : {A : Set} (x y : A) → (x ∷ []) ≡ (y ∷ []) → x ≡ y-    cons-injective x .x refl = refl-    ```--    Parameters are not unified, so they are ignored by the new criterion.--  - A larger example: antisymmetry of ≤.--    ```agda-    data _≤_ : ℕ → ℕ → Set where-      lz : (n : ℕ) → zero ≤ n-      ls : (m n : ℕ) → m ≤ n → suc m ≤ suc n--    ≤-antisym : (m n : ℕ) → m ≤ n → n ≤ m → m ≡ n-    ≤-antisym .zero    .zero    (lz .zero) (lz .zero)   = refl-    ≤-antisym .(suc m) .(suc n) (ls m n p) (ls .n .m q) =-                 cong suc (≤-antisym m n p q)-    ```--  - [ Issue [#1025](https://github.com/agda/agda/issues/1025) ]--    ```agda-    postulate mySpace : Set-    postulate myPoint : mySpace--    data Foo : myPoint ≡ myPoint → Set where-      foo : Foo refl--    test : (i : foo ≡ foo) → i ≡ refl-    test refl = {!!}-    ```--    When applying injectivity to the equation `foo ≡ foo` of type `Foo-    refl`, it is checked that the index `refl` of type `myPoint ≡-    myPoint` is self-unifiable. The equation `refl ≡ refl` again-    requires injectivity, so now the index `myPoint` is checked for-    self-unifiability, hence the error:--    ```-    Cannot eliminate reflexive equation myPoint = myPoint of type-    mySpace because K has been disabled.-    when checking that the pattern refl has type foo ≡ foo-    ```--Termination checking-----------------------* A buggy facility coined "matrix-shaped orders" that supported-  uncurried functions (which take tuples of arguments instead of one-  argument after another) has been removed from the termination-  checker. [Issue [#787](https://github.com/agda/agda/issues/787)]--* Definitions which fail the termination checker are not unfolded any-  longer to avoid loops or stack overflows in Agda.  However, the-  termination checker for a mutual block is only invoked after-  type-checking, so there can still be loops if you define a-  non-terminating function.  But termination checking now happens-  before the other supplementary checks: positivity, polarity,-  injectivity and projection-likeness.  Note that with the pragma `{-#-  NO_TERMINATION_CHECK #-}` you can make Agda treat any function as-  terminating.--* Termination checking of functions defined by `with` has been improved.--  Cases which previously required `--termination-depth` to pass the-  termination checker (due to use of `with`) no longer need the-  flag. For example--  ```agda-  merge : List A → List A → List A-  merge [] ys = ys-  merge xs [] = xs-  merge (x ∷ xs) (y ∷ ys) with x ≤ y-  merge (x ∷ xs) (y ∷ ys)    | false = y ∷ merge (x ∷ xs) ys-  merge (x ∷ xs) (y ∷ ys)    | true  = x ∷ merge xs (y ∷ ys)-  ```--  This failed to termination check previously, since the `with`-  expands to an auxiliary function `merge-aux`:--  ```agda-  merge-aux x y xs ys false = y ∷ merge (x ∷ xs) ys-  merge-aux x y xs ys true  = x ∷ merge xs (y ∷ ys)-  ```--  This function makes a call to `merge` in which the size of one of-  the arguments is increasing. To make this pass the termination-  checker now inlines the definition of `merge-aux` before checking,-  thus effectively termination checking the original source program.--  As a result of this transformation doing `with` on a variable no longer-  preserves termination. For instance, this does not termination check:--  ```agda-  bad : Nat → Nat-  bad n with n-  ... | zero  = zero-  ... | suc m = bad m-  ```--* The performance of the termination checker has been improved.  For-  higher `--termination-depth` the improvement is significant.  While-  the default `--termination-depth` is still 1, checking with higher-  `--termination-depth` should now be feasible.--Compiler backends--------------------* The MAlonzo compiler backend now has support for compiling modules-  that are not full programs (i.e. don't have a main function). The-  goal is that you can write part of a program in Agda and the rest in-  Haskell, and invoke the Agda functions from the Haskell code. The-  following features were added for this reason:--  - A new command-line option `--compile-no-main`: the command--    ```-    agda --compile-no-main Test.agda-    ```--    will compile `Test.agda` and all its dependencies to Haskell and-    compile the resulting Haskell files with `--make`, but (unlike-    `--compile`) not tell GHC to treat `Test.hs` as the main-    module. This type of compilation can be invoked from Emacs by-    customizing the `agda2-backend` variable to value `MAlonzoNoMain` and-    then calling `C-c C-x C-c` as before.--  - A new pragma `COMPILED_EXPORT` was added as part of the MAlonzo-    FFI. If we have an Agda file containing the following:--    ```agda-     module A.B where--     test : SomeType-     test = someImplementation--     {-# COMPILED_EXPORT test someHaskellId #-}-    ```--    then test will be compiled to a Haskell function called-    `someHaskellId` in module `MAlonzo.Code.A.B` that can be invoked-    from other Haskell code. Its type will be translated according to-    the normal MAlonzo rules.--Tools--------### Emacs mode--* A new goal command `Helper Function Type` (`C-c C-h`) has been added.--  If you write an application of an undefined function in a goal, the-  `Helper Function Type` command will print the type that the function-  needs to have in order for it to fit the goal. The type is also-  added to the Emacs kill-ring and can be pasted into the buffer using-  `C-y`.--  The application must be of the form `f args` where `f` is the name of the-  helper function you want to create. The arguments can use all the normal-  features like named implicits or instance arguments.--  Example:--  Here's a start on a naive reverse on vectors:--  ```agda-  reverse : ∀ {A n} → Vec A n → Vec A n-  reverse [] = []-  reverse (x ∷ xs) = {!snoc (reverse xs) x!}-  ```--  Calling `C-c C-h` in the goal prints--  ```agda-  snoc : ∀ {A} {n} → Vec A n → A → Vec A (suc n)-  ```--* A new command `Explain why a particular name is in scope` (`C-c-  C-w`) has been added.-  [Issue [#207](https://github.com/agda/agda/issues/207)]--  This command can be called from a goal or from the top-level and will as the-  name suggests explain why a particular name is in scope.--  For each definition or module that the given name can refer to a trace is-  printed of all open statements and module applications leading back to the-  original definition of the name.--  For example, given--  ```agda-  module A (X : Set₁) where-    data Foo : Set where-      mkFoo : Foo-  module B (Y : Set₁) where-    open A Y public-  module C = B Set-  open C-  ```--  Calling `C-c C-w` on `mkFoo` at the top-level prints--  ```-  mkFoo is in scope as-  * a constructor Issue207.C._.Foo.mkFoo brought into scope by-    - the opening of C at Issue207.agda:13,6-7-    - the application of B at Issue207.agda:11,12-13-    - the application of A at Issue207.agda:9,8-9-    - its definition at Issue207.agda:6,5-10-  ```--  This command is useful if Agda complains about an ambiguous name and-  you need to figure out how to hide the undesired interpretations.--* Improvements to the `make case` command (`C-c C-c`)--  - One can now also split on hidden variables, using the name-    (starting with `.`) with which they are printed.  Use `C-c C-`, to-    see all variables in context.--  - Concerning the printing of generated clauses:--    * Uses named implicit arguments to improve readability.--    * Picks explicit occurrences over implicit ones when there is a-      choice of binding site for a variable.--    * Avoids binding variables in implicit positions by replacing dot-      patterns that uses them by wildcards (`._`).--* Key bindings for lots of "mathematical" characters (examples: 𝐴𝑨𝒜𝓐𝔄)-  have been added to the Agda input method.  Example: type-  `\MiA\MIA\McA\MCA\MfA` to get 𝐴𝑨𝒜𝓐𝔄.--  Note: `\McB` does not exist in Unicode (as well as others in that style),-  but the `\MC` (bold) alphabet is complete.--* Key bindings for "blackboard bold" B (𝔹) and 0-9 (𝟘-𝟡) have been-  added to the Agda input method (`\bb` and `\b[0-9]`).--* Key bindings for controlling simplification/normalisation:--  [TODO: Simplification should be explained somewhere.]--  Commands like `Goal type and context` (`C-c C-,`) could previously-  be invoked in two ways. By default the output was normalised, but if-  a prefix argument was used (for instance via `C-u C-c C-,`), then no-  explicit normalisation was performed. Now there are three options:--  - By default (`C-c C-,`) the output is simplified.--  - If `C-u` is used exactly once (`C-u C-c C-,`), then the result is-    neither (explicitly) normalised nor simplified.--  - If `C-u` is used twice (`C-u C-u C-c C-,`), then the result is-    normalised.--  [TODO: As part of the release of Agda 2.3.4 the key binding page on-  the wiki should be updated.]--### LaTeX-backend--* Two new color scheme options were added to `agda.sty`:--  `\usepackage[bw]{agda}`, which highlights in black and white;-  `\usepackage[conor]{agda}`, which highlights using Conor's colors.--  The default (no options passed) is to use the standard colors.--* If `agda.sty` cannot be found by the LateX environment, it is now-  copied into the LateX output directory (`latex` by default) instead-  of the working directory. This means that the commands needed to-  produce a PDF now is--  ```-  agda --latex -i . <file>.lagda-  cd latex-  pdflatex <file>.tex-  ```--* The LaTeX-backend has been made more tool agnostic, in particular-  XeLaTeX and LuaLaTeX should now work. Here is a small example-  (`test/LaTeXAndHTML/succeed/UnicodeInput.lagda`):--  ```latex-  \documentclass{article}-  \usepackage{agda}-  \begin{document}--  \begin{code}-  data αβγδεζθικλμνξρστυφχψω : Set₁ where--  postulate-    →⇒⇛⇉⇄↦⇨↠⇀⇁ : Set-  \end{code}--  \[-  ∀X [ ∅ ∉ X ⇒ ∃f:X ⟶  ⋃ X\ ∀A ∈ X (f(A) ∈ A) ]-  \]-  \end{document}-  ```--  Compiled as follows, it should produce a nice looking PDF (tested with-  TeX Live 2012):--  ```-  agda --latex <file>.lagda-  cd latex-  xelatex <file>.tex (or lualatex <file>.tex)-  ```--  If symbols are missing or XeLaTeX/LuaLaTeX complains about the font-  missing, try setting a different font using:--  ```latex-  \setmathfont{<math-font>}-  ```--  Use the `fc-list` tool to list available fonts.--* Add experimental support for hyperlinks to identifiers--  If the `hyperref` LateX package is loaded before the Agda package-  and the links option is passed to the Agda package, then the Agda-  package provides a function called `\AgdaTarget`. Identifiers which-  have been declared targets, by the user, will become clickable-  hyperlinks in the rest of the document. Here is a small example-  (`test/LaTeXAndHTML/succeed/Links.lagda`):--  ```latex-  \documentclass{article}-  \usepackage{hyperref}-  \usepackage[links]{agda}-  \begin{document}--  \AgdaTarget{ℕ}-  \AgdaTarget{zero}-  \begin{code}-  data ℕ : Set where-    zero  : ℕ-    suc   : ℕ → ℕ-  \end{code}--  See next page for how to define \AgdaFunction{two} (doesn't turn into a-  link because the target hasn't been defined yet). We could do it-  manually though; \hyperlink{two}{\AgdaDatatype{two}}.--  \newpage--  \AgdaTarget{two}-  \hypertarget{two}{}-  \begin{code}-  two : ℕ-  two = suc (suc zero)-  \end{code}--  \AgdaInductiveConstructor{zero} is of type-  \AgdaDatatype{ℕ}. \AgdaInductiveConstructor{suc} has not been defined to-  be a target so it doesn't turn into a link.--  \newpage--  Now that the target for \AgdaFunction{two} has been defined the link-  works automatically.--  \begin{code}-  data Bool : Set where-    true false : Bool-  \end{code}--  The AgdaTarget command takes a list as input, enabling several-  targets to be specified as follows:--  \AgdaTarget{if, then, else, if\_then\_else\_}-  \begin{code}-  if_then_else_ : {A : Set} → Bool → A → A → A-  if true  then t else f = t-  if false then t else f = f-  \end{code}--  \newpage--  Mixfix identifier need their underscores escaped:-  \AgdaFunction{if\_then\_else\_}.--  \end{document}-  ```--  The boarders around the links can be suppressed using hyperref's-  hidelinks option:--  ```latex-    \usepackage[hidelinks]{hyperref}-  ```--  Note that the current approach to links does not keep track of scoping-  or types, and hence overloaded names might create links which point to-  the wrong place. Therefore it is recommended to not overload names-  when using the links option at the moment, this might get fixed in the-  future.--Release notes for Agda 2 version 2.3.2.2-========================================--* Fixed a bug that sometimes made it tricky to use the Emacs mode on-  Windows [Issue [#757](https://github.com/agda/agda/issues/757)].--* Made Agda build with newer versions of some libraries.--* Fixed a bug that caused ambiguous parse error messages-  [Issue [#147](https://github.com/agda/agda/issues/147)].--Release notes for Agda 2 version 2.3.2.1-========================================--Installation---------------* Made it possible to compile Agda with more recent versions of-  hashable, QuickCheck and Win32.--* Excluded mtl-2.1.--Type checking----------------* Fixed bug in the termination checker-  (Issue [#754](https://github.com/agda/agda/issues/754)).--Release notes for Agda 2 version 2.3.2-======================================--Installation---------------* The Agda-executable package has been removed.--  The executable is now provided as part of the Agda package.--* The Emacs mode no longer depends on haskell-mode or GHCi.--* Compilation of Emacs mode Lisp files.--  You can now compile the Emacs mode Lisp files by running `agda-mode-  compile`. This command is run by `make install`.--  Compilation can, in some cases, give a noticeable speedup.--  WARNING: If you reinstall the Agda mode without recompiling the-  Emacs Lisp files, then Emacs may continue using the old, compiled-  files.--Pragmas and options----------------------* The `--without-K` check now reconstructs constructor parameters.--  New specification of `--without-K`:--  If the flag is activated, then Agda only accepts certain-  case-splits. If the type of the variable to be split is-  `D pars ixs`, where `D` is a data (or record) type, `pars` stands-  for the parameters, and `ixs` the indices, then the following-  requirements must be satisfied:--  - The indices `ixs` must be applications of constructors (or-    literals) to distinct variables. Constructors are usually not-    applied to parameters, but for the purposes of this check-    constructor parameters are treated as other arguments.--  - These distinct variables must not be free in pars.--* Irrelevant arguments are printed as `_` by default now.  To turn on-  printing of irrelevant arguments, use option--  ```-  --show-irrelevant-  ```--* New: Pragma `NO_TERMINATION_CHECK` to switch off termination checker-  for individual function definitions and mutual blocks.--  The pragma must precede a function definition or a mutual block.-  Examples (see `test/Succeed/NoTerminationCheck.agda`):--  1. Skipping a single definition: before type signature.--     ```agda-     {-# NO_TERMINATION_CHECK #-}-     a : A-     a = a-     ```--  2. Skipping a single definition: before first clause.--     ```agda-     b : A-     {-# NO_TERMINATION_CHECK #-}-     b = b-     ```--  3. Skipping an old-style mutual block: Before `mutual` keyword.--     ```agda-     {-# NO_TERMINATION_CHECK #-}-     mutual-       c : A-       c = d--       d : A-       d = c-     ```--  4. Skipping a new-style mutual block: Anywhere before a type-     signature or first function clause in the block--     ```agda-     i : A-     j : A--     i = j-     {-# NO_TERMINATION_CHECK #-}-     j = i-     ```--  The pragma cannot be used in `--safe` mode.--Language-----------* Let binding record patterns--  ```agda-  record _×_ (A B : Set) : Set where-    constructor _,_-    field-      fst : A-      snd : B-  open _×_--  let (x , (y , z)) = t-  in  u-  ```--  will now be interpreted as--  ```agda-  let x = fst t-      y = fst (snd t)-      z = snd (snd t)-  in  u-  ```--  Note that the type of `t` needs to be inferable. If you need to-  provide a type signature, you can write the following:--  ```agda-  let a : ...-      a = t-      (x , (y , z)) = a-  in  u-  ```--* Pattern synonyms--  A pattern synonym is a declaration that can be used on the left hand-  side (when pattern matching) as well as the right hand side (in-  expressions). For example:--  ```agda-  pattern z    = zero-  pattern ss x = suc (suc x)--  f : ℕ -> ℕ-  f z       = z-  f (suc z) = ss z-  f (ss n)  = n-  ```--  Pattern synonyms are implemented by substitution on the abstract-  syntax, so definitions are scope-checked but not type-checked. They-  are particularly useful for universe constructions.--* Qualified mixfix operators--  It is now possible to use a qualified mixfix operator by qualifying-  the first part of the name. For instance--  ```agda-  import Data.Nat as Nat-  import Data.Bool as Bool--  two = Bool.if true then 1 Nat.+ 1 else 0-  ```--* Sections [Issue [#735](https://github.com/agda/agda/issues/735)].-  Agda now parses anonymous modules as sections:--  ```agda-  module _ {a} (A : Set a) where--    data List : Set a where-      []  : List-      _∷_ : (x : A) (xs : List) → List--  module _ {a} {A : Set a} where--    _++_ : List A → List A → List A-    []       ++ ys = ys-    (x ∷ xs) ++ ys = x ∷ (xs ++ ys)--  test : List Nat-  test = (5 ∷ []) ++ (3 ∷ [])-  ```--  In general, now the syntax--  ```agda-  module _ parameters where-    declarations-  ```--  is accepted and has the same effect as--  ```agda-  private-    module M parameters where-      declarations-  open M public-  ```--  for a fresh name `M`.--* Instantiating a module in an open import statement-  [Issue [#481](https://github.com/agda/agda/issues/481)]. Now-  accepted:--  ```agda-  open import Path.Module args [using/hiding/renaming (...)]-  ```--  This only brings the imported identifiers from `Path.Module` into scope,-  not the module itself!  Consequently, the following is pointless, and raises-  an error:--  ```agda-    import Path.Module args [using/hiding/renaming (...)]-  ```--  You can give a private name `M` to the instantiated module via--  ```agda-  import Path.Module args as M [using/hiding/renaming (...)]-  open import Path.Module args as M [using/hiding/renaming (...)]-  ```--  Try to avoid `as` as part of the arguments.  `as` is not a keyword;-  the following can be legal, although slightly obfuscated Agda code:--  ```agda-  open import as as as as as as-  ```--* Implicit module parameters can be given by name. E.g.--  ```agda-  open M {namedArg = bla}-  ```--  This feature has been introduced in Agda 2.3.0 already.--* Multiple type signatures sharing a same type can now be written as a single-  type signature.--  ```agda-  one two : ℕ-  one = suc zero-  two = suc one-  ```--Goal and error display-------------------------* Meta-variables that were introduced by hidden argument `arg` are now-  printed as `_arg_number` instead of just `_number`.-  [Issue [#526](https://github.com/agda/agda/issues/526)]--* Agda expands identifiers in anonymous modules when printing.  Should-  make some goals nicer to read.-  [Issue [#721](https://github.com/agda/agda/issues/721)]--* When a module identifier is ambiguous, Agda tells you if one of them-  is a data type module.-  [Issues [#318](https://github.com/agda/agda/issues/318),-  [#705](https://github.com/agda/agda/issues/705)]--Type checking----------------* Improved coverage checker. The coverage checker splits on arguments-  that have constructor or literal pattern, committing to the-  left-most split that makes progress.  Consider the lookup function-  for vectors:--  ```agda-  data Fin : Nat → Set where-    zero : {n : Nat} → Fin (suc n)-    suc  : {n : Nat} → Fin n → Fin (suc n)--  data Vec (A : Set) : Nat → Set where-    []  : Vec A zero-    _∷_ : {n : Nat} → A → Vec A n → Vec A (suc n)--  _!!_ : {A : Set}{n : Nat} → Vec A n → Fin n → A-  (x ∷ xs) !! zero  = x-  (x ∷ xs) !! suc i = xs !! i-  ```--  In Agda up to 2.3.0, this definition is rejected unless we add-  an absurd clause--  ```agda-  [] !! ()-  ```--  This is because the coverage checker committed on splitting on the-  vector argument, even though this inevitably lead to failed-  coverage, because a case for the empty vector `[]` is missing.--  The improvement to the coverage checker consists on committing only-  on splits that have a chance of covering, since all possible-  constructor patterns are present.  Thus, Agda will now split first-  on the `Fin` argument, since cases for both `zero` and `suc` are-  present.  Then, it can split on the `Vec` argument, since the empty-  vector is already ruled out by instantiating `n` to a `suc _`.--* Instance arguments resolution will now consider candidates which-  still expect hidden arguments. For example:--  ```agda-  record Eq (A : Set) : Set where-    field eq : A → A → Bool--  open Eq {{...}}--  eqFin : {n : ℕ} → Eq (Fin n)-  eqFin = record { eq = primEqFin }--  testFin : Bool-  testFin = eq fin1 fin2-  ```--  The type-checker will now resolve the instance argument of the `eq`-  function to `eqFin {_}`. This is only done for hidden arguments, not-  instance arguments, so that the instance search stays non-recursive.--* Constraint solving: Upgraded Miller patterns to record patterns.-  [Issue [#456](https://github.com/agda/agda/issues/456)]--  Agda now solves meta-variables that are applied to record patterns.-  A typical (but here, artificial) case is:--  ```agda-  record Sigma (A : Set)(B : A -> Set) : Set where-    constructor _,_-    field-      fst : A-      snd : B fst--  test : (A : Set)(B : A -> Set) ->-    let X : Sigma A B -> Sigma A B-        X = _-    in  (x : A)(y : B x) -> X (x , y) ≡ (x , y)-  test A B x y = refl-  ```--  This yields a constraint of the form--  ```-  _X A B (x , y) := t[x,y]-  ```--  (with `t[x,y] = (x, y)`) which is not a Miller pattern.-  However, Agda now solves this as--  ```-  _X A B z := t[fst z,snd z].-  ```--* Changed: solving recursive constraints.-  [Issue [#585](https://github.com/agda/agda/issues/585)]--  Until 2.3.0, Agda sometimes inferred values that did not pass the-  termination checker later, or would even make Agda loop. To prevent-  this, the occurs check now also looks into the definitions of the-  current mutual block, to avoid constructing recursive solutions. As-  a consequence, also terminating recursive solutions are no longer-  found automatically.--  This effects a programming pattern where the recursively computed-  type of a recursive function is left to Agda to solve.--  ```agda-  mutual--    T : D -> Set-    T pattern1 = _-    T pattern2 = _--    f : (d : D) -> T d-    f pattern1 = rhs1-    f pattern2 = rhs2-  ```--  This might no longer work from now on. See examples-  `test/Fail/Issue585*.agda`.--* Less eager introduction of implicit parameters.-  [Issue [#679](https://github.com/agda/agda/issues/679)]--  Until Agda 2.3.0, trailing hidden parameters were introduced eagerly-  on the left hand side of a definition.  For instance, one could not-  write--  ```agda-  test : {A : Set} -> Set-  test = \ {A} -> A-  ```--  because internally, the hidden argument `{A : Set}` was added to the-  left-hand side, yielding--  ```agda-  test {_} = \ {A} -> A-  ```--  which raised a type error.  Now, Agda only introduces the trailing-  implicit parameters it has to, in order to maintain uniform function-  arity.  For instance, in--  ```agda-  test : Bool -> {A B C : Set} -> Set-  test true {A}      = A-  test false {B = B} = B-  ```--  Agda will introduce parameters `A` and `B` in all clauses, but not-  `C`, resulting in--  ```agda-  test : Bool -> {A B C : Set} -> Set-  test true  {A} {_}     = A-  test false {_} {B = B} = B-  ```--  Note that for checking `where`-clauses, still all hidden trailing-  parameters are in scope.  For instance:--  ```agda-  id : {i : Level}{A : Set i} -> A -> A-  id = myId-    where myId : forall {A} -> A -> A-          myId x = x-  ```--  To be able to fill in the meta variable `_1` in--  ```agda-  myId : {A : Set _1} -> A -> A-  ```--  the hidden parameter `{i : Level}` needs to be in scope.--  As a result of this more lazy introduction of implicit parameters,-  the following code now passes.--  ```agda-  data Unit : Set where-    unit : Unit--  T : Unit → Set-  T unit = {u : Unit} → Unit--  test : (u : Unit) → T u-  test unit with unit-  ... | _ = λ {v} → v-  ```--  Before, Agda would eagerly introduce the hidden parameter `{v}` as-  unnamed left-hand side parameter, leaving no way to refer to it.--  The related Issue [#655](https://github.com/agda/agda/issues/655)-  has also been addressed.  It is now possible to make `synonym'-  definitions--  ```-  name = expression-  ```--  even when the type of expression begins with a hidden quantifier.-  Simple example:--  ```-  id2 = id-  ```--  That resulted in unsolved metas until 2.3.0.--* Agda detects unused arguments and ignores them during equality-  checking. [Issue [#691](https://github.com/agda/agda/issues/691),-  solves also Issue [#44](https://github.com/agda/agda/issues/44)]--  Agda's polarity checker now assigns 'Nonvariant' to arguments that-  are not actually used (except for absurd matches).  If `f`'s first-  argument is Nonvariant, then `f x` is definitionally equal to `f y`-  regardless of `x` and `y`.  It is similar to irrelevance, but does-  not require user annotation.--  For instance, unused module parameters do no longer get in the way:--  ```agda-  module M (x : Bool) where--    not : Bool → Bool-    not true  = false-    not false = true--  open M true-  open M false renaming (not to not′)--  test : (y : Bool) → not y ≡ not′ y-  test y = refl-  ```--  Matching against record or absurd patterns does not count as `use',-  so we get some form of proof irrelevance:--  ```agda-  data ⊥ : Set where-  record ⊤ : Set where-    constructor trivial--  data Bool : Set where-    true false : Bool--  True : Bool → Set-  True true  = ⊤-  True false = ⊥--  fun : (b : Bool) → True b → Bool-  fun true  trivial = true-  fun false ()--  test : (b : Bool) → (x y : True b) → fun b x ≡ fun b y-  test b x y = refl-  ```--  More examples in `test/Succeed/NonvariantPolarity.agda`.--  Phantom arguments:  Parameters of record and data types are considered-  `used' even if they are not actually used.  Consider:--  ```agda-  False : Nat → Set-  False zero    = ⊥-  False (suc n) = False n--  module Invariant where-    record Bla (n : Nat)(p : False n) : Set where--  module Nonvariant where-    Bla : (n : Nat) → False n → Set-    Bla n p = ⊤-  ```--  Even though record `Bla` does not use its parameters `n` and `p`,-  they are considered as used, allowing "phantom type" techniques.--  In contrast, the arguments of function `Bla` are recognized as-  unused.  The following code type-checks if we open `Invariant` but-  leaves unsolved metas if we open `Nonvariant`.--  ```agda-  drop-suc : {n : Nat}{p : False n} → Bla (suc n) p → Bla n p-  drop-suc _ = _--  bla : (n : Nat) → {p : False n} → Bla n p → ⊥-  bla zero {()} b-  bla (suc n) b = bla n (drop-suc b)-  ```--  If `Bla` is considered invariant, the hidden argument in the-  recursive call can be inferred to be `p`.  If it is considered-  non-variant, then `Bla n X = Bla n p` does not entail `X = p` and-  the hidden argument remains unsolved.  Since `bla` does not actually-  use its hidden argument, its value is not important and it could be-  searched for.  Unfortunately, polarity analysis of `bla` happens-  only after type checking, thus, the information that `bla` is-  non-variant in `p` is not available yet when meta-variables are-  solved.  (See-  `test/Fail/BrokenInferenceDueToNonvariantPolarity.agda`)--* Agda now expands simple definitions (one clause, terminating) to-  check whether a function is constructor-  headed. [Issue [#747](https://github.com/agda/agda/issues/747)] For-  instance, the following now also works:--  ```agda-  MyPair : Set -> Set -> Set-  MyPair A B = Pair A B--  Vec : Set -> Nat -> Set-  Vec A zero    = Unit-  Vec A (suc n) = MyPair A (Vec A n)-  ```--  Here, `Unit` and `Pair` are data or record types.--Compiler backends--------------------* `-Werror` is now overridable.--  To enable compilation of Haskell modules containing warnings, the-  `-Werror` flag for the MAlonzo backend has been made-  overridable. If, for example, `--ghc-flag=-Wwarn` is passed when-  compiling, one can get away with things like:--  ```agda-  data PartialBool : Set where-    true : PartialBool--  {-# COMPILED_DATA PartialBool Bool True #-}-  ```--  The default behavior remains as it used to be and rejects the above-  program.--Tools--------### Emacs mode--* Asynchronous Emacs mode.--  One can now use Emacs while a buffer is type-checked. If the buffer-  is edited while the type-checker runs, then syntax highlighting will-  not be updated when type-checking is complete.--* Interactive syntax highlighting.--  The syntax highlighting is updated while a buffer is type-checked:--  - At first the buffer is highlighted in a somewhat crude way-    (without go-to-definition information for overloaded-    constructors).--  - If the highlighting level is "interactive", then the piece of code-    that is currently being type-checked is highlighted as such. (The-    default is "non-interactive".)--  - When a mutual block has been type-checked it is highlighted-    properly (this highlighting includes warnings for potential-    non-termination).--  The highlighting level can be controlled via the new configuration-  variable `agda2-highlight-level`.--* Multiple case-splits can now be performed in one go.--  Consider the following example:--  ```agda-  _==_ : Bool → Bool → Bool-  b₁ == b₂ = {!!}-  ```--  If you split on `b₁ b₂`, then you get the following code:--  ```agda-  _==_ : Bool → Bool → Bool-  true == true = {!!}-  true == false = {!!}-  false == true = {!!}-  false == false = {!!}-  ```--  The order of the variables matters. Consider the following code:--  ```agda-  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A-  lookup xs i = {!!}-  ```--  If you split on `xs i`, then you get the following code:--  ```agda-  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A-  lookup [] ()-  lookup (x ∷ xs) zero = {!!}-  lookup (x ∷ xs) (suc i) = {!!}-  ```--  However, if you split on `i xs`, then you get the following code-  instead:--  ```agda-  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A-  lookup (x ∷ xs) zero = ?-  lookup (x ∷ xs) (suc i) = ?-  ```--  This code is rejected by Agda 2.3.0, but accepted by 2.3.2 thanks-  to improved coverage checking (see above).--* The Emacs mode now presents information about which module is-  currently being type-checked.--* New global menu entry: `Information about the character at point`.--  If this entry is selected, then information about the character at-  point is displayed, including (in many cases) information about how-  to type the character.--* Commenting/uncommenting the rest of the buffer.--  One can now comment or uncomment the rest of the buffer by typing-  `C-c C-x M-;` or by selecting the menu entry `Comment/uncomment` the-  rest of the buffer".--* The Emacs mode now uses the Agda executable instead of GHCi.--  The `*ghci*` buffer has been renamed to `*agda2*`.--  A new configuration variable has been introduced:-  `agda2-program-name`, the name of the Agda executable (by default-  `agda`).--  The variable `agda2-ghci-options` has been replaced by-  `agda2-program-args`: extra arguments given to the Agda executable-  (by default `none`).--  If you want to limit Agda's memory consumption you can add some-  arguments to `agda2-program-args`, for instance `+RTS -M1.5G -RTS`.--* The Emacs mode no longer depends on haskell-mode.--  Users who have customised certain haskell-mode variables (such as-  `haskell-ghci-program-args`) may want to update their configuration.--### LaTeX-backend--An experimental LaTeX-backend which does precise highlighting a la the-HTML-backend and code alignment a la lhs2TeX has been added.--Here is a sample input literate Agda file:--  ```latex-  \documentclass{article}--  \usepackage{agda}--  \begin{document}--  The following module declaration will be hidden in the output.--  \AgdaHide{-  \begin{code}-  module M where-  \end{code}-  }--  Two or more spaces can be used to make the backend align stuff.--  \begin{code}-  data ℕ : Set where-    zero  : ℕ-    suc   : ℕ → ℕ--  _+_ : ℕ → ℕ → ℕ-  zero   + n = n-  suc m  + n = suc (m + n)-  \end{code}--  \end{document}-  ```--To produce an output PDF issue the following commands:--  ```-  agda --latex -i . <file>.lagda-  pdflatex latex/<file>.tex-  ```--Only the top-most module is processed, like with lhs2tex and unlike-with the HTML-backend. If you want to process imported modules you-have to call `agda --latex` manually on each of those modules.--There are still issues related to formatting, see the bug tracker for-more information:--  https://code.google.com/p/agda/issues/detail?id=697--The default `agda.sty` might therefore change in backwards-incompatible-ways, as work proceeds in trying to resolve those problems.--Implemented features:--* Two or more spaces can be used to force alignment of things, like-  with lhs2tex. See example above.--* The highlighting information produced by the type checker is used to-  generate the output. For example, the data declaration in the-  example above, produces:--  ```agda-  \AgdaKeyword{data} \AgdaDatatype{ℕ} \AgdaSymbol{:}-      \AgdaPrimitiveType{Set} \AgdaKeyword{where}-  ```--  These LaTeX commands are defined in `agda.sty` (which is imported by-  `\usepackage{agda}`) and cause the highlighting.--* The LaTeX-backend checks if `agda.sty` is found by the LaTeX-  environment, if it isn't a default `agda.sty` is copied from Agda's-  `data-dir` into the working directory (and thus made available to-  the LaTeX environment).--  If the default `agda.sty` isn't satisfactory (colors, fonts,-  spacing, etc) then the user can modify it and make put it somewhere-  where the LaTeX environment can find it. Hopefully most aspects-  should be modifiable via `agda.sty` rather than having to tweak the-  implementation.--* `--latex-dir` can be used to change the default output directory.--Release notes for Agda 2 version 2.3.0-======================================--Language-----------* New more liberal syntax for mutually recursive definitions.--  It is no longer necessary to use the `mutual` keyword to define-  mutually recursive functions or datatypes. Instead, it is enough to-  declare things before they are used. Instead of--  ```agda-  mutual-    f : A-    f = a[f, g]--    g : B[f]-    g = b[f, g]-  ```--  you can now write--  ```agda-  f : A-  g : B[f]-  f = a[f, g]-  g = b[f, g].-  ```--  With the new style you have more freedom in choosing the order in-  which things are type checked (previously type signatures were-  always checked before definitions). Furthermore you can mix-  arbitrary declarations, such as modules and postulates, with-  mutually recursive definitions.--  For data types and records the following new syntax is used to-  separate the declaration from the definition:--  ```agda-  -- Declaration.-  data Vec (A : Set) : Nat → Set  -- Note the absence of 'where'.--  -- Definition.-  data Vec A where-    []   : Vec A zero-    _::_ : {n : Nat} → A → Vec A n → Vec A (suc n)--  -- Declaration.-  record Sigma (A : Set) (B : A → Set) : Set--  -- Definition.-  record Sigma A B where-    constructor _,_-    field fst : A-          snd : B fst-  ```--  When making separated declarations/definitions private or abstract-  you should attach the `private` keyword to the declaration and the-  `abstract` keyword to the definition. For instance, a private,-  abstract function can be defined as--  ```agda-  private-    f : A-  abstract-    f = e-  ```--  Finally it may be worth noting that the old style of mutually-  recursive definitions is still supported (it basically desugars into-  the new style).--* Pattern matching lambdas.--  Anonymous pattern matching functions can be defined using the syntax--  ```-  \ { p11 .. p1n -> e1 ; ... ; pm1 .. pmn -> em }-  ```--  (where, as usual, `\` and `->` can be replaced by `λ` and-  `→`). Internally this is translated into a function definition of-  the following form:--  ```-  .extlam p11 .. p1n = e1-  ...-  .extlam pm1 .. pmn = em-  ```--  This means that anonymous pattern matching functions are generative.-  For instance, `refl` will not be accepted as an inhabitant of the type--  ```agda-  (λ { true → true ; false → false }) ≡-  (λ { true → true ; false → false }),-  ```--  because this is equivalent to `extlam1 ≡ extlam2` for some distinct-  fresh names `extlam1` and `extlam2`.--  Currently the `where` and `with` constructions are not allowed in-  (the top-level clauses of) anonymous pattern matching functions.--  Examples:--  ```agda-  and : Bool → Bool → Bool-  and = λ { true x → x ; false _ → false }--  xor : Bool → Bool → Bool-  xor = λ { true  true  → false-          ; false false → false-          ; _     _     → true-          }--  fst : {A : Set} {B : A → Set} → Σ A B → A-  fst = λ { (a , b) → a }--  snd : {A : Set} {B : A → Set} (p : Σ A B) → B (fst p)-  snd = λ { (a , b) → b }-  ```--* Record update syntax.--  Assume that we have a record type and a corresponding value:--  ```agda-  record MyRecord : Set where-    field-      a b c : ℕ--  old : MyRecord-  old = record { a = 1; b = 2; c = 3 }-  ```--  Then we can update (some of) the record value's fields in the-  following way:--  ```agda-  new : MyRecord-  new = record old { a = 0; c = 5 }-  ```--  Here new normalises to `record { a = 0; b = 2; c = 5 }`. Any-  expression yielding a value of type `MyRecord` can be used instead of-  old.--  Record updating is not allowed to change types: the resulting value-  must have the same type as the original one, including the record-  parameters. Thus, the type of a record update can be inferred if the-  type of the original record can be inferred.--  The record update syntax is expanded before type checking. When the-  expression--  ```agda-  record old { upd-fields }-  ```--  is checked against a record type `R`, it is expanded to--  ```agda-  let r = old in record { new-fields },-  ```--  where old is required to have type `R` and new-fields is defined as-  follows: for each field `x` in `R`,--    - if `x = e` is contained in `upd-fields` then `x = e` is included in-      `new-fields`, and otherwise--    - if `x` is an explicit field then `x = R.x r` is included in-      `new-fields`, and--    - if `x` is an implicit or instance field, then it is omitted from-      `new-fields`.--  (Instance arguments are explained below.) The reason for treating-  implicit and instance fields specially is to allow code like the-  following:--  ```agda-  record R : Set where-    field-      {length} : ℕ-      vec      : Vec ℕ length-      -- More fields…--  xs : R-  xs = record { vec = 0 ∷ 1 ∷ 2 ∷ [] }--  ys = record xs { vec = 0 ∷ [] }-  ```--  Without the special treatment the last expression would need to-  include a new binding for length (for instance `length = _`).--* Record patterns which do not contain data type patterns, but which-  do contain dot patterns, are no longer rejected.--* When the `--without-K` flag is used literals are now treated as-  constructors.--* Under-applied functions can now reduce.--  Consider the following definition:--  ```agda-  id : {A : Set} → A → A-  id x = x-  ```--  Previously the expression `id` would not reduce. This has been-  changed so that it now reduces to `λ x → x`. Usually this makes-  little difference, but it can be important in conjunction with-  `with`. See Issue [#365](https://github.com/agda/agda/issues/365)-  for an example.--* Unused AgdaLight legacy syntax `(x y : A; z v : B)` for telescopes-  has been removed.--### Universe polymorphism--* Universe polymorphism is now enabled by default.  Use-  `--no-universe-polymorphism` to disable it.--* Universe levels are no longer defined as a data type.--  The basic level combinators can be introduced in the following way:--  ```agda-  postulate-    Level : Set-    zero  : Level-    suc   : Level → Level-    max   : Level → Level → Level--  {-# BUILTIN LEVEL     Level #-}-  {-# BUILTIN LEVELZERO zero  #-}-  {-# BUILTIN LEVELSUC  suc   #-}-  {-# BUILTIN LEVELMAX  max   #-}-  ```--* The BUILTIN equality is now required to be universe-polymorphic.--* `trustMe` is now universe-polymorphic.--### Meta-variables and unification--* Unsolved meta-variables are now frozen after every mutual block.-  This means that they cannot be instantiated by subsequent code. For-  instance,--  ```agda-  one : Nat-  one = _--  bla : one ≡ suc zero-  bla = refl-  ```--  leads to an error now, whereas previously it lead to the-  instantiation of `_` with `suc zero`. If you want to make use of the-  old behaviour, put the two definitions in a mutual block.--  All meta-variables are unfrozen during interactive editing, so that-  the user can fill holes interactively. Note that type-checking of-  interactively given terms is not perfect: Agda sometimes refuses to-  load a file, even though no complaints were raised during the-  interactive construction of the file. This is because certain checks-  (for instance, positivity) are only invoked when a file is loaded.--* Record types can now be inferred.--  If there is a unique known record type with fields matching the-  fields in a record expression, then the type of the expression will-  be inferred to be the record type applied to unknown parameters.--  If there is no known record type with the given fields the type-  checker will give an error instead of producing lots of unsolved-  meta-variables.--  Note that "known record type" refers to any record type in any-  imported module, not just types which are in scope.--* The occurrence checker distinguishes rigid and strongly rigid-  occurrences [Reed, LFMTP 2009; Abel & Pientka, TLCA 2011].--  The completeness checker now accepts the following code:--  ```agda-  h : (n : Nat) → n ≡ suc n → Nat-  h n ()-  ```--  Internally this generates a constraint `_n = suc _n` where the-  meta-variable `_n` occurs strongly rigidly, i.e. on a constructor-  path from the root, in its own defining term tree. This is never-  solvable.--  Weakly rigid recursive occurrences may have a solution [Jason Reed's-  PhD thesis, page 106]:--  ```agda-  test : (k : Nat) →-         let X : (Nat → Nat) → Nat-             X = _-         in-         (f : Nat → Nat) → X f ≡ suc (f (X (λ x → k)))-  test k f = refl-  ```--  The constraint `_X k f = suc (f (_X k (λ x → k)))` has the solution-  `_X k f = suc (f (suc k))`, despite the recursive occurrence of-  `_X`.  Here `_X` is not strongly rigid, because it occurs under the-  bound variable `f`. Previously Agda rejected this code; now it instead-  complains about an unsolved meta-variable.--* Equation constraints involving the same meta-variable in the head-  now trigger pruning [Pientka, PhD, Sec. 3.1.2; Abel & Pientka, TLCA-  2011]. Example:--  ```agda-  same : let X : A → A → A → A × A-             X = _-         in {x y z : A} → X x y y ≡ (x , y)-                        × X x x y ≡ X x y y-  same = refl , refl-  ```--  The second equation implies that `X` cannot depend on its second-  argument. After pruning the first equation is linear and can be-  solved.--* Instance arguments.--  A new type of hidden function arguments has been added: instance-  arguments. This new feature is based on influences from Scala's-  implicits and Agda's existing implicit arguments.--  Plain implicit arguments are marked by single braces: `{…}`. Instance-  arguments are instead marked by double braces: `{{…}}`. Example:--  ```agda-  postulate-    A : Set-    B : A → Set-    a : A-    f : {{a : A}} → B a-  ```--  Instead of the double braces you can use the symbols `⦃` and `⦄`,-  but these symbols must in many cases be surrounded by-  whitespace. (If you are using Emacs and the Agda input method, then-  you can conjure up the symbols by typing `\{{` and `\}}`,-  respectively.)--  Instance arguments behave as ordinary implicit arguments, except for-  one important aspect: resolution of arguments which are not provided-  explicitly. For instance, consider the following code:--  ```agda-    test = f-  ```--  Here Agda will notice that `f`'s instance argument was not provided-  explicitly, and try to infer it. All definitions in scope at `f`'s-  call site, as well as all variables in the context, are considered.-  If exactly one of these names has the required type `A`, then the-  instance argument will be instantiated to this name.--  This feature can be used as an alternative to Haskell type classes.-  If we define--  ```agda-  record Eq (A : Set) : Set where-    field equal : A → A → Bool,-  ```--  then we can define the following projection:--  ```agda-  equal : {A : Set} {{eq : Eq A}} → A → A → Bool-  equal {{eq}} = Eq.equal eq-  ```--  Now consider the following expression:--  ```agda-  equal false false ∨ equal 3 4-  ```--  If the following `Eq` "instances" for `Bool` and `ℕ` are in scope, and no-  others, then the expression is accepted:--  ```agda-  eq-Bool : Eq Bool-  eq-Bool = record { equal = … }--  eq-ℕ : Eq ℕ-  eq-ℕ = record { equal = … }-  ```--  A shorthand notation is provided to avoid the need to define-  projection functions manually:--  ```agda-  module Eq-with-implicits = Eq {{...}}-  ```--  This notation creates a variant of `Eq`'s record module, where the-  main `Eq` argument is an instance argument instead of an explicit one.-  It is equivalent to the following definition:--  ```agda-  module Eq-with-implicits {A : Set} {{eq : Eq A}} = Eq eq-  ```--  Note that the short-hand notation allows you to avoid naming the-  "-with-implicits" module:--  ```agda-  open Eq {{...}}-  ```--  Instance argument resolution is not recursive. As an example,-  consider the following "parametrised instance":--  ```agda-  eq-List : {A : Set} → Eq A → Eq (List A)-  eq-List {A} eq = record { equal = eq-List-A }-    where-    eq-List-A : List A → List A → Bool-    eq-List-A []       []       = true-    eq-List-A (a ∷ as) (b ∷ bs) = equal a b ∧ eq-List-A as bs-    eq-List-A _        _        = false-  ```--  Assume that the only `Eq` instances in scope are `eq-List` and-  `eq-ℕ`.  Then the following code does not type-check:--  ```agda-  test = equal (1 ∷ 2 ∷ []) (3 ∷ 4 ∷ [])-  ```--  However, we can make the code work by constructing a suitable-  instance manually:--  ```agda-  test′ = equal (1 ∷ 2 ∷ []) (3 ∷ 4 ∷ [])-    where eq-List-ℕ = eq-List eq-ℕ-  ```--  By restricting the "instance search" to be non-recursive we avoid-  introducing a new, compile-time-only evaluation model to Agda.--  For more information about instance arguments, see Devriese &-  Piessens [ICFP 2011]. Some examples are also available in the-  examples/instance-arguments subdirectory of the Agda distribution.--### Irrelevance--* Dependent irrelevant function types.--  Some examples illustrating the syntax of dependent irrelevant-  function types:--  ```-  .(x y : A) → B    .{x y z : A} → B-  ∀ x .y → B        ∀ x .{y} {z} .v → B-  ```--  The declaration--  ```-  f : .(x : A) → B[x]-  f x = t[x]-  ```--  requires that `x` is irrelevant both in `t[x]` and in `B[x]`. This-  is possible if, for instance, `B[x] = B′ x`, with `B′ : .A → Set`.--  Dependent irrelevance allows us to define the eliminator for the-  `Squash` type:--  ```agda-  record Squash (A : Set) : Set where-    constructor squash-    field-      .proof : A--  elim-Squash : {A : Set} (P : Squash A → Set)-                (ih : .(a : A) → P (squash a)) →-                (a⁻ : Squash A) → P a⁻-  elim-Squash P ih (squash a) = ih a-  ```--  Note that this would not type-check with--  ```agda-  (ih : (a : A) -> P (squash a)).-  ```--* Records with only irrelevant fields.--  The following now works:--  ```agda-  record IsEquivalence {A : Set} (_≈_ : A → A → Set) : Set where-    field-      .refl  : Reflexive _≈_-      .sym   : Symmetric _≈_-      .trans : Transitive _≈_--  record Setoid : Set₁ where-    infix 4 _≈_-    field-      Carrier        : Set-      _≈_            : Carrier → Carrier → Set-      .isEquivalence : IsEquivalence _≈_--    open IsEquivalence isEquivalence public-  ```--  Previously Agda complained about the application-  `IsEquivalence isEquivalence`, because `isEquivalence` is irrelevant-  and the `IsEquivalence` module expected a relevant argument. Now,-  when record modules are generated for records consisting solely of-  irrelevant arguments, the record parameter is made irrelevant:--   ```agda-  module IsEquivalence {A : Set} {_≈_ : A → A → Set}-                       .(r : IsEquivalence {A = A} _≈_) where-    …-  ```--* Irrelevant things are no longer erased internally. This means that-  they are printed as ordinary terms, not as `_` as before.--* The new flag `--experimental-irrelevance` enables irrelevant-  universe levels and matching on irrelevant data when only one-  constructor is available. These features are very experimental and-  likely to change or disappear.--### Reflection--* The reflection API has been extended to mirror features like-  irrelevance, instance arguments and universe polymorphism, and to-  give (limited) access to definitions. For completeness all the-  builtins and primitives are listed below:--  ```agda-  -- Names.--  postulate Name : Set--  {-# BUILTIN QNAME Name #-}--  primitive-    -- Equality of names.-    primQNameEquality : Name → Name → Bool--  -- Is the argument visible (explicit), hidden (implicit), or an-  -- instance argument?--  data Visibility : Set where-    visible hidden instance : Visibility--  {-# BUILTIN HIDING   Visibility #-}-  {-# BUILTIN VISIBLE  visible    #-}-  {-# BUILTIN HIDDEN   hidden     #-}-  {-# BUILTIN INSTANCE instance   #-}--  -- Arguments can be relevant or irrelevant.--  data Relevance : Set where-    relevant irrelevant : Relevance--  {-# BUILTIN RELEVANCE  Relevance  #-}-  {-# BUILTIN RELEVANT   relevant   #-}-  {-# BUILTIN IRRELEVANT irrelevant #-}--  -- Arguments.--  data Arg A : Set where-    arg : (v : Visibility) (r : Relevance) (x : A) → Arg A--  {-# BUILTIN ARG    Arg #-}-  {-# BUILTIN ARGARG arg #-}--  -- Terms.--  mutual-    data Term : Set where-      -- Variable applied to arguments.-      var     : (x : ℕ) (args : List (Arg Term)) → Term-      -- Constructor applied to arguments.-      con     : (c : Name) (args : List (Arg Term)) → Term-      -- Identifier applied to arguments.-      def     : (f : Name) (args : List (Arg Term)) → Term-      -- Different kinds of λ-abstraction.-      lam     : (v : Visibility) (t : Term) → Term-      -- Pi-type.-      pi      : (t₁ : Arg Type) (t₂ : Type) → Term-      -- A sort.-      sort    : Sort → Term-      -- Anything else.-      unknown : Term--    data Type : Set where-      el : (s : Sort) (t : Term) → Type--    data Sort : Set where-      -- A Set of a given (possibly neutral) level.-      set     : (t : Term) → Sort-      -- A Set of a given concrete level.-      lit     : (n : ℕ) → Sort-      -- Anything else.-      unknown : Sort--  {-# BUILTIN AGDASORT            Sort    #-}-  {-# BUILTIN AGDATYPE            Type    #-}-  {-# BUILTIN AGDATERM            Term    #-}-  {-# BUILTIN AGDATERMVAR         var     #-}-  {-# BUILTIN AGDATERMCON         con     #-}-  {-# BUILTIN AGDATERMDEF         def     #-}-  {-# BUILTIN AGDATERMLAM         lam     #-}-  {-# BUILTIN AGDATERMPI          pi      #-}-  {-# BUILTIN AGDATERMSORT        sort    #-}-  {-# BUILTIN AGDATERMUNSUPPORTED unknown #-}-  {-# BUILTIN AGDATYPEEL          el      #-}-  {-# BUILTIN AGDASORTSET         set     #-}-  {-# BUILTIN AGDASORTLIT         lit     #-}-  {-# BUILTIN AGDASORTUNSUPPORTED unknown #-}--  postulate-    -- Function definition.-    Function  : Set-    -- Data type definition.-    Data-type : Set-    -- Record type definition.-    Record    : Set--  {-# BUILTIN AGDAFUNDEF    Function  #-}-  {-# BUILTIN AGDADATADEF   Data-type #-}-  {-# BUILTIN AGDARECORDDEF Record    #-}--  -- Definitions.--  data Definition : Set where-    function     : Function  → Definition-    data-type    : Data-type → Definition-    record′      : Record    → Definition-    constructor′ : Definition-    axiom        : Definition-    primitive′   : Definition--  {-# BUILTIN AGDADEFINITION                Definition   #-}-  {-# BUILTIN AGDADEFINITIONFUNDEF          function     #-}-  {-# BUILTIN AGDADEFINITIONDATADEF         data-type    #-}-  {-# BUILTIN AGDADEFINITIONRECORDDEF       record′      #-}-  {-# BUILTIN AGDADEFINITIONDATACONSTRUCTOR constructor′ #-}-  {-# BUILTIN AGDADEFINITIONPOSTULATE       axiom        #-}-  {-# BUILTIN AGDADEFINITIONPRIMITIVE       primitive′   #-}--  primitive-    -- The type of the thing with the given name.-    primQNameType        : Name → Type-    -- The definition of the thing with the given name.-    primQNameDefinition  : Name → Definition-    -- The constructors of the given data type.-    primDataConstructors : Data-type → List Name-  ```--  As an example the expression--  ```agda-  primQNameType (quote zero)-  ```--  is definitionally equal to--  ```agda-  el (lit 0) (def (quote ℕ) [])-  ```--  (if `zero` is a constructor of the data type `ℕ`).--* New keyword: `unquote`.--  The construction `unquote t` converts a representation of an Agda term-  to actual Agda code in the following way:--  1. The argument `t` must have type `Term` (see the reflection API above).--  2. The argument is normalised.--  3. The entire construction is replaced by the normal form, which is-     treated as syntax written by the user and type-checked in the-     usual way.--  Examples:--  ```agda-  test : unquote (def (quote ℕ) []) ≡ ℕ-  test = refl--  id : (A : Set) → A → A-  id = unquote (lam visible (lam visible (var 0 [])))--  id-ok : id ≡ (λ A (x : A) → x)-  id-ok = refl-  ```--* New keyword: `quoteTerm`.--  The construction `quoteTerm t` is similar to `quote n`, but whereas-  `quote` is restricted to names `n`, `quoteTerm` accepts terms-  `t`. The construction is handled in the following way:--  1. The type of `t` is inferred. The term `t` must be type-correct.--  2. The term `t` is normalised.--  3. The construction is replaced by the Term representation (see the-     reflection API above) of the normal form. Any unsolved metavariables-     in the term are represented by the `unknown` term constructor.--  Examples:--  ```agda-  test₁ : quoteTerm (λ {A : Set} (x : A) → x) ≡-          lam hidden (lam visible (var 0 []))-  test₁ = refl--  -- Local variables are represented as de Bruijn indices.-  test₂ : (λ {A : Set} (x : A) → quoteTerm x) ≡ (λ x → var 0 [])-  test₂ = refl--  -- Terms are normalised before being quoted.-  test₃ : quoteTerm (0 + 0) ≡ con (quote zero) []-  test₃ = refl-  ```--Compiler backends--------------------### MAlonzo--* The MAlonzo backend's FFI now handles universe polymorphism in a-  better way.--  The translation of Agda types and kinds into Haskell now supports-  universe-polymorphic postulates. The core changes are that the-  translation of function types has been changed from--  ```-  T[[ Pi (x : A) B ]] =-    if A has a Haskell kind then-      forall x. () -> T[[ B ]]-    else if x in fv B then-      undef-    else-      T[[ A ]] -> T[[ B ]]-  ```--  into--  ```-  T[[ Pi (x : A) B ]] =-    if x in fv B then-      forall x. T[[ A ]] -> T[[ B ]]  -- Note: T[[A]] not Unit.-    else-      T[[ A ]] -> T[[ B ]],-  ```--  and that the translation of constants (postulates, constructors and-  literals) has been changed from--  ```-  T[[ k As ]] =-    if COMPILED_TYPE k T then-      T T[[ As ]]-    else-      undef-  ```--  into--  ```-  T[[ k As ]] =-    if COMPILED_TYPE k T then-      T T[[ As ]]-    else if COMPILED k E then-      ()-    else-      undef.-  ```--  For instance, assuming a Haskell definition--  ```haskell-    type AgdaIO a b = IO b,-  ```--  we can set up universe-polymorphic `IO` in the following way:--  ```agda-  postulate-    IO     : ∀ {ℓ} → Set ℓ → Set ℓ-    return : ∀ {a} {A : Set a} → A → IO A-    _>>=_  : ∀ {a b} {A : Set a} {B : Set b} →-             IO A → (A → IO B) → IO B--  {-# COMPILED_TYPE IO AgdaIO              #-}-  {-# COMPILED return  (\_ _ -> return)    #-}-  {-# COMPILED _>>=_   (\_ _ _ _ -> (>>=)) #-}-  ```--  This is accepted because (assuming that the universe level type is-  translated to the Haskell unit type `()`)--  ```haskell-  (\_ _ -> return)-    : forall a. () -> forall b. () -> b -> AgdaIO a b-    = T [[ ∀ {a} {A : Set a} → A → IO A ]]-  ```--  and--  ```haskell-  (\_ _ _ _ -> (>>=))-    : forall a. () -> forall b. () ->-        forall c. () -> forall d. () ->-          AgdaIO a c -> (c -> AgdaIO b d) -> AgdaIO b d-    = T [[ ∀ {a b} {A : Set a} {B : Set b} →-             IO A → (A → IO B) → IO B ]].-  ```--### Epic--* New Epic backend pragma: `STATIC`.--  In the Epic backend, functions marked with the `STATIC` pragma will be-  normalised before compilation. Example usage:--  ```-  {-# STATIC power #-}--  power : ℕ → ℕ → ℕ-  power 0       x = 1-  power 1       x = x-  power (suc n) x = power n x * x-  ```--  Occurrences of `power 4 x` will be replaced by `((x * x) * x) * x`.--* Some new optimisations have been implemented in the Epic backend:--  - Removal of unused arguments.--  A worker/wrapper transformation is performed so that unused-  arguments can be removed by Epic's inliner. For instance, the map-  function is transformed in the following way:--  ```agda-  map_wrap : (A B : Set) → (A → B) → List A → List B-  map_wrap A B f xs = map_work f xs--  map_work f []       = []-  map_work f (x ∷ xs) = f x ∷ map_work f xs-  ```--  If `map_wrap` is inlined (which it will be in any saturated call),-  then `A` and `B` disappear in the generated code.--  Unused arguments are found using abstract interpretation. The bodies-  of all functions in a module are inspected to decide which variables-  are used. The behaviour of postulates is approximated based on their-  types. Consider `return`, for instance:--  ```agda-  postulate return : {A : Set} → A → IO A-  ```--  The first argument of `return` can be removed, because it is of type-  Set and thus cannot affect the outcome of a program at runtime.--  - Injection detection.--  At runtime many functions may turn out to be inefficient variants of-  the identity function. This is especially true after forcing.-  Injection detection replaces some of these functions with more-  efficient versions. Example:--  ```agda-  inject : {n : ℕ} → Fin n → Fin (1 + n)-  inject {suc n} zero    = zero-  inject {suc n} (suc i) = suc (inject {n} i)-  ```--  Forcing removes the `Fin` constructors' `ℕ` arguments, so this-  function is an inefficient identity function that can be replaced by-  the following one:--  ```agda-  inject {_} x = x-  ```--  To actually find this function, we make the induction hypothesis-  that inject is an identity function in its second argument and look-  at the branches of the function to decide if this holds.--  Injection detection also works over data type barriers. Example:--  ```agda-  forget : {A : Set} {n : ℕ} → Vec A n → List A-  forget []       = []-  forget (x ∷ xs) = x ∷ forget xs-  ```--  Given that the constructor tags (in the compiled Epic code) for-  `Vec.[]` and `List.[]` are the same, and that the tags for `Vec._∷_`-  and `List._∷_` are also the same, this is also an identity-  function. We can hence replace the definition with the following-  one:--  ```agda-  forget {_} xs = xs-  ```--  To get this to apply as often as possible, constructor tags are-  chosen *after* injection detection has been run, in a way to make as-  many functions as possible injections.--  Constructor tags are chosen once per source file, so it may be-  advantageous to define conversion functions like forget in the same-  module as one of the data types. For instance, if `Vec.agda` imports-  `List.agda`, then the forget function should be put in `Vec.agda` to-  ensure that vectors and lists get the same tags (unless some other-  injection function, which puts different constraints on the tags, is-  prioritised).--  - Smashing.--  This optimisation finds types whose values are inferable at runtime:--    * A data type with only one constructor where all fields are-      inferable is itself inferable.--    * `Set ℓ` is inferable (as it has no runtime representation).--  A function returning an inferable data type can be smashed, which-  means that it is replaced by a function which simply returns the-  inferred value.--  An important example of an inferable type is the usual propositional-  equality type (`_≡_`). Any function returning a propositional-  equality can simply return the reflexivity constructor directly-  without computing anything.--  This optimisation makes more arguments unused. It also makes the-  Epic code size smaller, which in turn speeds up compilation.--### JavaScript--* ECMAScript compiler backend.--  A new compiler backend is being implemented, targetting ECMAScript-  (also known as JavaScript), with the goal of allowing Agda programs-  to be run in browsers or other ECMAScript environments.--  The backend is still at an experimental stage: the core language is-  implemented, but many features are still missing.--  The ECMAScript compiler can be invoked from the command line using-  the flag `--js`:--  ```-  agda --js --compile-dir=<DIR> <FILE>.agda-  ```--  Each source `<FILE>.agda` is compiled into an ECMAScript target-  `<DIR>/jAgda.<TOP-LEVEL MODULE NAME>.js`. The compiler can also be-  invoked using the Emacs mode (the variable `agda2-backend` controls-  which backend is used).--  Note that ECMAScript is a strict rather than lazy language. Since-  Agda programs are total, this should not impact program semantics,-  but it may impact their space or time usage.--  ECMAScript does not support algebraic datatypes or pattern-matching.-  These features are translated to a use of the visitor pattern. For-  instance, the standard library's `List` data type and `null`-  function are translated into the following code:--  ```javascript-  exports["List"] = {};-  exports["List"]["[]"] = function (x0) {-      return x0["[]"]();-    };-  exports["List"]["_∷_"] = function (x0) {-      return function (x1) {-        return function (x2) {-          return x2["_∷_"](x0, x1);-        };-      };-    };--  exports["null"] = function (x0) {-      return function (x1) {-        return function (x2) {-          return x2({-            "[]": function () {-              return jAgda_Data_Bool["Bool"]["true"];-            },-            "_∷_": function (x3, x4) {-              return jAgda_Data_Bool["Bool"]["false"];-            }-          });-        };-      };-    };-  ```--  Agda records are translated to ECMAScript objects, preserving field-  names.--  Top-level Agda modules are translated to ECMAScript modules,-  following the `common.js` module specification. A top-level Agda-  module `Foo.Bar` is translated to an ECMAScript module-  `jAgda.Foo.Bar`.--  The ECMAScript compiler does not compile to Haskell, so the pragmas-  related to the Haskell FFI (`IMPORT`, `COMPILED_DATA` and-  `COMPILED`) are not used by the ECMAScript backend. Instead, there-  is a `COMPILED_JS` pragma which may be applied to any-  declaration. For postulates, primitives, functions and values, it-  gives the ECMAScript code to be emitted by the compiler. For data-  types, it gives a function which is applied to a value of that type,-  and a visitor object. For instance, a binding of natural numbers to-  ECMAScript integers (ignoring overflow errors) is:--  ```agda-  data ℕ : Set where-    zero : ℕ-    suc  : ℕ → ℕ--  {-# COMPILED_JS ℕ function (x,v) {-      if (x < 1) { return v.zero(); } else { return v.suc(x-1); }-    } #-}-  {-# COMPILED_JS zero 0 #-}-  {-# COMPILED_JS suc function (x) { return x+1; } #-}--  _+_ : ℕ → ℕ → ℕ-  zero  + n = n-  suc m + n = suc (m + n)--  {-# COMPILED_JS _+_ function (x) { return function (y) {-                        return x+y; };-    } #-}-  ```--  To allow FFI code to be optimised, the ECMAScript in a `COMPILED_JS`-  declaration is parsed, using a simple parser that recognises a pure-  functional subset of ECMAScript, consisting of functions, function-  applications, return, if-statements, if-expressions,-  side-effect-free binary operators (no precedence, left associative),-  side-effect-free prefix operators, objects (where all member names-  are quoted), field accesses, and string and integer literals.-  Modules may be imported using the require (`<module-id>`) syntax: any-  impure code, or code outside the supported fragment, can be placed-  in a module and imported.--Tools--------* New flag `--safe`, which can be used to type-check untrusted code.--  This flag disables postulates, `primTrustMe`, and "unsafe" OPTION-  pragmas, some of which are known to make Agda inconsistent.--  Rejected pragmas:--  ```-  --allow-unsolved-metas-  --experimental-irrelevance-  --guardedness-preserving-type-construtors-  --injective-type-constructors-  --no-coverage-check-  --no-positivity-check-  --no-termination-check-  --sized-types-  --type-in-type-  ```--  Note that, at the moment, it is not possible to define the universe-  level or coinduction primitives when `--safe` is used (because they-  must be introduced as postulates). This can be worked around by-  type-checking trusted files in a first pass, without using `--safe`,-  and then using `--saf`e in a second pass. Modules which have already-  been type-checked are not re-type-checked just because `--safe` is-  used.--* Dependency graphs.--  The new flag `--dependency-graph=FILE` can be used to generate a DOT-  file containing a module dependency graph. The generated file (FILE)-  can be rendered using a tool like dot.--* The `--no-unreachable-check` flag has been removed.--* Projection functions are highlighted as functions instead of as-  fields. Field names (in record definitions and record values) are-  still highlighted as fields.--* Support for jumping to positions mentioned in the information-  buffer has been added.--* The `make install` command no longer installs Agda globally (by-  default).--Release notes for Agda 2 version 2.2.10-=======================================--Language-----------* New flag: `--without-K`.--  This flag makes pattern matching more restricted. If the flag is-  activated, then Agda only accepts certain case-splits. If the type-  of the variable to be split is `D pars ixs`, where `D` is a data (or-  record) type, pars stands for the parameters, and `ixs` the indices,-  then the following requirements must be satisfied:--  - The indices `ixs` must be applications of constructors to distinct-    variables.--  - These variables must not be free in pars.--  The intended purpose of `--without-K` is to enable experiments with-  a propositional equality without the K rule. Let us define-  propositional equality as follows:--  ```agda-  data _≡_ {A : Set} : A → A → Set where-    refl : ∀ x → x ≡ x-  ```--  Then the obvious implementation of the J rule is accepted:--  ```agda-  J : {A : Set} (P : {x y : A} → x ≡ y → Set) →-      (∀ x → P (refl x)) →-      ∀ {x y} (x≡y : x ≡ y) → P x≡y-  J P p (refl x) = p x-  ```--  The same applies to Christine Paulin-Mohring's version of the J rule:--  ```agda-  J′ : {A : Set} {x : A} (P : {y : A} → x ≡ y → Set) →-       P (refl x) →-       ∀ {y} (x≡y : x ≡ y) → P x≡y-  J′ P p (refl x) = p-  ```--  On the other hand, the obvious implementation of the K rule is not-  accepted:--  ```agda-  K : {A : Set} (P : {x : A} → x ≡ x → Set) →-      (∀ x → P (refl x)) →-      ∀ {x} (x≡x : x ≡ x) → P x≡x-  K P p (refl x) = p x-  ```--  However, we have *not* proved that activation of `--without-K`-  ensures that the K rule cannot be proved in some other way.--* Irrelevant declarations.--  Postulates and functions can be marked as irrelevant by prefixing-  the name with a dot when the name is declared. Example:--  ```agda-  postulate-    .irrelevant : {A : Set} → .A → A-  ```--  Irrelevant names may only be used in irrelevant positions or in-  definitions of things which have been declared irrelevant.--  The axiom irrelevant above can be used to define a projection from-  an irrelevant record field:--  ```agda-  data Subset (A : Set) (P : A → Set) : Set where-    _#_ : (a : A) → .(P a) → Subset A P--  elem : ∀ {A P} → Subset A P → A-  elem (a # p) = a--  .certificate : ∀ {A P} (x : Subset A P) → P (elem x)-  certificate (a # p) = irrelevant p-  ```--  The right-hand side of certificate is relevant, so we cannot define--  ```agda-  certificate (a # p) = p-  ```--  (because `p` is irrelevant). However, certificate is declared to be-  irrelevant, so it can use the axiom irrelevant. Furthermore the-  first argument of the axiom is irrelevant, which means that-  irrelevant `p` is well-formed.--  As shown above the axiom irrelevant justifies irrelevant-  projections. Previously no projections were generated for irrelevant-  record fields, such as the field certificate in the following-  record type:--  ```agda-  record Subset (A : Set) (P : A → Set) : Set where-    constructor _#_-    field-      elem         : A-      .certificate : P elem-  ```--  Now projections are generated automatically for irrelevant fields-  (unless the flag `--no-irrelevant-projections` is used). Note that-  irrelevant projections are highly experimental.--* Termination checker recognises projections.--  Projections now preserve sizes, both in patterns and expressions.-  Example:--  ```agda-  record Wrap (A : Set) : Set where-    constructor wrap-    field-      unwrap : A--  open Wrap public--  data WNat : Set where-    zero : WNat-    suc  : Wrap WNat → WNat--  id : WNat → WNat-  id zero    = zero-  id (suc w) = suc (wrap (id (unwrap w)))-  ```--  In the structural ordering `unwrap w` ≤ `w`. This means that--  ```agda-    unwrap w ≤ w < suc w,-  ```--  and hence the recursive call to id is accepted.--  Projections also preserve guardedness.--Tools--------* Hyperlinks for top-level module names now point to the start of the-  module rather than to the declaration of the module name. This-  applies both to the Emacs mode and to the output of `agda --html`.--* Most occurrences of record field names are now highlighted as-  "fields". Previously many occurrences were highlighted as-  "functions".--* Emacs mode: It is no longer possible to change the behaviour of the-  `TAB` key by customising `agda2-indentation`.--* Epic compiler backend.--  A new compiler backend is being implemented. This backend makes use-  of Edwin Brady's language Epic-  (http://www.cs.st-andrews.ac.uk/~eb/epic.php) and its compiler. The-  backend should handle most Agda code, but is still at an-  experimental stage: more testing is needed, and some things written-  below may not be entirely true.--  The Epic compiler can be invoked from the command line using the-  flag `--epic`:--  ```-  agda --epic --epic-flag=<EPIC-FLAG> --compile-dir=<DIR> <FILE>.agda-  ```--  The `--epic-flag` flag can be given multiple times; each flag is-  given verbatim to the Epic compiler (in the given order). The-  resulting executable is named after the main module and placed in-  the directory specified by the `--compile-dir` flag (default: the-  project root). Intermediate files are placed in a subdirectory-  called `Epic`.--  The backend requires that there is a definition named main. This-  definition should be a value of type `IO Unit`, but at the moment-  this is not checked (so it is easy to produce a program which-  segfaults).  Currently the backend represents actions of type `IO A`-  as functions from `Unit` to `A`, and main is applied to the unit-  value.--  The Epic compiler compiles via C, not Haskell, so the pragmas-  related to the Haskell FFI (`IMPORT`, `COMPILED_DATA` and-  `COMPILED`) are not used by the Epic backend. Instead there is a new-  pragma `COMPILED_EPIC`. This pragma is used to give Epic code for-  postulated definitions (Epic code can in turn call C code). The form-  of the pragma is `{-# COMPILED_EPIC def code #-}`, where `def` is-  the name of an Agda postulate and `code` is some Epic code which-  should include the function arguments, return type and function-  body. As an example the `IO` monad can be defined as follows:--  ```agda-  postulate-    IO     : Set → Set-    return : ∀ {A} → A → IO A-    _>>=_  : ∀ {A B} → IO A → (A → IO B) → IO B--  {-# COMPILED_EPIC return (u : Unit, a : Any) -> Any =-                      ioreturn(a) #-}-  {-# COMPILED_EPIC-        _>>=_ (u1 : Unit, u2 : Unit, x : Any, f : Any) -> Any =-          iobind(x,f) #-}-  ```--  Here `ioreturn` and `iobind` are Epic functions which are defined in-  the file `AgdaPrelude.e` which is always included.--  By default the backend will remove so-called forced constructor-  arguments (and case-splitting on forced variables will be-  rewritten). This optimisation can be disabled by using the flag-  `--no-forcing`.--  All data types which look like unary natural numbers after forced-  constructor arguments have been removed (i.e. types with two-  constructors, one nullary and one with a single recursive argument)-  will be represented as "BigInts". This applies to the standard `Fin`-  type, for instance.--  The backend supports Agda's primitive functions and the BUILTIN-  pragmas. If the BUILTIN pragmas for unary natural numbers are used,-  then some operations, like addition and multiplication, will use-  more efficient "BigInt" operations.--  If you want to make use of the Epic backend you need to install some-  dependencies, see the README.--* The Emacs mode can compile using either the MAlonzo or the Epic-  backend. The variable `agda2-backend` controls which backend is-  used.--Release notes for Agda 2 version 2.2.8-======================================--Language-----------* Record pattern matching.--  It is now possible to pattern match on named record constructors.-  Example:--  ```agda-  record Σ (A : Set) (B : A → Set) : Set where-    constructor _,_-    field-      proj₁ : A-      proj₂ : B proj₁--  map : {A B : Set} {P : A → Set} {Q : B → Set}-        (f : A → B) → (∀ {x} → P x → Q (f x)) →-        Σ A P → Σ B Q-  map f g (x , y) = (f x , g y)-  ```--  The clause above is internally translated into the following one:--  ```agda-  map f g p = (f (Σ.proj₁ p) , g (Σ.proj₂ p))-  ```--  Record patterns containing data type patterns are not translated.-  Example:--  ```agda-  add : ℕ × ℕ → ℕ-  add (zero  , n) = n-  add (suc m , n) = suc (add (m , n))-  ```--  Record patterns which do not contain data type patterns, but which-  do contain dot patterns, are currently rejected. Example:--  ```agda-  Foo : {A : Set} (p₁ p₂ : A × A) → proj₁ p₁ ≡ proj₁ p₂ → Set₁-  Foo (x , y) (.x , y′) refl = Set-  ```--* Proof irrelevant function types.--  Agda now supports irrelevant non-dependent function types:--  ```agda-  f : .A → B-  ```--  This type implies that `f` does not depend computationally on its-  argument. One intended use case is data structures with embedded-  proofs, like sorted lists:--  ```agda-  postulate-    _≤_ : ℕ → ℕ → Set-    p₁  : 0 ≤ 1-    p₂  : 0 ≤ 1--  data SList (bound : ℕ) : Set where-    []    : SList bound-    scons : (head : ℕ) →-            .(head ≤ bound) →-            (tail : SList head) →-            SList bound-  ```--  The effect of the irrelevant type in the signature of `scons` is-  that `scons`'s second argument is never inspected after Agda has-  ensured that it has the right type. It is even thrown away, leading-  to smaller term sizes and hopefully some gain in efficiency. The-  type-checker ignores irrelevant arguments when checking equality, so-  two lists can be equal even if they contain different proofs:--  ```agda-  l₁ : SList 1-  l₁ = scons 0 p₁ []--  l₂ : SList 1-  l₂ = scons 0 p₂ []--  l₁≡l₂ : l₁ ≡ l₂-  l₁≡l₂ = refl-  ```--  Irrelevant arguments can only be used in irrelevant contexts.-  Consider the following subset type:--  ```agda-  data Subset (A : Set) (P : A → Set) : Set where-    _#_ : (elem : A) → .(P elem) → Subset A P-  ```--  The following two uses are fine:--  ```agda-  elimSubset : ∀ {A C : Set} {P} →-               Subset A P → ((a : A) → .(P a) → C) → C-  elimSubset (a # p) k = k a p--  elem : {A : Set} {P : A → Set} → Subset A P → A-  elem (x # p) = x-  ```--  However, if we try to project out the proof component, then Agda-  complains that `variable p is declared irrelevant, so it cannot be-  used here`:--  ```agda-  prjProof : ∀ {A P} (x : Subset A P) → P (elem x)-  prjProof (a # p) = p-  ```--  Matching against irrelevant arguments is also forbidden, except in-  the case of irrefutable matches (record constructor patterns which-  have been translated away). For instance, the match against the-  pattern `(p , q)` here is accepted:--  ```agda-  elim₂ : ∀ {A C : Set} {P Q : A → Set} →-          Subset A (λ x → Σ (P x) (λ _ → Q x)) →-          ((a : A) → .(P a) → .(Q a) → C) → C-  elim₂ (a # (p , q)) k = k a p q-  ```--  Absurd matches `()` are also allowed.--  Note that record fields can also be irrelevant. Example:--  ```agda-  record Subset (A : Set) (P : A → Set) : Set where-    constructor _#_-    field-      elem   : A-      .proof : P elem-  ```--  Irrelevant fields are never in scope, neither inside nor outside the-  record. This means that no record field can depend on an irrelevant-  field, and furthermore projections are not defined for such fields.-  Irrelevant fields can only be accessed using pattern matching, as in-  `elimSubset` above.--  Irrelevant function types were added very recently, and have not-  been subjected to much experimentation yet, so do not be surprised-  if something is changed before the next release. For instance,-  dependent irrelevant function spaces (`.(x : A) → B`) might be added-  in the future.--* Mixfix binders.--  It is now possible to declare user-defined syntax that binds-  identifiers. Example:--  ```agda-  postulate-    State  : Set → Set → Set-    put    : ∀ {S} → S → State S ⊤-    get    : ∀ {S} → State S S-    return : ∀ {A S} → A → State S A-    bind   : ∀ {A B S} → State S B → (B → State S A) → State S A--  syntax bind e₁ (λ x → e₂) = x ← e₁ , e₂--  increment : State ℕ ⊤-  increment = x ← get ,-              put (1 + x)-  ```--  The syntax declaration for `bind` implies that `x` is in scope in-  `e₂`, but not in `e₁`.--  You can give fixity declarations along with syntax declarations:--  ```agda-  infixr 40 bind-  syntax bind e₁ (λ x → e₂) = x ← e₁ , e₂-  ```--  The fixity applies to the syntax, not the name; syntax declarations-  are also restricted to ordinary, non-operator names. The following-  declaration is disallowed:--  ```agda-  syntax _==_ x y = x === y-  ```agda--  Syntax declarations must also be linear; the following declaration-  is disallowed:--  ```agda-  syntax wrong x = x + x-  ```--  Syntax declarations were added very recently, and have not been-  subjected to much experimentation yet, so do not be surprised if-  something is changed before the next release.--* `Prop` has been removed from the language.--  The experimental sort `Prop` has been disabled. Any program using-  `Prop` should typecheck if `Prop` is replaced by `Set₀`. Note that-  `Prop` is still a keyword.--* Injective type constructors off by default.--  Automatic injectivity of type constructors has been disabled (by-  default). To enable it, use the flag-  `--injective-type-constructors`, either on the command line or in an-  OPTIONS pragma. Note that this flag makes Agda anti-classical and-  possibly inconsistent:--    Agda with excluded middle is inconsistent-    http://thread.gmane.org/gmane.comp.lang.agda/1367--  See `test/Succeed/InjectiveTypeConstructors.agda` for an example.--* Termination checker can count.--  There is a new flag `--termination-depth=N` accepting values `N >=-  1` (with `N = 1` being the default) which influences the behavior of-  the termination checker. So far, the termination checker has only-  distinguished three cases when comparing the argument of a recursive-  call with the formal parameter of the callee.--  `<`: the argument is structurally smaller than the parameter--  `=`: they are equal--  `?`: the argument is bigger or unrelated to the parameter--  This behavior, which is still the default (`N = 1`), will not-  recognise the following functions as terminating.--   ```agda-   mutual--      f : ℕ → ℕ-      f zero          = zero-      f (suc zero)    = zero-      f (suc (suc n)) = aux n--      aux : ℕ → ℕ-      aux m = f (suc m)-  ```--  The call graph--  ```-  f --(<)--> aux --(?)--> f-  ```--  yields a recursive call from `f` to `f` via `aux` where the relation-  of call argument to callee parameter is computed as "unrelated"-  (composition of `<` and `?`).--  Setting `N >= 2` allows a finer analysis: `n` has two constructors-  less than `suc (suc n)`, and `suc m` has one more than `m`, so we get the-  call graph:--  ```-  f --(-2)--> aux --(+1)--> f-  ```--  The indirect call `f --> f` is now labeled with `(-1)`, and the-  termination checker can recognise that the call argument is-  decreasing on this path.--  Setting the termination depth to `N` means that the termination-  checker counts decrease up to `N` and increase up to `N-1`. The-  default, `N=1`, means that no increase is counted, every increase-  turns to "unrelated".--  In practice, examples like the one above sometimes arise when `with`-  is used. As an example, the program--  ```agda-  f : ℕ → ℕ-  f zero          = zero-  f (suc zero)    = zero-  f (suc (suc n)) with zero-  ... | _ = f (suc n)-  ```--  is internally represented as--  ```agda-  mutual--    f : ℕ → ℕ-    f zero          = zero-    f (suc zero)    = zero-    f (suc (suc n)) = aux n zero--    aux : ℕ → ℕ → ℕ-    aux m k = f (suc m)-  ```--  Thus, by default, the definition of `f` using `with` is not accepted-  by the termination checker, even though it looks structural (`suc n`-  is a subterm of `suc suc n`). Now, the termination checker is-  satisfied if the option `--termination-depth=2` is used.--  Caveats:--  - This is an experimental feature, hopefully being replaced by-    something smarter in the near future.--  - Increasing the termination depth will quickly lead to very long-    termination checking times. So, use with care. Setting termination-    depth to `100` by habit, just to be on the safe side, is not a good-    idea!--  - Increasing termination depth only makes sense for linear data-    types such as `ℕ` and `Size`. For other types, increase cannot be-    recognised. For instance, consider a similar example with lists.--    ```agda-    data List : Set where-      nil  : List-      cons : ℕ → List → List--    mutual-      f : List → List-      f nil                  = nil-      f (cons x nil)         = nil-      f (cons x (cons y ys)) = aux y ys--      aux : ℕ → List → List-      aux z zs = f (cons z zs)-     ```--    Here the termination checker compares `cons z zs` to `z` and also-    to `zs`. In both cases, the result will be "unrelated", no matter-    how high we set the termination depth. This is because when-    comparing `cons z zs` to `zs`, for instance, `z` is unrelated to-    `zs`, thus, `cons z zs` is also unrelated to `zs`. We cannot say-    it is just "one larger" since `z` could be a very large term. Note-    that this points to a weakness of untyped termination checking.--    To regain the benefit of increased termination depth, we need to-    index our lists by a linear type such as `ℕ` or `Size`. With-    termination depth `2`, the above example is accepted for vectors-    instead of lists.--* The `codata` keyword has been removed. To use coinduction, use the-  following new builtins: `INFINITY`, `SHARP` and `FLAT`. Example:--  ```agda-  {-# OPTIONS --universe-polymorphism #-}--  module Coinduction where--  open import Level--  infix 1000 ♯_--  postulate-    ∞  : ∀ {a} (A : Set a) → Set a-    ♯_ : ∀ {a} {A : Set a} → A → ∞ A-    ♭  : ∀ {a} {A : Set a} → ∞ A → A--  {-# BUILTIN INFINITY ∞  #-}-  {-# BUILTIN SHARP    ♯_ #-}-  {-# BUILTIN FLAT     ♭  #-}-  ```--  Note that (non-dependent) pattern matching on `SHARP` is no longer-  allowed.--  Note also that strange things might happen if you try to combine the-  pragmas above with `COMPILED_TYPE`, `COMPILED_DATA` or `COMPILED`-  pragmas, or if the pragmas do not occur right after the postulates.--  The compiler compiles the `INFINITY` builtin to nothing (more or-  less), so that the use of coinduction does not get in the way of FFI-  declarations:--  ```agda-  data Colist (A : Set) : Set where-    []  : Colist A-    _∷_ : (x : A) (xs : ∞ (Colist A)) → Colist A--  {-# COMPILED_DATA Colist [] [] (:) #-}-  ```--* Infinite types.--  If the new flag `--guardedness-preserving-type-constructors` is-  used, then type constructors are treated as inductive constructors-  when we check productivity (but only in parameters, and only if they-  are used strictly positively or not at all). This makes examples-  such as the following possible:--  ```agda-  data Rec (A : ∞ Set) : Set where-    fold : ♭ A → Rec A--  -- Σ cannot be a record type below.--  data Σ (A : Set) (B : A → Set) : Set where-    _,_ : (x : A) → B x → Σ A B--  syntax Σ A (λ x → B) = Σ[ x ∶ A ] B--  -- Corecursive definition of the W-type.--  W : (A : Set) → (A → Set) → Set-  W A B = Rec (♯ (Σ[ x ∶ A ] (B x → W A B)))--  syntax W A (λ x → B) = W[ x ∶ A ] B--  sup : {A : Set} {B : A → Set} (x : A) (f : B x → W A B) → W A B-  sup x f = fold (x , f)--  W-rec : {A : Set} {B : A → Set}-          (P : W A B → Set) →-          (∀ {x} {f : B x → W A B} → (∀ y → P (f y)) → P (sup x f)) →-          ∀ x → P x-  W-rec P h (fold (x , f)) = h (λ y → W-rec P h (f y))--  -- Induction-recursion encoded as corecursion-recursion.--  data Label : Set where-    ′0 ′1 ′2 ′σ ′π ′w : Label--  mutual--    U : Set-    U = Σ Label U′--    U′ : Label → Set-    U′ ′0 = ⊤-    U′ ′1 = ⊤-    U′ ′2 = ⊤-    U′ ′σ = Rec (♯ (Σ[ a ∶ U ] (El a → U)))-    U′ ′π = Rec (♯ (Σ[ a ∶ U ] (El a → U)))-    U′ ′w = Rec (♯ (Σ[ a ∶ U ] (El a → U)))--    El : U → Set-    El (′0 , _)            = ⊥-    El (′1 , _)            = ⊤-    El (′2 , _)            = Bool-    El (′σ , fold (a , b)) = Σ[ x ∶ El a ]  El (b x)-    El (′π , fold (a , b)) =   (x : El a) → El (b x)-    El (′w , fold (a , b)) = W[ x ∶ El a ]  El (b x)--  U-rec : (P : ∀ u → El u → Set) →-          P (′1 , _) tt →-          P (′2 , _) true →-          P (′2 , _) false →-          (∀ {a b x y} →-           P a x → P (b x) y → P (′σ , fold (a , b)) (x , y)) →-          (∀ {a b f} →-           (∀ x → P (b x) (f x)) → P (′π , fold (a , b)) f) →-          (∀ {a b x f} →-           (∀ y → P (′w , fold (a , b)) (f y)) →-           P (′w , fold (a , b)) (sup x f)) →-          ∀ u (x : El u) → P u x-  U-rec P P1 P2t P2f Pσ Pπ Pw = rec-    where-    rec : ∀ u (x : El u) → P u x-    rec (′0 , _)            ()-    rec (′1 , _)            _              = P1-    rec (′2 , _)            true           = P2t-    rec (′2 , _)            false          = P2f-    rec (′σ , fold (a , b)) (x , y)        = Pσ (rec _ x) (rec _ y)-    rec (′π , fold (a , b)) f              = Pπ (λ x → rec _ (f x))-    rec (′w , fold (a , b)) (fold (x , f)) = Pw (λ y → rec _ (f y))-  ```--  The `--guardedness-preserving-type-constructors` extension is based-  on a rather operational understanding of `∞`/`♯_`; it's not yet-  clear if this extension is consistent.--* Qualified constructors.--  Constructors can now be referred to qualified by their data type.-  For instance, given--  ```agda-  data Nat : Set where-    zero : Nat-    suc  : Nat → Nat--  data Fin : Nat → Set where-    zero : ∀ {n} → Fin (suc n)-    suc  : ∀ {n} → Fin n → Fin (suc n)-  ```--  you can refer to the constructors unambiguously as `Nat.zero`,-  `Nat.suc`, `Fin.zero`, and `Fin.suc` (`Nat` and `Fin` are modules-  containing the respective constructors). Example:--  ```agda-  inj : (n m : Nat) → Nat.suc n ≡ suc m → n ≡ m-  inj .m m refl = refl-  ```--  Previously you had to write something like--  ```agda-  inj : (n m : Nat) → _≡_ {Nat} (suc n) (suc m) → n ≡ m-  ```--  to make the type checker able to figure out that you wanted the-  natural number suc in this case.--* Reflection.--  There are two new constructs for reflection:--    - `quoteGoal x in e`--      In `e` the value of `x` will be a representation of the goal type-      (the type expected of the whole expression) as an element in a-      datatype of Agda terms (see below). For instance,--      ```agda-      example : ℕ-      example = quoteGoal x in {! at this point x = def (quote ℕ) [] !}-      ```--    - `quote x : Name`--      If `x` is the name of a definition (function, datatype, record,-      or a constructor), `quote x` gives you the representation of `x`-      as a value in the primitive type `Name` (see below).--  Quoted terms use the following BUILTINs and primitives (available-  from the standard library module `Reflection`):--  ```agda-  -- The type of Agda names.--  postulate Name : Set--  {-# BUILTIN QNAME Name #-}--  primitive primQNameEquality : Name → Name → Bool--  -- Arguments.--  Explicit? = Bool--  data Arg A : Set where-    arg : Explicit? → A → Arg A--  {-# BUILTIN ARG    Arg #-}-  {-# BUILTIN ARGARG arg #-}--  -- The type of Agda terms.--  data Term : Set where-    var     : ℕ → List (Arg Term) → Term-    con     : Name → List (Arg Term) → Term-    def     : Name → List (Arg Term) → Term-    lam     : Explicit? → Term → Term-    pi      : Arg Term → Term → Term-    sort    : Term-    unknown : Term--  {-# BUILTIN AGDATERM            Term    #-}-  {-# BUILTIN AGDATERMVAR         var     #-}-  {-# BUILTIN AGDATERMCON         con     #-}-  {-# BUILTIN AGDATERMDEF         def     #-}-  {-# BUILTIN AGDATERMLAM         lam     #-}-  {-# BUILTIN AGDATERMPI          pi      #-}-  {-# BUILTIN AGDATERMSORT        sort    #-}-  {-# BUILTIN AGDATERMUNSUPPORTED unknown #-}-  ```--  Reflection may be useful when working with internal decision-  procedures, such as the standard library's ring solver.--* Minor record definition improvement.--  The definition of a record type is now available when type checking-  record module definitions. This means that you can define things-  like the following:--  ```agda-  record Cat : Set₁ where-    field-      Obj  : Set-      _=>_ : Obj → Obj → Set-      -- ...--    -- not possible before:-    op : Cat-    op = record { Obj = Obj; _=>_ = λ A B → B => A }-  ```--Tools--------* The `Goal type and context` command now shows the goal type before-  the context, and the context is shown in reverse order. The `Goal-  type, context and inferred type` command has been modified in a-  similar way.--* Show module contents command.--  Given a module name `M` the Emacs mode can now display all the-  top-level modules and names inside `M`, along with types for the-  names. The command is activated using `C-c C-o` or the menus.--* Auto command.--  A command which searches for type inhabitants has been added. The-  command is invoked by pressing `C-C C-a` (or using the goal menu).-  There are several flags and parameters, e.g. `-c` which enables-  case-splitting in the search. For further information, see the Agda-  wiki:--    http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.Auto--* HTML generation is now possible for a module with unsolved-  meta-variables, provided that the `--allow-unsolved-metas` flag is-  used.--Release notes for Agda 2 version 2.2.6-======================================--Language-----------* Universe polymorphism (experimental extension).--  To enable universe polymorphism give the flag-  `--universe-polymorphism` on the command line or (recommended) as an-  OPTIONS pragma.--  When universe polymorphism is enabled `Set` takes an argument which is-  the universe level. For instance, the type of universe polymorphic-  identity is--  ```agda-  id : {a : Level} {A : Set a} → A → A.-  ```--  The type Level is isomorphic to the unary natural numbers and should-  be specified using the BUILTINs `LEVEL`, `LEVELZERO`, and-  `LEVELSUC`:--  ```agda-  data Level : Set where-    zero : Level-    suc  : Level → Level--  {-# BUILTIN LEVEL     Level #-}-  {-# BUILTIN LEVELZERO zero  #-}-  {-# BUILTIN LEVELSUC  suc   #-}-  ```--  There is an additional BUILTIN `LEVELMAX` for taking the maximum of two-  levels:--  ```agda-  max : Level → Level → Level-  max  zero    m      = m-  max (suc n)  zero   = suc n-  max (suc n) (suc m) = suc (max n m)--  {-# BUILTIN LEVELMAX max #-}-  ```--  The non-polymorphic universe levels `Set`, `Set₁` and so on are-  sugar for `Set zero`, `Set (suc zero)`, etc.--  At present there is no automatic lifting of types from one level to-  another. It can still be done (rather clumsily) by defining types-  like the following one:--  ```agda-  data Lifted {a} (A : Set a) : Set (suc a) where-    lift : A → Lifted A-  ```--  However, it is likely that automatic lifting is introduced at some-  point in the future.--* Multiple constructors, record fields, postulates or primitives can-  be declared using a single type signature:--  ```agda-  data Bool : Set where-    false true : Bool--  postulate-    A B : Set-  ```--* Record fields can be implicit:--  ```agda-  record R : Set₁ where-    field-      {A}         : Set-      f           : A → A-      {B C} D {E} : Set-      g           : B → C → E-  ```--  By default implicit fields are not printed.--* Record constructors can be defined:--  ```agda-  record Σ (A : Set) (B : A → Set) : Set where-    constructor _,_-    field-      proj₁ : A-      proj₂ : B proj₁-  ```--  In this example `_,_` gets the type--  ```agda-   (proj₁ : A) → B proj₁ → Σ A B.-  ```--  For implicit fields the corresponding constructor arguments become-  implicit.--  Note that the constructor is defined in the *outer* scope, so any-  fixity declaration has to be given outside the record definition.-  The constructor is not in scope inside the record module.--  Note also that pattern matching for records has not been implemented-  yet.--* BUILTIN hooks for equality.--  The data type--  ```agda-  data _≡_ {A : Set} (x : A) : A → Set where-    refl : x ≡ x-  ```--  can be specified as the builtin equality type using the following-  pragmas:--  ```agda-  {-# BUILTIN EQUALITY _≡_  #-}-  {-# BUILTIN REFL     refl #-}-  ```--  The builtin equality is used for the new rewrite construct and-  the `primTrustMe` primitive described below.--* New `rewrite` construct.--  If `eqn : a ≡ b`, where `_≡_` is the builtin equality (see above) you-  can now write--  ```agda-  f ps rewrite eqn = rhs-  ```--  instead of--  ```agda-    f ps with a | eqn-    ... | ._ | refl = rhs-  ```--  The `rewrite` construct has the effect of rewriting the goal and the-  context by the given equation (left to right).--  You can rewrite using several equations (in sequence) by separating-  them with vertical bars (|):--  ```agda-  f ps rewrite eqn₁ | eqn₂ | … = rhs-  ```--  It is also possible to add `with`-clauses after rewriting:--  ```agda-  f ps rewrite eqns with e-  ... | p = rhs-  ```--  Note that pattern matching happens before rewriting—if you want to-  rewrite and then do pattern matching you can use a with after the-  rewrite.--  See `test/Succeed/Rewrite.agda` for some examples.--* A new primitive, `primTrustMe`, has been added:--  ```agda-    primTrustMe : {A : Set} {x y : A} → x ≡ y-  ```--  Here `_≡_` is the builtin equality (see BUILTIN hooks for equality,-  above).--  If `x` and `y` are definitionally equal, then-  `primTrustMe {x = x} {y = y}` reduces to `refl`.--  Note that the compiler replaces all uses of `primTrustMe` with the-  `REFL` builtin, without any check for definitional-  equality. Incorrect uses of `primTrustMe` can potentially lead to-  segfaults or similar problems.--  For an example of the use of `primTrustMe`, see `Data.String` in-  version 0.3 of the standard library, where it is used to implement-  decidable equality on strings using the primitive boolean equality.--* Changes to the syntax and semantics of IMPORT pragmas, which are-  used by the Haskell FFI. Such pragmas must now have the following-  form:--  ```agda-  {-# IMPORT <module name> #-}-  ```--  These pragmas are interpreted as *qualified* imports, so Haskell-  names need to be given qualified (unless they come from the Haskell-  prelude).--* The horizontal tab character (U+0009) is no longer treated as white-  space.--* Line pragmas are no longer supported.--* The `--include-path` flag can no longer be used as a pragma.--* The experimental and incomplete support for proof irrelevance has-  been disabled.--Tools--------* New `intro` command in the Emacs mode. When there is a canonical way-  of building something of the goal type (for instance, if the goal-  type is a pair), the goal can be refined in this way. The command-  works for the following goal types:--    - A data type where only one of its constructors can be used to-      construct an element of the goal type. (For instance, if the-      goal is a non-empty vector, a `cons` will be introduced.)--    - A record type. A record value will be introduced. Implicit-      fields will not be included unless showing of implicit arguments-      is switched on.--    - A function type. A lambda binding as many variables as possible-      will be introduced. The variable names will be chosen from the-      goal type if its normal form is a dependent function type,-      otherwise they will be variations on `x`. Implicit lambdas will-      only be inserted if showing of implicit arguments is switched-      on.--  This command can be invoked by using the `refine` command-  (`C-c C-r`) when the goal is empty. (The old behaviour of the refine-  command in this situation was to ask for an expression using the-  minibuffer.)--* The Emacs mode displays `Checked` in the mode line if the current-  file type checked successfully without any warnings.--* If a file `F` is loaded, and this file defines the module `M`, it is-  an error if `F` is not the file which defines `M` according to the-  include path.--  Note that the command-line tool and the Emacs mode define the-  meaning of relative include paths differently: the command-line tool-  interprets them relative to the current working directory, whereas-  the Emacs mode interprets them relative to the root directory of the-  current project. (As an example, if the module `A.B.C` is loaded-  from the file `<some-path>/A/B/C.agda`, then the root directory is-  `<some-path>`.)--* It is an error if there are several files on the include path which-  match a given module name.--* Interface files are relocatable. You can move around source trees as-  long as the include path is updated in a corresponding way. Note-  that a module `M` may be re-typechecked if its time stamp is-  strictly newer than that of the corresponding interface file-  (`M.agdai`).--* Type-checking is no longer done when an up-to-date interface exists.-  (Previously the initial module was always type-checked.)--* Syntax highlighting files for Emacs (`.agda.el`) are no longer used.-  The `--emacs` flag has been removed. (Syntax highlighting-  information is cached in the interface files.)--* The Agate and Alonzo compilers have been retired. The options-  `--agate`, `--alonzo` and `--malonzo` have been removed.--* The default directory for MAlonzo output is the project's root-  directory. The `--malonzo-dir` flag has been renamed to-  `--compile-dir`.--* Emacs mode: `C-c C-x C-d` no longer resets the type checking state.-  `C-c C-x C-r` can be used for a more complete reset. `C-c C-x C-s`-  (which used to reload the syntax highlighting information) has been-  removed. `C-c C-l` can be used instead.--* The Emacs mode used to define some "abbrevs", unless the user-  explicitly turned this feature off. The new default is *not* to add-  any abbrevs. The old default can be obtained by customising-  `agda2-mode-abbrevs-use-defaults` (a customisation buffer can be-  obtained by typing `M-x customize-group agda2 RET` after an Agda-  file has been loaded).--Release notes for Agda 2 version 2.2.4-======================================--Important changes since 2.2.2:--* Change to the semantics of `open import` and `open module`. The-  declaration--  ```agda-  open import M <using/hiding/renaming>-  ```--  now translates to--  ```agda-  import A-  open A <using/hiding/renaming>-  ```--  instead of--  ```agda-  import A <using/hiding/renaming>-  open A-  ```--  The same translation is used for `open module M = E …`. Declarations-  involving the keywords as or public are changed in a corresponding-  way (`as` always goes with import, and `public` always with open).--  This change means that import directives do not affect the qualified-  names when open import/module is used. To get the old behaviour you-  can use the expanded version above.--* Names opened publicly in parameterised modules no longer inherit the-  module parameters. Example:--  ```agda-  module A where-    postulate X : Set--  module B (Y : Set) where-    open A public-  ```--  In Agda 2.2.2 `B.X` has type `(Y : Set) → Set`, whereas in-  Agda 2.2.4 `B.X` has type Set.--* Previously it was not possible to export a given constructor name-  through two different `open public` statements in the same module.-  This is now possible.--* Unicode subscript digits are now allowed for the hierarchy of-  universes (`Set₀`, `Set₁`, …): `Set₁` is equivalent to `Set1`.--Release notes for Agda 2 version 2.2.2-======================================--Tools--------* The `--malonzodir` option has been renamed to `--malonzo-dir`.--* The output of `agda --html` is by default placed in a directory-  called `html`.--Infrastructure-----------------* The Emacs mode is included in the Agda Cabal package, and installed-  by `cabal install`. The recommended way to enable the Emacs mode is-  to include the following code in `.emacs`:--  ```elisp-  (load-file (let ((coding-system-for-read 'utf-8))-                  (shell-command-to-string "agda-mode locate")))-  ```--Release notes for Agda 2 version 2.2.0-======================================--Important changes since 2.1.2 (which was released 2007-08-16):--Language-----------* Exhaustive pattern checking. Agda complains if there are missing-  clauses in a function definition.--* Coinductive types are supported. This feature is under-  development/evaluation, and may change.--  http://wiki.portal.chalmers.se/agda/agda.php?n=ReferenceManual.Codatatypes--* Another experimental feature: Sized types, which can make it easier-  to explain why your code is terminating.--* Improved constraint solving for functions with constructor headed-  right hand sides.--  http://wiki.portal.chalmers.se/agda/agda.php?n=ReferenceManual.FindingTheValuesOfImplicitArguments--* A simple, well-typed foreign function interface, which allows use of-  Haskell functions in Agda code.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.FFI--* The tokens `forall`, `->` and `\` can be written as `∀`, `→` and-  `λ`.--* Absurd lambdas: `λ ()` and `λ {}`.--  http://thread.gmane.org/gmane.comp.lang.agda/440--* Record fields whose values can be inferred can be omitted.--* Agda complains if it spots an unreachable clause, or if a pattern-  variable "shadows" a hidden constructor of matching type.--  http://thread.gmane.org/gmane.comp.lang.agda/720--Tools--------* Case-split: The user interface can replace a pattern variable with-  the corresponding constructor patterns. You get one new left-hand-  side for every possible constructor.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode--* The MAlonzo compiler.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.MAlonzo--* A new Emacs input method, which contains bindings for many Unicode-  symbols, is by default activated in the Emacs mode.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.UnicodeInput--* Highlighted, hyperlinked HTML can be generated from Agda source-  code.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.HowToGenerateWebPagesFromSourceCode--* The command-line interactive mode (`agda -I`) is no longer-  supported, but should still work.--  http://thread.gmane.org/gmane.comp.lang.agda/245--* Reload times when working on large projects are now considerably-  better.--  http://thread.gmane.org/gmane.comp.lang.agda/551--Libraries------------* A standard library is under development.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Libraries.StandardLibrary--Documentation----------------* The Agda wiki is better organised. It should be easier for a-  newcomer to find relevant information now.--  http://wiki.portal.chalmers.se/agda/--Infrastructure-----------------* Easy-to-install packages for Windows and Debian/Ubuntu have been-  prepared.--  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.Download--* Agda 2.2.0 is available from Hackage.--  http://hackage.haskell.org/+Release notes for Agda version 2.8.0+====================================++Highlights+----------++* Agda is now a self-contained single binary.++* Build all Agda files reachable from paths in the `.agda-lib` file with new flag `--build-library`.++* Experimental support for polarity annotations with new flag `--polarity`.++* Compile to JavaScript with ES6 module syntax with new flag `--js-es6`.++* Errors now have an identifier and follow the GNU standard.++Installation+------------++* Dropped support for GHC 8.6, added support for GHC 9.12.++* Agda supports GHC versions 8.8.4 to 9.12.2.++* The `agda` binary now contains everything to set itself up,+  it need not be shipped with additional files.++  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`.++  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.++     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`.++     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+--------++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+  triple : Nat → Nat → Nat → Nat × Nat × Nat+  {-# INLINE triple #-}+  triple x y z = record { fst = x ; snd = y , z }++  ex = triple 1 2 3+  ```++  Here, constructor inlining happens on the right hand side *of `ex`*+  rather than of `triple`.++Reflection+----------++Changes to the meta-programming facilities.++* New reflection primitive: `checkFromStringTC : String → Type → TC Term`++  Parse and type check the given string against the given type, returning+  the resulting term (when successful).+++Library management+------------------++* **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.)+++Interaction and emacs mode+--------------------------++* 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:++  > _sourcefile_:_line1_._column1_-_line2_._column2_: error: [_ErrorName_]+  > ...+  > _error message_+  > ...+  > when _error context_++  _line2_ or even _column2_ can be missing, in some cases even the entire error location.+  Internal errors might follow a different format.++  Warnings are printed in a similar format:++  > _sourcefile_:_line1_._column1_-_line2_._column2_: warning: -W[no]_WarningName_+  > ...+  > _warning text_+  > ...+  > when _warning context_++* 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,12 +1,34 @@-Copyright (c) 2005-2016 Ulf Norell, Andreas Abel, Nils Anders-Danielsson, Andrés Sicard-Ramírez, Dominique Devriese, Péter-Divianszki, Francesco Mazzoli, Stevan Andjelkovic, Daniel Gustafsson,-Alan Jeffrey, Makoto Takeyama, Andrea Vezzosi, Nicolas Pouillard,-James Chapman, Jean-Philippe Bernardy, Fredrik Lindblad, Nobuo-Yamashita, Fredrik Nordvall Forsberg, Patrik Jansson, Guilhem Moulin,-Stefan Monnier, Marcin Benke, Olle Fredriksson, Darin Morrison, Jesper-Cockx, Wolfram Kahl, Catarina Coquand+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,+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,+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``.+ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including@@ -25,68 +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/Parser/ReadP.hs is Copyright (c) The-University of Glasgow 2002 and is licensed under a BSD-like license as-follows:--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.--- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND 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-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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/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.
README.md view
@@ -3,184 +3,35 @@  [![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)-[![Build Status](https://travis-ci.org/agda/agda.svg?branch=stable-2.5)](https://travis-ci.org/agda/agda)--Table of contents:+[![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) -* [Documentation](#documentation)-* [Prerequisites](#prerequisites)-* [Installing Agda](#installing-agda)-* [Configuring the Emacs mode](#configuring-the-emacs-mode)-* [Installing Emacs under Windows](#installing-emacs-under-windows)+![The official Agda logo](https://raw.githubusercontent.com/agda/agda/master/doc/user-manual/agda.svg) -Note that this README only discusses installation of Agda, not its standard-library. See the [Agda Wiki][agdawiki] for information about the library.+Note that this README is only about Agda, not its standard+library. See the [Agda Wiki][agdawiki] for information about the+library.  Documentation -------------  * [User manual](http://agda.readthedocs.io)+  (per-commit pdf can be downloaded from the+  [github actions](https://github.com/agda/agda/actions/workflows/user_manual.yml) page) * [CHANGELOG](https://github.com/agda/agda/blob/master/CHANGELOG.md) -Prerequisites----------------You need recent versions of the following programs/libraries:--* GHC:           http://www.haskell.org/ghc/-* cabal-install: http://www.haskell.org/cabal/-* Alex:          http://www.haskell.org/alex/-* Happy:         http://www.haskell.org/happy/-* cpphs:         http://projects.haskell.org/cpphs/-* GNU Emacs:     http://www.gnu.org/software/emacs/--You should also make sure that programs installed by cabal-install are-on your shell's search path.--For instructions on installing a suitable version of Emacs under-Windows, see [below]((#installing-emacs-under-windows).--Non-Windows users need to ensure that the development files for the C-libraries zlib and ncurses are installed (see http://zlib.net and-http://www.gnu.org/software/ncurses/). Your package manager may be-able to install these files for you. For instance, on Debian or Ubuntu-it should suffice to run--    apt-get install zlib1g-dev libncurses5-dev--as root to get the correct files installed.--### Note on GHC's CPP language extension--Recent versions of Clang's preprocessor don't work well with Haskell.-In order to get some dependencies to build, you may need to set up Cabal-to have GHC use cpphs by default. You can do this by adding--    program-default-options-      ghc-options: -pgmPcpphs -optP--cpp--to your .cabal/config file. (You must be using cabal >= 1.18. Note-that some packages may not compile with this option set.)--You don't need to set this option to install *Agda* from the current-development source; Agda.cabal now uses cpphs.---Installing Agda------------------There are several ways to install Agda:---### Using a binary package prepared for your platform--Recommended if such a package exists. See the [Agda Wiki][agdawiki].---### Using a released source package from Hackage--Install the prerequisites mentioned below, then run the following commands:--    cabal update-    cabal install Agda-    agda-mode setup--The last command tries to set up Emacs for use with Agda. As an alternative you-can copy the following text to your .emacs file:--    (load-file (let ((coding-system-for-read 'utf-8))-                    (shell-command-to-string "agda-mode locate")))--It is also possible (but not necessary) to compile the Emacs mode's files:--    agda-mode compile--This can, in some cases, give a noticeable speedup.--**WARNING**: If you reinstall the Agda mode without recompiling the Emacs-Lisp files, then Emacs may continue using the old, compiled files.---### Using the development version of the code--You can obtain tarballs of the development version from the [Agda-Wiki][agdawiki], or clone the repository.--Install the prerequisites discussed in [Prerequisites](#prerequisites).--Then, either:--*(1a)* Run the following commands in the top-level directory of the Agda source-tree to install Agda:--    cabal update-    cabal install--*(1b)* Run `agda-mode setup` to set up Emacs for use with Agda. Alternatively,-add the following text to your .emacs file:--    (load-file (let ((coding-system-for-read 'utf-8))-                    (shell-command-to-string "agda-mode locate")))--It is also possible (but not necessary) to compile the Emacs mode's files:--    agda-mode compile--This can, in some cases, give a noticeable speedup.--**WARNING**: If you reinstall the Agda mode without recompiling the Emacs-Lisp files, then Emacs may continue using the old compiled files.--*(2)* Or, you can try to install Agda (including a compiled Emacs mode) by-running the following command:--    make install---Configuring the Emacs mode-----------------------------If you want to you can customise the Emacs mode. Just start Emacs and-type the following:--    M-x load-library RET agda2-mode RET-    M-x customize-group RET agda2 RET--This is useful if you want to change the Agda search path, in which-case you should change the agda2-include-dirs variable.--If you want some specific settings for the Emacs mode you can add them-to agda2-mode-hook. For instance, if you do not want to use the Agda-input method (for writing various symbols like ∀≥ℕ→π⟦⟧) you can add-the following to your .emacs:--    (add-hook 'agda2-mode-hook-              '(lambda ()-                ; If you do not want to use any input method:-                (deactivate-input-method)-                ; (In some versions of Emacs you should use-                ; inactivate-input-method instead of-                ; deactivate-input-method.)--                ; If you want to use the X input method:-                (set-input-method "X")))+Getting Started+---------------- -Note that, on some systems, the Emacs mode changes the default font of-the current frame in order to enable many Unicode symbols to be-displayed. This only works if the right fonts are available, though.-If you want to turn off this feature, then you should customise the-agda2-fontset-name variable.+* [Installation](https://agda.readthedocs.io/en/latest/getting-started/installation.html)+* [Quick guide to editing, type checking and compiling Agda+  code](https://agda.readthedocs.io/en/latest/getting-started/a-taste-of-agda.html) --------------------------------------------------------------------------Installing Emacs under Windows-------------------------------------------------------------------------+Contributing to Agda+-------------------- -A precompiled version of Emacs 24.3, with the necessary mathematical-fonts, is available at http://homepage.cs.uiowa.edu/~astump/agda/+* Contribution how-to: [`HACKING`](https://github.com/agda/agda/blob/master/HACKING.md)+* [Haskell style-guide](https://github.com/andreasabel/haskell-style-guide/blob/master/haskell-style.md)  [agdawiki]: http://wiki.portal.chalmers.se/agda/pmwiki.php--Hacking on Agda------------------Head to [`HACKING`](https://github.com/agda/agda/blob/master/HACKING)
− Setup.hs 
@@ -1,44 +0,0 @@--import Data.List-import Distribution.Simple-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup-import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.PackageDescription-import System.FilePath-import System.Process-import System.Exit--main = defaultMainWithHooks hooks--hooks = simpleUserHooks { regHook = checkAgdaPrimitiveAndRegister }--builtins :: [String]-builtins =-  [ "Bool", "Char", "Coinduction", "Equality", "Float"-  , "FromNat", "FromNeg", "FromString", "IO", "Int", "List"-  , "Nat", "Reflection", "Size", "Strict", "String"-  , "TrustMe", "Unit" ]--checkAgdaPrimitive :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()-checkAgdaPrimitive pkg info flags | regGenPkgConf flags /= NoFlag = return ()   -- Gets run twice, only do this the second time-checkAgdaPrimitive pkg info flags = do-  let dirs = absoluteInstallDirs pkg info NoCopyDest-      agda = buildDir info </> "agda" </> "agda" <.> exeExtension-      primMod ms = (ms, datadir dirs </> "lib" </> "prim" </> "Agda" </> foldr1 (</>) ms <.> "agda")-      prims      = primMod ["Primitive"] : [ primMod ["Builtin", m] | m <- builtins ]--      checkPrim (ms, file) = do-        ok <- rawSystem agda [file, "-v0"]-        case ok of-          ExitSuccess   -> return ()-          ExitFailure _ -> putStrLn $ "WARNING: Failed to typecheck " ++ intercalate "." ("Agda" : ms) ++ "!"--  putStrLn "Generating Agda library interface files..."-  mapM_ checkPrim prims--checkAgdaPrimitiveAndRegister :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()-checkAgdaPrimitiveAndRegister pkg info hooks flags = do-  checkAgdaPrimitive pkg info flags-  regHook simpleUserHooks pkg info hooks flags  -- This actually does something useful-
− dist/build/Agda/Syntax/Parser/Lexer.hs 
@@ -1,1079 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}-{-# LANGUAGE CPP,MagicHash #-}-{-# LINE 1 "src/full/Agda/Syntax/Parser/Lexer.x" #-}--{-# OPTIONS_GHC -fno-warn-deprecated-flags   #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-tabs               #-}-{-# OPTIONS_GHC -fno-warn-unused-imports     #-}--{-# LANGUAGE BangPatterns #-}--{-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an-    adaptation of GHC's lexer. The main lexing function 'lexer' is called by-    the "Agda.Syntax.Parser.Parser" to get the next token from the input.--}-module Agda.Syntax.Parser.Lexer-    ( -- * The main function-      lexer-      -- * Lex states-    , normal, code-    , layout, empty_layout, bol, imp_dir-      -- * Alex generated functions-    , AlexReturn(..), alexScanUser-    ) where---- -- import Data.List--import Agda.Syntax.Parser.Alex-import Agda.Syntax.Parser.Comments-#ifndef __HADDOCK__-import {-# SOURCE #-} Agda.Syntax.Parser.Layout-import {-# SOURCE #-} Agda.Syntax.Parser.LexActions-#endif-import Agda.Syntax.Parser.Monad-import Agda.Syntax.Parser.StringLiterals-import Agda.Syntax.Parser.Tokens-import Agda.Syntax.Literal---#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-import Data.Array.Base (unsafeAt)-#else-import Array-#endif-#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts-#else-import GlaExts-#endif-alex_tab_size :: Int-alex_tab_size = 8-alex_base :: AlexAddr-alex_base = AlexA# "\xf7\xff\xff\xff\x6c\x00\x00\x00\xe1\x00\x00\x00\x55\x01\x00\x00\xca\x01\x00\x00\x3f\x02\x00\x00\xb5\x02\x00\x00\x73\x00\x00\x00\xd8\xff\xff\xff\x94\x03\x00\x00\xf2\x03\x00\x00\x50\x04\x00\x00\xb6\x02\x00\x00\xac\x04\x00\x00\x08\x05\x00\x00\x5d\x05\x00\x00\x5c\x05\x00\x00\xdc\x05\x00\x00\xbb\x06\x00\x00\xba\x06\x00\x00\x3a\x07\x00\x00\xba\x07\x00\x00\x99\x08\x00\x00\xf5\x08\x00\x00\xf4\x08\x00\x00\x00\x00\x00\x00\x65\x09\x00\x00\x00\x00\x00\x00\xd6\x09\x00\x00\x00\x00\x00\x00\x47\x0a\x00\x00\x00\x00\x00\x00\x88\x0a\x00\x00\x00\x00\x00\x00\xc9\x0a\x00\x00\x00\x00\x00\x00\x0a\x0b\x00\x00\xe9\x0b\x00\x00\x68\x0c\x00\x00\x28\x0c\x00\x00\x00\x00\x00\x00\x28\x0d\x00\x00\xe8\x0c\x00\x00\x00\x00\x00\x00\xe8\x0d\x00\x00\x5e\x0e\x00\x00\xc0\x0d\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x0f\x00\x00\x4c\x10\x00\x00\x43\x11\x00\x00\x3a\x12\x00\x00\x31\x13\x00\x00\x28\x14\x00\x00\x1f\x15\x00\x00\x16\x16\x00\x00\x0d\x17\x00\x00\x04\x18\x00\x00\xfb\x18\x00\x00\xf2\x19\x00\x00\xe9\x1a\x00\x00\xe0\x1b\x00\x00\xd7\x1c\x00\x00\xce\x1d\x00\x00\xc5\x1e\x00\x00\xbc\x1f\x00\x00\xb3\x20\x00\x00\xaa\x21\x00\x00\xa1\x22\x00\x00\x98\x23\x00\x00\x8f\x24\x00\x00\x86\x25\x00\x00\x7d\x26\x00\x00\x74\x27\x00\x00\x6b\x28\x00\x00\x62\x29\x00\x00\x59\x2a\x00\x00\x50\x2b\x00\x00\x47\x2c\x00\x00\x3e\x2d\x00\x00\x35\x2e\x00\x00\x2c\x2f\x00\x00\x23\x30\x00\x00\x1a\x31\x00\x00\x11\x32\x00\x00\x08\x33\x00\x00\xff\x33\x00\x00\xf6\x34\x00\x00\xed\x35\x00\x00\xe4\x36\x00\x00\xdb\x37\x00\x00\xd2\x38\x00\x00\xc9\x39\x00\x00\xc0\x3a\x00\x00\xb7\x3b\x00\x00\xae\x3c\x00\x00\xa5\x3d\x00\x00\x9c\x3e\x00\x00\x93\x3f\x00\x00\x8a\x40\x00\x00\x81\x41\x00\x00\x78\x42\x00\x00\x6f\x43\x00\x00\x66\x44\x00\x00\x5d\x45\x00\x00\x54\x46\x00\x00\x4b\x47\x00\x00\x42\x48\x00\x00\x39\x49\x00\x00\x30\x4a\x00\x00\x27\x4b\x00\x00\x1e\x4c\x00\x00\x15\x4d\x00\x00\x0c\x4e\x00\x00\x03\x4f\x00\x00\xfa\x4f\x00\x00\xf1\x50\x00\x00\xe8\x51\x00\x00\xdf\x52\x00\x00\xd6\x53\x00\x00\xcd\x54\x00\x00\xc4\x55\x00\x00\xbb\x56\x00\x00\xb2\x57\x00\x00\xa9\x58\x00\x00\xa0\x59\x00\x00\x97\x5a\x00\x00\x8e\x5b\x00\x00\x85\x5c\x00\x00\x7c\x5d\x00\x00\x73\x5e\x00\x00\x6a\x5f\x00\x00\x61\x60\x00\x00\x58\x61\x00\x00\x4f\x62\x00\x00\x46\x63\x00\x00\x3d\x64\x00\x00\x34\x65\x00\x00\x2b\x66\x00\x00\x22\x67\x00\x00\x19\x68\x00\x00\x10\x69\x00\x00\x07\x6a\x00\x00\xfe\x6a\x00\x00\xf5\x6b\x00\x00\xec\x6c\x00\x00\xe3\x6d\x00\x00\xda\x6e\x00\x00\xd1\x6f\x00\x00\xc8\x70\x00\x00\xbf\x71\x00\x00\xb6\x72\x00\x00\xad\x73\x00\x00\xa4\x74\x00\x00\x9b\x75\x00\x00\x92\x76\x00\x00\x89\x77\x00\x00\x80\x78\x00\x00\x77\x79\x00\x00\x6e\x7a\x00\x00\x65\x7b\x00\x00\x5c\x7c\x00\x00\x53\x7d\x00\x00\x4a\x7e\x00\x00\x41\x7f\x00\x00\x38\x80\x00\x00\x2f\x81\x00\x00\x26\x82\x00\x00\x1d\x83\x00\x00\x14\x84\x00\x00\x0b\x85\x00\x00\x02\x86\x00\x00\xf9\x86\x00\x00\xf0\x87\x00\x00\xe7\x88\x00\x00\xde\x89\x00\x00\xd5\x8a\x00\x00\xcc\x8b\x00\x00\xc3\x8c\x00\x00\xba\x8d\x00\x00\xb1\x8e\x00\x00\xa8\x8f\x00\x00\x9f\x90\x00\x00\x96\x91\x00\x00\x8d\x92\x00\x00\x84\x93\x00\x00\x7b\x94\x00\x00\x72\x95\x00\x00\x69\x96\x00\x00\x60\x97\x00\x00\x57\x98\x00\x00\x4e\x99\x00\x00\x45\x9a\x00\x00\x3c\x9b\x00\x00\x33\x9c\x00\x00\x2a\x9d\x00\x00\x21\x9e\x00\x00\x18\x9f\x00\x00\x0f\xa0\x00\x00\x06\xa1\x00\x00\xfd\xa1\x00\x00\xf4\xa2\x00\x00\xeb\xa3\x00\x00\xe2\xa4\x00\x00\xd9\xa5\x00\x00\xd0\xa6\x00\x00\xc7\xa7\x00\x00\xbe\xa8\x00\x00\xb5\xa9\x00\x00\xac\xaa\x00\x00\xa3\xab\x00\x00\x9a\xac\x00\x00\x91\xad\x00\x00\x88\xae\x00\x00\x7f\xaf\x00\x00\x76\xb0\x00\x00\x6d\xb1\x00\x00\x64\xb2\x00\x00\x5b\xb3\x00\x00\x52\xb4\x00\x00\x49\xb5\x00\x00\x40\xb6\x00\x00\x37\xb7\x00\x00\x2e\xb8\x00\x00\x25\xb9\x00\x00\x1c\xba\x00\x00\x13\xbb\x00\x00\x0a\xbc\x00\x00\x01\xbd\x00\x00\xf8\xbd\x00\x00\xef\xbe\x00\x00\xe6\xbf\x00\x00\xdd\xc0\x00\x00\xd4\xc1\x00\x00\xcb\xc2\x00\x00\xc2\xc3\x00\x00\xb9\xc4\x00\x00\xb0\xc5\x00\x00\xa7\xc6\x00\x00\x9e\xc7\x00\x00\x95\xc8\x00\x00\x8c\xc9\x00\x00\x83\xca\x00\x00\x7a\xcb\x00\x00\x71\xcc\x00\x00\x68\xcd\x00\x00\x5f\xce\x00\x00\x56\xcf\x00\x00\x4d\xd0\x00\x00\xe3\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xd1\x00\x00\x43\xd2\x00\x00\x43\xd3\x00\x00\x39\xd4\x00\x00\x39\xd5\x00\x00\x2f\xd6\x00\x00\x2f\xd7\x00\x00\x2f\xd8\x00\x00\x2f\xd9\x00\x00\x2f\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x0f\x00\x00\x43\x10\x00\x00\x3a\x11\x00\x00\x31\x12\x00\x00\x16\x15\x00\x00\x0d\x16\x00\x00\x04\x17\x00\x00\xfb\x17\x00\x00\xf2\x18\x00\x00\xe9\x19\x00\x00\xe0\x1a\x00\x00\xd7\x1b\x00\x00\xce\x1c\x00\x00\xbc\x1e\x00\x00\xb3\x1f\x00\x00\xaa\x20\x00\x00\xa1\x21\x00\x00\x98\x22\x00\x00\x8f\x23\x00\x00\x86\x24\x00\x00\x7d\x25\x00\x00\x74\x26\x00\x00\x6b\x27\x00\x00\x62\x28\x00\x00\x59\x29\x00\x00\x50\x2a\x00\x00\x51\x2b\x00\x00\x3e\x2c\x00\x00\x3f\x2d\x00\x00\x2d\x2f\x00\x00\x55\x46\x00\x00\x31\x4a\x00\x00\x16\x4d\x00\x00\x59\x61\x00\x00\x11\x69\x00\x00\xf6\x6b\x00\x00\xed\x6c\x00\x00\xdb\x6e\x00\x00\xb7\x72\x00\x00\x54\x7d\x00\x00\xfa\x86\x00\x00\x9f\x8f\x00\x00\x2d\xd1\x00\x00\x23\xd4\x00\x00\x0e\xdb\x00\x00\x6a\xdb\x00\x00\xc6\xdb\x00\x00\x22\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\xff\xff\xff\xda\xff\xff\xff\x00\x00\x00\x00\x7e\xdc\x00\x00\xda\xdc\x00\x00\x73\x41\x00\x00\x36\xdd\x00\x00\x92\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\xff\xff\xff\x00\x00\x00\x00\xee\xdd\x00\x00\x23\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\xde\x00\x00\xa6\xde\x00\x00\x02\xdf\x00\x00\x5e\xdf\x00\x00\xba\xdf\x00\x00\x16\xe0\x00\x00\x72\xe0\x00\x00\xce\xe0\x00\x00\x2a\xe1\x00\x00\x86\xe1\x00\x00\xe2\xe1\x00\x00\x3e\xe2\x00\x00\x9a\xe2\x00\x00\xf6\xe2\x00\x00\x52\xe3\x00\x00\xae\xe3\x00\x00\x0a\xe4\x00\x00\x66\xe4\x00\x00\xc2\xe4\x00\x00\x1e\xe5\x00\x00\x7c\xe5\x00\x00\xda\xe5\x00\x00\x38\xe6\x00\x00\x96\xe6\x00\x00\xf4\xe6\x00\x00\x52\xe7\x00\x00\xb0\xe7\x00\x00\x0c\xe8\x00\x00\x68\xe8\x00\x00\xc4\xe8\x00\x00\x20\xe9\x00\x00\x7c\xe9\x00\x00\xd8\xe9\x00\x00\x34\xea\x00\x00\x90\xea\x00\x00\xec\xea\x00\x00\x48\xeb\x00\x00\xa4\xeb\x00\x00\x00\xec\x00\x00\x5c\xec\x00\x00\xb8\xec\x00\x00\x14\xed\x00\x00\x70\xed\x00\x00\xcc\xed\x00\x00\x28\xee\x00\x00\x84\xee\x00\x00\xe0\xee\x00\x00\x3c\xef\x00\x00\x98\xef\x00\x00\xf4\xef\x00\x00\x50\xf0\x00\x00\xac\xf0\x00\x00\x08\xf1\x00\x00\x64\xf1\x00\x00\xc0\xf1\x00\x00\x1c\xf2\x00\x00\x78\xf2\x00\x00\xd4\xf2\x00\x00\x30\xf3\x00\x00\x8c\xf3\x00\x00\xe8\xf3\x00\x00\x44\xf4\x00\x00\xa0\xf4\x00\x00\xfc\xf4\x00\x00\x58\xf5\x00\x00\xb4\xf5\x00\x00\x10\xf6\x00\x00\x6c\xf6\x00\x00\xc8\xf6\x00\x00\x24\xf7\x00\x00\x80\xf7\x00\x00\xdc\xf7\x00\x00\x38\xf8\x00\x00\x94\xf8\x00\x00\xf0\xf8\x00\x00\x4c\xf9\x00\x00\xa8\xf9\x00\x00\x04\xfa\x00\x00\x60\xfa\x00\x00\xbc\xfa\x00\x00\x18\xfb\x00\x00\x74\xfb\x00\x00\xd0\xfb\x00\x00\x2c\xfc\x00\x00\x88\xfc\x00\x00\xe4\xfc\x00\x00\x40\xfd\x00\x00\x9c\xfd\x00\x00\xf8\xfd\x00\x00\x54\xfe\x00\x00\xb0\xfe\x00\x00\x0c\xff\x00\x00\x68\xff\x00\x00\xc4\xff\x00\x00\x20\x00\x01\x00\x7c\x00\x01\x00\xd8\x00\x01\x00\x34\x01\x01\x00\x90\x01\x01\x00\xec\x01\x01\x00\x48\x02\x01\x00\xa4\x02\x01\x00\x00\x03\x01\x00\x5c\x03\x01\x00\xb8\x03\x01\x00\x14\x04\x01\x00\x70\x04\x01\x00\xcc\x04\x01\x00\x28\x05\x01\x00\x84\x05\x01\x00\xe0\x05\x01\x00\x3c\x06\x01\x00\x98\x06\x01\x00\xf4\x06\x01\x00\x50\x07\x01\x00\xac\x07\x01\x00\x08\x08\x01\x00\x64\x08\x01\x00\xc0\x08\x01\x00\x1c\x09\x01\x00\x78\x09\x01\x00\xd4\x09\x01\x00\x30\x0a\x01\x00\x8c\x0a\x01\x00\xe8\x0a\x01\x00\x44\x0b\x01\x00\xa0\x0b\x01\x00\xfc\x0b\x01\x00\x58\x0c\x01\x00\xb4\x0c\x01\x00\x10\x0d\x01\x00\x6c\x0d\x01\x00\xc8\x0d\x01\x00\x24\x0e\x01\x00\x80\x0e\x01\x00\xdc\x0e\x01\x00\x38\x0f\x01\x00\x94\x0f\x01\x00\xf0\x0f\x01\x00\x4c\x10\x01\x00\xa8\x10\x01\x00\x04\x11\x01\x00\x60\x11\x01\x00\xbc\x11\x01\x00\x18\x12\x01\x00\x74\x12\x01\x00\xd0\x12\x01\x00\x2c\x13\x01\x00\x88\x13\x01\x00\xe4\x13\x01\x00\x40\x14\x01\x00\x9c\x14\x01\x00\xf8\x14\x01\x00\x54\x15\x01\x00\xb0\x15\x01\x00\x0c\x16\x01\x00\x68\x16\x01\x00\xc4\x16\x01\x00\x20\x17\x01\x00\x7c\x17\x01\x00\xd8\x17\x01\x00\x34\x18\x01\x00\x90\x18\x01\x00\xec\x18\x01\x00\x48\x19\x01\x00\xa4\x19\x01\x00\x00\x1a\x01\x00\x5c\x1a\x01\x00\xb8\x1a\x01\x00\x14\x1b\x01\x00\x70\x1b\x01\x00\xcc\x1b\x01\x00\x28\x1c\x01\x00\x84\x1c\x01\x00\xe0\x1c\x01\x00\x3c\x1d\x01\x00\x98\x1d\x01\x00\xf4\x1d\x01\x00\x50\x1e\x01\x00\xac\x1e\x01\x00\x08\x1f\x01\x00\x64\x1f\x01\x00\xc0\x1f\x01\x00\x1c\x20\x01\x00\x78\x20\x01\x00\xd4\x20\x01\x00\x30\x21\x01\x00\x8c\x21\x01\x00\xe8\x21\x01\x00\x44\x22\x01\x00\xa0\x22\x01\x00\xfc\x22\x01\x00\x58\x23\x01\x00\xb4\x23\x01\x00\x10\x24\x01\x00\x6c\x24\x01\x00\xc8\x24\x01\x00\x24\x25\x01\x00\x80\x25\x01\x00\xdc\x25\x01\x00\x38\x26\x01\x00\x94\x26\x01\x00\xf0\x26\x01\x00\x4c\x27\x01\x00\xa8\x27\x01\x00\x04\x28\x01\x00\x60\x28\x01\x00\xbc\x28\x01\x00\x18\x29\x01\x00\x74\x29\x01\x00\xd0\x29\x01\x00\x2c\x2a\x01\x00\x88\x2a\x01\x00\xe4\x2a\x01\x00\x40\x2b\x01\x00\x9c\x2b\x01\x00\xf8\x2b\x01\x00\x54\x2c\x01\x00\xb0\x2c\x01\x00\x0c\x2d\x01\x00\x68\x2d\x01\x00\xc4\x2d\x01\x00\x20\x2e\x01\x00\x7c\x2e\x01\x00\xd8\x2e\x01\x00\x34\x2f\x01\x00\x90\x2f\x01\x00\xec\x2f\x01\x00\x48\x30\x01\x00\xa4\x30\x01\x00\x00\x31\x01\x00\x5c\x31\x01\x00"#--alex_table :: AlexAddr-alex_table = AlexA# "\x00\x00\x0b\x01\x30\x00\x30\x00\x30\x00\xfe\x00\x33\x00\x3f\x01\x40\x01\x48\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\xdb\x01\x53\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x52\x01\x4a\x01\x4b\x01\xdb\x01\xdb\x01\xdb\x01\x68\x01\x41\x01\xdb\x01\x5a\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x43\x01\x42\x01\xdb\x01\x44\x01\xdb\x01\x46\x01\x4e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x4d\x01\xdb\x01\xdb\x01\x45\x01\xdb\x01\xdf\x01\xdb\x01\xbc\x01\x9b\x01\xdd\x01\xb0\x01\xdb\x01\xc8\x01\x3a\x02\xdb\x01\xdb\x01\x85\x01\xb4\x01\xda\x01\x02\x02\xca\x01\xb5\x01\xbd\x01\xc7\x01\xc6\x01\xb8\x01\xdb\x01\x95\x01\xdb\x01\xdb\x01\xdb\x01\x50\x01\x47\x01\x51\x01\xdb\x01\x0c\x01\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x31\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x09\x00\x30\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x17\x00\x12\x00\x12\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x08\x00\x12\x00\x00\x00\x12\x00\x0b\x01\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\xdb\x01\x53\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x52\x01\x4a\x01\x4b\x01\xdb\x01\xdb\x01\xdb\x01\x68\x01\x41\x01\xdb\x01\x5a\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x43\x01\x42\x01\xdb\x01\x44\x01\xdb\x01\x46\x01\x4e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x4d\x01\xdb\x01\xdb\x01\x45\x01\xdb\x01\xdf\x01\xdb\x01\xbc\x01\x9b\x01\xdd\x01\xb0\x01\xdb\x01\xc8\x01\x3a\x02\xdb\x01\xdb\x01\x85\x01\xb4\x01\xda\x01\x02\x02\xca\x01\xb5\x01\xbd\x01\xc7\x01\xc6\x01\xb8\x01\xdb\x01\x95\x01\xdb\x01\xdb\x01\xdb\x01\x50\x01\x47\x01\x51\x01\xdb\x01\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x09\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x17\x00\x12\x00\x12\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x08\x00\x12\x00\x00\x00\x12\x00\x0b\x01\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x67\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0c\x00\xdb\x01\xdb\x01\x0b\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x83\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x08\x00\xdb\x01\x00\x00\xdb\x01\x0d\x01\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x09\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x17\x00\x12\x00\x12\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x08\x00\x12\x00\x00\x00\x12\x00\xff\xff\x32\x00\x32\x00\x32\x00\x32\x00\x3e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\xdb\x01\x69\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x98\x00\xa1\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x8f\x00\x00\x00\x00\x00\x7b\x00\x9d\x00\xb6\x00\xca\x00\xa4\x00\x00\x00\xa0\x00\xcd\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x02\x01\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\xff\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x0a\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x00\x01\x12\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0e\x00\x1d\x02\x1d\x02\x0d\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x00\x00\x1d\x02\x2c\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x0a\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x00\x00\x12\x00\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x10\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x65\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0e\x00\x1d\x02\x1d\x02\x0d\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x00\x00\x1d\x02\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2e\x00\x10\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x24\x00\x14\x00\x1d\x00\x1d\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xcb\x01\xdb\x01\x88\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe6\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xff\xff\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x22\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x23\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x34\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x2e\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x39\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3b\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xff\xff\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x51\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x5a\x00\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf6\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\x2d\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf3\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2d\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdd\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x87\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd3\x00\xdb\x01\xdb\x01\xd0\x01\xdb\x01\xdb\x01\xdb\x01\xa7\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xaa\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd2\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd0\x00\xdb\x01\xdb\x01\xdb\x01\x8f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8d\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc7\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc0\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xff\xff\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2a\x00\x11\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x15\x00\x1b\x00\x1b\x00\x1b\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x02\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x01\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x02\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x04\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x00\x00\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x04\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x0a\x01\x0a\x01\x0a\x01\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x0a\x01\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x04\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x08\x01\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x01\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x08\x01\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x04\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xff\xff\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x04\x01\x00\x00\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x27\x00\x13\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x18\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x49\x01\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\x22\x02\xdb\x01\x6d\x01\x25\x00\xdb\x01\x57\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x54\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1e\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x21\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x21\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\x58\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x21\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x21\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x25\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x25\x00\xdb\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x26\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x24\x02\x1d\x02\x24\x02\x0f\x00\x1d\x02\x60\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5d\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1f\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\xdb\x01\x1d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1e\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x23\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x23\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x63\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x23\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x23\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x20\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1f\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\xdb\x01\x1d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x08\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xff\x00\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x08\x01\x0f\x00\xdb\x01\x5b\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\x59\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\x4c\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xff\x00\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd3\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdc\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x62\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x10\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x13\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x14\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x15\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x18\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x19\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1f\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x20\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x26\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x27\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x29\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x31\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x32\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x33\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x36\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x39\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3b\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x3b\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x37\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x34\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x33\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x32\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x31\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x30\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2f\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2c\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x29\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x28\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x84\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1c\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1b\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x93\x01\x1a\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x19\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x18\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x17\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x16\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x15\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x14\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x13\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x12\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x11\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x10\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0f\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0e\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x89\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0c\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0b\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0a\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x09\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x08\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x07\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x06\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x05\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x04\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x03\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x94\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xed\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x9d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xfb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x01\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa5\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf7\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf1\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xab\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xfe\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc5\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xad\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xaf\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xfa\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf6\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb1\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf5\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf4\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf3\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xef\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xee\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb6\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb7\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xeb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe4\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd1\x01\xdb\x01\xdb\x01\xc3\x01\xdb\x01\xdb\x01\xe8\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xbf\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc0\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc1\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe7\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe5\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe3\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xcd\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xce\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe1\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x69\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6a\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd5\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd6\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6b\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd9\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd8\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd7\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe0\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xcf\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xcc\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xe2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xbe\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xba\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xea\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xec\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xb3\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf0\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xfc\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xae\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xac\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xfd\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa8\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa6\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xff\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xbb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa4\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa3\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa2\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa1\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xa0\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x9f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x9e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x9c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xde\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xd4\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x9a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x99\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x98\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x97\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x96\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x92\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x91\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x90\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x8b\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x87\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x86\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xc4\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x82\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x81\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x80\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x27\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7d\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2b\x02\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2e\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x7b\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x79\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x78\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x77\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x76\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x75\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x35\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x74\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x73\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x72\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x36\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x71\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x70\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x6f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x38\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x39\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x6e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\xdb\x01\x1d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\x5c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x5f\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x5e\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\xdb\x01\x1d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\x22\x02\xdb\x01\x6d\x01\x0f\x00\xdb\x01\x62\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x62\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x1d\x02\xdb\x01\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x24\x02\x1d\x02\x24\x02\x0f\x00\x1d\x02\x66\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x0f\x00\x1d\x02\x66\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x64\x01\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x1d\x02\x00\x00\x1d\x02\xdb\x01\x1d\x02\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\x56\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x38\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x37\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2a\x02\xdb\x01\xdb\x01\x35\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x34\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x30\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\x2c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2b\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x2a\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x28\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x25\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x24\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x21\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1c\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x1b\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x17\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x16\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x12\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x11\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xf8\x01\x0f\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\x00\x00\xdb\x01\xdb\x01\xdb\x01\x6c\x01\x0f\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x0e\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\xdb\x01\x00\x00\xdb\x01\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--alex_check :: AlexAddr-alex_check = AlexA# "\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x23\x00\x2e\x00\x2e\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x20\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x20\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x21\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\x23\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x42\x00\x43\x00\x44\x00\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\xff\xff\x52\x00\x53\x00\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x7c\x00\xff\xff\x7e\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x20\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\x23\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x20\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x2d\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x20\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_deflt :: AlexAddr-alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x00\x1f\x00\x21\x00\x21\x00\x23\x00\x23\x00\x28\x00\x28\x00\x2b\x00\x2b\x00\x2f\x00\x2f\x00\xff\xff\x04\x01\x04\x01\x04\x01\xb9\x00\xb9\x00\xb9\x00\x31\x00\x31\x00\x31\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x04\x01\x03\x01\x03\x01\x04\x01\x0a\x01\x04\x01\x0a\x01\x09\x01\x09\x01\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_accept = listArray (0::Int,571) [AlexAccNone,AlexAccPred 524 ( not' eof )(AlexAccNone),AlexAccNone,AlexAcc 523,AlexAccNone,AlexAcc 522,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc 521,AlexAcc 520,AlexAcc 519,AlexAcc 518,AlexAcc 517,AlexAcc 516,AlexAcc 515,AlexAcc 514,AlexAcc 513,AlexAcc 512,AlexAcc 511,AlexAcc 510,AlexAcc 509,AlexAcc 508,AlexAcc 507,AlexAcc 506,AlexAcc 505,AlexAcc 504,AlexAcc 503,AlexAcc 502,AlexAcc 501,AlexAcc 500,AlexAcc 499,AlexAcc 498,AlexAcc 497,AlexAcc 496,AlexAcc 495,AlexAcc 494,AlexAcc 493,AlexAcc 492,AlexAcc 491,AlexAcc 490,AlexAcc 489,AlexAcc 488,AlexAcc 487,AlexAcc 486,AlexAcc 485,AlexAcc 484,AlexAcc 483,AlexAcc 482,AlexAcc 481,AlexAcc 480,AlexAcc 479,AlexAcc 478,AlexAcc 477,AlexAcc 476,AlexAcc 475,AlexAcc 474,AlexAcc 473,AlexAcc 472,AlexAcc 471,AlexAcc 470,AlexAcc 469,AlexAcc 468,AlexAcc 467,AlexAcc 466,AlexAcc 465,AlexAcc 464,AlexAcc 463,AlexAcc 462,AlexAcc 461,AlexAcc 460,AlexAcc 459,AlexAcc 458,AlexAcc 457,AlexAcc 456,AlexAcc 455,AlexAcc 454,AlexAcc 453,AlexAcc 452,AlexAcc 451,AlexAcc 450,AlexAcc 449,AlexAcc 448,AlexAcc 447,AlexAcc 446,AlexAcc 445,AlexAcc 444,AlexAcc 443,AlexAcc 442,AlexAcc 441,AlexAcc 440,AlexAcc 439,AlexAcc 438,AlexAcc 437,AlexAcc 436,AlexAcc 435,AlexAcc 434,AlexAcc 433,AlexAcc 432,AlexAcc 431,AlexAcc 430,AlexAcc 429,AlexAcc 428,AlexAcc 427,AlexAcc 426,AlexAcc 425,AlexAcc 424,AlexAcc 423,AlexAcc 422,AlexAcc 421,AlexAcc 420,AlexAcc 419,AlexAcc 418,AlexAcc 417,AlexAcc 416,AlexAcc 415,AlexAcc 414,AlexAcc 413,AlexAcc 412,AlexAcc 411,AlexAcc 410,AlexAcc 409,AlexAcc 408,AlexAcc 407,AlexAcc 406,AlexAcc 405,AlexAcc 404,AlexAcc 403,AlexAcc 402,AlexAcc 401,AlexAcc 400,AlexAcc 399,AlexAcc 398,AlexAcc 397,AlexAcc 396,AlexAcc 395,AlexAcc 394,AlexAcc 393,AlexAcc 392,AlexAcc 391,AlexAcc 390,AlexAcc 389,AlexAcc 388,AlexAcc 387,AlexAcc 386,AlexAcc 385,AlexAcc 384,AlexAcc 383,AlexAcc 382,AlexAcc 381,AlexAcc 380,AlexAcc 379,AlexAcc 378,AlexAcc 377,AlexAcc 376,AlexAcc 375,AlexAcc 374,AlexAcc 373,AlexAcc 372,AlexAcc 371,AlexAcc 370,AlexAcc 369,AlexAcc 368,AlexAcc 367,AlexAcc 366,AlexAcc 365,AlexAcc 364,AlexAcc 363,AlexAcc 362,AlexAcc 361,AlexAcc 360,AlexAcc 359,AlexAcc 358,AlexAcc 357,AlexAcc 356,AlexAcc 355,AlexAcc 354,AlexAcc 353,AlexAcc 352,AlexAcc 351,AlexAcc 350,AlexAcc 349,AlexAcc 348,AlexAcc 347,AlexAcc 346,AlexAcc 345,AlexAcc 344,AlexAcc 343,AlexAcc 342,AlexAcc 341,AlexAcc 340,AlexAcc 339,AlexAcc 338,AlexAcc 337,AlexAcc 336,AlexAcc 335,AlexAcc 334,AlexAcc 333,AlexAcc 332,AlexAcc 331,AlexAcc 330,AlexAcc 329,AlexAcc 328,AlexAcc 327,AlexAcc 326,AlexAcc 325,AlexAcc 324,AlexAcc 323,AlexAcc 322,AlexAcc 321,AlexAcc 320,AlexAccPred 319 ( not' (followedBy '#') )(AlexAccNone),AlexAccPred 318 ( not' (followedBy '#') )(AlexAccNone),AlexAcc 317,AlexAcc 316,AlexAcc 315,AlexAccPred 314 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 313 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 312 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 311 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 310 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 309 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAccNone)),AlexAccPred 308 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAcc 307)),AlexAccPred 306 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAcc 305)),AlexAccPred 304 ( keepComments .&&. (followedBy '\n' .||. eof) )(AlexAccSkipPred ( followedBy '\n' .||. eof )(AlexAcc 303)),AlexAcc 302,AlexAccSkip,AlexAccSkip,AlexAcc 301,AlexAcc 300,AlexAcc 299,AlexAcc 298,AlexAcc 297,AlexAcc 296,AlexAcc 295,AlexAcc 294,AlexAcc 293,AlexAcc 292,AlexAcc 291,AlexAcc 290,AlexAcc 289,AlexAcc 288,AlexAcc 287,AlexAcc 286,AlexAcc 285,AlexAcc 284,AlexAcc 283,AlexAcc 282,AlexAcc 281,AlexAcc 280,AlexAcc 279,AlexAcc 278,AlexAcc 277,AlexAcc 276,AlexAcc 275,AlexAcc 274,AlexAcc 273,AlexAcc 272,AlexAcc 271,AlexAcc 270,AlexAcc 269,AlexAcc 268,AlexAcc 267,AlexAcc 266,AlexAcc 265,AlexAcc 264,AlexAcc 263,AlexAcc 262,AlexAcc 261,AlexAcc 260,AlexAcc 259,AlexAcc 258,AlexAcc 257,AlexAcc 256,AlexAcc 255,AlexAcc 254,AlexAcc 253,AlexAcc 252,AlexAcc 251,AlexAcc 250,AlexAcc 249,AlexAcc 248,AlexAcc 247,AlexAcc 246,AlexAcc 245,AlexAcc 244,AlexAccPred 243 (alexRightContext 7)(AlexAccNone),AlexAcc 242,AlexAcc 241,AlexAcc 240,AlexAcc 239,AlexAcc 238,AlexAcc 237,AlexAccPred 236 (alexRightContext 45)(AlexAccNone),AlexAcc 235,AlexAcc 234,AlexAcc 233,AlexAcc 232,AlexAcc 231,AlexAcc 230,AlexAcc 229,AlexAcc 228,AlexAcc 227,AlexAcc 226,AlexAcc 225,AlexAcc 224,AlexAcc 223,AlexAcc 222,AlexAcc 221,AlexAcc 220,AlexAcc 219,AlexAcc 218,AlexAcc 217,AlexAcc 216,AlexAcc 215,AlexAcc 214,AlexAcc 213,AlexAcc 212,AlexAcc 211,AlexAcc 210,AlexAcc 209,AlexAcc 208,AlexAcc 207,AlexAcc 206,AlexAcc 205,AlexAcc 204,AlexAcc 203,AlexAcc 202,AlexAcc 201,AlexAcc 200,AlexAcc 199,AlexAcc 198,AlexAcc 197,AlexAcc 196,AlexAcc 195,AlexAcc 194,AlexAcc 193,AlexAcc 192,AlexAcc 191,AlexAcc 190,AlexAcc 189,AlexAcc 188,AlexAcc 187,AlexAcc 186,AlexAcc 185,AlexAcc 184,AlexAcc 183,AlexAcc 182,AlexAcc 181,AlexAcc 180,AlexAcc 179,AlexAcc 178,AlexAcc 177,AlexAcc 176,AlexAcc 175,AlexAcc 174,AlexAcc 173,AlexAcc 172,AlexAcc 171,AlexAcc 170,AlexAcc 169,AlexAcc 168,AlexAcc 167,AlexAcc 166,AlexAcc 165,AlexAcc 164,AlexAcc 163,AlexAcc 162,AlexAcc 161,AlexAcc 160,AlexAcc 159,AlexAcc 158,AlexAcc 157,AlexAcc 156,AlexAcc 155,AlexAcc 154,AlexAcc 153,AlexAcc 152,AlexAcc 151,AlexAcc 150,AlexAcc 149,AlexAcc 148,AlexAcc 147,AlexAcc 146,AlexAcc 145,AlexAcc 144,AlexAcc 143,AlexAcc 142,AlexAcc 141,AlexAcc 140,AlexAcc 139,AlexAcc 138,AlexAcc 137,AlexAcc 136,AlexAcc 135,AlexAcc 134,AlexAcc 133,AlexAcc 132,AlexAcc 131,AlexAcc 130,AlexAcc 129,AlexAcc 128,AlexAcc 127,AlexAcc 126,AlexAcc 125,AlexAcc 124,AlexAcc 123,AlexAcc 122,AlexAcc 121,AlexAcc 120,AlexAcc 119,AlexAcc 118,AlexAcc 117,AlexAcc 116,AlexAcc 115,AlexAcc 114,AlexAcc 113,AlexAcc 112,AlexAcc 111,AlexAcc 110,AlexAcc 109,AlexAcc 108,AlexAcc 107,AlexAcc 106,AlexAcc 105,AlexAcc 104,AlexAcc 103,AlexAcc 102,AlexAcc 101,AlexAcc 100,AlexAcc 99,AlexAcc 98,AlexAcc 97,AlexAcc 96,AlexAcc 95,AlexAcc 94,AlexAcc 93,AlexAcc 92,AlexAcc 91,AlexAcc 90,AlexAcc 89,AlexAcc 88,AlexAcc 87,AlexAcc 86,AlexAcc 85,AlexAcc 84,AlexAcc 83,AlexAcc 82,AlexAcc 81,AlexAcc 80,AlexAcc 79,AlexAcc 78,AlexAcc 77,AlexAcc 76,AlexAcc 75,AlexAcc 74,AlexAcc 73,AlexAcc 72,AlexAcc 71,AlexAcc 70,AlexAcc 69,AlexAcc 68,AlexAcc 67,AlexAcc 66,AlexAcc 65,AlexAcc 64,AlexAcc 63,AlexAcc 62,AlexAcc 61,AlexAcc 60,AlexAcc 59,AlexAcc 58,AlexAcc 57,AlexAcc 56,AlexAcc 55,AlexAcc 54,AlexAcc 53,AlexAcc 52,AlexAcc 51,AlexAcc 50,AlexAcc 49,AlexAcc 48,AlexAcc 47,AlexAcc 46,AlexAcc 45,AlexAcc 44,AlexAcc 43,AlexAcc 42,AlexAcc 41,AlexAcc 40,AlexAcc 39,AlexAcc 38,AlexAcc 37,AlexAcc 36,AlexAcc 35,AlexAcc 34,AlexAcc 33,AlexAcc 32,AlexAcc 31,AlexAcc 30,AlexAcc 29,AlexAcc 28,AlexAcc 27,AlexAcc 26,AlexAcc 25,AlexAcc 24,AlexAcc 23,AlexAcc 22,AlexAcc 21,AlexAcc 20,AlexAcc 19,AlexAcc 18,AlexAcc 17,AlexAcc 16,AlexAcc 15,AlexAcc 14,AlexAcc 13,AlexAcc 12,AlexAcc 11,AlexAcc 10,AlexAcc 9,AlexAcc 8,AlexAcc 7,AlexAcc 6,AlexAcc 5,AlexAcc 4,AlexAcc 3,AlexAcc 2,AlexAcc 1,AlexAcc 0]--alex_actions = array (0::Int,525) [(524,alex_action_40),(523,alex_action_43),(522,alex_action_42),(521,alex_action_2),(520,alex_action_3),(519,alex_action_4),(518,alex_action_5),(517,alex_action_6),(516,alex_action_7),(515,alex_action_8),(514,alex_action_9),(513,alex_action_10),(512,alex_action_11),(511,alex_action_12),(510,alex_action_13),(509,alex_action_14),(508,alex_action_15),(507,alex_action_16),(506,alex_action_17),(505,alex_action_18),(504,alex_action_19),(503,alex_action_20),(502,alex_action_21),(501,alex_action_22),(500,alex_action_23),(499,alex_action_24),(498,alex_action_25),(497,alex_action_26),(496,alex_action_27),(495,alex_action_28),(494,alex_action_29),(493,alex_action_30),(492,alex_action_31),(491,alex_action_32),(490,alex_action_32),(489,alex_action_32),(488,alex_action_32),(487,alex_action_32),(486,alex_action_32),(485,alex_action_32),(484,alex_action_32),(483,alex_action_32),(482,alex_action_32),(481,alex_action_32),(480,alex_action_32),(479,alex_action_32),(478,alex_action_32),(477,alex_action_32),(476,alex_action_32),(475,alex_action_32),(474,alex_action_32),(473,alex_action_32),(472,alex_action_32),(471,alex_action_32),(470,alex_action_32),(469,alex_action_32),(468,alex_action_32),(467,alex_action_32),(466,alex_action_32),(465,alex_action_32),(464,alex_action_32),(463,alex_action_32),(462,alex_action_32),(461,alex_action_32),(460,alex_action_32),(459,alex_action_32),(458,alex_action_32),(457,alex_action_32),(456,alex_action_32),(455,alex_action_32),(454,alex_action_32),(453,alex_action_32),(452,alex_action_32),(451,alex_action_32),(450,alex_action_32),(449,alex_action_32),(448,alex_action_32),(447,alex_action_32),(446,alex_action_32),(445,alex_action_32),(444,alex_action_32),(443,alex_action_32),(442,alex_action_32),(441,alex_action_32),(440,alex_action_32),(439,alex_action_32),(438,alex_action_32),(437,alex_action_32),(436,alex_action_32),(435,alex_action_32),(434,alex_action_32),(433,alex_action_32),(432,alex_action_32),(431,alex_action_32),(430,alex_action_32),(429,alex_action_32),(428,alex_action_32),(427,alex_action_32),(426,alex_action_32),(425,alex_action_32),(424,alex_action_32),(423,alex_action_32),(422,alex_action_32),(421,alex_action_32),(420,alex_action_32),(419,alex_action_32),(418,alex_action_32),(417,alex_action_32),(416,alex_action_32),(415,alex_action_32),(414,alex_action_32),(413,alex_action_32),(412,alex_action_32),(411,alex_action_32),(410,alex_action_32),(409,alex_action_32),(408,alex_action_32),(407,alex_action_32),(406,alex_action_32),(405,alex_action_32),(404,alex_action_32),(403,alex_action_32),(402,alex_action_32),(401,alex_action_32),(400,alex_action_32),(399,alex_action_32),(398,alex_action_32),(397,alex_action_32),(396,alex_action_32),(395,alex_action_32),(394,alex_action_32),(393,alex_action_32),(392,alex_action_32),(391,alex_action_32),(390,alex_action_32),(389,alex_action_32),(388,alex_action_32),(387,alex_action_32),(386,alex_action_32),(385,alex_action_32),(384,alex_action_32),(383,alex_action_32),(382,alex_action_32),(381,alex_action_32),(380,alex_action_32),(379,alex_action_32),(378,alex_action_32),(377,alex_action_32),(376,alex_action_32),(375,alex_action_32),(374,alex_action_32),(373,alex_action_32),(372,alex_action_32),(371,alex_action_32),(370,alex_action_32),(369,alex_action_32),(368,alex_action_32),(367,alex_action_32),(366,alex_action_32),(365,alex_action_32),(364,alex_action_32),(363,alex_action_32),(362,alex_action_32),(361,alex_action_32),(360,alex_action_32),(359,alex_action_32),(358,alex_action_32),(357,alex_action_32),(356,alex_action_32),(355,alex_action_32),(354,alex_action_32),(353,alex_action_32),(352,alex_action_32),(351,alex_action_32),(350,alex_action_32),(349,alex_action_32),(348,alex_action_32),(347,alex_action_32),(346,alex_action_32),(345,alex_action_32),(344,alex_action_32),(343,alex_action_32),(342,alex_action_32),(341,alex_action_32),(340,alex_action_32),(339,alex_action_32),(338,alex_action_32),(337,alex_action_32),(336,alex_action_32),(335,alex_action_32),(334,alex_action_32),(333,alex_action_32),(332,alex_action_32),(331,alex_action_32),(330,alex_action_32),(329,alex_action_32),(328,alex_action_32),(327,alex_action_32),(326,alex_action_32),(325,alex_action_32),(324,alex_action_32),(323,alex_action_32),(322,alex_action_32),(321,alex_action_32),(320,alex_action_32),(319,alex_action_33),(318,alex_action_33),(317,alex_action_34),(316,alex_action_35),(315,alex_action_35),(314,alex_action_36),(313,alex_action_36),(312,alex_action_36),(311,alex_action_36),(310,alex_action_36),(309,alex_action_36),(308,alex_action_36),(307,alex_action_114),(306,alex_action_36),(305,alex_action_114),(304,alex_action_36),(303,alex_action_114),(302,alex_action_38),(301,alex_action_44),(300,alex_action_45),(299,alex_action_46),(298,alex_action_47),(297,alex_action_48),(296,alex_action_49),(295,alex_action_50),(294,alex_action_51),(293,alex_action_52),(292,alex_action_53),(291,alex_action_54),(290,alex_action_55),(289,alex_action_56),(288,alex_action_57),(287,alex_action_58),(286,alex_action_59),(285,alex_action_60),(284,alex_action_61),(283,alex_action_62),(282,alex_action_63),(281,alex_action_64),(280,alex_action_65),(279,alex_action_66),(278,alex_action_67),(277,alex_action_68),(276,alex_action_69),(275,alex_action_70),(274,alex_action_71),(273,alex_action_72),(272,alex_action_73),(271,alex_action_74),(270,alex_action_74),(269,alex_action_74),(268,alex_action_75),(267,alex_action_76),(266,alex_action_77),(265,alex_action_78),(264,alex_action_79),(263,alex_action_80),(262,alex_action_81),(261,alex_action_82),(260,alex_action_83),(259,alex_action_84),(258,alex_action_85),(257,alex_action_86),(256,alex_action_87),(255,alex_action_88),(254,alex_action_89),(253,alex_action_90),(252,alex_action_91),(251,alex_action_92),(250,alex_action_93),(249,alex_action_94),(248,alex_action_95),(247,alex_action_96),(246,alex_action_97),(245,alex_action_98),(244,alex_action_99),(243,alex_action_100),(242,alex_action_101),(241,alex_action_102),(240,alex_action_103),(239,alex_action_104),(238,alex_action_105),(237,alex_action_106),(236,alex_action_107),(235,alex_action_108),(234,alex_action_109),(233,alex_action_110),(232,alex_action_111),(231,alex_action_112),(230,alex_action_112),(229,alex_action_112),(228,alex_action_112),(227,alex_action_112),(226,alex_action_112),(225,alex_action_112),(224,alex_action_112),(223,alex_action_113),(222,alex_action_113),(221,alex_action_113),(220,alex_action_113),(219,alex_action_113),(218,alex_action_113),(217,alex_action_113),(216,alex_action_113),(215,alex_action_113),(214,alex_action_113),(213,alex_action_113),(212,alex_action_114),(211,alex_action_114),(210,alex_action_114),(209,alex_action_114),(208,alex_action_114),(207,alex_action_114),(206,alex_action_114),(205,alex_action_114),(204,alex_action_114),(203,alex_action_114),(202,alex_action_114),(201,alex_action_114),(200,alex_action_114),(199,alex_action_114),(198,alex_action_114),(197,alex_action_114),(196,alex_action_114),(195,alex_action_114),(194,alex_action_114),(193,alex_action_114),(192,alex_action_114),(191,alex_action_114),(190,alex_action_114),(189,alex_action_114),(188,alex_action_114),(187,alex_action_114),(186,alex_action_114),(185,alex_action_114),(184,alex_action_114),(183,alex_action_114),(182,alex_action_114),(181,alex_action_114),(180,alex_action_114),(179,alex_action_114),(178,alex_action_114),(177,alex_action_114),(176,alex_action_114),(175,alex_action_114),(174,alex_action_114),(173,alex_action_114),(172,alex_action_114),(171,alex_action_114),(170,alex_action_114),(169,alex_action_114),(168,alex_action_114),(167,alex_action_114),(166,alex_action_114),(165,alex_action_114),(164,alex_action_114),(163,alex_action_114),(162,alex_action_114),(161,alex_action_114),(160,alex_action_114),(159,alex_action_114),(158,alex_action_114),(157,alex_action_114),(156,alex_action_114),(155,alex_action_114),(154,alex_action_114),(153,alex_action_114),(152,alex_action_114),(151,alex_action_114),(150,alex_action_114),(149,alex_action_114),(148,alex_action_114),(147,alex_action_114),(146,alex_action_114),(145,alex_action_114),(144,alex_action_114),(143,alex_action_114),(142,alex_action_114),(141,alex_action_114),(140,alex_action_114),(139,alex_action_114),(138,alex_action_114),(137,alex_action_114),(136,alex_action_114),(135,alex_action_114),(134,alex_action_114),(133,alex_action_114),(132,alex_action_114),(131,alex_action_114),(130,alex_action_114),(129,alex_action_114),(128,alex_action_114),(127,alex_action_114),(126,alex_action_114),(125,alex_action_114),(124,alex_action_114),(123,alex_action_114),(122,alex_action_114),(121,alex_action_114),(120,alex_action_114),(119,alex_action_114),(118,alex_action_114),(117,alex_action_114),(116,alex_action_114),(115,alex_action_114),(114,alex_action_114),(113,alex_action_114),(112,alex_action_114),(111,alex_action_114),(110,alex_action_114),(109,alex_action_114),(108,alex_action_114),(107,alex_action_114),(106,alex_action_114),(105,alex_action_114),(104,alex_action_114),(103,alex_action_114),(102,alex_action_114),(101,alex_action_114),(100,alex_action_114),(99,alex_action_114),(98,alex_action_114),(97,alex_action_114),(96,alex_action_114),(95,alex_action_114),(94,alex_action_114),(93,alex_action_114),(92,alex_action_114),(91,alex_action_114),(90,alex_action_114),(89,alex_action_114),(88,alex_action_114),(87,alex_action_114),(86,alex_action_114),(85,alex_action_114),(84,alex_action_114),(83,alex_action_114),(82,alex_action_114),(81,alex_action_114),(80,alex_action_114),(79,alex_action_114),(78,alex_action_114),(77,alex_action_114),(76,alex_action_114),(75,alex_action_114),(74,alex_action_114),(73,alex_action_114),(72,alex_action_114),(71,alex_action_114),(70,alex_action_114),(69,alex_action_114),(68,alex_action_114),(67,alex_action_114),(66,alex_action_114),(65,alex_action_114),(64,alex_action_114),(63,alex_action_114),(62,alex_action_114),(61,alex_action_114),(60,alex_action_114),(59,alex_action_114),(58,alex_action_114),(57,alex_action_114),(56,alex_action_114),(55,alex_action_114),(54,alex_action_114),(53,alex_action_114),(52,alex_action_114),(51,alex_action_114),(50,alex_action_114),(49,alex_action_114),(48,alex_action_114),(47,alex_action_114),(46,alex_action_114),(45,alex_action_114),(44,alex_action_114),(43,alex_action_114),(42,alex_action_114),(41,alex_action_114),(40,alex_action_114),(39,alex_action_114),(38,alex_action_114),(37,alex_action_114),(36,alex_action_114),(35,alex_action_114),(34,alex_action_114),(33,alex_action_114),(32,alex_action_114),(31,alex_action_114),(30,alex_action_114),(29,alex_action_114),(28,alex_action_114),(27,alex_action_114),(26,alex_action_114),(25,alex_action_114),(24,alex_action_114),(23,alex_action_114),(22,alex_action_114),(21,alex_action_114),(20,alex_action_114),(19,alex_action_114),(18,alex_action_114),(17,alex_action_114),(16,alex_action_114),(15,alex_action_114),(14,alex_action_114),(13,alex_action_114),(12,alex_action_114),(11,alex_action_114),(10,alex_action_114),(9,alex_action_114),(8,alex_action_114),(7,alex_action_114),(6,alex_action_114),(5,alex_action_114),(4,alex_action_114),(3,alex_action_114),(2,alex_action_114),(1,alex_action_114),(0,alex_action_114)]--{-# LINE 242 "src/full/Agda/Syntax/Parser/Lexer.x" #-}----- | This is the initial state for parsing a regular, non-literate file.-normal :: LexState-normal = 0---{-| The layout state. Entered when we see a layout keyword ('withLayout') and-    exited either when seeing an open brace ('openBrace') or at the next token-    ('newLayoutContext').--    Update: we don't use braces for layout anymore.--}-layout :: LexState-layout = layout_---{-| The state inside a pragma.--}-pragma :: LexState-pragma = pragma_--{-| We enter this state from 'newLayoutContext' when the token following a-    layout keyword is to the left of (or at the same column as) the current-    layout context. Example:--    > data Empty : Set where-    > foo : Empty -> Nat--    Here the second line is not part of the @where@ clause since it is has the-    same indentation as the @data@ definition. What we have to do is insert an-    empty layout block @{}@ after the @where@. The only thing that can happen-    in this state is that 'emptyLayout' is executed, generating the closing-    brace. The open brace is generated when entering by 'newLayoutContext'.--}-empty_layout :: LexState-empty_layout = empty_layout_----- | This state is entered at the beginning of each line. You can't lex---   anything in this state, and to exit you have to check the layout rule.---   Done with 'offsideRule'.-bol :: LexState-bol = bol_----- | This state can only be entered by the parser. In this state you can only---   lex the keywords @using@, @hiding@, @renaming@ and @to@. Moreover they are---   only keywords in this particular state. The lexer will never enter this---   state by itself, that has to be done in the parser.-imp_dir :: LexState-imp_dir = imp_dir_----- | Return the next token. This is the function used by Happy in the parser.------   @lexer k = 'lexToken' >>= k@-lexer :: (Token -> Parser a) -> Parser a-lexer k = lexToken >>= k---- | Do not use this function; it sets the 'ParseFlags' to--- 'undefined'.-alexScan :: AlexInput -> Int -> AlexReturn (LexAction Token)---- | This is the main lexing function generated by Alex.-alexScanUser :: ([LexState], ParseFlags) -> AlexInput -> Int -> AlexReturn (LexAction Token)----bol_,code,empty_layout_,imp_dir_,layout_,pragma_ :: Int-bol_ = 1-code = 2-empty_layout_ = 3-imp_dir_ = 4-layout_ = 5-pragma_ = 6-alex_action_2 =  begin pragma -alex_action_3 =  symbol SymOpenPragma -alex_action_4 =  endWith $ symbol SymClosePragma -alex_action_5 =  keyword KwBUILTIN -alex_action_6 =  keyword KwCATCHALL -alex_action_7 =  keyword KwCOMPILED -alex_action_8 =  keyword KwCOMPILED_DATA -alex_action_9 =  keyword KwCOMPILED_DATA_UHC -alex_action_10 =  keyword KwCOMPILED_DECLARE_DATA -alex_action_11 =  keyword KwCOMPILED_EPIC -alex_action_12 =  keyword KwCOMPILED_EXPORT -alex_action_13 =  keyword KwCOMPILED_JS -alex_action_14 =  keyword KwCOMPILED_TYPE -alex_action_15 =  keyword KwCOMPILED_UHC -alex_action_16 =  keyword KwHASKELL -alex_action_17 =  keyword KwDISPLAY -alex_action_18 =  keyword KwIMPORT -alex_action_19 =  keyword KwIMPORT_UHC -alex_action_20 =  keyword KwIMPOSSIBLE -alex_action_21 =  keyword KwINLINE -alex_action_22 =  keyword KwLINE -alex_action_23 =  keyword KwMEASURE -alex_action_24 =  keyword KwNO_POSITIVITY_CHECK -alex_action_25 =  keyword KwNO_TERMINATION_CHECK -alex_action_26 =  keyword KwNON_TERMINATING -alex_action_27 =  keyword KwOPTIONS -alex_action_28 =  keyword KwPOLARITY -alex_action_29 =  keyword KwREWRITE -alex_action_30 =  keyword KwSTATIC -alex_action_31 =  keyword KwTERMINATING -alex_action_32 =  withInterval $ TokString -alex_action_33 =  nestedComment -alex_action_34 =  symbol SymEndComment -alex_action_35 =  symbol SymEndComment -alex_action_36 =  withInterval TokComment -alex_action_38 =  begin bol_ -alex_action_40 =  offsideRule -alex_action_42 =  endWith newLayoutContext -alex_action_43 =  emptyLayout -alex_action_44 =  keyword KwLet -alex_action_45 =  keyword KwIn -alex_action_46 =  keyword KwWhere -alex_action_47 =  keyword KwField -alex_action_48 =  keyword KwWith -alex_action_49 =  keyword KwRewrite -alex_action_50 =  keyword KwPostulate -alex_action_51 =  keyword KwPrimitive -alex_action_52 =  keyword KwOpen -alex_action_53 =  keyword KwImport -alex_action_54 =  keyword KwModule -alex_action_55 =  keyword KwData -alex_action_56 =  keyword KwCoData -alex_action_57 =  keyword KwRecord -alex_action_58 =  keyword KwConstructor -alex_action_59 =  keyword KwInductive -alex_action_60 =  keyword KwCoInductive -alex_action_61 =  keyword KwEta -alex_action_62 =  keyword KwNoEta -alex_action_63 =  keyword KwInfix -alex_action_64 =  keyword KwInfixL -alex_action_65 =  keyword KwInfixR -alex_action_66 =  keyword KwMutual -alex_action_67 =  keyword KwAbstract -alex_action_68 =  keyword KwPrivate -alex_action_69 =  keyword KwInstance -alex_action_70 =  keyword KwOverlap -alex_action_71 =  keyword KwMacro -alex_action_72 =  keyword KwSet -alex_action_73 =  keyword KwForall -alex_action_74 =  withInterval' (read . drop 3) TokSetN -alex_action_75 =  keyword KwQuoteGoal -alex_action_76 =  keyword KwQuoteContext -alex_action_77 =  keyword KwQuote -alex_action_78 =  keyword KwQuoteTerm -alex_action_79 =  keyword KwUnquote -alex_action_80 =  keyword KwUnquoteDecl -alex_action_81 =  keyword KwUnquoteDef  -alex_action_82 =  keyword KwTactic -alex_action_83 =  keyword KwSyntax -alex_action_84 =  keyword KwPatternSyn -alex_action_85 =  keyword KwUsing -alex_action_86 =  keyword KwHiding -alex_action_87 =  keyword KwRenaming -alex_action_88 =  endWith $ keyword KwTo -alex_action_89 =  keyword KwPublic -alex_action_90 =  hole -alex_action_91 =  symbol SymEllipsis -alex_action_92 =  symbol SymDotDot -alex_action_93 =  symbol SymDot -alex_action_94 =  symbol SymSemi -alex_action_95 =  symbol SymColon -alex_action_96 =  symbol SymEqual -alex_action_97 =  symbol SymUnderscore -alex_action_98 =  symbol SymQuestionMark -alex_action_99 =  symbol SymBar -alex_action_100 =  symbol SymOpenIdiomBracket -alex_action_101 =  symbol SymCloseIdiomBracket -alex_action_102 =  symbol SymOpenParen -alex_action_103 =  symbol SymCloseParen -alex_action_104 =  symbol SymArrow -alex_action_105 =  symbol SymLambda -alex_action_106 =  symbol SymAs -alex_action_107 =  symbol SymDoubleOpenBrace -alex_action_108 =  symbol SymOpenBrace -alex_action_109 =  symbol SymCloseBrace -alex_action_110 =  litChar -alex_action_111 =  litString -alex_action_112 =  literal LitNat -alex_action_113 =  literal LitFloat -alex_action_114 =  identifier -{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 9 "<command-line>" #-}-{-# LINE 1 "/usr/local/stow/ghc-8.0.2-rc2/lib/ghc-8.0.1.20161213/include/ghcversion.h" #-}-------------------{-# LINE 9 "<command-line>" #-}-{-# LINE 1 "/tmp/ghc18762_0/ghc_2.h" #-}-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# LINE 9 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine--{-# LINE 21 "templates/GenericTemplate.hs" #-}-------- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ > 706-#define GTE(n,m) (tagToEnum# (n >=# m))-#define EQ(n,m) (tagToEnum# (n ==# m))-#else-#define GTE(n,m) (n >=# m)-#define EQ(n,m) (n ==# m)-#endif-{-# LINE 51 "templates/GenericTemplate.hs" #-}---data AlexAddr = AlexA# Addr#--- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow16Int# i-  where-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))-        off' = off *# 2#-#else-  indexInt16OffAddr# arr off-#endif------{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow32Int# i-  where-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-                     (b2 `uncheckedShiftL#` 16#) `or#`-                     (b1 `uncheckedShiftL#` 8#) `or#` b0)-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))-   off' = off *# 4#-#else-  indexInt32OffAddr# arr off-#endif-------#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif------- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a-  = AlexEOF-  | AlexError  !AlexInput-  | AlexSkip   !AlexInput !Int-  | AlexToken  !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input (I# (sc))-  = alexScanUser undefined input (I# (sc))--alexScanUser user input (I# (sc))-  = case alex_scan_tkn user input 0# input sc AlexNone of-  (AlexNone, input') ->-    case alexGetByte input of-      Nothing ->----                                   AlexEOF-      Just _ ->----                                   AlexError input'--  (AlexLastSkip input'' len, _) ->----    AlexSkip input'' len--  (AlexLastAcc k input''' len, _) ->----    AlexToken input''' len (alex_actions ! k)----- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user orig_input len input s last_acc =-  input `seq` -- strict in the input-  let-  new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))-  in-  new_acc `seq`-  case alexGetByte input of-     Nothing -> (new_acc, input)-     Just (c, new_input) ->----      case fromIntegral c of { (I# (ord_c)) ->-        let-                base   = alexIndexInt32OffAddr alex_base s-                offset = (base +# ord_c)-                check  = alexIndexInt16OffAddr alex_check offset--                new_s = if GTE(offset,0#) && EQ(check,ord_c)-                          then alexIndexInt16OffAddr alex_table offset-                          else alexIndexInt16OffAddr alex_deflt s-        in-        case new_s of-            -1# -> (new_acc, input)-                -- on an error, we want to keep the input *before* the-                -- character that failed, not after.-            _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)-                                                -- note that the length is increased ONLY if this is the 1st byte in a char encoding)-                        new_input new_s new_acc-      }-  where-        check_accs (AlexAccNone) = last_acc-        check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len))-        check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len))--        check_accs (AlexAccPred a predx rest)-           | predx user orig_input (I# (len)) input-           = AlexLastAcc a input (I# (len))-           | otherwise-           = check_accs rest-        check_accs (AlexAccSkipPred predx rest)-           | predx user orig_input (I# (len)) input-           = AlexLastSkip input (I# (len))-           | otherwise-           = check_accs rest---data AlexLastAcc-  = AlexNone-  | AlexLastAcc !Int !AlexInput !Int-  | AlexLastSkip     !AlexInput !Int--data AlexAcc user-  = AlexAccNone-  | AlexAcc Int-  | AlexAccSkip--  | AlexAccPred Int (AlexAccPred user) (AlexAcc user)-  | AlexAccSkipPred (AlexAccPred user) (AlexAcc user)--type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool---- -------------------------------------------------------------------------------- Predicates on a rule--alexAndPred p1 p2 user in1 len in2-  = p1 user in1 len in2 && p2 user in1 len in2----alexPrevCharIsPred :: Char -> AlexAccPred _-alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input--alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input)----alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _-alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input----alexRightContext :: Int -> AlexAccPred _-alexRightContext (I# (sc)) user _ _ input =-     case alex_scan_tkn user input 0# input sc AlexNone of-          (AlexNone, _) -> False-          _ -> True-        -- TODO: there's no need to find the longest-        -- match when checking the right context, just-        -- the first match will do.
− dist/build/Agda/Syntax/Parser/Parser.hs 
@@ -1,7338 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# LANGUAGE TupleSections #-}--{-| The parser is generated by Happy (<http://www.haskell.org/happy>).- -- - Ideally, ranges should be as precise as possible, to get messages that- - emphasize precisely the faulting term(s) upon error.- -- - However, interactive highlighting is only applied at the end of each- - mutual block, keywords are only highlighted once (see- - `TypeChecking.Rules.Decl'). So if the ranges of two declarations- - interleave, one must ensure that keyword ranges are not included in- - the intersection. (Otherwise they are uncolored by the interactive- - highlighting.)- -- -}-module Agda.Syntax.Parser.Parser (-      moduleParser-    , moduleNameParser-    , exprParser-    , exprWhereParser-    , tokensParser-    , splitOnDots  -- only used by the internal test-suite-    ) where--import Control.Monad--import Data.Char-import Data.Functor-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Traversable as T--import Debug.Trace--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.Pretty ()-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Literal--import Agda.TypeChecking.Positivity.Occurrence hiding (tests)--import Agda.Utils.Either hiding (tests)-import Agda.Utils.Hash-import Agda.Utils.List ( spanJust, chopWhen )-import Agda.Utils.Monad-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Agda.Utils.Impossible-#include "undefined.h"-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--newtype HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84 = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn9 :: ([Token]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Token])-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: ([Token]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Token])-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (Token) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Token)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: (([Pragma], [Declaration])) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (([Pragma], [Declaration]))-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyIn13 :: t13 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn13 #-}-happyOut13 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t13-happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut13 #-}-happyIn14 :: t14 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn14 #-}-happyOut14 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t14-happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut14 #-}-happyIn15 :: t15 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn15 #-}-happyOut15 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t15-happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut15 #-}-happyIn16 :: (()) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn16 #-}-happyOut16 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (())-happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut16 #-}-happyIn17 :: (Integer) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn17 #-}-happyOut17 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Integer)-happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut17 #-}-happyIn18 :: (Name) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn18 #-}-happyOut18 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Name)-happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut18 #-}-happyIn19 :: ([Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn19 #-}-happyOut19 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Name])-happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut19 #-}-happyIn20 :: (Range) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn20 #-}-happyOut20 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Range)-happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut20 #-}-happyIn21 :: (Arg Name) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn21 #-}-happyOut21 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Arg Name)-happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut21 #-}-happyIn22 :: ([Arg Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn22 #-}-happyOut22 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg Name])-happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut22 #-}-happyIn23 :: ([Arg Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn23 #-}-happyOut23 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg Name])-happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut23 #-}-happyIn24 :: (QName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn24 #-}-happyOut24 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (QName)-happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut24 #-}-happyIn25 :: (QName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn25 #-}-happyOut25 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (QName)-happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut25 #-}-happyIn26 :: (Name) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn26 #-}-happyOut26 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Name)-happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut26 #-}-happyIn27 :: ([Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn27 #-}-happyOut27 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Name])-happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut27 #-}-happyIn28 :: ([Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn28 #-}-happyOut28 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Name])-happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut28 #-}-happyIn29 :: (Either [Name] [Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn29 #-}-happyOut29 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Either [Name] [Expr])-happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut29 #-}-happyIn30 :: ([WithHiding Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn30 #-}-happyOut30 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([WithHiding Name])-happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut30 #-}-happyIn31 :: ([String]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn31 #-}-happyOut31 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([String])-happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut31 #-}-happyIn32 :: (String) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn32 #-}-happyOut32 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (String)-happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut32 #-}-happyIn33 :: ([(Interval, String)]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn33 #-}-happyOut33 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([(Interval, String)])-happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut33 #-}-happyIn34 :: (Name) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn34 #-}-happyOut34 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Name)-happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut34 #-}-happyIn35 :: (QName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn35 #-}-happyOut35 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (QName)-happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut35 #-}-happyIn36 :: ([QName]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn36 #-}-happyOut36 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([QName])-happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut36 #-}-happyIn37 :: (Expr) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn37 #-}-happyOut37 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Expr)-happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut37 #-}-happyIn38 :: t38 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn38 #-}-happyOut38 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t38-happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut38 #-}-happyIn39 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn39 #-}-happyOut39 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut39 #-}-happyIn40 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn40 #-}-happyOut40 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut40 #-}-happyIn41 :: t41 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn41 #-}-happyOut41 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t41-happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut41 #-}-happyIn42 :: (Expr) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn42 #-}-happyOut42 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Expr)-happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut42 #-}-happyIn43 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn43 #-}-happyOut43 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut43 #-}-happyIn44 :: t44 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn44 #-}-happyOut44 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t44-happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut44 #-}-happyIn45 :: t45 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn45 #-}-happyOut45 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t45-happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut45 #-}-happyIn46 :: t46 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn46 #-}-happyOut46 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t46-happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut46 #-}-happyIn47 :: (RecordAssignments) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn47 #-}-happyOut47 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RecordAssignments)-happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut47 #-}-happyIn48 :: (RecordAssignments) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn48 #-}-happyOut48 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RecordAssignments)-happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut48 #-}-happyIn49 :: (RecordAssignment) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn49 #-}-happyOut49 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RecordAssignment)-happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut49 #-}-happyIn50 :: (ModuleAssignment) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn50 #-}-happyOut50 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ModuleAssignment)-happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut50 #-}-happyIn51 :: ([FieldAssignment]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn51 #-}-happyOut51 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([FieldAssignment])-happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut51 #-}-happyIn52 :: ([FieldAssignment]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn52 #-}-happyOut52 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([FieldAssignment])-happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut52 #-}-happyIn53 :: (FieldAssignment) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn53 #-}-happyOut53 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (FieldAssignment)-happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut53 #-}-happyIn54 :: t54 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn54 #-}-happyOut54 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t54-happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut54 #-}-happyIn55 :: t55 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn55 #-}-happyOut55 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t55-happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut55 #-}-happyIn56 :: ([TypedBindings]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn56 #-}-happyOut56 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([TypedBindings])-happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut56 #-}-happyIn57 :: (TypedBindings) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn57 #-}-happyOut57 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (TypedBindings)-happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut57 #-}-happyIn58 :: (TypedBindings) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn58 #-}-happyOut58 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (TypedBindings)-happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut58 #-}-happyIn59 :: (TypedBindings) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn59 #-}-happyOut59 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (TypedBindings)-happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut59 #-}-happyIn60 :: ([LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn60 #-}-happyOut60 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([LamBinding])-happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut60 #-}-happyIn61 :: (Either ([LamBinding], Hiding) [Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn61 #-}-happyOut61 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Either ([LamBinding], Hiding) [Expr])-happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut61 #-}-happyIn62 :: ([Either Hiding LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn62 #-}-happyOut62 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Either Hiding LamBinding])-happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut62 #-}-happyIn63 :: (Either [Either Hiding LamBinding] [Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn63 #-}-happyOut63 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Either [Either Hiding LamBinding] [Expr])-happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut63 #-}-happyIn64 :: ((LHS,RHS,WhereClause,Bool)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn64 #-}-happyOut64 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((LHS,RHS,WhereClause,Bool))-happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut64 #-}-happyIn65 :: ((LHS,RHS,WhereClause,Bool)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn65 #-}-happyOut65 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((LHS,RHS,WhereClause,Bool))-happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut65 #-}-happyIn66 :: ((LHS,RHS,WhereClause,Bool)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn66 #-}-happyOut66 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((LHS,RHS,WhereClause,Bool))-happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut66 #-}-happyIn67 :: ([(LHS,RHS,WhereClause,Bool)]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn67 #-}-happyOut67 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([(LHS,RHS,WhereClause,Bool)])-happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut67 #-}-happyIn68 :: ([LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn68 #-}-happyOut68 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([LamBinding])-happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut68 #-}-happyIn69 :: ([LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn69 #-}-happyOut69 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([LamBinding])-happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut69 #-}-happyIn70 :: ([LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn70 #-}-happyOut70 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([LamBinding])-happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut70 #-}-happyIn71 :: ([LamBinding]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn71 #-}-happyOut71 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([LamBinding])-happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut71 #-}-happyIn72 :: (Either [LamBinding] [Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn72 #-}-happyOut72 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Either [LamBinding] [Expr])-happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut72 #-}-happyIn73 :: (ImportDirective) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn73 #-}-happyOut73 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ImportDirective)-happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut73 #-}-happyIn74 :: ([ImportDirective]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn74 #-}-happyOut74 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([ImportDirective])-happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut74 #-}-happyIn75 :: (ImportDirective) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn75 #-}-happyOut75 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ImportDirective)-happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut75 #-}-happyIn76 :: ((Using, Range)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn76 #-}-happyOut76 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((Using, Range))-happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut76 #-}-happyIn77 :: (([ImportedName], Range)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn77 #-}-happyOut77 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (([ImportedName], Range))-happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut77 #-}-happyIn78 :: (([Renaming] , Range)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn78 #-}-happyOut78 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (([Renaming] , Range))-happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut78 #-}-happyIn79 :: ([Renaming]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn79 #-}-happyOut79 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Renaming])-happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut79 #-}-happyIn80 :: (Renaming) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn80 #-}-happyOut80 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Renaming)-happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut80 #-}-happyIn81 :: (ImportedName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn81 #-}-happyOut81 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ImportedName)-happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut81 #-}-happyIn82 :: (ImportedName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn82 #-}-happyOut82 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ImportedName)-happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut82 #-}-happyIn83 :: ([ImportedName]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn83 #-}-happyOut83 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([ImportedName])-happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut83 #-}-happyIn84 :: t84 -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn84 #-}-happyOut84 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> t84-happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut84 #-}-happyIn85 :: (LHS) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn85 #-}-happyOut85 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (LHS)-happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut85 #-}-happyIn86 :: ([Pattern]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn86 #-}-happyOut86 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Pattern])-happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut86 #-}-happyIn87 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn87 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn87 #-}-happyOut87 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut87 #-}-happyIn88 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn88 #-}-happyOut88 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut88 #-}-happyIn89 :: (WhereClause) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn89 #-}-happyOut89 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (WhereClause)-happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut89 #-}-happyIn90 :: (ExprWhere) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn90 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn90 #-}-happyOut90 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (ExprWhere)-happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut90 #-}-happyIn91 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn91 #-}-happyOut91 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut91 #-}-happyIn92 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn92 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn92 #-}-happyOut92 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut92 #-}-happyIn93 :: ([Arg Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn93 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn93 #-}-happyOut93 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg Declaration])-happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut93 #-}-happyIn94 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn94 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn94 #-}-happyOut94 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut94 #-}-happyIn95 :: (RHSOrTypeSigs) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn95 #-}-happyOut95 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RHSOrTypeSigs)-happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut95 #-}-happyIn96 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn96 #-}-happyOut96 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut96 #-}-happyIn97 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn97 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn97 #-}-happyOut97 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut97 #-}-happyIn98 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn98 #-}-happyOut98 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut98 #-}-happyIn99 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn99 #-}-happyOut99 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut99 #-}-happyIn100 :: ((Name, IsInstance)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn100 #-}-happyOut100 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((Name, IsInstance))-happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut100 #-}-happyIn101 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn101 #-}-happyOut101 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut101 #-}-happyIn102 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn102 #-}-happyOut102 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut102 #-}-happyIn103 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn103 #-}-happyOut103 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut103 #-}-happyIn104 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn104 #-}-happyOut104 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut104 #-}-happyIn105 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn105 #-}-happyOut105 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut105 #-}-happyIn106 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn106 #-}-happyOut106 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut106 #-}-happyIn107 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn107 #-}-happyOut107 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut107 #-}-happyIn108 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn108 #-}-happyOut108 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut108 #-}-happyIn109 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn109 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn109 #-}-happyOut109 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut109 #-}-happyIn110 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn110 #-}-happyOut110 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut110 #-}-happyIn111 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn111 #-}-happyOut111 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut111 #-}-happyIn112 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn112 #-}-happyOut112 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut112 #-}-happyIn113 :: ([Arg Name]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn113 #-}-happyOut113 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg Name])-happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut113 #-}-happyIn114 :: ([RString]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn114 #-}-happyOut114 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([RString])-happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut114 #-}-happyIn115 :: ([NamedArg HoleName]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn115 #-}-happyOut115 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([NamedArg HoleName])-happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut115 #-}-happyIn116 :: (NamedArg HoleName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn116 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn116 #-}-happyOut116 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (NamedArg HoleName)-happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut116 #-}-happyIn117 :: (HoleName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn117 #-}-happyOut117 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (HoleName)-happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut117 #-}-happyIn118 :: (HoleName) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn118 #-}-happyOut118 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (HoleName)-happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut118 #-}-happyIn119 :: (RString) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn119 #-}-happyOut119 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RString)-happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut119 #-}-happyIn120 :: (Maybe Range) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn120 #-}-happyOut120 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Maybe Range)-happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut120 #-}-happyIn121 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn121 #-}-happyOut121 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut121 #-}-happyIn122 :: ([Expr]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn122 #-}-happyOut122 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Expr])-happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut122 #-}-happyIn123 :: ([TypedBindings] -> Parser ModuleApplication) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn123 #-}-happyOut123 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([TypedBindings] -> Parser ModuleApplication)-happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut123 #-}-happyIn124 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn124 #-}-happyOut124 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut124 #-}-happyIn125 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn125 #-}-happyOut125 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut125 #-}-happyIn126 :: (Name) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn126 #-}-happyOut126 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Name)-happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut126 #-}-happyIn127 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn127 #-}-happyOut127 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut127 #-}-happyIn128 :: (Declaration) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn128 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn128 #-}-happyOut128 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Declaration)-happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut128 #-}-happyIn129 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn129 #-}-happyOut129 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut129 #-}-happyIn130 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn130 #-}-happyOut130 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut130 #-}-happyIn131 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn131 #-}-happyOut131 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut131 #-}-happyIn132 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn132 #-}-happyOut132 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut132 #-}-happyIn133 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn133 #-}-happyOut133 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut133 #-}-happyIn134 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn134 #-}-happyOut134 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut134 #-}-happyIn135 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn135 #-}-happyOut135 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut135 #-}-happyIn136 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn136 #-}-happyOut136 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut136 #-}-happyIn137 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn137 #-}-happyOut137 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut137 #-}-happyIn138 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn138 #-}-happyOut138 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut138 #-}-happyIn139 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn139 #-}-happyOut139 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut139 #-}-happyIn140 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn140 #-}-happyOut140 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut140 #-}-happyIn141 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn141 #-}-happyOut141 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut141 #-}-happyIn142 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn142 #-}-happyOut142 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut142 #-}-happyIn143 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn143 #-}-happyOut143 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut143 #-}-happyIn144 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn144 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn144 #-}-happyOut144 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut144 #-}-happyIn145 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn145 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn145 #-}-happyOut145 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut145 #-}-happyIn146 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn146 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn146 #-}-happyOut146 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut146 #-}-happyIn147 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn147 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn147 #-}-happyOut147 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut147 #-}-happyIn148 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn148 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn148 #-}-happyOut148 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut148 #-}-happyIn149 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn149 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn149 #-}-happyOut149 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut149 #-}-happyIn150 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn150 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn150 #-}-happyOut150 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut150 #-}-happyIn151 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn151 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn151 #-}-happyOut151 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut151 #-}-happyIn152 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn152 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn152 #-}-happyOut152 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut152 #-}-happyIn153 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn153 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn153 #-}-happyOut153 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut153 #-}-happyIn154 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn154 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn154 #-}-happyOut154 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut154 #-}-happyIn155 :: (Pragma) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn155 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn155 #-}-happyOut155 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Pragma)-happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut155 #-}-happyIn156 :: ([(Range, Occurrence)]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn156 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn156 #-}-happyOut156 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([(Range, Occurrence)])-happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut156 #-}-happyIn157 :: ((Range, Occurrence)) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn157 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn157 #-}-happyOut157 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ((Range, Occurrence))-happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut157 #-}-happyIn158 :: ([TypeSignature]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn158 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn158 #-}-happyOut158 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([TypeSignature])-happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut158 #-}-happyIn159 :: ([TypeSignature]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn159 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn159 #-}-happyOut159 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([TypeSignature])-happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut159 #-}-happyIn160 :: ([Arg TypeSignature]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn160 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn160 #-}-happyOut160 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg TypeSignature])-happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut160 #-}-happyIn161 :: ([Arg TypeSignature]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn161 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn161 #-}-happyOut161 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Arg TypeSignature])-happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut161 #-}-happyIn162 :: (((Maybe (Ranged Induction), Maybe Bool, Maybe (Name, IsInstance)), [Declaration])) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn162 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn162 #-}-happyOut162 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (((Maybe (Ranged Induction), Maybe Bool, Maybe (Name, IsInstance)), [Declaration]))-happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut162 #-}-happyIn163 :: ([RecordDirective]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn163 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn163 #-}-happyOut163 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([RecordDirective])-happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut163 #-}-happyIn164 :: (RecordDirective) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn164 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn164 #-}-happyOut164 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (RecordDirective)-happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut164 #-}-happyIn165 :: (Ranged Bool) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn165 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn165 #-}-happyOut165 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Ranged Bool)-happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut165 #-}-happyIn166 :: (Ranged Induction) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn166 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn166 #-}-happyOut166 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Ranged Induction)-happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut166 #-}-happyIn167 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn167 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn167 #-}-happyOut167 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut167 #-}-happyIn168 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn168 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn168 #-}-happyOut168 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut168 #-}-happyIn169 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn169 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn169 #-}-happyOut169 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut169 #-}-happyIn170 :: ([Declaration]) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyIn170 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn170 #-}-happyOut170 :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> ([Declaration])-happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut170 #-}-happyInTok :: (Token) -> (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84)-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn t13 t14 t15 t38 t41 t44 t45 t46 t54 t55 t84) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x00\x00\xd4\x0b\xd4\x0b\xf6\x06\xde\x04\xb6\x0b\x00\x00\x9d\x04\xff\x06\x00\x00\x2c\x07\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x06\x00\x00\x00\x00\xb7\x09\xef\x04\xe8\x06\xd6\x0a\xec\x06\x00\x00\x00\x00\x00\x00\xe5\x06\x00\x00\xb2\x0d\x00\x00\x67\x0d\x00\x00\x00\x00\xf1\x06\x67\x0d\x00\x00\x00\x00\x1b\x03\x9c\x09\x68\x0b\x9a\x07\x4e\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x06\xde\x06\x34\x04\xc6\x00\xea\x06\x51\x01\x68\x0b\xed\x06\x00\x00\x05\x02\xcf\x06\x25\x03\x4e\x0d\x7c\x07\x24\x07\x4e\x09\xcf\x06\xcf\x06\xe7\x06\x00\x00\xda\x06\x1b\x02\xd5\x06\x00\x00\x00\x00\xb2\xff\xb2\xff\x00\x00\xca\x06\xe3\x06\xd9\x06\xb6\x01\xd8\x06\x12\x07\xd1\x06\xc3\x06\xd8\x04\x00\x00\x00\x00\x30\x09\x24\x07\xe2\x08\x22\x0c\x22\x0c\x22\x0c\x00\x00\x20\x01\x4a\x0b\x22\x0c\x22\x0c\x00\x00\x00\x00\xf5\x0a\x22\x0c\xf5\x0a\x00\x00\x6f\x01\xbf\x06\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x06\xb5\x06\xb5\x06\xb9\x06\xab\x06\xab\x06\xab\x06\xac\x06\xac\x06\xc6\xff\xac\x06\xff\xff\x9d\x06\xa8\x06\xa3\x06\xa0\x06\x03\x0d\x93\x06\xe5\x00\x93\x06\xf1\x12\x9c\x06\x00\x00\x00\x00\x49\x08\xf5\x0a\x00\x00\xa2\x06\x00\x00\x66\x0a\xb8\x05\x95\x06\xbd\x05\xf9\x01\x00\x00\xc4\x08\x6c\x08\x51\x08\xd0\x06\xea\x0c\x9b\x06\xea\x0c\x91\x06\xd8\x04\xe2\x06\xe0\x06\x3d\x06\xfd\x09\xf5\x0a\x96\x06\xfd\x09\x00\x00\x22\x0c\x22\x0c\xc6\x00\xf5\x0a\xf5\x0a\x00\x00\x00\x00\xb0\x06\x22\x0c\xea\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x0a\x00\x00\x00\x00\x00\x00\x8a\x06\x00\x00\x22\x0c\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\xf5\x0a\xf5\x0a\x92\x06\xea\x0c\x85\x06\x00\x00\x8d\x06\x00\x00\x00\x00\x7b\x06\x22\x0c\x84\x06\xa7\x06\x61\x01\x7f\x06\x00\x00\x04\x01\xf5\x00\x22\x0c\x7e\x06\x77\x06\x7d\x06\x00\x00\x7c\x06\x00\x00\x22\x0c\x22\x0c\x22\x0c\x00\x00\x22\x0c\x22\x0c\xd7\x0a\x94\x09\x7a\x06\x94\x09\x03\x08\xe8\x07\x89\x0a\x00\x00\x00\x00\x75\x06\x00\x00\x5c\x00\x5e\x06\x61\x06\x61\x06\x61\x06\x61\x06\x61\x06\x61\x06\x61\x06\x61\x06\x61\x06\x5f\x06\x5d\x06\x53\x06\x52\x06\x46\x06\x4e\x06\x3a\x06\x44\x06\x42\x06\x3b\x06\x36\x06\x35\x06\x33\x06\x2f\x06\x30\x06\x2e\x06\x40\x06\x3c\x06\x6e\x0a\xee\x02\xc3\x08\x00\x00\x00\x00\x27\x06\x00\x00\x23\x04\x9f\x0c\x27\x06\x00\x00\xaf\x03\xaf\x03\x00\x00\x00\x00\x00\x00\xd2\x00\x00\x00\xd2\x00\xd2\x00\x00\x00\x75\x01\xaf\x03\xaf\x03\x00\x00\x00\x00\x00\x00\x3d\x06\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x03\x5b\x06\x5a\x06\x00\x00\x00\x00\x00\x00\x22\x0c\x22\x0c\x26\x06\xb2\xff\x2b\x06\x24\x06\xb2\xff\x25\x06\x39\x00\x00\x00\xd8\x04\x00\x00\x00\x00\x6e\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x0a\x00\x00\x00\x00\x86\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x06\x1a\x06\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x03\x6c\x00\xaf\x03\xe7\xff\x00\x00\x8b\x01\x29\x06\x00\x00\x69\x00\x18\x06\x8b\x01\x79\x01\x96\x00\x52\x00\x52\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x43\x06\xdd\xff\xaf\x03\x86\x0c\x24\x00\x06\x07\x00\x00\x1e\x06\x1d\x06\x00\x00\x69\x00\xd9\xff\x22\x0c\xbb\x03\x00\x00\x00\x00\x00\x00\xe7\x05\x68\x00\x68\x00\x00\x00\x00\x00\x6e\x0a\x6e\x0a\x00\x00\x00\x00\x0a\x06\x00\x00\x00\x00\x08\x06\x03\x06\x00\x00\x00\x00\x05\x06\xfa\x05\x00\x00\x00\x00\x00\x00\xfc\x05\xf6\x05\x00\x00\xef\x05\xea\x05\xe2\x05\xdf\x05\xcf\x05\xcf\x05\xcf\x05\xce\x05\xcd\x05\xcd\x05\xc9\x05\xc7\x05\xc5\x05\x00\x00\xc4\x05\xc4\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x05\x01\xf9\x00\x78\x00\xf9\x00\x00\x00\xd2\x05\x20\x0a\x00\x00\x20\x0a\x05\x0a\x00\x00\x00\x00\x00\x00\xd8\x05\xc6\x05\x00\x00\xb3\x05\xd8\x04\x00\x00\x24\x00\x05\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xcc\x05\x00\x00\xc8\x05\xab\x05\x00\x00\xb7\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x05\xb4\x05\xad\x05\xb0\x05\xb0\x05\xaa\x05\xa9\x05\xa5\x05\x00\x00\xa4\x05\xa3\x05\xa0\x05\x00\x00\x9d\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x05\xa7\x05\x64\x00\x9c\x05\x9a\x05\xe1\xff\x00\x00\x8d\x05\x7a\x01\x86\x05\x05\x0a\x00\x00\x76\x05\x05\x0a\x05\x0a\xb2\xff\x00\x00\x00\x00\x7e\x05\x74\x05\xd8\x04\x74\x05\x00\x00\x52\x00\x82\x05\x73\x05\x73\x05\xb2\xff\x00\x00\x73\x05\x73\x05\x00\x00\x73\x05\x73\x05\x7d\x05\x00\x00\x00\x00\x75\x01\x05\x0a\x00\x00\x6e\x05\x05\x0a\x00\x00\x6e\x05\x05\x0a\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x9f\x05\x00\x00\x9b\x05\x00\x00\x00\x00\x00\x00\x05\x0a\x6b\x05\xb2\xff\x5e\x05\xb2\xff\x8b\x01\x8b\x01\x00\x00\x00\x00\x3b\x0c\x24\x00\x00\x00\xd8\x04\x24\x00\x00\x00\x00\x00\x00\x00\x99\x05\x00\x00\x05\x05\x55\x05\x00\x00\x70\x05\x6f\x05\x68\x00\x00\x00\x6a\x05\x68\x05\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x05\x53\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\xf4\xff\x2c\x00\x00\x00\x00\x00\x5d\x05\x52\x05\x00\x00\x49\x05\x49\x05\x4d\x05\x58\x05\x75\x05\x00\x00\x00\x00\x4c\x05\x00\x00\x00\x00\x4a\x05\x00\x00\x48\x05\x48\x05\x44\x05\x43\x05\x43\x05\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x37\x05\x00\x00\x00\x00\x42\x05\x00\x00\x40\x05\x00\x00\x24\x00\x00\x00\x00\x00\xb8\x06\x00\x00\x00\x00\x8b\x01\x8b\x01\x8b\x01\x8b\x01\x00\x00\x3e\x05\x3e\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\xff\x00\x00\x00\x00\xd5\x05\x00\x00\x00\x00\x00\x00\x6d\x05\x41\x05\x3c\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x05\x2c\x05\x7c\x05\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x25\x05\x00\x00\x1d\x05\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x38\x05\xef\x12\x42\x03\x69\x05\x40\x03\xcb\x02\x66\x05\x64\x05\x00\x00\x00\x00\x16\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x0b\x0e\x05\x00\x00\xb6\x02\xc4\x04\x00\x00\x00\x00\x00\x00\x57\x05\x00\x00\xcd\x00\x00\x00\x7f\x03\x00\x00\x00\x00\x11\x05\xe0\x03\x00\x00\x00\x00\xb2\x06\xd2\x12\xb5\x12\xa6\x0f\x98\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x0c\x05\x00\x00\x00\x00\x7b\x12\x00\x00\x00\x00\xf9\x04\x00\x00\x00\x00\xe0\x03\x8f\x06\x29\x0e\x6f\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x05\x4b\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x04\x30\x02\x00\x00\x00\x00\xcf\x0d\x00\x0e\x4c\x0e\x53\x04\x89\x0f\x76\x0f\x00\x00\x00\x00\x5c\x06\x63\x0f\x50\x0f\x00\x00\x00\x00\x5e\x12\x44\x09\x41\x12\x00\x00\xf9\xff\xf5\x03\x4f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x04\x47\x05\x46\x05\xaa\x04\x3d\x05\x32\x05\x06\x05\x96\x04\x8f\x04\x21\x00\x84\x04\x30\x02\x0d\x05\x72\x04\x06\x04\xfa\x03\xb5\x00\x8d\x04\x81\x04\x7a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x24\x12\x00\x00\x00\x00\x00\x00\xbe\x06\x00\x00\x00\x00\x3e\x01\x61\x00\x00\x00\x5c\x06\x90\x05\x03\x00\x40\x04\xba\x02\x00\x00\xb3\x02\x00\x00\x1a\x01\x00\x00\x00\x00\x38\x03\xfe\x06\x07\x12\x00\x00\x3c\x03\x00\x00\x3d\x0f\x2a\x0f\x41\x04\xea\x11\xcd\x11\x00\x00\x00\x00\x3f\x04\x90\x07\xf5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x02\x73\x04\x00\x00\x00\x00\x00\x00\x00\x00\x77\x04\x93\x11\x76\x11\x00\x00\xdf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x01\xd8\x08\x04\x04\x21\x04\x00\x00\x00\x00\x00\x00\x3a\x04\x2d\x04\xeb\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x02\x17\x0f\x04\x0f\x00\x00\xf1\x0e\xde\x0e\xa5\x01\x02\x06\x00\x00\xf9\x03\x5c\x06\x28\x05\xcb\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x04\x2b\x04\x20\x04\x09\x04\x03\x04\xfc\x03\xee\x03\xec\x03\xe5\x03\xe2\x03\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x03\xdb\x03\x00\x00\x00\x00\x00\x00\xda\x03\xc4\x03\x27\x00\xb1\x03\x00\x00\x70\x04\x00\x00\x00\x00\x59\x11\xa4\x03\xbc\x06\x00\x00\x00\x00\x04\x00\x00\x00\xff\x01\x36\x01\x9c\x03\x00\x00\x79\x06\x09\x06\x00\x00\x00\x00\x00\x00\xaf\x02\x00\x00\x88\x02\xd9\x01\x00\x00\xfb\xff\xa1\x05\x39\x05\x00\x00\x00\x00\x00\x00\xae\x02\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x0e\xa5\x0e\x00\x00\x95\x03\x00\x00\x00\x00\x81\x03\x00\x00\x00\x00\x00\x00\xfc\x01\x00\x00\x00\x00\x3c\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x11\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x03\xb9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x4f\x02\x00\x00\x00\x00\x19\x04\x00\x00\x00\x00\x26\x04\xe5\x02\xf2\x03\x6d\x03\x65\x03\x29\x05\x9d\x03\x70\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xac\x00\xae\x08\xa6\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x16\x04\x00\x00\x92\x0e\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x03\x62\x03\x00\x00\x00\x00\x02\x11\xe5\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x02\xbf\x02\x00\x00\x00\x00\x3e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x03\x00\x00\x09\x03\x00\x03\xf3\x02\xcd\x02\xe9\x02\xdd\x02\x00\x00\x00\x00\xcc\x02\x00\x00\xc1\x02\xa4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x03\x00\x00\xce\x02\x00\x00\xbb\x02\x00\x00\x00\x00\x19\x01\x00\x00\x8e\x00\xc8\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x00\x00\x3f\x08\xab\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x02\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x01\x00\x00\x00\x00\xf4\x01\x00\x00\xb7\x00\x00\x00\xc6\x01\x71\x10\x00\x00\x41\x00\x54\x10\x37\x10\x25\x02\x00\x00\x00\x00\x00\x00\xe0\x02\x29\x00\xd6\x02\x00\x00\x2f\x02\x00\x00\x53\x02\x43\x02\xfb\x01\x00\x00\x61\x03\x39\x03\x00\x00\x1a\x03\x12\x03\x00\x00\x00\x00\x00\x00\x41\x02\x1a\x10\x00\x00\x63\x02\xfd\x0f\x00\x00\x1c\x02\xe0\x0f\x00\x00\x00\x00\x00\x00\x9b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x0f\x00\x00\xe2\x01\x00\x00\xd0\x01\xc9\x03\x7d\x03\x00\x00\x00\x00\x43\x00\x66\x07\x00\x00\x26\x00\x32\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x68\x01\x00\x00\x00\x00\x00\x00\x22\x02\x00\x00\x00\x00\x00\x00\x07\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x27\x02\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x5a\x01\x00\x00\x00\x00\x00\x00\x13\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\xef\x00\x00\x00\xbe\x00\xae\x00\x00\x00\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x08\x00\x00\x00\x29\x04\x00\x00\x00\x00\xa6\x0f\x00\x00\x00\x00\x79\x03\xd7\x02\xbc\x02\x4d\x02\x00\x00\x14\x01\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x24\x02\x00\x00\x00\x00\x00\x00\x9a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x35\x00\x9d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\xf7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x6c\xff\x43\xff\xc9\xfe\x57\xff\x55\xff\x54\xff\x51\xff\x00\x00\x2f\xff\x2e\xff\x4e\xff\xa6\xfe\x00\x00\x00\x00\x00\x00\x3f\xff\x3d\xff\x3b\xff\x00\x00\x3c\xff\x00\x00\x3e\xff\x00\x00\x3a\xff\x39\xff\xcd\xfe\x00\x00\x40\xff\x41\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\x6d\xff\x42\xff\x6c\xff\x6b\xff\x00\x00\x00\x00\x78\xfe\xc7\xfe\x58\xff\x00\x00\x00\x00\x00\x00\x20\xff\x1e\xff\x00\x00\x00\x00\x00\x00\x78\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\xff\x00\x00\x65\xff\x00\x00\x44\xff\x34\xff\x00\x00\x00\x00\x82\xff\x00\x00\x00\x00\x00\x00\x64\xff\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x35\xff\x32\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\xff\x00\x00\x78\xfe\x00\x00\x00\x00\x21\xff\x5b\xff\x00\x00\x00\x00\x00\x00\xc3\xfe\x00\x00\x00\x00\x1a\xfe\xc1\xfe\xc0\xfe\xbf\xfe\xbe\xfe\xbd\xfe\xbc\xfe\xc2\xfe\xbb\xfe\xba\xfe\xb9\xfe\xb8\xfe\xb7\xfe\xb6\xfe\xb5\xfe\xae\xfe\xb0\xfe\xaf\xfe\xb4\xfe\xb3\xfe\xb2\xfe\x8d\xff\xb1\xfe\x6a\xfe\x50\xfe\x69\xfe\x68\xfe\x67\xfe\x66\xfe\x64\xfe\x63\xfe\x65\xfe\x62\xfe\x61\xfe\x60\xfe\x5f\xfe\x5e\xfe\x5d\xfe\x5c\xfe\x53\xfe\x56\xfe\x57\xfe\x58\xfe\x55\xfe\x54\xfe\x5b\xfe\x5a\xfe\x59\xfe\x52\xfe\x51\xfe\x18\xfe\x6b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\xff\xee\xfe\x04\xff\x00\x00\x48\xff\x00\x00\x0f\xff\x0c\xff\x05\xff\x00\x00\x00\x00\x00\x00\x69\xff\x78\xfe\x00\x00\x00\x00\xc9\xfe\x00\x00\x4c\xff\x47\xff\x00\x00\x2d\xff\x00\x00\x00\x00\x78\xfe\xf3\xfe\x00\x00\x00\x00\xf4\xfe\xef\xfe\x00\x00\x00\x00\xc7\xfe\x00\x00\x00\x00\x53\xff\x46\xff\xcb\xfe\x00\x00\x00\x00\xf8\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf2\xff\xf1\xff\xf0\xff\xef\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\xe0\xff\xdf\xff\xde\xff\xdd\xff\xdc\xff\xdb\xff\xda\xff\xd9\xff\xd8\xff\xd7\xff\xd6\xff\xd5\xff\xd4\xff\xd3\xff\xd2\xff\xd1\xff\xd0\xff\xcf\xff\xce\xff\xcd\xff\xcc\xff\xcb\xff\xca\xff\xc9\xff\xc8\xff\xc7\xff\xc6\xff\xc5\xff\xc4\xff\xc3\xff\xc2\xff\xc1\xff\xc0\xff\xbf\xff\xbe\xff\xbd\xff\xbc\xff\xbb\xff\xba\xff\xb9\xff\xb8\xff\xb7\xff\xb6\xff\xb5\xff\xb4\xff\xb3\xff\xb2\xff\xb1\xff\xb0\xff\xaf\xff\xae\xff\xad\xff\xac\xff\xab\xff\xaa\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\xa4\xff\xa3\xff\xa2\xff\xa1\xff\xa0\xff\x9f\xff\x9e\xff\x9d\xff\x9c\xff\x9b\xff\x9a\xff\x99\xff\x98\xff\x97\xff\x96\xff\x95\xff\x94\xff\x93\xff\x92\xff\x91\xff\x90\xff\x8f\xff\x33\xff\xc8\xfe\xcf\xfe\x00\x00\xa8\xfe\xa7\xfe\xa9\xfe\x66\xff\x65\xff\x4e\xff\x00\x00\xf6\xfe\xf7\xfe\x50\xff\xf5\xfe\x00\x00\x00\x00\x00\x00\x6c\xff\x74\xfe\x00\x00\x2c\xff\x2b\xff\x28\xff\x29\xff\x26\xff\x00\x00\xcd\xfe\xcb\xfe\xfe\xfe\x00\x00\xf8\xfe\x00\x00\x00\x00\x00\x00\x02\xff\x00\x00\x01\xff\x64\xff\x03\xff\xed\xfe\x00\x00\x00\x00\x00\x00\xec\xfe\x00\x00\x00\x00\x00\x00\x0b\xff\x07\xff\x0c\xff\x78\xfe\x00\x00\x00\x00\x10\xff\x52\xff\x06\xff\x36\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xff\x00\x00\x60\xff\x00\x00\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xfe\x95\xfe\x91\xfe\x00\x00\x92\xfe\x8b\xfe\x74\xfe\x00\x00\x97\xfe\xf0\xfe\xf0\xfe\x6c\xfe\x93\xfe\x94\xfe\x00\x00\x86\xff\x00\x00\x00\x00\x98\xfe\x00\x00\xf0\xfe\xf0\xfe\x96\xfe\x8e\xff\x8c\xff\x78\xfe\x89\xff\x88\xff\x1c\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x59\xff\x56\xff\x5a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\xff\x00\x00\x17\xff\x37\xff\x00\x00\x81\xff\x16\xff\x38\xff\x15\xff\x45\xff\x00\x00\x12\xff\x11\xff\x74\xfe\x13\xff\x1d\xff\x1b\xff\x1c\xff\x1a\xff\x18\xff\x19\xff\x00\x00\x00\x00\x1d\xfe\x8a\xff\x8b\xff\x1b\xfe\xf0\xfe\x00\x00\xf0\xfe\x00\x00\x7e\xff\x7a\xff\x00\x00\x2c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\xff\x9b\xfe\x9a\xfe\x99\xfe\x00\x00\x00\x00\xf0\xfe\x74\xfe\xe3\xfe\x00\x00\x8a\xfe\x00\x00\x00\x00\x2f\xfe\x00\x00\x00\x00\x26\xff\x00\x00\x87\xfe\x85\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x7a\xfe\x90\xfe\x00\x00\x00\x00\x84\xff\x3c\xfe\x00\x00\x5d\xff\x5c\xff\x00\x00\x60\xff\x34\xfe\x5e\xff\x00\x00\x63\xff\x3d\xfe\x36\xfe\x3e\xfe\x00\x00\x00\x00\x37\xfe\x00\x00\x00\x00\x63\xff\x00\x00\x63\xff\x63\xff\x63\xff\x00\x00\x63\xff\x63\xff\x00\x00\x00\x00\x63\xff\x3a\xfe\x00\x00\x00\x00\x09\xff\x08\xff\x0a\xff\x0e\xff\x0d\xff\xfe\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfe\x00\x00\x00\x00\x4a\xff\x00\x00\x00\x00\xce\xfe\xcc\xfe\x4b\xff\x00\x00\x00\x00\x25\xff\x24\xff\x00\x00\x31\xff\xe3\xfe\x00\x00\x4d\xff\x4f\xff\x1e\xfe\xea\xfe\xeb\xfe\xca\xfe\x22\xff\x27\xff\xe5\xfe\xe3\xfe\xe1\xfe\xe0\xfe\xdf\xfe\x00\x00\xe2\xfe\x00\x00\x00\x00\x2a\xff\x00\x00\x30\xff\x00\xff\xfc\xfe\xfb\xfe\xf9\xfe\xfa\xfe\x00\x00\xe8\xfe\xe9\xfe\xe6\xfe\xe7\xfe\x49\xff\x00\x00\x00\x00\x00\x00\x63\xff\x63\xff\x00\x00\x00\x00\x00\x00\x61\xff\x00\x00\x00\x00\x00\x00\x42\xfe\x00\x00\x39\xfe\x38\xfe\x40\xfe\x3b\xfe\x62\xff\x4f\xfe\x00\x00\x5f\xff\x4c\xfe\x41\xfe\x8e\xfe\x8f\xfe\x00\x00\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x00\x00\x86\xfe\x00\x00\x6c\xff\x00\x00\x00\x00\x31\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x76\xfe\x73\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x68\xff\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xff\x00\x00\x00\x00\x80\xff\x00\x00\x00\x00\x00\x00\xaa\xfe\x2e\xfe\x00\x00\x00\x00\x7b\xff\x00\x00\x00\x00\xf2\xfe\x00\x00\x00\x00\xf1\xfe\xc5\xfe\xc4\xfe\xe3\xfe\x77\xfe\x00\x00\xa2\xfe\xa1\xfe\xa3\xfe\xac\xfe\x2d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\xff\x76\xff\x7d\xff\x6d\xfe\x74\xfe\xe3\xfe\x6e\xfe\x00\x00\xe3\xfe\x8c\xfe\xad\xfe\x30\xfe\x9e\xfe\x9f\xfe\x28\xfe\x8d\xfe\x89\xfe\x00\x00\x00\x00\x00\x00\x83\xfe\x00\x00\x00\x00\x00\x00\x84\xfe\x33\xfe\x35\xfe\x32\xfe\x3f\xfe\x44\xfe\x48\xfe\x45\xfe\x4a\xfe\x46\xfe\x49\xfe\x00\x00\x00\x00\x4b\xfe\x4d\xfe\x4e\xfe\xff\xfe\x23\xff\xd3\xfe\x87\xff\xd3\xfe\xe4\xfe\xd5\xfe\xd1\xfe\x00\x00\xd2\xfe\x00\x00\x00\x00\x00\x00\xd9\xfe\x00\x00\x87\xff\xdb\xfe\x00\x00\x47\xfe\x43\xfe\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\xfe\x25\xfe\x00\x00\x26\xfe\x23\xfe\x24\xfe\x00\x00\x1f\xfe\x00\x00\x22\xfe\x20\xfe\x00\x00\x21\xfe\x00\x00\x75\xfe\xe3\xfe\x70\xfe\x71\xfe\x00\x00\x77\xff\x79\xff\x72\xff\x74\xff\x6e\xff\x70\xff\xab\xfe\x00\x00\x00\x00\xa4\xfe\xa5\xfe\x71\xff\x6f\xff\x75\xff\x73\xff\x00\x00\x6f\xfe\xa0\xfe\x78\xfe\x9d\xfe\x29\xfe\x2b\xfe\x78\xfe\x00\x00\x00\x00\x81\xfe\x7c\xfe\x7b\xfe\x82\xfe\xde\xfe\x00\x00\x00\x00\x87\xff\xdc\xfe\xd7\xfe\xd4\xfe\xdd\xfe\x00\x00\xd0\xfe\xda\xfe\xd8\xfe\xd6\xfe\x7e\xfe\x7f\xfe\x27\xfe\x00\x00\x00\x00\x72\xfe\x00\x00\x2a\xfe\x9c\xfe"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x05\x00\x09\x00\x09\x00\x09\x00\x09\x00\x2d\x00\x0c\x00\x14\x00\x0e\x00\x2d\x00\x0f\x00\x09\x00\x09\x00\x0a\x00\x5d\x00\x00\x00\x5f\x00\x0f\x00\x14\x00\x2d\x00\x09\x00\x13\x00\x14\x00\x52\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x50\x00\x09\x00\x65\x00\x66\x00\x09\x00\x51\x00\x09\x00\x0f\x00\x10\x00\x09\x00\x52\x00\x31\x00\x0f\x00\x10\x00\x50\x00\x0f\x00\x10\x00\x37\x00\x38\x00\x05\x00\x3a\x00\x09\x00\x18\x00\x14\x00\x1d\x00\x1b\x00\x49\x00\x0b\x00\x4b\x00\x65\x00\x23\x00\x4c\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x59\x00\x52\x00\x54\x00\x2c\x00\x55\x00\x0f\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x53\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x65\x00\x66\x00\x23\x00\x24\x00\x25\x00\x00\x00\x09\x00\x6f\x00\x70\x00\x0b\x00\x75\x00\x73\x00\x74\x00\x61\x00\x11\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x8d\x00\x65\x00\x59\x00\x98\x00\x53\x00\x0f\x00\x75\x00\x09\x00\x72\x00\x2d\x00\x96\x00\x72\x00\xa0\x00\x0f\x00\x09\x00\x4d\x00\x4e\x00\x99\x00\x46\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x9e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x71\x00\x09\x00\x52\x00\x65\x00\x4f\x00\x09\x00\x09\x00\x0f\x00\x50\x00\x55\x00\x09\x00\x0f\x00\x2b\x00\x2c\x00\x11\x00\x67\x00\x0f\x00\x37\x00\x38\x00\x39\x00\x50\x00\x65\x00\x61\x00\x62\x00\x09\x00\x65\x00\x05\x00\x23\x00\x24\x00\x25\x00\x4c\x00\x23\x00\x24\x00\x25\x00\x09\x00\x5f\x00\x52\x00\x24\x00\x14\x00\x55\x00\x0f\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x30\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x3d\x00\x3e\x00\x3f\x00\x24\x00\x5c\x00\x2d\x00\x5e\x00\x6f\x00\x70\x00\x9e\x00\x9f\x00\x73\x00\x74\x00\x65\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x07\x00\x8d\x00\x6e\x00\x71\x00\x09\x00\x0f\x00\x69\x00\x71\x00\x09\x00\x09\x00\x52\x00\x6e\x00\xa0\x00\xa1\x00\x0f\x00\x0f\x00\x10\x00\x09\x00\x6e\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x51\x00\x65\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\x26\x00\x27\x00\x28\x00\x29\x00\x4f\x00\x0f\x00\x2c\x00\x09\x00\x64\x00\x50\x00\x65\x00\x67\x00\x2a\x00\x2b\x00\x2c\x00\x11\x00\x37\x00\x38\x00\x39\x00\x4f\x00\x5f\x00\x50\x00\x5d\x00\x62\x00\x5f\x00\x23\x00\x24\x00\x25\x00\x4c\x00\x6e\x00\x49\x00\x4a\x00\x4b\x00\x6e\x00\x52\x00\x09\x00\x5f\x00\x55\x00\x62\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x58\x00\x09\x00\x6b\x00\x6c\x00\x5c\x00\x6e\x00\x5e\x00\x6f\x00\x70\x00\x11\x00\x12\x00\x73\x00\x74\x00\x10\x00\x11\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x07\x00\x54\x00\x8d\x00\x71\x00\x57\x00\x0f\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x09\x00\x09\x00\xa0\x00\x50\x00\x9e\x00\x9f\x00\x0f\x00\x0f\x00\x10\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x5f\x00\x52\x00\x4d\x00\x4e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x51\x00\x09\x00\x27\x00\x28\x00\x29\x00\x56\x00\x5c\x00\x2c\x00\x5e\x00\x65\x00\x5c\x00\x6e\x00\x5e\x00\x4d\x00\x4e\x00\x65\x00\x0b\x00\x37\x00\x38\x00\x65\x00\x3a\x00\x05\x00\x06\x00\x09\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x5c\x00\x09\x00\x5e\x00\x11\x00\x12\x00\x52\x00\x0b\x00\x0f\x00\x55\x00\x65\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x23\x00\x24\x00\x25\x00\x09\x00\x0b\x00\x51\x00\x09\x00\x6f\x00\x70\x00\x0f\x00\x10\x00\x73\x00\x74\x00\x59\x00\x11\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x07\x00\x30\x00\x0b\x00\x09\x00\x8d\x00\x0f\x00\x35\x00\x9b\x00\x9c\x00\x9d\x00\x09\x00\x09\x00\xa0\x00\x0c\x00\x0d\x00\x3e\x00\x3f\x00\x0f\x00\x10\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\x52\x00\x09\x00\x0c\x00\x09\x00\x0e\x00\x71\x00\x58\x00\x4d\x00\x4e\x00\x0f\x00\x5c\x00\x09\x00\x5e\x00\x09\x00\x0c\x00\x15\x00\x0e\x00\x09\x00\x58\x00\x65\x00\x99\x00\x11\x00\x5c\x00\x6e\x00\x5e\x00\x1f\x00\x20\x00\x21\x00\x68\x00\x23\x00\x24\x00\x25\x00\x6e\x00\x51\x00\x46\x00\x47\x00\x48\x00\x4c\x00\x49\x00\x4a\x00\x4b\x00\x6d\x00\x6e\x00\x52\x00\x32\x00\x5d\x00\x55\x00\x5f\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x30\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x3d\x00\x3e\x00\x3f\x00\x6d\x00\x6e\x00\x09\x00\x94\x00\x6f\x00\x70\x00\x54\x00\x16\x00\x73\x00\x74\x00\x11\x00\x12\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x09\x00\x16\x00\x9e\x00\x9f\x00\x09\x00\x0f\x00\x1a\x00\x09\x00\x11\x00\x12\x00\x0f\x00\x09\x00\xa0\x00\x09\x00\x0b\x00\x11\x00\x0c\x00\x0f\x00\x0e\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\x22\x00\x23\x00\x24\x00\x25\x00\x0b\x00\x0f\x00\x1a\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\x09\x00\x16\x00\x0c\x00\x17\x00\x0e\x00\x30\x00\x0f\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x3b\x00\x3c\x00\x16\x00\x3e\x00\x3f\x00\x18\x00\x1f\x00\x20\x00\x21\x00\x4c\x00\x23\x00\x24\x00\x25\x00\x09\x00\x16\x00\x52\x00\x9e\x00\x9f\x00\x55\x00\x0f\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x16\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x16\x00\x4c\x00\x23\x00\x24\x00\x25\x00\x09\x00\x0a\x00\x6f\x00\x70\x00\x16\x00\x55\x00\x73\x00\x74\x00\x09\x00\x0a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x09\x00\x09\x00\x0a\x00\x16\x00\x09\x00\x58\x00\x0f\x00\x2d\x00\x09\x00\x5c\x00\x09\x00\x5e\x00\x11\x00\xa0\x00\x0f\x00\x10\x00\x0f\x00\x93\x00\x65\x00\x16\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x4d\x00\x4e\x00\x09\x00\x0a\x00\x30\x00\x52\x00\x09\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x58\x00\x9e\x00\x9f\x00\x09\x00\x5c\x00\x3c\x00\x5e\x00\x3e\x00\x3f\x00\x97\x00\x58\x00\x9e\x00\x9f\x00\x65\x00\x5c\x00\x09\x00\x5e\x00\x4c\x00\x0c\x00\x09\x00\x0e\x00\x09\x00\x0c\x00\x52\x00\x0e\x00\x0b\x00\x55\x00\x0f\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x51\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x0b\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\x09\x00\x6f\x00\x70\x00\x0c\x00\x0d\x00\x73\x00\x74\x00\x05\x00\x06\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x1a\x00\x00\x00\x01\x00\x02\x00\x6d\x00\x6e\x00\x05\x00\x09\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x0e\x00\xa0\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x19\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\x16\x00\x25\x00\x26\x00\x27\x00\x19\x00\x29\x00\x2a\x00\x2b\x00\x6d\x00\x6e\x00\x18\x00\x09\x00\x4d\x00\x4e\x00\x0c\x00\x1a\x00\x0e\x00\x52\x00\x09\x00\x23\x00\x24\x00\x25\x00\x1a\x00\x58\x00\x1a\x00\x09\x00\x11\x00\x5c\x00\x51\x00\x5e\x00\x6a\x00\x6b\x00\x6c\x00\x11\x00\x6e\x00\x58\x00\x65\x00\x49\x00\x1a\x00\x5c\x00\x4c\x00\x5e\x00\x4e\x00\x05\x00\x06\x00\x1a\x00\x52\x00\x53\x00\x65\x00\x55\x00\x09\x00\x1a\x00\x58\x00\x0c\x00\x5a\x00\x0e\x00\x5c\x00\x30\x00\x5e\x00\x05\x00\x06\x00\x61\x00\x35\x00\x63\x00\x30\x00\x65\x00\x66\x00\x06\x00\x68\x00\x01\x00\x02\x00\x3e\x00\x3f\x00\x05\x00\x1a\x00\x07\x00\x08\x00\x3d\x00\x3e\x00\x3f\x00\x06\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1a\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x4d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x9e\x00\x9f\x00\x25\x00\x26\x00\x27\x00\x09\x00\x29\x00\x2a\x00\x2b\x00\x9e\x00\x9f\x00\x0f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x15\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x4e\x00\x4d\x00\x4e\x00\x1f\x00\x20\x00\x21\x00\x52\x00\x23\x00\x24\x00\x25\x00\x09\x00\x0a\x00\x58\x00\x05\x00\x49\x00\x0b\x00\x5c\x00\x4c\x00\x5e\x00\x4e\x00\x09\x00\x0a\x00\x32\x00\x52\x00\x53\x00\x65\x00\x55\x00\x09\x00\x0a\x00\x58\x00\x4e\x00\x5a\x00\x4f\x00\x5c\x00\x50\x00\x5e\x00\x9e\x00\x9f\x00\x61\x00\x09\x00\x63\x00\x9e\x00\x65\x00\x66\x00\x95\x00\x68\x00\x69\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x08\x00\x0a\x00\x9e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x09\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x9e\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x2f\x00\x30\x00\x25\x00\x26\x00\x27\x00\x9e\x00\x29\x00\x2a\x00\x2b\x00\x09\x00\x09\x00\x0b\x00\x9e\x00\x0c\x00\x0d\x00\x0f\x00\x00\x00\x01\x00\x08\x00\x13\x00\x14\x00\x65\x00\x66\x00\x50\x00\x51\x00\x97\x00\x09\x00\x65\x00\x66\x00\x08\x00\x9e\x00\x1f\x00\x20\x00\x21\x00\x11\x00\x23\x00\x24\x00\x25\x00\x49\x00\x09\x00\x09\x00\x4c\x00\x04\x00\x4e\x00\x9e\x00\x06\x00\x0b\x00\x52\x00\x53\x00\x31\x00\x55\x00\x0b\x00\x50\x00\x58\x00\x4d\x00\x5a\x00\x09\x00\x5c\x00\x9e\x00\x5e\x00\x56\x00\x4f\x00\x02\x00\x01\x00\x63\x00\x30\x00\x65\x00\x66\x00\x03\x00\x68\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x3d\x00\x3e\x00\x3f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x61\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x65\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x14\x00\x65\x00\x25\x00\x26\x00\x27\x00\x59\x00\x29\x00\x2a\x00\x2b\x00\x09\x00\x59\x00\x0b\x00\x65\x00\x28\x00\x60\x00\x0f\x00\x60\x00\x5d\x00\x60\x00\x13\x00\x14\x00\x59\x00\x59\x00\x4f\x00\x65\x00\x5f\x00\x09\x00\x59\x00\x4f\x00\x65\x00\x65\x00\x1f\x00\x20\x00\x21\x00\x11\x00\x23\x00\x24\x00\x25\x00\x49\x00\x64\x00\x64\x00\x4c\x00\x65\x00\x4e\x00\x54\x00\x5f\x00\x54\x00\x52\x00\x53\x00\x31\x00\x55\x00\x54\x00\x54\x00\x58\x00\x2d\x00\x5a\x00\x2d\x00\x5c\x00\x5f\x00\x5e\x00\x2d\x00\x50\x00\x60\x00\x51\x00\x63\x00\x30\x00\x65\x00\x66\x00\x60\x00\x68\x00\x01\x00\x02\x00\x65\x00\x04\x00\x05\x00\x65\x00\x07\x00\x08\x00\x3d\x00\x3e\x00\x3f\x00\x5f\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x60\x00\x12\x00\x13\x00\x14\x00\x15\x00\x51\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x65\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x51\x00\x5d\x00\x25\x00\x26\x00\x27\x00\x5f\x00\x29\x00\x2a\x00\x2b\x00\x64\x00\x4f\x00\x58\x00\x64\x00\x4d\x00\x4e\x00\x64\x00\x64\x00\x64\x00\x52\x00\x09\x00\x54\x00\x64\x00\x64\x00\x52\x00\x58\x00\x64\x00\x09\x00\x11\x00\x5c\x00\x58\x00\x5e\x00\x67\x00\x64\x00\x5c\x00\x11\x00\x5e\x00\x65\x00\x65\x00\x49\x00\x64\x00\x58\x00\x4c\x00\x65\x00\x4e\x00\x58\x00\x5f\x00\x54\x00\x52\x00\x53\x00\x51\x00\x55\x00\x67\x00\x67\x00\x58\x00\x67\x00\x5a\x00\x67\x00\x5c\x00\x30\x00\x5e\x00\x67\x00\x67\x00\x67\x00\x35\x00\x63\x00\x30\x00\x65\x00\x66\x00\x55\x00\x68\x00\x01\x00\x02\x00\x3e\x00\x3f\x00\x05\x00\x64\x00\x07\x00\x08\x00\x3d\x00\x3e\x00\x3f\x00\x67\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x64\x00\x12\x00\x13\x00\x14\x00\x15\x00\x64\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x64\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x64\x00\x67\x00\x25\x00\x26\x00\x27\x00\x09\x00\x29\x00\x2a\x00\x2b\x00\x64\x00\x67\x00\x0f\x00\x64\x00\x50\x00\x64\x00\x51\x00\x2d\x00\x15\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x60\x00\x50\x00\x60\x00\x1f\x00\x20\x00\x21\x00\x59\x00\x23\x00\x24\x00\x25\x00\x09\x00\x5f\x00\x59\x00\x5f\x00\x49\x00\x2d\x00\x2d\x00\x4c\x00\x11\x00\x4e\x00\x65\x00\x51\x00\x32\x00\x52\x00\x53\x00\x51\x00\x55\x00\x65\x00\x64\x00\x58\x00\x67\x00\x5a\x00\x09\x00\x5c\x00\x67\x00\x5e\x00\x67\x00\x67\x00\x0f\x00\x64\x00\x63\x00\x67\x00\x65\x00\x66\x00\x15\x00\x68\x00\x64\x00\x30\x00\x64\x00\x30\x00\x64\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x67\x00\x3d\x00\x3e\x00\x3f\x00\x67\x00\x67\x00\x09\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x08\x00\x32\x00\x64\x00\x11\x00\x67\x00\x09\x00\x67\x00\x09\x00\x67\x00\x54\x00\x12\x00\x6f\x00\x70\x00\x11\x00\x54\x00\x11\x00\x54\x00\x54\x00\x54\x00\x54\x00\x1c\x00\x2e\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x57\x00\x4f\x00\x25\x00\x2e\x00\x27\x00\x65\x00\x29\x00\x30\x00\x51\x00\x5f\x00\x33\x00\x34\x00\x35\x00\x36\x00\x5f\x00\x54\x00\x0b\x00\x30\x00\x0b\x00\x30\x00\x5e\x00\x3e\x00\x3f\x00\x57\x00\x35\x00\x24\x00\x60\x00\x54\x00\x5b\x00\x65\x00\x3d\x00\x3e\x00\x3f\x00\x3e\x00\x3f\x00\x6f\x00\x70\x00\x60\x00\x49\x00\x65\x00\x60\x00\x4c\x00\x4d\x00\x4e\x00\x09\x00\x60\x00\x09\x00\x52\x00\x53\x00\x60\x00\x55\x00\x08\x00\x11\x00\x58\x00\x11\x00\x5a\x00\x68\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x12\x00\x60\x00\x65\x00\x60\x00\x0a\x00\x65\x00\x66\x00\x60\x00\x68\x00\x61\x00\x1c\x00\x60\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x5f\x00\x59\x00\x25\x00\x08\x00\x27\x00\x30\x00\x29\x00\x30\x00\x59\x00\x59\x00\x50\x00\x5f\x00\x35\x00\x12\x00\x50\x00\x69\x00\x5f\x00\x3c\x00\x51\x00\x3e\x00\x3f\x00\x3e\x00\x3f\x00\x1c\x00\x54\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x69\x00\x57\x00\x25\x00\x65\x00\x27\x00\x60\x00\x29\x00\x57\x00\x49\x00\x24\x00\x69\x00\x4c\x00\x4d\x00\x4e\x00\x56\x00\x60\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x12\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x08\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x65\x00\x66\x00\xff\xff\x68\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x08\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\x12\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\x49\x00\x52\x00\xff\xff\x54\x00\xff\xff\x4e\x00\xff\xff\x58\x00\xff\xff\x52\x00\x53\x00\x5c\x00\x55\x00\x5e\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x65\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\x63\x00\x49\x00\x65\x00\x66\x00\xff\xff\x68\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x12\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\x52\x00\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\x58\x00\x58\x00\x59\x00\x5a\x00\x5c\x00\x5c\x00\x5e\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x08\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\x49\x00\x52\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\x58\x00\xff\xff\x52\x00\x53\x00\x5c\x00\x55\x00\x5e\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\x65\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x65\x00\x66\x00\xff\xff\x68\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\x08\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x08\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\x49\x00\x52\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\x58\x00\xff\xff\x52\x00\x53\x00\x5c\x00\x55\x00\x5e\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x65\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x65\x00\x66\x00\xff\xff\x68\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x12\x00\xff\xff\xff\xff\x63\x00\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x08\x00\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\x49\x00\x52\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\x58\x00\xff\xff\x52\x00\x53\x00\x5c\x00\x55\x00\x5e\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x65\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x65\x00\x66\x00\xff\xff\x68\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\x52\x00\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\x58\x00\x58\x00\xff\xff\x5a\x00\x5c\x00\x5c\x00\x5e\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x65\x00\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x08\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x12\x00\x68\x00\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x09\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0f\x00\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x08\x00\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x49\x00\x68\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x08\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\x27\x00\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x65\x00\x66\x00\x4e\x00\x68\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x1c\x00\x68\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x65\x00\x66\x00\x4e\x00\x68\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x1c\x00\x68\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x65\x00\x66\x00\x4e\x00\x68\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x1c\x00\x68\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x65\x00\x66\x00\x4e\x00\x68\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x1c\x00\x68\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x09\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x4e\x00\x32\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\xff\xff\xff\xff\x09\x00\x58\x00\x0b\x00\x5a\x00\xff\xff\x5c\x00\x0f\x00\x5e\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0f\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\xe1\x01\xbc\x01\xf1\x02\xe9\x01\x08\x00\x90\x02\xea\x01\xfb\x02\xeb\x01\x9a\x02\x09\x00\x08\x00\x98\x01\x00\x02\x4b\x00\xe3\x01\x4c\x00\x09\x00\xa5\x01\xaf\x02\x49\x03\x41\x00\x4b\x01\xa9\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x61\x01\x0d\x00\x0e\x00\x62\x01\x10\x00\x11\x00\x12\x00\x91\x02\x2d\x00\x2b\x00\x2c\x00\x5b\x02\x9b\x02\x2d\x00\x2e\x00\xa6\x01\x2d\x00\xd6\x02\x45\x00\x2e\x00\xc7\x02\xb0\x02\x2e\x00\xc7\x02\x63\x01\x64\x01\x4a\x03\x65\x01\x41\x03\x14\x02\xf6\x02\x5c\x02\x15\x02\xf2\x02\x55\x01\x3f\x03\x0d\x02\x5d\x02\x13\x00\x42\x03\x98\x01\x00\x02\x08\x00\xfc\x02\x69\x00\xec\x01\x5e\x02\x6a\x00\x09\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x01\x02\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2b\x00\x2c\x00\x10\x00\x11\x00\xfb\x01\xe3\x01\xb3\x00\x50\x00\x7b\x00\x48\x03\xbd\x01\x7c\x00\x7d\x00\xe4\x01\x6c\x01\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\x66\x01\x2b\x00\xd9\x01\xed\x01\xce\x02\x09\x00\xa7\x01\x08\x00\x15\x03\xb2\x02\x02\x02\xc8\x02\x53\x01\x09\x00\x45\x02\xa0\x02\xa1\x02\x2a\x03\x30\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xaa\x01\x36\x02\x0d\x00\x0e\x00\x62\x01\x10\x00\x11\x00\x12\x00\x17\x03\x08\x00\xda\x02\x2b\x00\xb8\x01\x08\x00\xb3\x00\x09\x00\xb3\x02\x89\x02\x08\x00\x09\x00\xec\x02\x48\x02\xb4\x00\x31\x02\x09\x00\x62\x02\x63\x02\x64\x02\xd5\x01\x0d\x02\xe4\x01\xb9\x01\x2c\x03\x0d\x02\x2d\x03\x10\x00\x11\x00\xfb\x01\x13\x00\x10\x00\x11\x00\xfb\x01\x08\x00\x69\x02\x69\x00\x9d\x01\x68\x00\x6a\x00\x09\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xe5\x01\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x98\x02\xe7\x01\xd0\x00\xc7\x00\xa4\x02\x69\x00\xa5\x02\x50\x00\x7b\x00\xb9\x01\x22\x03\x7c\x00\x7d\x00\x2b\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\x37\x03\x66\x01\x30\x03\x97\x02\xf1\x02\x09\x00\xd2\x02\xb6\x02\x08\x00\x56\x01\xc0\x00\xd3\x02\x9b\x00\x9c\x00\x09\x00\x2e\x00\x57\x01\x45\x02\x31\x03\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x9c\x01\x2b\x00\x36\x02\x0d\x00\x0e\x00\x62\x01\x10\x00\x11\x00\x12\x00\x08\x00\x58\x01\x59\x01\x5a\x01\x5b\x01\xb8\x01\x09\x00\x5c\x01\xb3\x00\xde\x02\xd5\x01\x2b\x00\xdf\x02\x46\x02\x47\x02\x48\x02\x70\x01\x62\x02\x63\x02\x65\x02\xb8\x01\x40\x02\xd5\x01\x4b\x00\xb9\x01\x4c\x00\x10\x00\x11\x00\xfb\x01\x13\x00\x33\x03\xf2\x02\xf3\x02\xf4\x02\x34\x03\x69\x00\x3b\x03\x6b\x02\x6a\x00\xb9\x01\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x07\x03\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x6e\x01\xb3\x00\x8c\x02\x07\x02\xc2\x01\x08\x02\xc3\x01\x50\x00\x7b\x00\xf4\x01\x9c\x02\x7c\x00\x7d\x00\xef\x01\xf0\x01\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\xf6\x02\x64\x00\x66\x01\xfc\x01\x65\x00\x09\x00\x08\x03\x09\x03\x0a\x03\x0b\x03\x08\x00\x56\x01\x0c\x03\x65\xff\xb9\x01\x23\x03\x09\x00\x2e\x00\x57\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x65\xff\xa9\x01\xf1\x01\xf2\x01\x36\x02\x0d\x00\x0e\x00\x62\x01\x10\x00\x11\x00\x12\x00\x4d\x02\x3c\x03\x5e\x02\x5a\x01\x5b\x01\xdb\x00\xf3\x01\x5c\x01\xf4\x01\x2b\x00\xa7\x02\x06\x03\xa8\x02\xf1\x01\xf2\x01\x2b\x00\x1b\x03\x63\x01\x64\x01\x2b\x00\x37\x02\x2e\x03\x2f\x03\xb3\x00\x40\x03\xf8\x02\xf9\x02\x13\x00\xf3\x01\x08\x00\xf4\x01\xf4\x01\xf5\x01\x69\x00\x1d\x03\x09\x00\x6a\x00\x2b\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x07\x03\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x10\x00\x11\x00\xfb\x01\x2d\x00\xc3\x02\x55\xff\xb3\x00\x50\x00\x7b\x00\x2e\x00\xd7\x01\x7c\x00\x7d\x00\x55\xff\xb4\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\xf6\x02\x74\x01\xcb\x02\xf1\x02\x66\x01\x09\x00\xfe\x01\x45\x03\x0a\x03\x0b\x03\xe9\x01\x2d\x00\x46\x03\x9d\x02\xc5\x02\x76\x01\xd0\x00\x2e\x00\xa3\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xe9\x01\xc0\x00\xa2\x02\xea\x01\x08\x00\xeb\x01\x4b\x02\x6e\x01\x3b\x00\x5e\x00\x09\x00\x6f\x01\xe9\x01\x70\x01\xb3\x00\xea\x01\x4c\x00\x24\x03\xa5\x02\x5f\x00\x2b\x00\xd0\x02\xb4\x00\x60\x00\xd4\x02\x61\x00\x6a\x01\x0d\x00\x0e\x00\xff\x01\x10\x00\x11\x00\x4d\x01\xd8\x02\x55\xff\xf7\x02\xf8\x02\xf9\x02\x13\x00\xf2\x02\xfc\x02\xf4\x02\xff\x02\x00\x03\x69\x00\xc8\x01\x55\xff\x6a\x00\x55\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xe5\x01\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xb0\x02\xe7\x01\xd0\x00\x03\x03\x00\x03\xb3\x00\xdc\x02\x50\x00\x7b\x00\xbd\x02\xe6\x02\x7c\x00\x7d\x00\xf4\x01\xf6\x01\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\xb3\x00\xe7\x02\xb9\x01\xb9\x02\x08\x00\x09\x00\x6c\x02\xb3\x00\xf4\x01\xf7\x01\x09\x00\x08\x00\x53\x01\xe9\x01\x67\x02\xb4\x00\xea\x01\x09\x00\x25\x03\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x08\x00\xd7\x00\x10\x00\x11\x00\xc6\x00\x69\x02\x09\x00\x6d\x02\x5f\x01\x10\x00\x11\x00\xc6\x00\xe9\x01\x08\x00\x6e\x02\xea\x01\x73\x02\x26\x03\xcc\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xcd\x00\xce\x00\x71\x02\xcf\x00\xd0\x00\x81\x02\xd6\x00\x0d\x00\x0e\x00\x13\x00\x10\x00\x11\x00\x4d\x01\x08\x00\x72\x02\x69\x00\xb9\x01\xbb\x02\x6a\x00\x09\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x02\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x76\x02\x13\x00\x10\x00\x11\x00\x44\x01\x98\x01\xbf\x02\x50\x00\x7b\x00\x77\x02\x14\x00\x7c\x00\x7d\x00\x98\x01\xc0\x02\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x08\x00\x98\x01\xc1\x02\x79\x02\xb3\x00\x0a\x02\x09\x00\xbd\x00\x2d\x00\x0b\x02\x08\x00\x0c\x02\xb4\x00\xe4\x01\x2e\x00\x2f\x00\x09\x00\x80\x02\x0d\x02\x7e\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x32\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\xbe\x00\xbf\x00\x98\x01\xc2\x02\xcc\x00\xc0\x00\xa2\x02\x35\x00\x36\x00\x37\x00\x38\x00\xc1\x00\xb9\x01\xc6\x02\xa5\x02\xc2\x00\x4f\x01\xc3\x00\xcf\x00\xd0\x00\xa9\x02\x5a\x00\xb9\x01\xc9\x02\x2b\x00\x5b\x00\xe9\x01\x5c\x00\x13\x00\xea\x01\xe9\x01\x27\x03\x08\x00\xea\x01\x69\x00\x19\x03\xda\x01\x6a\x00\x09\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x39\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xdd\x01\xc5\x00\x10\x00\x11\x00\xc6\x00\xfa\x01\xe9\x01\x50\x00\x7b\x00\x9d\x02\x9e\x02\x7c\x00\x7d\x00\x6b\x02\x3e\x02\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x12\x02\xe3\x01\x9e\x00\x9f\x00\x86\x02\x87\x02\xa0\x00\xe9\x01\xa1\x00\x16\x00\xea\x01\x78\xfe\x1a\x03\x53\x01\xa2\x00\xa3\x00\xa4\x00\xa5\x00\x17\x02\x17\x00\xa6\x00\xa7\x00\xa8\x00\x1f\x02\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\x09\x00\x19\x02\x1e\x00\xaf\x00\x1f\x00\x1e\x02\x20\x00\xb0\x00\xb1\x00\x89\x02\x8a\x02\x24\x02\xe9\x01\xbe\x00\xbf\x00\xea\x01\x25\x02\xa8\x02\xc0\x00\xb3\x00\x10\x00\x11\x00\x55\x00\x26\x02\x5f\x00\x27\x02\xb3\x00\xb4\x00\xd2\x00\x8e\x02\xd3\x00\x05\x02\x06\x02\x07\x02\xb4\x00\x08\x02\x0a\x02\x2b\x00\x21\x00\x28\x02\x0b\x02\x22\x00\x0c\x02\x23\x00\x91\x02\x92\x02\x29\x02\x24\x00\x25\x00\x0d\x02\x26\x00\xe9\x01\x2a\x02\x27\x00\xea\x01\x28\x00\xad\x02\x29\x00\x74\x01\x2a\x00\xaa\x02\xab\x02\xe4\x01\x34\x02\xb2\x00\xe5\x01\x2b\x00\x2c\x00\x3e\x02\x2d\x00\x9e\x00\x9f\x00\x76\x01\xd0\x00\xa0\x00\x2b\x02\xa1\x00\x16\x00\xb3\x02\xe7\x01\xd0\x00\x40\x02\xa2\x00\xa3\x00\xa4\x00\xa5\x00\x2c\x02\x17\x00\xa6\x00\xa7\x00\xa8\x00\x2d\x02\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\x43\x02\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\xb9\x01\xb4\x02\x1e\x00\xaf\x00\x1f\x00\x08\x00\x20\x00\xb0\x00\xb1\x00\xb9\x01\xb5\x02\x09\x00\xf0\x02\x56\x02\x57\x02\x58\x02\x59\x02\x4c\x00\x29\x03\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\x42\x02\xbe\x00\xbf\x00\x6a\x01\x0d\x00\x0e\x00\xc0\x00\x10\x00\x11\x00\x4d\x01\x98\x01\x10\x02\x78\x01\x4f\x02\x21\x00\x50\x02\x79\x01\x22\x00\x7a\x01\x23\x00\x98\x01\x99\x01\xc5\x01\x24\x00\x25\x00\x2b\x00\x26\x00\x98\x01\x9a\x01\x27\x00\x46\x01\x28\x00\x60\x01\x29\x00\x4a\x01\x2a\x00\xb9\x01\xba\x01\x19\xfe\x9c\x01\xb2\x00\x9e\x01\x2b\x00\x2c\x00\x9f\x01\x2d\x00\x19\xfe\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x01\x01\x01\x02\x01\x03\x01\x04\x01\x05\x01\x06\x01\x07\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x14\x01\x15\x01\x16\x01\x17\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\x30\x01\x31\x01\x32\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\x3d\x01\x3e\x01\x3f\x01\x40\x01\x41\x01\x42\x01\x43\x01\x44\x01\x9e\x00\x9f\x00\x0e\x03\x0f\x03\xa0\x00\x10\x03\xa1\x00\x16\x00\xab\x01\x78\xfe\xa1\x01\x11\x03\xa2\x00\xa3\x00\xa4\x00\x12\x03\xa2\x01\x17\x00\xa6\x00\xa7\x00\xa8\x00\x13\x03\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\xa5\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\x5c\x00\x38\x00\x1e\x00\xaf\x00\x1f\x00\xa9\x01\x20\x00\xb0\x00\xb1\x00\x08\x00\xe9\x01\x32\x02\xaa\x01\x9d\x02\xa1\x02\x09\x00\x40\x00\x07\x00\xad\x01\x4e\x01\x42\x00\x2b\x00\x2c\x00\xd5\x00\xd6\x00\xaf\x01\xb3\x00\x2b\x00\x2c\x00\xae\x01\xb3\x01\x4c\x01\x0d\x00\x0e\x00\xb4\x00\x10\x00\x11\x00\x4d\x01\x21\x00\xb1\x01\xb2\x01\x22\x00\xb4\x01\x23\x00\xc9\x01\xb6\x01\xd0\x01\x24\x00\x25\x00\x49\x00\x26\x00\xd1\x01\x66\x00\x27\x00\xc3\x00\x28\x00\xc9\x00\x29\x00\xca\x00\x2a\x00\xd3\x00\xd8\x00\xdb\x00\x07\x00\xb2\x00\xe5\x01\x2b\x00\x2c\x00\x30\x00\x2d\x00\x9e\x00\x9f\x00\x0e\x03\x0f\x03\xa0\x00\x10\x03\xa1\x00\x16\x00\xe6\x01\xe7\x01\xd0\x00\x11\x03\xa2\x00\xa3\x00\xa4\x00\x12\x03\x4c\x03\x17\x00\xa6\x00\xa7\x00\xa8\x00\x13\x03\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\x2b\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\xfb\x02\x2b\x00\x1e\x00\xaf\x00\x1f\x00\x44\x03\x20\x00\xb0\x00\xb1\x00\x08\x00\x45\x03\x69\x01\x2b\x00\x39\x03\xbc\x01\x09\x00\xd2\x02\x33\x03\x2c\x03\x4e\x01\x42\x00\x37\x03\x3b\x03\x3a\x03\x0d\x02\x36\x03\xb3\x00\x3e\x03\x3f\x03\x0d\x02\x2b\x00\x4c\x01\x0d\x00\x0e\x00\xb4\x00\x10\x00\x11\x00\x4d\x01\x21\x00\xfe\x02\xff\x02\x22\x00\x0d\x02\x23\x00\x02\x03\x1d\x03\x03\x03\x24\x00\x25\x00\x49\x00\x26\x00\x05\x03\x06\x03\x27\x00\x14\x03\x28\x00\x21\x03\x29\x00\x1f\x03\x2a\x00\x22\x03\xbf\x02\xbc\x01\xcb\x02\xb2\x00\xe5\x01\x2b\x00\x2c\x00\xbc\x01\x2d\x00\x9e\x00\x9f\x00\x2b\x00\x48\x03\xa0\x00\x2b\x00\xa1\x00\x16\x00\xe8\x01\xe7\x01\xd0\x00\xc5\x02\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xd2\x02\x17\x00\xa6\x00\xa7\x00\xa8\x00\xd7\x02\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\x0d\x02\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\xdb\x02\xd8\x02\x1e\x00\xaf\x00\x1f\x00\xdc\x02\x20\x00\xb0\x00\xb1\x00\xe0\x02\x60\x02\xee\x02\xe1\x02\xef\xfe\xef\xfe\xe2\x02\xe3\x02\xe4\x02\xef\xfe\xb3\x00\xef\xfe\xe5\x02\xe6\x02\xc0\x00\xef\xfe\xe9\x02\xb3\x00\xb4\x00\xef\xfe\x5a\x00\xef\xfe\x1b\x02\xea\x02\x72\x01\xb4\x00\x73\x01\x2b\x00\xef\xfe\x21\x00\xeb\x02\xef\x02\x22\x00\x2b\x00\x23\x00\xf0\x02\x61\x02\x67\x02\x24\x00\x25\x00\x4d\x02\x26\x00\x14\x02\x1b\x02\x27\x00\x70\x02\x28\x00\x71\x02\x29\x00\x74\x01\x2a\x00\x1b\x02\x75\x02\x1b\x02\x35\x02\xb2\x00\xe5\x01\x2b\x00\x2c\x00\x8c\x02\x2d\x00\x9e\x00\x9f\x00\x76\x01\xd0\x00\xa0\x00\x79\x02\xa1\x00\x16\x00\xf8\x01\xe7\x01\xd0\x00\x1b\x02\xa2\x00\xa3\x00\xa4\x00\xa5\x00\x7b\x02\x17\x00\xa6\x00\xa7\x00\xa8\x00\x7c\x02\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x18\x00\x7d\x02\x19\x00\x1a\x00\x1b\x00\x1c\x00\xae\x00\x7e\x02\x1b\x02\x1e\x00\xaf\x00\x1f\x00\x08\x00\x20\x00\xb0\x00\xb1\x00\x80\x02\x17\x02\x09\x00\x83\x02\x94\x02\x84\x02\x95\x02\x9c\x02\x4c\x00\x14\x03\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\xb1\x01\xad\x02\xbc\x01\x6a\x01\x0d\x00\x0e\x00\xda\x01\x10\x00\x11\x00\x4d\x01\xb3\x00\xdc\x01\xdd\x01\xdf\x01\x21\x00\xe0\x01\xe1\x01\x22\x00\xb4\x00\x23\x00\x2b\x00\x0f\x02\x4f\x00\x24\x00\x25\x00\x10\x02\x26\x00\x2b\x00\x12\x02\x27\x00\x14\x02\x28\x00\x08\x00\x29\x00\x17\x02\x2a\x00\x19\x02\x1b\x02\x09\x00\x1c\x02\xb2\x00\x19\x02\x2b\x00\x2c\x00\x4c\x00\x2d\x00\x1d\x02\x80\x01\x1e\x02\xe5\x01\x21\x02\x4d\x00\x33\x00\x0b\x00\x4e\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x14\x02\xf9\x01\xe7\x01\xd0\x00\x22\x02\x23\x02\xb3\x00\x35\x00\x36\x00\x37\x00\x38\x00\x16\x00\x4f\x00\x2f\x02\xb4\x00\x24\x02\xb3\x00\x17\x02\xb3\x00\x14\x02\x0d\xff\x17\x00\x50\x00\x51\x00\xb4\x00\x0e\xff\xb4\x00\x0a\xff\x08\xff\x09\xff\x42\x02\x18\x00\x48\x01\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xc5\x00\x4a\x02\x1e\x00\x48\x01\x1f\x00\x2b\x00\x20\x00\xb5\x00\x4d\x02\x4b\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x52\x02\x51\x01\x55\x01\xe5\x01\x56\x01\x74\x01\x5e\x01\xba\x00\xbb\x00\x5f\x01\x75\x01\xda\x00\x74\x01\x7b\x01\x7e\x01\x2b\x00\x03\x02\xe7\x01\xd0\x00\x76\x01\xd0\x00\x50\x00\x51\x00\xcc\x00\x21\x00\x2b\x00\xa1\x01\x29\x03\x3b\x00\x3c\x00\xb3\x00\xcc\x00\xb3\x00\x24\x00\x25\x00\xcc\x00\x26\x00\x16\x00\xb4\x00\x3d\x00\xb4\x00\x28\x00\xad\x01\x3e\x00\x4b\x00\x3f\x00\x4c\x00\x17\x00\xb1\x01\x2b\x00\xcc\x00\xcc\x01\x2b\x00\x2c\x00\xbc\x01\x2d\x00\xb6\x01\x18\x00\xcc\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xd0\x01\xcb\x01\x1e\x00\x16\x00\x1f\x00\xcc\x00\x20\x00\x74\x01\xcd\x01\xce\x01\xcf\x01\xd3\x01\x7c\x01\x17\x00\xd5\x01\xff\xff\xd4\x01\x52\x01\x66\x00\xcf\x00\xd0\x00\x76\x01\xd0\x00\x18\x00\x62\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xff\xff\xc5\x00\x1e\x00\x2b\x00\x1f\x00\xcc\x00\x20\x00\x65\x00\x21\x00\xda\x00\xff\xff\x96\x02\x3b\x00\x3c\x00\xdb\x00\x32\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x4b\x00\x3f\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x4b\x00\x3f\x00\x4c\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x09\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x16\x03\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\x17\x00\x45\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x3d\x00\x55\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\xb7\x02\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x4b\x00\x3f\x00\x4c\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x4b\x00\x2a\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x27\x00\x34\x02\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x17\x00\x54\x02\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\xbe\x00\xbf\x00\x00\x00\x00\x00\x21\x00\xc0\x00\x00\x00\x0b\xff\x00\x00\x23\x00\x00\x00\x78\x01\x00\x00\x24\x00\x25\x00\x79\x01\x26\x00\x7a\x01\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x2b\x00\x2a\x00\x68\x01\x00\x00\x00\x00\x00\x00\x69\x01\x21\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x4b\x00\x2a\x00\x4c\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x09\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x96\x02\x55\x02\x56\x02\x57\x02\x58\x02\x59\x02\x17\x00\x00\x00\x44\x02\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\xbe\x00\xbf\x00\x23\x00\x00\x00\x00\x00\xc0\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x5f\x00\x27\x00\x6c\x01\x28\x00\xd2\x00\x29\x00\x05\x02\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\x47\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x09\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\xbf\x01\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x3d\x00\x55\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\x47\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\xbe\x00\xbf\x00\x00\x00\x00\x00\x21\x00\xc0\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x78\x01\x00\x00\x24\x00\x25\x00\x79\x01\x26\x00\x7a\x01\x00\x00\x3d\x00\x55\x00\x28\x00\x00\x00\x3e\x00\x2b\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x47\xff\x26\x00\x16\x00\x47\xff\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\xbe\x00\xbf\x00\x00\x00\x00\x00\x21\x00\xc0\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x5f\x00\x00\x00\x24\x00\x25\x00\xd2\x00\x26\x00\xd3\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x2b\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x17\x00\x00\x00\x00\x00\x69\x01\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x16\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\xbe\x00\xbf\x00\x00\x00\x00\x00\x21\x00\xc0\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x78\x01\x00\x00\x24\x00\x25\x00\x79\x01\x26\x00\x7a\x01\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x2b\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x32\x02\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x09\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x3c\x02\x0d\x00\x0e\x00\x3d\x02\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\xbe\x00\xbf\x00\x23\x00\x00\x00\x00\x00\xc0\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x5f\x00\x27\x00\x00\x00\x28\x00\xd2\x00\x29\x00\xd3\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x01\x2b\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x16\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x53\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x09\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\xd6\x00\x0d\x00\x0e\x00\xd7\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x16\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x21\x00\x00\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x21\x00\x2d\x00\x00\x00\x00\x00\x3b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x16\x00\x00\x00\x3d\x00\x00\x00\x28\x00\x00\x00\x3e\x00\x00\x00\x3f\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1f\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x23\x00\x2d\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x19\x03\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x18\x00\x2d\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x23\x00\x2d\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\xfe\x01\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x18\x00\x2d\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x23\x00\x2d\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x18\x00\x2d\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x28\x00\x00\x00\x58\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x23\x00\x2d\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x28\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x18\x00\x2d\x00\x19\x00\x1a\x00\x00\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x1e\x00\x08\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x33\x00\x0b\x00\x4e\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x35\x00\x36\x00\x37\x00\x38\x00\x23\x00\xc8\x01\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x08\x00\x27\x00\x47\x00\x28\x00\x00\x00\x29\x00\x09\x00\xc9\x00\x00\x00\x00\x00\x41\x00\x42\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x48\x00\x33\x00\x0b\x00\x44\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x36\x00\x37\x00\x38\x00\xc7\x01\x08\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x33\x00\x0b\x00\x44\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x35\x00\x36\x00\x37\x00\x38\x00\x49\x00\x09\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x33\x00\x0b\x00\x44\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x35\x00\x36\x00\x37\x00\x38\x00\xc6\x01\x09\x00\x00\x00\x00\x00\x00\x00\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x33\x00\x0b\x00\x44\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x02\x35\x00\x36\x00\x37\x00\x38\x00\x45\x00\x09\x00\x00\x00\x00\x00\x00\x00\x41\x00\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x46\x02\x47\x02\x48\x02\x00\x00\x00\x00\x08\x00\x00\x00\x45\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc6\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc7\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x38\x02\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x45\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x39\x02\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc3\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x3a\x02\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc4\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x3b\x02\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc6\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc7\x01\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x4e\x01\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x45\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x49\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x45\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x49\x00\x4c\x01\x0d\x00\x0e\x00\x09\x00\x10\x00\x11\x00\x4d\x01\x41\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x4c\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4d\x01\x08\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x03\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x02\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x35\x00\x36\x00\x37\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x33\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x34\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x36\x00\x37\x00\x38\x00\x7f\x01\x80\x01\x81\x01\x82\x01\x83\x01\x84\x01\x85\x01\x86\x01\x87\x01\x88\x01\x89\x01\x8a\x01\x8b\x01\x8c\x01\x8d\x01\x8e\x01\x8f\x01\x90\x01\x91\x01\x92\x01\x93\x01\x94\x01\x95\x01\x96\x01\x97\x01\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (6, 487) [-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11),-	(12 , happyReduce_12),-	(13 , happyReduce_13),-	(14 , happyReduce_14),-	(15 , happyReduce_15),-	(16 , happyReduce_16),-	(17 , happyReduce_17),-	(18 , happyReduce_18),-	(19 , happyReduce_19),-	(20 , happyReduce_20),-	(21 , happyReduce_21),-	(22 , happyReduce_22),-	(23 , happyReduce_23),-	(24 , happyReduce_24),-	(25 , happyReduce_25),-	(26 , happyReduce_26),-	(27 , happyReduce_27),-	(28 , happyReduce_28),-	(29 , happyReduce_29),-	(30 , happyReduce_30),-	(31 , happyReduce_31),-	(32 , happyReduce_32),-	(33 , happyReduce_33),-	(34 , happyReduce_34),-	(35 , happyReduce_35),-	(36 , happyReduce_36),-	(37 , happyReduce_37),-	(38 , happyReduce_38),-	(39 , happyReduce_39),-	(40 , happyReduce_40),-	(41 , happyReduce_41),-	(42 , happyReduce_42),-	(43 , happyReduce_43),-	(44 , happyReduce_44),-	(45 , happyReduce_45),-	(46 , happyReduce_46),-	(47 , happyReduce_47),-	(48 , happyReduce_48),-	(49 , happyReduce_49),-	(50 , happyReduce_50),-	(51 , happyReduce_51),-	(52 , happyReduce_52),-	(53 , happyReduce_53),-	(54 , happyReduce_54),-	(55 , happyReduce_55),-	(56 , happyReduce_56),-	(57 , happyReduce_57),-	(58 , happyReduce_58),-	(59 , happyReduce_59),-	(60 , happyReduce_60),-	(61 , happyReduce_61),-	(62 , happyReduce_62),-	(63 , happyReduce_63),-	(64 , happyReduce_64),-	(65 , happyReduce_65),-	(66 , happyReduce_66),-	(67 , happyReduce_67),-	(68 , happyReduce_68),-	(69 , happyReduce_69),-	(70 , happyReduce_70),-	(71 , happyReduce_71),-	(72 , happyReduce_72),-	(73 , happyReduce_73),-	(74 , happyReduce_74),-	(75 , happyReduce_75),-	(76 , happyReduce_76),-	(77 , happyReduce_77),-	(78 , happyReduce_78),-	(79 , happyReduce_79),-	(80 , happyReduce_80),-	(81 , happyReduce_81),-	(82 , happyReduce_82),-	(83 , happyReduce_83),-	(84 , happyReduce_84),-	(85 , happyReduce_85),-	(86 , happyReduce_86),-	(87 , happyReduce_87),-	(88 , happyReduce_88),-	(89 , happyReduce_89),-	(90 , happyReduce_90),-	(91 , happyReduce_91),-	(92 , happyReduce_92),-	(93 , happyReduce_93),-	(94 , happyReduce_94),-	(95 , happyReduce_95),-	(96 , happyReduce_96),-	(97 , happyReduce_97),-	(98 , happyReduce_98),-	(99 , happyReduce_99),-	(100 , happyReduce_100),-	(101 , happyReduce_101),-	(102 , happyReduce_102),-	(103 , happyReduce_103),-	(104 , happyReduce_104),-	(105 , happyReduce_105),-	(106 , happyReduce_106),-	(107 , happyReduce_107),-	(108 , happyReduce_108),-	(109 , happyReduce_109),-	(110 , happyReduce_110),-	(111 , happyReduce_111),-	(112 , happyReduce_112),-	(113 , happyReduce_113),-	(114 , happyReduce_114),-	(115 , happyReduce_115),-	(116 , happyReduce_116),-	(117 , happyReduce_117),-	(118 , happyReduce_118),-	(119 , happyReduce_119),-	(120 , happyReduce_120),-	(121 , happyReduce_121),-	(122 , happyReduce_122),-	(123 , happyReduce_123),-	(124 , happyReduce_124),-	(125 , happyReduce_125),-	(126 , happyReduce_126),-	(127 , happyReduce_127),-	(128 , happyReduce_128),-	(129 , happyReduce_129),-	(130 , happyReduce_130),-	(131 , happyReduce_131),-	(132 , happyReduce_132),-	(133 , happyReduce_133),-	(134 , happyReduce_134),-	(135 , happyReduce_135),-	(136 , happyReduce_136),-	(137 , happyReduce_137),-	(138 , happyReduce_138),-	(139 , happyReduce_139),-	(140 , happyReduce_140),-	(141 , happyReduce_141),-	(142 , happyReduce_142),-	(143 , happyReduce_143),-	(144 , happyReduce_144),-	(145 , happyReduce_145),-	(146 , happyReduce_146),-	(147 , happyReduce_147),-	(148 , happyReduce_148),-	(149 , happyReduce_149),-	(150 , happyReduce_150),-	(151 , happyReduce_151),-	(152 , happyReduce_152),-	(153 , happyReduce_153),-	(154 , happyReduce_154),-	(155 , happyReduce_155),-	(156 , happyReduce_156),-	(157 , happyReduce_157),-	(158 , happyReduce_158),-	(159 , happyReduce_159),-	(160 , happyReduce_160),-	(161 , happyReduce_161),-	(162 , happyReduce_162),-	(163 , happyReduce_163),-	(164 , happyReduce_164),-	(165 , happyReduce_165),-	(166 , happyReduce_166),-	(167 , happyReduce_167),-	(168 , happyReduce_168),-	(169 , happyReduce_169),-	(170 , happyReduce_170),-	(171 , happyReduce_171),-	(172 , happyReduce_172),-	(173 , happyReduce_173),-	(174 , happyReduce_174),-	(175 , happyReduce_175),-	(176 , happyReduce_176),-	(177 , happyReduce_177),-	(178 , happyReduce_178),-	(179 , happyReduce_179),-	(180 , happyReduce_180),-	(181 , happyReduce_181),-	(182 , happyReduce_182),-	(183 , happyReduce_183),-	(184 , happyReduce_184),-	(185 , happyReduce_185),-	(186 , happyReduce_186),-	(187 , happyReduce_187),-	(188 , happyReduce_188),-	(189 , happyReduce_189),-	(190 , happyReduce_190),-	(191 , happyReduce_191),-	(192 , happyReduce_192),-	(193 , happyReduce_193),-	(194 , happyReduce_194),-	(195 , happyReduce_195),-	(196 , happyReduce_196),-	(197 , happyReduce_197),-	(198 , happyReduce_198),-	(199 , happyReduce_199),-	(200 , happyReduce_200),-	(201 , happyReduce_201),-	(202 , happyReduce_202),-	(203 , happyReduce_203),-	(204 , happyReduce_204),-	(205 , happyReduce_205),-	(206 , happyReduce_206),-	(207 , happyReduce_207),-	(208 , happyReduce_208),-	(209 , happyReduce_209),-	(210 , happyReduce_210),-	(211 , happyReduce_211),-	(212 , happyReduce_212),-	(213 , happyReduce_213),-	(214 , happyReduce_214),-	(215 , happyReduce_215),-	(216 , happyReduce_216),-	(217 , happyReduce_217),-	(218 , happyReduce_218),-	(219 , happyReduce_219),-	(220 , happyReduce_220),-	(221 , happyReduce_221),-	(222 , happyReduce_222),-	(223 , happyReduce_223),-	(224 , happyReduce_224),-	(225 , happyReduce_225),-	(226 , happyReduce_226),-	(227 , happyReduce_227),-	(228 , happyReduce_228),-	(229 , happyReduce_229),-	(230 , happyReduce_230),-	(231 , happyReduce_231),-	(232 , happyReduce_232),-	(233 , happyReduce_233),-	(234 , happyReduce_234),-	(235 , happyReduce_235),-	(236 , happyReduce_236),-	(237 , happyReduce_237),-	(238 , happyReduce_238),-	(239 , happyReduce_239),-	(240 , happyReduce_240),-	(241 , happyReduce_241),-	(242 , happyReduce_242),-	(243 , happyReduce_243),-	(244 , happyReduce_244),-	(245 , happyReduce_245),-	(246 , happyReduce_246),-	(247 , happyReduce_247),-	(248 , happyReduce_248),-	(249 , happyReduce_249),-	(250 , happyReduce_250),-	(251 , happyReduce_251),-	(252 , happyReduce_252),-	(253 , happyReduce_253),-	(254 , happyReduce_254),-	(255 , happyReduce_255),-	(256 , happyReduce_256),-	(257 , happyReduce_257),-	(258 , happyReduce_258),-	(259 , happyReduce_259),-	(260 , happyReduce_260),-	(261 , happyReduce_261),-	(262 , happyReduce_262),-	(263 , happyReduce_263),-	(264 , happyReduce_264),-	(265 , happyReduce_265),-	(266 , happyReduce_266),-	(267 , happyReduce_267),-	(268 , happyReduce_268),-	(269 , happyReduce_269),-	(270 , happyReduce_270),-	(271 , happyReduce_271),-	(272 , happyReduce_272),-	(273 , happyReduce_273),-	(274 , happyReduce_274),-	(275 , happyReduce_275),-	(276 , happyReduce_276),-	(277 , happyReduce_277),-	(278 , happyReduce_278),-	(279 , happyReduce_279),-	(280 , happyReduce_280),-	(281 , happyReduce_281),-	(282 , happyReduce_282),-	(283 , happyReduce_283),-	(284 , happyReduce_284),-	(285 , happyReduce_285),-	(286 , happyReduce_286),-	(287 , happyReduce_287),-	(288 , happyReduce_288),-	(289 , happyReduce_289),-	(290 , happyReduce_290),-	(291 , happyReduce_291),-	(292 , happyReduce_292),-	(293 , happyReduce_293),-	(294 , happyReduce_294),-	(295 , happyReduce_295),-	(296 , happyReduce_296),-	(297 , happyReduce_297),-	(298 , happyReduce_298),-	(299 , happyReduce_299),-	(300 , happyReduce_300),-	(301 , happyReduce_301),-	(302 , happyReduce_302),-	(303 , happyReduce_303),-	(304 , happyReduce_304),-	(305 , happyReduce_305),-	(306 , happyReduce_306),-	(307 , happyReduce_307),-	(308 , happyReduce_308),-	(309 , happyReduce_309),-	(310 , happyReduce_310),-	(311 , happyReduce_311),-	(312 , happyReduce_312),-	(313 , happyReduce_313),-	(314 , happyReduce_314),-	(315 , happyReduce_315),-	(316 , happyReduce_316),-	(317 , happyReduce_317),-	(318 , happyReduce_318),-	(319 , happyReduce_319),-	(320 , happyReduce_320),-	(321 , happyReduce_321),-	(322 , happyReduce_322),-	(323 , happyReduce_323),-	(324 , happyReduce_324),-	(325 , happyReduce_325),-	(326 , happyReduce_326),-	(327 , happyReduce_327),-	(328 , happyReduce_328),-	(329 , happyReduce_329),-	(330 , happyReduce_330),-	(331 , happyReduce_331),-	(332 , happyReduce_332),-	(333 , happyReduce_333),-	(334 , happyReduce_334),-	(335 , happyReduce_335),-	(336 , happyReduce_336),-	(337 , happyReduce_337),-	(338 , happyReduce_338),-	(339 , happyReduce_339),-	(340 , happyReduce_340),-	(341 , happyReduce_341),-	(342 , happyReduce_342),-	(343 , happyReduce_343),-	(344 , happyReduce_344),-	(345 , happyReduce_345),-	(346 , happyReduce_346),-	(347 , happyReduce_347),-	(348 , happyReduce_348),-	(349 , happyReduce_349),-	(350 , happyReduce_350),-	(351 , happyReduce_351),-	(352 , happyReduce_352),-	(353 , happyReduce_353),-	(354 , happyReduce_354),-	(355 , happyReduce_355),-	(356 , happyReduce_356),-	(357 , happyReduce_357),-	(358 , happyReduce_358),-	(359 , happyReduce_359),-	(360 , happyReduce_360),-	(361 , happyReduce_361),-	(362 , happyReduce_362),-	(363 , happyReduce_363),-	(364 , happyReduce_364),-	(365 , happyReduce_365),-	(366 , happyReduce_366),-	(367 , happyReduce_367),-	(368 , happyReduce_368),-	(369 , happyReduce_369),-	(370 , happyReduce_370),-	(371 , happyReduce_371),-	(372 , happyReduce_372),-	(373 , happyReduce_373),-	(374 , happyReduce_374),-	(375 , happyReduce_375),-	(376 , happyReduce_376),-	(377 , happyReduce_377),-	(378 , happyReduce_378),-	(379 , happyReduce_379),-	(380 , happyReduce_380),-	(381 , happyReduce_381),-	(382 , happyReduce_382),-	(383 , happyReduce_383),-	(384 , happyReduce_384),-	(385 , happyReduce_385),-	(386 , happyReduce_386),-	(387 , happyReduce_387),-	(388 , happyReduce_388),-	(389 , happyReduce_389),-	(390 , happyReduce_390),-	(391 , happyReduce_391),-	(392 , happyReduce_392),-	(393 , happyReduce_393),-	(394 , happyReduce_394),-	(395 , happyReduce_395),-	(396 , happyReduce_396),-	(397 , happyReduce_397),-	(398 , happyReduce_398),-	(399 , happyReduce_399),-	(400 , happyReduce_400),-	(401 , happyReduce_401),-	(402 , happyReduce_402),-	(403 , happyReduce_403),-	(404 , happyReduce_404),-	(405 , happyReduce_405),-	(406 , happyReduce_406),-	(407 , happyReduce_407),-	(408 , happyReduce_408),-	(409 , happyReduce_409),-	(410 , happyReduce_410),-	(411 , happyReduce_411),-	(412 , happyReduce_412),-	(413 , happyReduce_413),-	(414 , happyReduce_414),-	(415 , happyReduce_415),-	(416 , happyReduce_416),-	(417 , happyReduce_417),-	(418 , happyReduce_418),-	(419 , happyReduce_419),-	(420 , happyReduce_420),-	(421 , happyReduce_421),-	(422 , happyReduce_422),-	(423 , happyReduce_423),-	(424 , happyReduce_424),-	(425 , happyReduce_425),-	(426 , happyReduce_426),-	(427 , happyReduce_427),-	(428 , happyReduce_428),-	(429 , happyReduce_429),-	(430 , happyReduce_430),-	(431 , happyReduce_431),-	(432 , happyReduce_432),-	(433 , happyReduce_433),-	(434 , happyReduce_434),-	(435 , happyReduce_435),-	(436 , happyReduce_436),-	(437 , happyReduce_437),-	(438 , happyReduce_438),-	(439 , happyReduce_439),-	(440 , happyReduce_440),-	(441 , happyReduce_441),-	(442 , happyReduce_442),-	(443 , happyReduce_443),-	(444 , happyReduce_444),-	(445 , happyReduce_445),-	(446 , happyReduce_446),-	(447 , happyReduce_447),-	(448 , happyReduce_448),-	(449 , happyReduce_449),-	(450 , happyReduce_450),-	(451 , happyReduce_451),-	(452 , happyReduce_452),-	(453 , happyReduce_453),-	(454 , happyReduce_454),-	(455 , happyReduce_455),-	(456 , happyReduce_456),-	(457 , happyReduce_457),-	(458 , happyReduce_458),-	(459 , happyReduce_459),-	(460 , happyReduce_460),-	(461 , happyReduce_461),-	(462 , happyReduce_462),-	(463 , happyReduce_463),-	(464 , happyReduce_464),-	(465 , happyReduce_465),-	(466 , happyReduce_466),-	(467 , happyReduce_467),-	(468 , happyReduce_468),-	(469 , happyReduce_469),-	(470 , happyReduce_470),-	(471 , happyReduce_471),-	(472 , happyReduce_472),-	(473 , happyReduce_473),-	(474 , happyReduce_474),-	(475 , happyReduce_475),-	(476 , happyReduce_476),-	(477 , happyReduce_477),-	(478 , happyReduce_478),-	(479 , happyReduce_479),-	(480 , happyReduce_480),-	(481 , happyReduce_481),-	(482 , happyReduce_482),-	(483 , happyReduce_483),-	(484 , happyReduce_484),-	(485 , happyReduce_485),-	(486 , happyReduce_486),-	(487 , happyReduce_487)-	]--happy_n_terms = 106 :: Int-happy_n_nonterms = 162 :: Int--happyReduce_6 = happySpecReduce_1  0# happyReduction_6-happyReduction_6 happy_x_1-	 =  case happyOut10 happy_x_1 of { happy_var_1 -> -	happyIn9-		 (reverse happy_var_1-	)}--happyReduce_7 = happySpecReduce_2  1# happyReduction_7-happyReduction_7 happy_x_2-	happy_x_1-	 =  case happyOut10 happy_x_1 of { happy_var_1 -> -	case happyOut11 happy_x_2 of { happy_var_2 -> -	happyIn10-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_8 = happySpecReduce_0  1# happyReduction_8-happyReduction_8  =  happyIn10-		 ([]-	)--happyReduce_9 = happySpecReduce_1  2# happyReduction_9-happyReduction_9 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> -	happyIn11-		 (TokKeyword KwAbstract happy_var_1-	)}--happyReduce_10 = happySpecReduce_1  2# happyReduction_10-happyReduction_10 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> -	happyIn11-		 (TokKeyword KwCoData happy_var_1-	)}--happyReduce_11 = happySpecReduce_1  2# happyReduction_11-happyReduction_11 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> -	happyIn11-		 (TokKeyword KwCoInductive happy_var_1-	)}--happyReduce_12 = happySpecReduce_1  2# happyReduction_12-happyReduction_12 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwConstructor happy_var_1) -> -	happyIn11-		 (TokKeyword KwConstructor happy_var_1-	)}--happyReduce_13 = happySpecReduce_1  2# happyReduction_13-happyReduction_13 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> -	happyIn11-		 (TokKeyword KwData happy_var_1-	)}--happyReduce_14 = happySpecReduce_1  2# happyReduction_14-happyReduction_14 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwEta happy_var_1) -> -	happyIn11-		 (TokKeyword KwEta happy_var_1-	)}--happyReduce_15 = happySpecReduce_1  2# happyReduction_15-happyReduction_15 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwField happy_var_1) -> -	happyIn11-		 (TokKeyword KwField happy_var_1-	)}--happyReduce_16 = happySpecReduce_1  2# happyReduction_16-happyReduction_16 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwForall happy_var_1) -> -	happyIn11-		 (TokKeyword KwForall happy_var_1-	)}--happyReduce_17 = happySpecReduce_1  2# happyReduction_17-happyReduction_17 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> -	happyIn11-		 (TokKeyword KwHiding happy_var_1-	)}--happyReduce_18 = happySpecReduce_1  2# happyReduction_18-happyReduction_18 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwImport happy_var_1) -> -	happyIn11-		 (TokKeyword KwImport happy_var_1-	)}--happyReduce_19 = happySpecReduce_1  2# happyReduction_19-happyReduction_19 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwIn happy_var_1) -> -	happyIn11-		 (TokKeyword KwIn happy_var_1-	)}--happyReduce_20 = happySpecReduce_1  2# happyReduction_20-happyReduction_20 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> -	happyIn11-		 (TokKeyword KwInductive happy_var_1-	)}--happyReduce_21 = happySpecReduce_1  2# happyReduction_21-happyReduction_21 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> -	happyIn11-		 (TokKeyword KwInfix happy_var_1-	)}--happyReduce_22 = happySpecReduce_1  2# happyReduction_22-happyReduction_22 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> -	happyIn11-		 (TokKeyword KwInfixL happy_var_1-	)}--happyReduce_23 = happySpecReduce_1  2# happyReduction_23-happyReduction_23 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> -	happyIn11-		 (TokKeyword KwInfixR happy_var_1-	)}--happyReduce_24 = happySpecReduce_1  2# happyReduction_24-happyReduction_24 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> -	happyIn11-		 (TokKeyword KwInstance happy_var_1-	)}--happyReduce_25 = happySpecReduce_1  2# happyReduction_25-happyReduction_25 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwOverlap happy_var_1) -> -	happyIn11-		 (TokKeyword KwOverlap happy_var_1-	)}--happyReduce_26 = happySpecReduce_1  2# happyReduction_26-happyReduction_26 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> -	happyIn11-		 (TokKeyword KwLet happy_var_1-	)}--happyReduce_27 = happySpecReduce_1  2# happyReduction_27-happyReduction_27 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwMacro happy_var_1) -> -	happyIn11-		 (TokKeyword KwMacro happy_var_1-	)}--happyReduce_28 = happySpecReduce_1  2# happyReduction_28-happyReduction_28 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> -	happyIn11-		 (TokKeyword KwModule happy_var_1-	)}--happyReduce_29 = happySpecReduce_1  2# happyReduction_29-happyReduction_29 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> -	happyIn11-		 (TokKeyword KwMutual happy_var_1-	)}--happyReduce_30 = happySpecReduce_1  2# happyReduction_30-happyReduction_30 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwNoEta happy_var_1) -> -	happyIn11-		 (TokKeyword KwNoEta happy_var_1-	)}--happyReduce_31 = happySpecReduce_1  2# happyReduction_31-happyReduction_31 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> -	happyIn11-		 (TokKeyword KwOpen happy_var_1-	)}--happyReduce_32 = happySpecReduce_1  2# happyReduction_32-happyReduction_32 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> -	happyIn11-		 (TokKeyword KwPatternSyn happy_var_1-	)}--happyReduce_33 = happySpecReduce_1  2# happyReduction_33-happyReduction_33 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> -	happyIn11-		 (TokKeyword KwPostulate happy_var_1-	)}--happyReduce_34 = happySpecReduce_1  2# happyReduction_34-happyReduction_34 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> -	happyIn11-		 (TokKeyword KwPrimitive happy_var_1-	)}--happyReduce_35 = happySpecReduce_1  2# happyReduction_35-happyReduction_35 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> -	happyIn11-		 (TokKeyword KwPrivate happy_var_1-	)}--happyReduce_36 = happySpecReduce_1  2# happyReduction_36-happyReduction_36 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> -	happyIn11-		 (TokKeyword KwProp happy_var_1-	)}--happyReduce_37 = happySpecReduce_1  2# happyReduction_37-happyReduction_37 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> -	happyIn11-		 (TokKeyword KwPublic happy_var_1-	)}--happyReduce_38 = happySpecReduce_1  2# happyReduction_38-happyReduction_38 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> -	happyIn11-		 (TokKeyword KwQuote happy_var_1-	)}--happyReduce_39 = happySpecReduce_1  2# happyReduction_39-happyReduction_39 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> -	happyIn11-		 (TokKeyword KwQuoteContext happy_var_1-	)}--happyReduce_40 = happySpecReduce_1  2# happyReduction_40-happyReduction_40 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> -	happyIn11-		 (TokKeyword KwQuoteGoal happy_var_1-	)}--happyReduce_41 = happySpecReduce_1  2# happyReduction_41-happyReduction_41 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> -	happyIn11-		 (TokKeyword KwQuoteTerm happy_var_1-	)}--happyReduce_42 = happySpecReduce_1  2# happyReduction_42-happyReduction_42 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	happyIn11-		 (TokKeyword KwRecord happy_var_1-	)}--happyReduce_43 = happySpecReduce_1  2# happyReduction_43-happyReduction_43 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> -	happyIn11-		 (TokKeyword KwRenaming happy_var_1-	)}--happyReduce_44 = happySpecReduce_1  2# happyReduction_44-happyReduction_44 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwRewrite happy_var_1) -> -	happyIn11-		 (TokKeyword KwRewrite happy_var_1-	)}--happyReduce_45 = happySpecReduce_1  2# happyReduction_45-happyReduction_45 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> -	happyIn11-		 (TokKeyword KwSet happy_var_1-	)}--happyReduce_46 = happySpecReduce_1  2# happyReduction_46-happyReduction_46 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwSyntax happy_var_1) -> -	happyIn11-		 (TokKeyword KwSyntax happy_var_1-	)}--happyReduce_47 = happySpecReduce_1  2# happyReduction_47-happyReduction_47 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> -	happyIn11-		 (TokKeyword KwTactic happy_var_1-	)}--happyReduce_48 = happySpecReduce_1  2# happyReduction_48-happyReduction_48 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwTo happy_var_1) -> -	happyIn11-		 (TokKeyword KwTo happy_var_1-	)}--happyReduce_49 = happySpecReduce_1  2# happyReduction_49-happyReduction_49 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> -	happyIn11-		 (TokKeyword KwUnquote happy_var_1-	)}--happyReduce_50 = happySpecReduce_1  2# happyReduction_50-happyReduction_50 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> -	happyIn11-		 (TokKeyword KwUnquoteDecl happy_var_1-	)}--happyReduce_51 = happySpecReduce_1  2# happyReduction_51-happyReduction_51 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDef happy_var_1) -> -	happyIn11-		 (TokKeyword KwUnquoteDef happy_var_1-	)}--happyReduce_52 = happySpecReduce_1  2# happyReduction_52-happyReduction_52 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> -	happyIn11-		 (TokKeyword KwUsing happy_var_1-	)}--happyReduce_53 = happySpecReduce_1  2# happyReduction_53-happyReduction_53 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwWhere happy_var_1) -> -	happyIn11-		 (TokKeyword KwWhere happy_var_1-	)}--happyReduce_54 = happySpecReduce_1  2# happyReduction_54-happyReduction_54 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwWith happy_var_1) -> -	happyIn11-		 (TokKeyword KwWith happy_var_1-	)}--happyReduce_55 = happySpecReduce_1  2# happyReduction_55-happyReduction_55 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwBUILTIN happy_var_1) -> -	happyIn11-		 (TokKeyword KwBUILTIN happy_var_1-	)}--happyReduce_56 = happySpecReduce_1  2# happyReduction_56-happyReduction_56 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCATCHALL happy_var_1) -> -	happyIn11-		 (TokKeyword KwCATCHALL happy_var_1-	)}--happyReduce_57 = happySpecReduce_1  2# happyReduction_57-happyReduction_57 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED happy_var_1-	)}--happyReduce_58 = happySpecReduce_1  2# happyReduction_58-happyReduction_58 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_DATA happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_DATA happy_var_1-	)}--happyReduce_59 = happySpecReduce_1  2# happyReduction_59-happyReduction_59 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_DATA_UHC happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_DATA_UHC happy_var_1-	)}--happyReduce_60 = happySpecReduce_1  2# happyReduction_60-happyReduction_60 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_DECLARE_DATA happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_DECLARE_DATA happy_var_1-	)}--happyReduce_61 = happySpecReduce_1  2# happyReduction_61-happyReduction_61 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EPIC happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_EPIC happy_var_1-	)}--happyReduce_62 = happySpecReduce_1  2# happyReduction_62-happyReduction_62 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EXPORT happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_EXPORT happy_var_1-	)}--happyReduce_63 = happySpecReduce_1  2# happyReduction_63-happyReduction_63 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_JS happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_JS happy_var_1-	)}--happyReduce_64 = happySpecReduce_1  2# happyReduction_64-happyReduction_64 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_TYPE happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_TYPE happy_var_1-	)}--happyReduce_65 = happySpecReduce_1  2# happyReduction_65-happyReduction_65 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_UHC happy_var_1) -> -	happyIn11-		 (TokKeyword KwCOMPILED_UHC happy_var_1-	)}--happyReduce_66 = happySpecReduce_1  2# happyReduction_66-happyReduction_66 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwHASKELL happy_var_1) -> -	happyIn11-		 (TokKeyword KwHASKELL happy_var_1-	)}--happyReduce_67 = happySpecReduce_1  2# happyReduction_67-happyReduction_67 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwDISPLAY happy_var_1) -> -	happyIn11-		 (TokKeyword KwDISPLAY happy_var_1-	)}--happyReduce_68 = happySpecReduce_1  2# happyReduction_68-happyReduction_68 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwIMPORT happy_var_1) -> -	happyIn11-		 (TokKeyword KwIMPORT happy_var_1-	)}--happyReduce_69 = happySpecReduce_1  2# happyReduction_69-happyReduction_69 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwIMPORT_UHC happy_var_1) -> -	happyIn11-		 (TokKeyword KwIMPORT_UHC happy_var_1-	)}--happyReduce_70 = happySpecReduce_1  2# happyReduction_70-happyReduction_70 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwIMPOSSIBLE happy_var_1) -> -	happyIn11-		 (TokKeyword KwIMPOSSIBLE happy_var_1-	)}--happyReduce_71 = happySpecReduce_1  2# happyReduction_71-happyReduction_71 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwINLINE happy_var_1) -> -	happyIn11-		 (TokKeyword KwINLINE happy_var_1-	)}--happyReduce_72 = happySpecReduce_1  2# happyReduction_72-happyReduction_72 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwMEASURE happy_var_1) -> -	happyIn11-		 (TokKeyword KwMEASURE happy_var_1-	)}--happyReduce_73 = happySpecReduce_1  2# happyReduction_73-happyReduction_73 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_1) -> -	happyIn11-		 (TokKeyword KwNO_TERMINATION_CHECK happy_var_1-	)}--happyReduce_74 = happySpecReduce_1  2# happyReduction_74-happyReduction_74 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwNO_POSITIVITY_CHECK happy_var_1) -> -	happyIn11-		 (TokKeyword KwNO_POSITIVITY_CHECK happy_var_1-	)}--happyReduce_75 = happySpecReduce_1  2# happyReduction_75-happyReduction_75 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwNON_TERMINATING happy_var_1) -> -	happyIn11-		 (TokKeyword KwNON_TERMINATING happy_var_1-	)}--happyReduce_76 = happySpecReduce_1  2# happyReduction_76-happyReduction_76 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwOPTIONS happy_var_1) -> -	happyIn11-		 (TokKeyword KwOPTIONS happy_var_1-	)}--happyReduce_77 = happySpecReduce_1  2# happyReduction_77-happyReduction_77 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPOLARITY happy_var_1) -> -	happyIn11-		 (TokKeyword KwPOLARITY happy_var_1-	)}--happyReduce_78 = happySpecReduce_1  2# happyReduction_78-happyReduction_78 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwREWRITE happy_var_1) -> -	happyIn11-		 (TokKeyword KwREWRITE happy_var_1-	)}--happyReduce_79 = happySpecReduce_1  2# happyReduction_79-happyReduction_79 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwSTATIC happy_var_1) -> -	happyIn11-		 (TokKeyword KwSTATIC happy_var_1-	)}--happyReduce_80 = happySpecReduce_1  2# happyReduction_80-happyReduction_80 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwTERMINATING happy_var_1) -> -	happyIn11-		 (TokKeyword KwTERMINATING happy_var_1-	)}--happyReduce_81 = happySpecReduce_1  2# happyReduction_81-happyReduction_81 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> -	happyIn11-		 (TokSetN happy_var_1-	)}--happyReduce_82 = happySpecReduce_1  2# happyReduction_82-happyReduction_82 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokTeX happy_var_1) -> -	happyIn11-		 (TokTeX happy_var_1-	)}--happyReduce_83 = happySpecReduce_1  2# happyReduction_83-happyReduction_83 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokComment happy_var_1) -> -	happyIn11-		 (TokComment happy_var_1-	)}--happyReduce_84 = happySpecReduce_1  2# happyReduction_84-happyReduction_84 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> -	happyIn11-		 (TokSymbol SymEllipsis happy_var_1-	)}--happyReduce_85 = happySpecReduce_1  2# happyReduction_85-happyReduction_85 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDotDot happy_var_1) -> -	happyIn11-		 (TokSymbol SymDotDot happy_var_1-	)}--happyReduce_86 = happySpecReduce_1  2# happyReduction_86-happyReduction_86 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> -	happyIn11-		 (TokSymbol SymDot happy_var_1-	)}--happyReduce_87 = happySpecReduce_1  2# happyReduction_87-happyReduction_87 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> -	happyIn11-		 (TokSymbol SymSemi happy_var_1-	)}--happyReduce_88 = happySpecReduce_1  2# happyReduction_88-happyReduction_88 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymColon happy_var_1) -> -	happyIn11-		 (TokSymbol SymColon happy_var_1-	)}--happyReduce_89 = happySpecReduce_1  2# happyReduction_89-happyReduction_89 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymEqual happy_var_1) -> -	happyIn11-		 (TokSymbol SymEqual happy_var_1-	)}--happyReduce_90 = happySpecReduce_1  2# happyReduction_90-happyReduction_90 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> -	happyIn11-		 (TokSymbol SymUnderscore happy_var_1-	)}--happyReduce_91 = happySpecReduce_1  2# happyReduction_91-happyReduction_91 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> -	happyIn11-		 (TokSymbol SymQuestionMark happy_var_1-	)}--happyReduce_92 = happySpecReduce_1  2# happyReduction_92-happyReduction_92 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymArrow happy_var_1) -> -	happyIn11-		 (TokSymbol SymArrow happy_var_1-	)}--happyReduce_93 = happySpecReduce_1  2# happyReduction_93-happyReduction_93 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> -	happyIn11-		 (TokSymbol SymLambda happy_var_1-	)}--happyReduce_94 = happySpecReduce_1  2# happyReduction_94-happyReduction_94 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymAs happy_var_1) -> -	happyIn11-		 (TokSymbol SymAs happy_var_1-	)}--happyReduce_95 = happySpecReduce_1  2# happyReduction_95-happyReduction_95 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymBar happy_var_1) -> -	happyIn11-		 (TokSymbol SymBar happy_var_1-	)}--happyReduce_96 = happySpecReduce_1  2# happyReduction_96-happyReduction_96 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	happyIn11-		 (TokSymbol SymOpenParen happy_var_1-	)}--happyReduce_97 = happySpecReduce_1  2# happyReduction_97-happyReduction_97 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymCloseParen happy_var_1) -> -	happyIn11-		 (TokSymbol SymCloseParen happy_var_1-	)}--happyReduce_98 = happySpecReduce_1  2# happyReduction_98-happyReduction_98 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenIdiomBracket happy_var_1) -> -	happyIn11-		 (TokSymbol SymOpenIdiomBracket happy_var_1-	)}--happyReduce_99 = happySpecReduce_1  2# happyReduction_99-happyReduction_99 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymCloseIdiomBracket happy_var_1) -> -	happyIn11-		 (TokSymbol SymCloseIdiomBracket happy_var_1-	)}--happyReduce_100 = happySpecReduce_1  2# happyReduction_100-happyReduction_100 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymDoubleOpenBrace happy_var_1-	)}--happyReduce_101 = happySpecReduce_1  2# happyReduction_101-happyReduction_101 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymDoubleCloseBrace happy_var_1-	)}--happyReduce_102 = happySpecReduce_1  2# happyReduction_102-happyReduction_102 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymOpenBrace happy_var_1-	)}--happyReduce_103 = happySpecReduce_1  2# happyReduction_103-happyReduction_103 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymCloseBrace happy_var_1-	)}--happyReduce_104 = happySpecReduce_1  2# happyReduction_104-happyReduction_104 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenVirtualBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymOpenVirtualBrace happy_var_1-	)}--happyReduce_105 = happySpecReduce_1  2# happyReduction_105-happyReduction_105 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymCloseVirtualBrace happy_var_1) -> -	happyIn11-		 (TokSymbol SymCloseVirtualBrace happy_var_1-	)}--happyReduce_106 = happySpecReduce_1  2# happyReduction_106-happyReduction_106 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> -	happyIn11-		 (TokSymbol SymVirtualSemi happy_var_1-	)}--happyReduce_107 = happySpecReduce_1  2# happyReduction_107-happyReduction_107 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	happyIn11-		 (TokSymbol SymOpenPragma happy_var_1-	)}--happyReduce_108 = happySpecReduce_1  2# happyReduction_108-happyReduction_108 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymClosePragma happy_var_1) -> -	happyIn11-		 (TokSymbol SymClosePragma happy_var_1-	)}--happyReduce_109 = happySpecReduce_1  2# happyReduction_109-happyReduction_109 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokId happy_var_1) -> -	happyIn11-		 (TokId happy_var_1-	)}--happyReduce_110 = happySpecReduce_1  2# happyReduction_110-happyReduction_110 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> -	happyIn11-		 (TokQId happy_var_1-	)}--happyReduce_111 = happySpecReduce_1  2# happyReduction_111-happyReduction_111 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	happyIn11-		 (TokString happy_var_1-	)}--happyReduce_112 = happySpecReduce_1  2# happyReduction_112-happyReduction_112 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> -	happyIn11-		 (TokLiteral happy_var_1-	)}--happyReduce_113 = happySpecReduce_3  3# happyReduction_113-happyReduction_113 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut127 happy_x_2 of { happy_var_2 -> -	happyIn12-		 (takeOptionsPragmas happy_var_2-	)}--happyReduce_114 = happySpecReduce_0  4# happyReduction_114-happyReduction_114  =  happyIn13-		 (()-	)--happyReduce_115 = happySpecReduce_1  4# happyReduction_115-happyReduction_115 happy_x_1-	 =  happyIn13-		 (()-	)--happyReduce_116 = happySpecReduce_1  5# happyReduction_116-happyReduction_116 happy_x_1-	 =  happyIn14-		 (()-	)--happyReduce_117 = happyMonadReduce 1# 5# happyReduction_117-happyReduction_117 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (( popContext)-	) (\r -> happyReturn (happyIn14 r))--happyReduce_118 = happySpecReduce_1  6# happyReduction_118-happyReduction_118 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> -	happyIn15-		 (happy_var_1-	)}--happyReduce_119 = happySpecReduce_1  6# happyReduction_119-happyReduction_119 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> -	happyIn15-		 (happy_var_1-	)}--happyReduce_120 = happyMonadReduce 0# 7# happyReduction_120-happyReduction_120 (happyRest) tk-	 = happyThen (( pushLexState imp_dir)-	) (\r -> happyReturn (happyIn16 r))--happyReduce_121 = happyMonadReduce 1# 8# happyReduction_121-happyReduction_121 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> -	( case happy_var_1 of {-                     LitNat _ i -> return i;-                     _          -> fail $ "Expected integer"-                   })}-	) (\r -> happyReturn (happyIn17 r))--happyReduce_122 = happyMonadReduce 1# 9# happyReduction_122-happyReduction_122 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) -> -	( mkName happy_var_1)}-	) (\r -> happyReturn (happyIn18 r))--happyReduce_123 = happySpecReduce_2  10# happyReduction_123-happyReduction_123 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	case happyOut19 happy_x_2 of { happy_var_2 -> -	happyIn19-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_124 = happySpecReduce_1  10# happyReduction_124-happyReduction_124 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn19-		 ([happy_var_1]-	)}--happyReduce_125 = happySpecReduce_1  11# happyReduction_125-happyReduction_125 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> -	happyIn20-		 (getRange happy_var_1-	)}--happyReduce_126 = happyMonadReduce 2# 11# happyReduction_126-happyReduction_126 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> -	(-      if posPos (fromJust (rEnd' (getRange happy_var_2))) --         posPos (fromJust (rStart' (getRange happy_var_1))) > 2-      then parseErrorAt (fromJust (rStart' (getRange happy_var_2)))-         "Expecting '}}', found separated '}'s."-      else return $ getRange (happy_var_1, happy_var_2))}}-	) (\r -> happyReturn (happyIn20 r))--happyReduce_127 = happySpecReduce_2  12# happyReduction_127-happyReduction_127 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn21-		 (setRelevance NonStrict $ defaultArg happy_var_2-	)}--happyReduce_128 = happySpecReduce_2  12# happyReduction_128-happyReduction_128 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn21-		 (setRelevance Irrelevant $ defaultArg happy_var_2-	)}--happyReduce_129 = happySpecReduce_1  12# happyReduction_129-happyReduction_129 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn21-		 (defaultArg happy_var_1-	)}--happyReduce_130 = happySpecReduce_2  13# happyReduction_130-happyReduction_130 happy_x_2-	happy_x_1-	 =  case happyOut21 happy_x_1 of { happy_var_1 -> -	case happyOut22 happy_x_2 of { happy_var_2 -> -	happyIn22-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_131 = happySpecReduce_1  13# happyReduction_131-happyReduction_131 happy_x_1-	 =  case happyOut21 happy_x_1 of { happy_var_1 -> -	happyIn22-		 ([happy_var_1]-	)}--happyReduce_132 = happySpecReduce_2  14# happyReduction_132-happyReduction_132 happy_x_2-	happy_x_1-	 =  case happyOut21 happy_x_1 of { happy_var_1 -> -	case happyOut23 happy_x_2 of { happy_var_2 -> -	happyIn23-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_133 = happySpecReduce_1  14# happyReduction_133-happyReduction_133 happy_x_1-	 =  case happyOut21 happy_x_1 of { happy_var_1 -> -	happyIn23-		 ([happy_var_1]-	)}--happyReduce_134 = happyReduce 4# 14# happyReduction_134-happyReduction_134 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut22 happy_x_2 of { happy_var_2 -> -	case happyOut23 happy_x_4 of { happy_var_4 -> -	happyIn23-		 (map makeInstance happy_var_2 ++ happy_var_4-	) `HappyStk` happyRest}}--happyReduce_135 = happySpecReduce_3  14# happyReduction_135-happyReduction_135 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut22 happy_x_2 of { happy_var_2 -> -	happyIn23-		 (map makeInstance happy_var_2-	)}--happyReduce_136 = happyReduce 4# 14# happyReduction_136-happyReduction_136 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut22 happy_x_2 of { happy_var_2 -> -	case happyOut23 happy_x_4 of { happy_var_4 -> -	happyIn23-		 (map hide happy_var_2 ++ happy_var_4-	) `HappyStk` happyRest}}--happyReduce_137 = happySpecReduce_3  14# happyReduction_137-happyReduction_137 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut22 happy_x_2 of { happy_var_2 -> -	happyIn23-		 (map hide happy_var_2-	)}--happyReduce_138 = happyReduce 5# 14# happyReduction_138-happyReduction_138 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut23 happy_x_5 of { happy_var_5 -> -	happyIn23-		 (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5-	) `HappyStk` happyRest}}--happyReduce_139 = happyReduce 4# 14# happyReduction_139-happyReduction_139 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	happyIn23-		 (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3-	) `HappyStk` happyRest}--happyReduce_140 = happyReduce 5# 14# happyReduction_140-happyReduction_140 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut23 happy_x_5 of { happy_var_5 -> -	happyIn23-		 (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5-	) `HappyStk` happyRest}}--happyReduce_141 = happyReduce 4# 14# happyReduction_141-happyReduction_141 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	happyIn23-		 (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3-	) `HappyStk` happyRest}--happyReduce_142 = happyReduce 5# 14# happyReduction_142-happyReduction_142 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut23 happy_x_5 of { happy_var_5 -> -	happyIn23-		 (map (hide . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5-	) `HappyStk` happyRest}}--happyReduce_143 = happyReduce 4# 14# happyReduction_143-happyReduction_143 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	happyIn23-		 (map (hide . setRelevance NonStrict . defaultArg) happy_var_3-	) `HappyStk` happyRest}--happyReduce_144 = happyReduce 5# 14# happyReduction_144-happyReduction_144 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut23 happy_x_5 of { happy_var_5 -> -	happyIn23-		 (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5-	) `HappyStk` happyRest}}--happyReduce_145 = happyReduce 4# 14# happyReduction_145-happyReduction_145 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut19 happy_x_3 of { happy_var_3 -> -	happyIn23-		 (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3-	) `HappyStk` happyRest}--happyReduce_146 = happyMonadReduce 1# 15# happyReduction_146-happyReduction_146 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> -	( mkQName happy_var_1)}-	) (\r -> happyReturn (happyIn24 r))--happyReduce_147 = happySpecReduce_1  15# happyReduction_147-happyReduction_147 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn24-		 (QName happy_var_1-	)}--happyReduce_148 = happySpecReduce_1  16# happyReduction_148-happyReduction_148 happy_x_1-	 =  case happyOut24 happy_x_1 of { happy_var_1 -> -	happyIn25-		 (happy_var_1-	)}--happyReduce_149 = happySpecReduce_1  17# happyReduction_149-happyReduction_149 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn26-		 (happy_var_1-	)}--happyReduce_150 = happySpecReduce_1  17# happyReduction_150-happyReduction_150 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> -	happyIn26-		 (Name (getRange happy_var_1) [Hole]-	)}--happyReduce_151 = happySpecReduce_2  18# happyReduction_151-happyReduction_151 happy_x_2-	happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	case happyOut27 happy_x_2 of { happy_var_2 -> -	happyIn27-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_152 = happySpecReduce_1  18# happyReduction_152-happyReduction_152 happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	happyIn27-		 ([happy_var_1]-	)}--happyReduce_153 = happySpecReduce_1  19# happyReduction_153-happyReduction_153 happy_x_1-	 =  case happyOut29 happy_x_1 of { happy_var_1 -> -	happyIn28-		 (case happy_var_1 of-      Left ns -> ns-      Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern"-	)}--happyReduce_154 = happyMonadReduce 1# 20# happyReduction_154-happyReduction_154 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> -	(-    let getName :: Expr -> Maybe Name-        getName (Ident (QName x)) = Just x-        getName (Underscore r _)  = Just (Name r [Hole])-        getName _                 = Nothing--        isAbsurd :: Expr -> Bool-        isAbsurd (Absurd _)                  = True-        isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e-        isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e-        isAbsurd (Paren _ expr)              = isAbsurd expr-        isAbsurd (RawApp _ exprs)            = any isAbsurd exprs-        isAbsurd _                           = False-    in-    if any isAbsurd happy_var_1 then return $ Right happy_var_1 else-    case mapM getName happy_var_1 of-        Just good -> return $ Left good-        Nothing   -> fail $ "expected sequence of bound identifiers")}-	) (\r -> happyReturn (happyIn29 r))--happyReduce_155 = happyMonadReduce 1# 21# happyReduction_155-happyReduction_155 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> -	(-    let -- interpret an expression as name-        getName :: Expr -> Maybe Name-        getName (Ident (QName x)) = Just x-        getName (Underscore r _)  = Just (Name r [Hole])-        getName _                 = Nothing--        getNames :: Expr -> Maybe [Name]-        getNames (RawApp _ es) = mapM getName es-        getNames e             = singleton `fmap` getName e--        -- interpret an expression as name or list of hidden names-        getName1 :: Expr -> Maybe [WithHiding Name]-        getName1 (Ident (QName x)) = Just [WithHiding NotHidden x]-        getName1 (Underscore r _)  = Just [WithHiding NotHidden $ Name r [Hole]]-        getName1 (HiddenArg _ (Named Nothing e))-                                   = map (WithHiding Hidden) `fmap` getNames e-        getName1 _                 = Nothing--    in-    case mapM getName1 happy_var_1 of-        Just good -> return $ concat good-        Nothing   -> fail $ "expected sequence of possibly hidden bound identifiers")}-	) (\r -> happyReturn (happyIn30 r))--happyReduce_156 = happySpecReduce_0  22# happyReduction_156-happyReduction_156  =  happyIn31-		 ([]-	)--happyReduce_157 = happySpecReduce_2  22# happyReduction_157-happyReduction_157 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	case happyOut31 happy_x_2 of { happy_var_2 -> -	happyIn31-		 (snd happy_var_1 : happy_var_2-	)}}--happyReduce_158 = happySpecReduce_1  23# happyReduction_158-happyReduction_158 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	happyIn32-		 (snd happy_var_1-	)}--happyReduce_159 = happySpecReduce_0  24# happyReduction_159-happyReduction_159  =  happyIn33-		 ([]-	)--happyReduce_160 = happySpecReduce_2  24# happyReduction_160-happyReduction_160 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	case happyOut33 happy_x_2 of { happy_var_2 -> -	happyIn33-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_161 = happyMonadReduce 1# 25# happyReduction_161-happyReduction_161 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	( mkName happy_var_1)}-	) (\r -> happyReturn (happyIn34 r))--happyReduce_162 = happyMonadReduce 1# 26# happyReduction_162-happyReduction_162 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	( pragmaQName happy_var_1)}-	) (\r -> happyReturn (happyIn35 r))--happyReduce_163 = happyMonadReduce 1# 27# happyReduction_163-happyReduction_163 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut33 happy_x_1 of { happy_var_1 -> -	( mapM pragmaQName happy_var_1)}-	) (\r -> happyReturn (happyIn36 r))--happyReduce_164 = happySpecReduce_2  28# happyReduction_164-happyReduction_164 happy_x_2-	happy_x_1-	 =  case happyOut54 happy_x_1 of { happy_var_1 -> -	case happyOut37 happy_x_2 of { happy_var_2 -> -	happyIn37-		 (Pi happy_var_1 happy_var_2-	)}}--happyReduce_165 = happySpecReduce_3  28# happyReduction_165-happyReduction_165 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut43 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymArrow happy_var_2) -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn37-		 (Fun (getRange (happy_var_1,happy_var_2,happy_var_3))-                                              (RawApp (getRange happy_var_1) happy_var_1)-                                              happy_var_3-	)}}}--happyReduce_166 = happySpecReduce_3  28# happyReduction_166-happyReduction_166 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymEqual happy_var_2) -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn37-		 (Equal (getRange (happy_var_1, happy_var_2, happy_var_3)) happy_var_1 happy_var_3-	)}}}--happyReduce_167 = happySpecReduce_1  28# happyReduction_167-happyReduction_167 happy_x_1-	 =  case happyOut38 happy_x_1 of { happy_var_1 -> -	happyIn37-		 (happy_var_1-	)}--happyReduce_168 = happyMonadReduce 1# 29# happyReduction_168-happyReduction_168 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut39 happy_x_1 of { happy_var_1 -> -	( case happy_var_1 of-                      { [e]    -> return e-                      ; e : es -> return $ WithApp (fuseRange e es) e es-                      ; []     -> fail "impossible: empty with expressions"-                      })}-	) (\r -> happyReturn (happyIn38 r))--happyReduce_169 = happySpecReduce_3  30# happyReduction_169-happyReduction_169 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut43 happy_x_1 of { happy_var_1 -> -	case happyOut39 happy_x_3 of { happy_var_3 -> -	happyIn39-		 (RawApp (getRange happy_var_1) happy_var_1 :  happy_var_3-	)}}--happyReduce_170 = happySpecReduce_1  30# happyReduction_170-happyReduction_170 happy_x_1-	 =  case happyOut40 happy_x_1 of { happy_var_1 -> -	happyIn39-		 ([RawApp (getRange happy_var_1) happy_var_1]-	)}--happyReduce_171 = happySpecReduce_1  31# happyReduction_171-happyReduction_171 happy_x_1-	 =  case happyOut41 happy_x_1 of { happy_var_1 -> -	happyIn40-		 ([happy_var_1]-	)}--happyReduce_172 = happySpecReduce_2  31# happyReduction_172-happyReduction_172 happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	case happyOut40 happy_x_2 of { happy_var_2 -> -	happyIn40-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_173 = happySpecReduce_3  32# happyReduction_173-happyReduction_173 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> -	case happyOut60 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn41-		 (Lam (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 happy_var_3-	)}}}--happyReduce_174 = happySpecReduce_1  32# happyReduction_174-happyReduction_174 happy_x_1-	 =  case happyOut42 happy_x_1 of { happy_var_1 -> -	happyIn41-		 (happy_var_1-	)}--happyReduce_175 = happySpecReduce_3  32# happyReduction_175-happyReduction_175 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut68 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn41-		 (forallPi happy_var_2 happy_var_3-	)}}--happyReduce_176 = happyReduce 4# 32# happyReduction_176-happyReduction_176 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	happyIn41-		 (Let (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4-	) `HappyStk` happyRest}}}}--happyReduce_177 = happySpecReduce_1  32# happyReduction_177-happyReduction_177 happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	happyIn41-		 (happy_var_1-	)}--happyReduce_178 = happyReduce 4# 32# happyReduction_178-happyReduction_178 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	happyIn41-		 (QuoteGoal (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4-	) `HappyStk` happyRest}}}}--happyReduce_179 = happySpecReduce_2  32# happyReduction_179-happyReduction_179 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> -	case happyOut43 happy_x_2 of { happy_var_2 -> -	happyIn41-		 (Tactic (getRange (happy_var_1, happy_var_2)) (RawApp (getRange happy_var_2) happy_var_2) []-	)}}--happyReduce_180 = happyReduce 4# 32# happyReduction_180-happyReduction_180 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> -	case happyOut43 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymBar happy_var_3) -> -	case happyOut39 happy_x_4 of { happy_var_4 -> -	happyIn41-		 (Tactic (getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4)) (RawApp (getRange happy_var_2) happy_var_2) happy_var_4-	) `HappyStk` happyRest}}}}--happyReduce_181 = happyReduce 4# 33# happyReduction_181-happyReduction_181 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> -	case happyOut67 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> -	happyIn42-		 (ExtendedLam (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) (reverse happy_var_3)-	) `HappyStk` happyRest}}}}--happyReduce_182 = happyReduce 5# 33# happyReduction_182-happyReduction_182 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwWhere happy_var_2) -> -	case happyOut67 happy_x_4 of { happy_var_4 -> -	happyIn42-		 (ExtendedLam (getRange (happy_var_1, happy_var_2, happy_var_4)) (reverse happy_var_4)-	) `HappyStk` happyRest}}}--happyReduce_183 = happyMonadReduce 2# 33# happyReduction_183-happyReduction_183 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> -	case happyOut61 happy_x_2 of { happy_var_2 -> -	( case happy_var_2 of-                                       Left (bs, h) -> if null bs then return $ AbsurdLam r h else-                                                       return $ Lam r bs (AbsurdLam r h)-                                                         where r = fuseRange happy_var_1 bs-                                       Right es -> do -- it is of the form @\ { p1 ... () }@-                                                     p <- exprToLHS (RawApp (getRange es) es);-                                                     return $ ExtendedLam (fuseRange happy_var_1 es)-                                                                     [(p [] [], AbsurdRHS, NoWhere, False)])}}-	) (\r -> happyReturn (happyIn42 r))--happyReduce_184 = happySpecReduce_1  34# happyReduction_184-happyReduction_184 happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	happyIn43-		 ([happy_var_1]-	)}--happyReduce_185 = happySpecReduce_2  34# happyReduction_185-happyReduction_185 happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	case happyOut43 happy_x_2 of { happy_var_2 -> -	happyIn43-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_186 = happySpecReduce_3  35# happyReduction_186-happyReduction_186 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> -	case happyOut37 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> -	happyIn44-		 (HiddenArg (getRange (happy_var_1,happy_var_2,happy_var_3)) (maybeNamed happy_var_2)-	)}}}--happyReduce_187 = happySpecReduce_2  35# happyReduction_187-happyReduction_187 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> -	happyIn44-		 (let r = fuseRange happy_var_1 happy_var_2 in HiddenArg r $ unnamed $ Absurd r-	)}}--happyReduce_188 = happySpecReduce_1  36# happyReduction_188-happyReduction_188 happy_x_1-	 =  case happyOut24 happy_x_1 of { happy_var_1 -> -	happyIn45-		 (Ident happy_var_1-	)}--happyReduce_189 = happySpecReduce_1  36# happyReduction_189-happyReduction_189 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> -	happyIn45-		 (Lit happy_var_1-	)}--happyReduce_190 = happySpecReduce_1  36# happyReduction_190-happyReduction_190 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> -	happyIn45-		 (QuestionMark (getRange happy_var_1) Nothing-	)}--happyReduce_191 = happySpecReduce_1  36# happyReduction_191-happyReduction_191 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> -	happyIn45-		 (Underscore (getRange happy_var_1) Nothing-	)}--happyReduce_192 = happySpecReduce_1  36# happyReduction_192-happyReduction_192 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> -	happyIn45-		 (Prop (getRange happy_var_1)-	)}--happyReduce_193 = happySpecReduce_1  36# happyReduction_193-happyReduction_193 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> -	happyIn45-		 (Set (getRange happy_var_1)-	)}--happyReduce_194 = happySpecReduce_1  36# happyReduction_194-happyReduction_194 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> -	happyIn45-		 (Quote (getRange happy_var_1)-	)}--happyReduce_195 = happySpecReduce_1  36# happyReduction_195-happyReduction_195 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> -	happyIn45-		 (QuoteTerm (getRange happy_var_1)-	)}--happyReduce_196 = happySpecReduce_1  36# happyReduction_196-happyReduction_196 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> -	happyIn45-		 (QuoteContext (getRange happy_var_1)-	)}--happyReduce_197 = happySpecReduce_1  36# happyReduction_197-happyReduction_197 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> -	happyIn45-		 (Unquote (getRange happy_var_1)-	)}--happyReduce_198 = happySpecReduce_1  36# happyReduction_198-happyReduction_198 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> -	happyIn45-		 (SetN (getRange (fst happy_var_1)) (snd happy_var_1)-	)}--happyReduce_199 = happySpecReduce_3  36# happyReduction_199-happyReduction_199 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> -	case happyOut37 happy_x_2 of { happy_var_2 -> -	case happyOut20 happy_x_3 of { happy_var_3 -> -	happyIn45-		 (InstanceArg (getRange (happy_var_1,happy_var_2,happy_var_3))-                                                          (maybeNamed happy_var_2)-	)}}}--happyReduce_200 = happySpecReduce_3  36# happyReduction_200-happyReduction_200 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	case happyOut37 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> -	happyIn45-		 (Paren (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2-	)}}}--happyReduce_201 = happySpecReduce_3  36# happyReduction_201-happyReduction_201 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenIdiomBracket happy_var_1) -> -	case happyOut37 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseIdiomBracket happy_var_3) -> -	happyIn45-		 (IdiomBrackets (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2-	)}}}--happyReduce_202 = happySpecReduce_2  36# happyReduction_202-happyReduction_202 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymCloseParen happy_var_2) -> -	happyIn45-		 (Absurd (fuseRange happy_var_1 happy_var_2)-	)}}--happyReduce_203 = happySpecReduce_2  36# happyReduction_203-happyReduction_203 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> -	case happyOut20 happy_x_2 of { happy_var_2 -> -	happyIn45-		 (let r = fuseRange happy_var_1 happy_var_2 in InstanceArg r $ unnamed $ Absurd r-	)}}--happyReduce_204 = happySpecReduce_3  36# happyReduction_204-happyReduction_204 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymAs happy_var_2) -> -	case happyOut46 happy_x_3 of { happy_var_3 -> -	happyIn45-		 (As (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_1 happy_var_3-	)}}}--happyReduce_205 = happySpecReduce_2  36# happyReduction_205-happyReduction_205 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> -	case happyOut46 happy_x_2 of { happy_var_2 -> -	happyIn45-		 (Dot (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_206 = happyReduce 4# 36# happyReduction_206-happyReduction_206 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> -	case happyOut47 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> -	happyIn45-		 (Rec (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}}--happyReduce_207 = happyReduce 5# 36# happyReduction_207-happyReduction_207 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	case happyOut45 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymOpenBrace happy_var_3) -> -	case happyOut51 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymCloseBrace happy_var_5) -> -	happyIn45-		 (RecUpdate (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_4-	) `HappyStk` happyRest}}}}}--happyReduce_208 = happySpecReduce_1  37# happyReduction_208-happyReduction_208 happy_x_1-	 =  case happyOut44 happy_x_1 of { happy_var_1 -> -	happyIn46-		 (happy_var_1-	)}--happyReduce_209 = happySpecReduce_1  37# happyReduction_209-happyReduction_209 happy_x_1-	 =  case happyOut45 happy_x_1 of { happy_var_1 -> -	happyIn46-		 (happy_var_1-	)}--happyReduce_210 = happySpecReduce_0  38# happyReduction_210-happyReduction_210  =  happyIn47-		 ([]-	)--happyReduce_211 = happySpecReduce_1  38# happyReduction_211-happyReduction_211 happy_x_1-	 =  case happyOut48 happy_x_1 of { happy_var_1 -> -	happyIn47-		 (happy_var_1-	)}--happyReduce_212 = happySpecReduce_1  39# happyReduction_212-happyReduction_212 happy_x_1-	 =  case happyOut49 happy_x_1 of { happy_var_1 -> -	happyIn48-		 ([happy_var_1]-	)}--happyReduce_213 = happySpecReduce_3  39# happyReduction_213-happyReduction_213 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut49 happy_x_1 of { happy_var_1 -> -	case happyOut48 happy_x_3 of { happy_var_3 -> -	happyIn48-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_214 = happySpecReduce_1  40# happyReduction_214-happyReduction_214 happy_x_1-	 =  case happyOut53 happy_x_1 of { happy_var_1 -> -	happyIn49-		 (Left  happy_var_1-	)}--happyReduce_215 = happySpecReduce_1  40# happyReduction_215-happyReduction_215 happy_x_1-	 =  case happyOut50 happy_x_1 of { happy_var_1 -> -	happyIn49-		 (Right happy_var_1-	)}--happyReduce_216 = happySpecReduce_3  41# happyReduction_216-happyReduction_216 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { happy_var_1 -> -	case happyOut122 happy_x_2 of { happy_var_2 -> -	case happyOut73 happy_x_3 of { happy_var_3 -> -	happyIn50-		 (ModuleAssignment happy_var_1 happy_var_2 happy_var_3-	)}}}--happyReduce_217 = happySpecReduce_0  42# happyReduction_217-happyReduction_217  =  happyIn51-		 ([]-	)--happyReduce_218 = happySpecReduce_1  42# happyReduction_218-happyReduction_218 happy_x_1-	 =  case happyOut52 happy_x_1 of { happy_var_1 -> -	happyIn51-		 (happy_var_1-	)}--happyReduce_219 = happySpecReduce_1  43# happyReduction_219-happyReduction_219 happy_x_1-	 =  case happyOut53 happy_x_1 of { happy_var_1 -> -	happyIn52-		 ([happy_var_1]-	)}--happyReduce_220 = happySpecReduce_3  43# happyReduction_220-happyReduction_220 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut53 happy_x_1 of { happy_var_1 -> -	case happyOut52 happy_x_3 of { happy_var_3 -> -	happyIn52-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_221 = happySpecReduce_3  44# happyReduction_221-happyReduction_221 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn53-		 (FieldAssignment happy_var_1 happy_var_3-	)}}--happyReduce_222 = happySpecReduce_2  45# happyReduction_222-happyReduction_222 happy_x_2-	happy_x_1-	 =  case happyOut55 happy_x_1 of { happy_var_1 -> -	happyIn54-		 (happy_var_1-	)}--happyReduce_223 = happySpecReduce_1  46# happyReduction_223-happyReduction_223 happy_x_1-	 =  case happyOut56 happy_x_1 of { happy_var_1 -> -	happyIn55-		 ({-TeleBind-} happy_var_1-	)}--happyReduce_224 = happySpecReduce_2  47# happyReduction_224-happyReduction_224 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	case happyOut56 happy_x_2 of { happy_var_2 -> -	happyIn56-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_225 = happySpecReduce_1  47# happyReduction_225-happyReduction_225 happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	happyIn56-		 ([happy_var_1]-	)}--happyReduce_226 = happyReduce 4# 48# happyReduction_226-happyReduction_226 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOut59 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setRelevance Irrelevant happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_227 = happyReduce 4# 48# happyReduction_227-happyReduction_227 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> -	case happyOut58 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setHiding Hidden $-                             setRelevance Irrelevant happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_228 = happyReduce 4# 48# happyReduction_228-happyReduction_228 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> -	case happyOut58 happy_x_3 of { happy_var_3 -> -	case happyOut20 happy_x_4 of { happy_var_4 -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setHiding Instance $-                             setRelevance Irrelevant happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_229 = happyReduce 4# 48# happyReduction_229-happyReduction_229 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOut59 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setRelevance NonStrict happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_230 = happyReduce 4# 48# happyReduction_230-happyReduction_230 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> -	case happyOut58 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setHiding Hidden $-                             setRelevance NonStrict happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_231 = happyReduce 4# 48# happyReduction_231-happyReduction_231 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> -	case happyOut58 happy_x_3 of { happy_var_3 -> -	case happyOut20 happy_x_4 of { happy_var_4 -> -	happyIn57-		 (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $-                             setHiding Instance $-                             setRelevance NonStrict happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_232 = happySpecReduce_3  48# happyReduction_232-happyReduction_232 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	case happyOut59 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> -	happyIn57-		 (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2-	)}}}--happyReduce_233 = happySpecReduce_3  48# happyReduction_233-happyReduction_233 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> -	case happyOut58 happy_x_2 of { happy_var_2 -> -	case happyOut20 happy_x_3 of { happy_var_3 -> -	happyIn57-		 (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) $-                             setHiding Instance happy_var_2-	)}}}--happyReduce_234 = happySpecReduce_3  48# happyReduction_234-happyReduction_234 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> -	case happyOut58 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> -	happyIn57-		 (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) $-                             setHiding Hidden happy_var_2-	)}}}--happyReduce_235 = happySpecReduce_3  48# happyReduction_235-happyReduction_235 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	case happyOut121 happy_x_2 of { happy_var_2 -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> -	happyIn57-		 (tLet (getRange (happy_var_1,happy_var_3)) happy_var_2-	)}}}--happyReduce_236 = happyReduce 4# 48# happyReduction_236-happyReduction_236 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> -	case happyOut167 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn57-		 (tLet (getRange (happy_var_1,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_237 = happySpecReduce_3  49# happyReduction_237-happyReduction_237 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut28 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymColon happy_var_2) -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn58-		 (let r = getRange (happy_var_1,happy_var_2,happy_var_3) -- the range is approximate only for TypedBindings-    in TypedBindings r $ defaultArg $ TBind r (map (pure . mkBoundName_) happy_var_1) happy_var_3-	)}}}--happyReduce_238 = happySpecReduce_3  50# happyReduction_238-happyReduction_238 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut30 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymColon happy_var_2) -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn59-		 (let r = getRange (happy_var_1,happy_var_2,happy_var_3) -- the range is approximate only for TypedBindings-    in TypedBindings r $ defaultArg $ TBind r (map (fmap mkBoundName_) happy_var_1) happy_var_3-	)}}}--happyReduce_239 = happyMonadReduce 2# 51# happyReduction_239-happyReduction_239 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> -	(-      case reverse happy_var_1 of-        Left _ : _ -> parseError "Absurd lambda cannot have a body."-        _ : _      -> return [ b | Right b <- happy_var_1 ]-        []         -> parsePanic "Empty LamBinds")}-	) (\r -> happyReturn (happyIn60 r))--happyReduce_240 = happyMonadReduce 1# 52# happyReduction_240-happyReduction_240 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut63 happy_x_1 of { happy_var_1 -> -	(-    case happy_var_1 of-      Left lb -> case reverse lb of-                   Right _ : _ -> parseError "Missing body for lambda"-                   Left h  : _ -> return $ Left ([ b | Right b <- init lb], h)-                   _           -> parseError "Unsupported variant of lambda"-      Right es -> return $ Right es)}-	) (\r -> happyReturn (happyIn61 r))--happyReduce_241 = happySpecReduce_2  53# happyReduction_241-happyReduction_241 happy_x_2-	happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	case happyOut62 happy_x_2 of { happy_var_2 -> -	happyIn62-		 (map Right happy_var_1 ++ happy_var_2-	)}}--happyReduce_242 = happySpecReduce_2  53# happyReduction_242-happyReduction_242 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	case happyOut62 happy_x_2 of { happy_var_2 -> -	happyIn62-		 (Right (DomainFull happy_var_1) : happy_var_2-	)}}--happyReduce_243 = happySpecReduce_1  53# happyReduction_243-happyReduction_243 happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	happyIn62-		 (map Right happy_var_1-	)}--happyReduce_244 = happySpecReduce_1  53# happyReduction_244-happyReduction_244 happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	happyIn62-		 ([Right $ DomainFull happy_var_1]-	)}--happyReduce_245 = happySpecReduce_2  53# happyReduction_245-happyReduction_245 happy_x_2-	happy_x_1-	 =  happyIn62-		 ([Left NotHidden]-	)--happyReduce_246 = happySpecReduce_2  53# happyReduction_246-happyReduction_246 happy_x_2-	happy_x_1-	 =  happyIn62-		 ([Left Hidden]-	)--happyReduce_247 = happySpecReduce_2  53# happyReduction_247-happyReduction_247 happy_x_2-	happy_x_1-	 =  happyIn62-		 ([Left Instance]-	)--happyReduce_248 = happySpecReduce_2  54# happyReduction_248-happyReduction_248 happy_x_2-	happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	case happyOut62 happy_x_2 of { happy_var_2 -> -	happyIn63-		 (Left $ map Right happy_var_1 ++ happy_var_2-	)}}--happyReduce_249 = happySpecReduce_2  54# happyReduction_249-happyReduction_249 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	case happyOut62 happy_x_2 of { happy_var_2 -> -	happyIn63-		 (Left $ Right (DomainFull happy_var_1) : happy_var_2-	)}}--happyReduce_250 = happySpecReduce_1  54# happyReduction_250-happyReduction_250 happy_x_1-	 =  case happyOut72 happy_x_1 of { happy_var_1 -> -	happyIn63-		 (case happy_var_1 of-                                    Left lb -> Left $ map Right lb-                                    Right es -> Right es-	)}--happyReduce_251 = happySpecReduce_1  54# happyReduction_251-happyReduction_251 happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	happyIn63-		 (Left [Right $ DomainFull happy_var_1]-	)}--happyReduce_252 = happySpecReduce_2  54# happyReduction_252-happyReduction_252 happy_x_2-	happy_x_1-	 =  happyIn63-		 (Left [Left NotHidden]-	)--happyReduce_253 = happySpecReduce_2  54# happyReduction_253-happyReduction_253 happy_x_2-	happy_x_1-	 =  happyIn63-		 (Left [Left Hidden]-	)--happyReduce_254 = happySpecReduce_2  54# happyReduction_254-happyReduction_254 happy_x_2-	happy_x_1-	 =  happyIn63-		 (Left [Left Instance]-	)--happyReduce_255 = happyMonadReduce 3# 55# happyReduction_255-happyReduction_255 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut43 happy_x_1 of { happy_var_1 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	( do-      p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1) ;-      return (p [] [], RHS happy_var_3, NoWhere, False))}}-	) (\r -> happyReturn (happyIn64 r))--happyReduce_256 = happyMonadReduce 4# 55# happyReduction_256-happyReduction_256 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut43 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	( do-      p <- exprToLHS (RawApp (getRange happy_var_2) happy_var_2) ;-      return (p [] [], RHS happy_var_4, NoWhere, True))}}-	) (\r -> happyReturn (happyIn64 r))--happyReduce_257 = happyMonadReduce 1# 56# happyReduction_257-happyReduction_257 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> -	( do-      p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1);-      return (p [] [], AbsurdRHS, NoWhere, False))}-	) (\r -> happyReturn (happyIn65 r))--happyReduce_258 = happyMonadReduce 2# 56# happyReduction_258-happyReduction_258 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut40 happy_x_2 of { happy_var_2 -> -	( do-      p <- exprToLHS (RawApp (getRange happy_var_2) happy_var_2);-      return (p [] [], AbsurdRHS, NoWhere, True))}-	) (\r -> happyReturn (happyIn65 r))--happyReduce_259 = happySpecReduce_1  57# happyReduction_259-happyReduction_259 happy_x_1-	 =  case happyOut64 happy_x_1 of { happy_var_1 -> -	happyIn66-		 (happy_var_1-	)}--happyReduce_260 = happySpecReduce_1  57# happyReduction_260-happyReduction_260 happy_x_1-	 =  case happyOut65 happy_x_1 of { happy_var_1 -> -	happyIn66-		 (happy_var_1-	)}--happyReduce_261 = happySpecReduce_3  58# happyReduction_261-happyReduction_261 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut67 happy_x_1 of { happy_var_1 -> -	case happyOut66 happy_x_3 of { happy_var_3 -> -	happyIn67-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_262 = happySpecReduce_3  58# happyReduction_262-happyReduction_262 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut65 happy_x_1 of { happy_var_1 -> -	case happyOut66 happy_x_3 of { happy_var_3 -> -	happyIn67-		 ([happy_var_3, happy_var_1]-	)}}--happyReduce_263 = happySpecReduce_1  58# happyReduction_263-happyReduction_263 happy_x_1-	 =  case happyOut64 happy_x_1 of { happy_var_1 -> -	happyIn67-		 ([happy_var_1]-	)}--happyReduce_264 = happySpecReduce_2  59# happyReduction_264-happyReduction_264 happy_x_2-	happy_x_1-	 =  case happyOut69 happy_x_1 of { happy_var_1 -> -	happyIn68-		 (happy_var_1-	)}--happyReduce_265 = happySpecReduce_2  60# happyReduction_265-happyReduction_265 happy_x_2-	happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	case happyOut69 happy_x_2 of { happy_var_2 -> -	happyIn69-		 (happy_var_1 ++ happy_var_2-	)}}--happyReduce_266 = happySpecReduce_2  60# happyReduction_266-happyReduction_266 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	case happyOut69 happy_x_2 of { happy_var_2 -> -	happyIn69-		 (DomainFull happy_var_1 : happy_var_2-	)}}--happyReduce_267 = happySpecReduce_1  60# happyReduction_267-happyReduction_267 happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	happyIn69-		 (happy_var_1-	)}--happyReduce_268 = happySpecReduce_1  60# happyReduction_268-happyReduction_268 happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	happyIn69-		 ([DomainFull happy_var_1]-	)}--happyReduce_269 = happySpecReduce_2  61# happyReduction_269-happyReduction_269 happy_x_2-	happy_x_1-	 =  case happyOut71 happy_x_1 of { happy_var_1 -> -	case happyOut70 happy_x_2 of { happy_var_2 -> -	happyIn70-		 (happy_var_1 ++ happy_var_2-	)}}--happyReduce_270 = happySpecReduce_2  61# happyReduction_270-happyReduction_270 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { happy_var_1 -> -	case happyOut70 happy_x_2 of { happy_var_2 -> -	happyIn70-		 (DomainFull happy_var_1 : happy_var_2-	)}}--happyReduce_271 = happySpecReduce_0  61# happyReduction_271-happyReduction_271  =  happyIn70-		 ([]-	)--happyReduce_272 = happySpecReduce_1  62# happyReduction_272-happyReduction_272 happy_x_1-	 =  case happyOut72 happy_x_1 of { happy_var_1 -> -	happyIn71-		 (case happy_var_1 of-                             Left lbs -> lbs-                             Right _ -> fail "expected sequence of bound identifiers, not absurd pattern"-	)}--happyReduce_273 = happySpecReduce_1  63# happyReduction_273-happyReduction_273 happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	happyIn72-		 (Left [DomainFree defaultArgInfo $ mkBoundName_ happy_var_1]-	)}--happyReduce_274 = happySpecReduce_2  63# happyReduction_274-happyReduction_274 happy_x_2-	happy_x_1-	 =  case happyOut26 happy_x_2 of { happy_var_2 -> -	happyIn72-		 (Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ happy_var_2]-	)}--happyReduce_275 = happySpecReduce_2  63# happyReduction_275-happyReduction_275 happy_x_2-	happy_x_1-	 =  case happyOut26 happy_x_2 of { happy_var_2 -> -	happyIn72-		 (Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ happy_var_2]-	)}--happyReduce_276 = happySpecReduce_3  63# happyReduction_276-happyReduction_276 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut29 happy_x_2 of { happy_var_2 -> -	happyIn72-		 (mapLeft (map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) happy_var_2-	)}--happyReduce_277 = happySpecReduce_3  63# happyReduction_277-happyReduction_277 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut28 happy_x_2 of { happy_var_2 -> -	happyIn72-		 (Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) happy_var_2-	)}--happyReduce_278 = happyReduce 4# 63# happyReduction_278-happyReduction_278 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut28 happy_x_3 of { happy_var_3 -> -	happyIn72-		 (Left $ map (DomainFree (setHiding Hidden $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3-	) `HappyStk` happyRest}--happyReduce_279 = happyReduce 4# 63# happyReduction_279-happyReduction_279 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut28 happy_x_3 of { happy_var_3 -> -	happyIn72-		 (Left $ map (DomainFree (setHiding Instance $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3-	) `HappyStk` happyRest}--happyReduce_280 = happyReduce 4# 63# happyReduction_280-happyReduction_280 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut28 happy_x_3 of { happy_var_3 -> -	happyIn72-		 (Left $ map (DomainFree (setHiding Hidden $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3-	) `HappyStk` happyRest}--happyReduce_281 = happyReduce 4# 63# happyReduction_281-happyReduction_281 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut28 happy_x_3 of { happy_var_3 -> -	happyIn72-		 (Left $ map (DomainFree  (setHiding Instance $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3-	) `HappyStk` happyRest}--happyReduce_282 = happyMonadReduce 1# 64# happyReduction_282-happyReduction_282 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut74 happy_x_1 of { happy_var_1 -> -	( mergeImportDirectives happy_var_1)}-	) (\r -> happyReturn (happyIn73 r))--happyReduce_283 = happySpecReduce_2  65# happyReduction_283-happyReduction_283 happy_x_2-	happy_x_1-	 =  case happyOut75 happy_x_1 of { happy_var_1 -> -	case happyOut74 happy_x_2 of { happy_var_2 -> -	happyIn74-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_284 = happySpecReduce_0  65# happyReduction_284-happyReduction_284  =  happyIn74-		 ([]-	)--happyReduce_285 = happySpecReduce_1  66# happyReduction_285-happyReduction_285 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> -	happyIn75-		 (defaultImportDir { importDirRange = getRange happy_var_1, publicOpen = True }-	)}--happyReduce_286 = happySpecReduce_1  66# happyReduction_286-happyReduction_286 happy_x_1-	 =  case happyOut76 happy_x_1 of { happy_var_1 -> -	happyIn75-		 (defaultImportDir { importDirRange = snd happy_var_1, using    = fst happy_var_1 }-	)}--happyReduce_287 = happySpecReduce_1  66# happyReduction_287-happyReduction_287 happy_x_1-	 =  case happyOut77 happy_x_1 of { happy_var_1 -> -	happyIn75-		 (defaultImportDir { importDirRange = snd happy_var_1, hiding   = fst happy_var_1 }-	)}--happyReduce_288 = happySpecReduce_1  66# happyReduction_288-happyReduction_288 happy_x_1-	 =  case happyOut78 happy_x_1 of { happy_var_1 -> -	happyIn75-		 (defaultImportDir { importDirRange = snd happy_var_1, impRenaming = fst happy_var_1 }-	)}--happyReduce_289 = happyReduce 4# 67# happyReduction_289-happyReduction_289 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOut83 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn76-		 ((Using happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))-	) `HappyStk` happyRest}}}}--happyReduce_290 = happyReduce 4# 68# happyReduction_290-happyReduction_290 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOut83 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn77-		 ((happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))-	) `HappyStk` happyRest}}}}--happyReduce_291 = happyReduce 4# 69# happyReduction_291-happyReduction_291 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOut79 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> -	happyIn78-		 ((happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))-	) `HappyStk` happyRest}}}}--happyReduce_292 = happySpecReduce_3  69# happyReduction_292-happyReduction_292 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> -	happyIn78-		 (([] , getRange (happy_var_1,happy_var_2,happy_var_3))-	)}}}--happyReduce_293 = happySpecReduce_3  70# happyReduction_293-happyReduction_293 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut80 happy_x_1 of { happy_var_1 -> -	case happyOut79 happy_x_3 of { happy_var_3 -> -	happyIn79-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_294 = happySpecReduce_1  70# happyReduction_294-happyReduction_294 happy_x_1-	 =  case happyOut80 happy_x_1 of { happy_var_1 -> -	happyIn79-		 ([happy_var_1]-	)}--happyReduce_295 = happySpecReduce_3  71# happyReduction_295-happyReduction_295 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut81 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokKeyword KwTo happy_var_2) -> -	case happyOut18 happy_x_3 of { happy_var_3 -> -	happyIn80-		 (Renaming happy_var_1 (setImportedName happy_var_1 happy_var_3) (getRange happy_var_2)-	)}}}--happyReduce_296 = happySpecReduce_2  72# happyReduction_296-happyReduction_296 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn81-		 (ImportedName happy_var_2-	)}--happyReduce_297 = happySpecReduce_3  72# happyReduction_297-happyReduction_297 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_3 of { happy_var_3 -> -	happyIn81-		 (ImportedModule happy_var_3-	)}--happyReduce_298 = happySpecReduce_1  73# happyReduction_298-happyReduction_298 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn82-		 (ImportedName happy_var_1-	)}--happyReduce_299 = happySpecReduce_2  73# happyReduction_299-happyReduction_299 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn82-		 (ImportedModule happy_var_2-	)}--happyReduce_300 = happySpecReduce_0  74# happyReduction_300-happyReduction_300  =  happyIn83-		 ([]-	)--happyReduce_301 = happySpecReduce_1  74# happyReduction_301-happyReduction_301 happy_x_1-	 =  case happyOut84 happy_x_1 of { happy_var_1 -> -	happyIn83-		 (happy_var_1-	)}--happyReduce_302 = happySpecReduce_1  75# happyReduction_302-happyReduction_302 happy_x_1-	 =  case happyOut82 happy_x_1 of { happy_var_1 -> -	happyIn84-		 ([happy_var_1]-	)}--happyReduce_303 = happySpecReduce_3  75# happyReduction_303-happyReduction_303 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut82 happy_x_1 of { happy_var_1 -> -	case happyOut84 happy_x_3 of { happy_var_3 -> -	happyIn84-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_304 = happyMonadReduce 3# 76# happyReduction_304-happyReduction_304 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut38 happy_x_1 of { happy_var_1 -> -	case happyOut88 happy_x_2 of { happy_var_2 -> -	case happyOut87 happy_x_3 of { happy_var_3 -> -	( exprToLHS happy_var_1 >>= \p -> return (p happy_var_2 happy_var_3))}}}-	) (\r -> happyReturn (happyIn85 r))--happyReduce_305 = happyReduce 4# 76# happyReduction_305-happyReduction_305 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> -	case happyOut86 happy_x_2 of { happy_var_2 -> -	case happyOut88 happy_x_3 of { happy_var_3 -> -	case happyOut87 happy_x_4 of { happy_var_4 -> -	happyIn85-		 (Ellipsis (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_3 happy_var_4-	) `HappyStk` happyRest}}}}--happyReduce_306 = happySpecReduce_0  77# happyReduction_306-happyReduction_306  =  happyIn86-		 ([]-	)--happyReduce_307 = happyMonadReduce 3# 77# happyReduction_307-happyReduction_307 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut43 happy_x_2 of { happy_var_2 -> -	case happyOut86 happy_x_3 of { happy_var_3 -> -	( exprToPattern (RawApp (getRange happy_var_2) happy_var_2) >>= \p ->-                   return (p : happy_var_3))}}-	) (\r -> happyReturn (happyIn86 r))--happyReduce_308 = happySpecReduce_0  78# happyReduction_308-happyReduction_308  =  happyIn87-		 ([]-	)--happyReduce_309 = happySpecReduce_2  78# happyReduction_309-happyReduction_309 happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_2 of { happy_var_2 -> -	happyIn87-		 (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] }-	)}--happyReduce_310 = happySpecReduce_0  79# happyReduction_310-happyReduction_310  =  happyIn88-		 ([]-	)--happyReduce_311 = happySpecReduce_2  79# happyReduction_311-happyReduction_311 happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { happy_var_2 -> -	happyIn88-		 (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] }-	)}--happyReduce_312 = happySpecReduce_0  80# happyReduction_312-happyReduction_312  =  happyIn89-		 (NoWhere-	)--happyReduce_313 = happySpecReduce_2  80# happyReduction_313-happyReduction_313 happy_x_2-	happy_x_1-	 =  case happyOut168 happy_x_2 of { happy_var_2 -> -	happyIn89-		 (AnyWhere happy_var_2-	)}--happyReduce_314 = happyReduce 4# 80# happyReduction_314-happyReduction_314 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut168 happy_x_4 of { happy_var_4 -> -	happyIn89-		 (SomeWhere happy_var_2 PublicAccess happy_var_4-	) `HappyStk` happyRest}}--happyReduce_315 = happyReduce 4# 80# happyReduction_315-happyReduction_315 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut126 happy_x_2 of { happy_var_2 -> -	case happyOut168 happy_x_4 of { happy_var_4 -> -	happyIn89-		 (SomeWhere happy_var_2 PublicAccess happy_var_4-	) `HappyStk` happyRest}}--happyReduce_316 = happySpecReduce_2  81# happyReduction_316-happyReduction_316 happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_1 of { happy_var_1 -> -	case happyOut89 happy_x_2 of { happy_var_2 -> -	happyIn90-		 (ExprWhere happy_var_1 happy_var_2-	)}}--happyReduce_317 = happySpecReduce_1  82# happyReduction_317-happyReduction_317 happy_x_1-	 =  case happyOut102 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (happy_var_1-	)}--happyReduce_318 = happySpecReduce_1  82# happyReduction_318-happyReduction_318 happy_x_1-	 =  case happyOut94 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (happy_var_1-	)}--happyReduce_319 = happySpecReduce_1  82# happyReduction_319-happyReduction_319 happy_x_1-	 =  case happyOut96 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_320 = happySpecReduce_1  82# happyReduction_320-happyReduction_320 happy_x_1-	 =  case happyOut97 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_321 = happySpecReduce_1  82# happyReduction_321-happyReduction_321 happy_x_1-	 =  case happyOut98 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_322 = happySpecReduce_1  82# happyReduction_322-happyReduction_322 happy_x_1-	 =  case happyOut99 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_323 = happySpecReduce_1  82# happyReduction_323-happyReduction_323 happy_x_1-	 =  case happyOut101 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_324 = happySpecReduce_1  82# happyReduction_324-happyReduction_324 happy_x_1-	 =  case happyOut103 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_325 = happySpecReduce_1  82# happyReduction_325-happyReduction_325 happy_x_1-	 =  case happyOut104 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_326 = happySpecReduce_1  82# happyReduction_326-happyReduction_326 happy_x_1-	 =  case happyOut105 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_327 = happySpecReduce_1  82# happyReduction_327-happyReduction_327 happy_x_1-	 =  case happyOut106 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_328 = happySpecReduce_1  82# happyReduction_328-happyReduction_328 happy_x_1-	 =  case happyOut107 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_329 = happySpecReduce_1  82# happyReduction_329-happyReduction_329 happy_x_1-	 =  case happyOut108 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_330 = happySpecReduce_1  82# happyReduction_330-happyReduction_330 happy_x_1-	 =  case happyOut109 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_331 = happySpecReduce_1  82# happyReduction_331-happyReduction_331 happy_x_1-	 =  case happyOut121 happy_x_1 of { happy_var_1 -> -	happyIn91-		 (happy_var_1-	)}--happyReduce_332 = happySpecReduce_1  82# happyReduction_332-happyReduction_332 happy_x_1-	 =  case happyOut124 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_333 = happySpecReduce_1  82# happyReduction_333-happyReduction_333 happy_x_1-	 =  case happyOut125 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_334 = happySpecReduce_1  82# happyReduction_334-happyReduction_334 happy_x_1-	 =  case happyOut128 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_335 = happySpecReduce_1  82# happyReduction_335-happyReduction_335 happy_x_1-	 =  case happyOut111 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_336 = happySpecReduce_1  82# happyReduction_336-happyReduction_336 happy_x_1-	 =  case happyOut112 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_337 = happySpecReduce_1  82# happyReduction_337-happyReduction_337 happy_x_1-	 =  case happyOut110 happy_x_1 of { happy_var_1 -> -	happyIn91-		 ([happy_var_1]-	)}--happyReduce_338 = happySpecReduce_3  83# happyReduction_338-happyReduction_338 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut19 happy_x_1 of { happy_var_1 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn92-		 (map (\ x -> TypeSig defaultArgInfo x happy_var_3) happy_var_1-	)}}--happyReduce_339 = happySpecReduce_3  84# happyReduction_339-happyReduction_339 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut23 happy_x_1 of { happy_var_1 -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn93-		 (map (fmap (\ x -> TypeSig defaultArgInfo x happy_var_3)) happy_var_1-	)}}--happyReduce_340 = happyReduce 4# 84# happyReduction_340-happyReduction_340 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut23 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	happyIn93-		 (let setOverlap (Arg i x) = Arg i{ argInfoOverlappable = True } x in-      map (setOverlap . fmap (\ x -> TypeSig defaultArgInfo x happy_var_4)) happy_var_2-	) `HappyStk` happyRest}}--happyReduce_341 = happySpecReduce_2  84# happyReduction_341-happyReduction_341 happy_x_2-	happy_x_1-	 =  case happyOut160 happy_x_2 of { happy_var_2 -> -	happyIn93-		 (let-      setInstance (TypeSig info x t) = TypeSig (setHiding Instance info) x t-      setInstance _ = __IMPOSSIBLE__ in-    map (fmap setInstance) happy_var_2-	)}--happyReduce_342 = happyMonadReduce 3# 85# happyReduction_342-happyReduction_342 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut85 happy_x_1 of { happy_var_1 -> -	case happyOut95 happy_x_2 of { happy_var_2 -> -	case happyOut89 happy_x_3 of { happy_var_3 -> -	( funClauseOrTypeSigs happy_var_1 happy_var_2 happy_var_3)}}}-	) (\r -> happyReturn (happyIn94 r))--happyReduce_343 = happySpecReduce_2  86# happyReduction_343-happyReduction_343 happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_2 of { happy_var_2 -> -	happyIn95-		 (JustRHS (RHS happy_var_2)-	)}--happyReduce_344 = happySpecReduce_2  86# happyReduction_344-happyReduction_344 happy_x_2-	happy_x_1-	 =  case happyOut37 happy_x_2 of { happy_var_2 -> -	happyIn95-		 (TypeSigsRHS happy_var_2-	)}--happyReduce_345 = happySpecReduce_0  86# happyReduction_345-happyReduction_345  =  happyIn95-		 (JustRHS AbsurdRHS-	)--happyReduce_346 = happyReduce 7# 87# happyReduction_346-happyReduction_346 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> -	case happyOut168 happy_x_7 of { happy_var_7 -> -	happyIn96-		 (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) Inductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7-	) `HappyStk` happyRest}}}}}}}--happyReduce_347 = happyReduce 7# 87# happyReduction_347-happyReduction_347 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> -	case happyOut168 happy_x_7 of { happy_var_7 -> -	happyIn96-		 (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) CoInductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7-	) `HappyStk` happyRest}}}}}}}--happyReduce_348 = happyReduce 5# 87# happyReduction_348-happyReduction_348 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> -	case happyOut168 happy_x_5 of { happy_var_5 -> -	happyIn96-		 (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 Nothing happy_var_5-	) `HappyStk` happyRest}}}}}--happyReduce_349 = happyReduce 5# 87# happyReduction_349-happyReduction_349 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> -	case happyOut168 happy_x_5 of { happy_var_5 -> -	happyIn96-		 (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) CoInductive happy_var_2 happy_var_3 Nothing happy_var_5-	) `HappyStk` happyRest}}}}}--happyReduce_350 = happyReduce 5# 88# happyReduction_350-happyReduction_350 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	happyIn97-		 (DataSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 happy_var_5-	) `HappyStk` happyRest}}}}}--happyReduce_351 = happyMonadReduce 7# 89# happyReduction_351-happyReduction_351 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	case happyOut45 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> -	case happyOut162 happy_x_7 of { happy_var_7 -> -	( exprToName happy_var_2 >>= \ n -> let ((x,y,z),ds) = happy_var_7 in return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) n x y z happy_var_3 (Just happy_var_5) ds)}}}}}}}-	) (\r -> happyReturn (happyIn98 r))--happyReduce_352 = happyMonadReduce 5# 89# happyReduction_352-happyReduction_352 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	case happyOut45 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> -	case happyOut162 happy_x_5 of { happy_var_5 -> -	( exprToName happy_var_2 >>= \ n -> let ((x,y,z),ds) = happy_var_5 in return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n x y z happy_var_3 Nothing ds)}}}}}-	) (\r -> happyReturn (happyIn98 r))--happyReduce_353 = happyMonadReduce 5# 90# happyReduction_353-happyReduction_353 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> -	case happyOut45 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	( exprToName happy_var_2 >>= \ n -> return $ RecordSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n happy_var_3 happy_var_5)}}}}}-	) (\r -> happyReturn (happyIn99 r))--happyReduce_354 = happySpecReduce_2  91# happyReduction_354-happyReduction_354 happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn100-		 ((happy_var_2, NotInstanceDef)-	)}--happyReduce_355 = happyReduce 5# 91# happyReduction_355-happyReduction_355 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut18 happy_x_4 of { happy_var_4 -> -	happyIn100-		 ((happy_var_4, InstanceDef)-	) `HappyStk` happyRest}--happyReduce_356 = happySpecReduce_3  92# happyReduction_356-happyReduction_356 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> -	case happyOut17 happy_x_2 of { happy_var_2 -> -	case happyOut27 happy_x_3 of { happy_var_3 -> -	happyIn101-		 (Infix (Fixity (getRange (happy_var_1,happy_var_3)) (Related happy_var_2) NonAssoc)   happy_var_3-	)}}}--happyReduce_357 = happySpecReduce_3  92# happyReduction_357-happyReduction_357 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> -	case happyOut17 happy_x_2 of { happy_var_2 -> -	case happyOut27 happy_x_3 of { happy_var_3 -> -	happyIn101-		 (Infix (Fixity (getRange (happy_var_1,happy_var_3)) (Related happy_var_2) LeftAssoc)  happy_var_3-	)}}}--happyReduce_358 = happySpecReduce_3  92# happyReduction_358-happyReduction_358 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> -	case happyOut17 happy_x_2 of { happy_var_2 -> -	case happyOut27 happy_x_3 of { happy_var_3 -> -	happyIn101-		 (Infix (Fixity (getRange (happy_var_1,happy_var_3)) (Related happy_var_2) RightAssoc) happy_var_3-	)}}}--happyReduce_359 = happySpecReduce_2  93# happyReduction_359-happyReduction_359 happy_x_2-	happy_x_1-	 =  case happyOut160 happy_x_2 of { happy_var_2 -> -	happyIn102-		 (let-                inst i | getHiding i == Instance = InstanceDef-                       | otherwise               = NotInstanceDef-                toField (Arg info (TypeSig info' x t)) = Field (inst info') x (Arg info t)-              in map toField happy_var_2-	)}--happyReduce_360 = happySpecReduce_2  94# happyReduction_360-happyReduction_360 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn103-		 (Mutual (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_361 = happySpecReduce_2  95# happyReduction_361-happyReduction_361 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn104-		 (Abstract (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_362 = happySpecReduce_2  96# happyReduction_362-happyReduction_362 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn105-		 (Private (fuseRange happy_var_1 happy_var_2) UserWritten happy_var_2-	)}}--happyReduce_363 = happySpecReduce_2  97# happyReduction_363-happyReduction_363 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn106-		 (InstanceB (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_364 = happySpecReduce_2  98# happyReduction_364-happyReduction_364 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwMacro happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn107-		 (Macro (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_365 = happySpecReduce_2  99# happyReduction_365-happyReduction_365 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> -	case happyOut167 happy_x_2 of { happy_var_2 -> -	happyIn108-		 (Postulate (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_366 = happySpecReduce_2  100# happyReduction_366-happyReduction_366 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> -	case happyOut158 happy_x_2 of { happy_var_2 -> -	happyIn109-		 (Primitive (fuseRange happy_var_1 happy_var_2) happy_var_2-	)}}--happyReduce_367 = happySpecReduce_3  101# happyReduction_367-happyReduction_367 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> -	case happyOut37 happy_x_3 of { happy_var_3 -> -	happyIn110-		 (UnquoteDecl (fuseRange happy_var_1 happy_var_3) [] happy_var_3-	)}}--happyReduce_368 = happyReduce 4# 101# happyReduction_368-happyReduction_368 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> -	case happyOut19 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	happyIn110-		 (UnquoteDecl (fuseRange happy_var_1 happy_var_4) happy_var_2 happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_369 = happyReduce 4# 101# happyReduction_369-happyReduction_369 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDef happy_var_1) -> -	case happyOut19 happy_x_2 of { happy_var_2 -> -	case happyOut37 happy_x_4 of { happy_var_4 -> -	happyIn110-		 (UnquoteDef (fuseRange happy_var_1 happy_var_4) happy_var_2 happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_370 = happyMonadReduce 5# 102# happyReduction_370-happyReduction_370 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut115 happy_x_3 of { happy_var_3 -> -	case happyOut114 happy_x_5 of { happy_var_5 -> -	(-  case happy_var_2 of-    Name _ [_] -> case mkNotation happy_var_3 (map rangedThing happy_var_5) of-      Left err -> parseError $ "Malformed syntax declaration: " ++ err-      Right n -> return $ Syntax happy_var_2 n-    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)")}}}-	) (\r -> happyReturn (happyIn111 r))--happyReduce_371 = happyMonadReduce 5# 103# happyReduction_371-happyReduction_371 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	case happyOut113 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymEqual happy_var_4) -> -	case happyOut37 happy_x_5 of { happy_var_5 -> -	( do-  p <- exprToPattern happy_var_5-  return (PatternSyn (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_3 p))}}}}}-	) (\r -> happyReturn (happyIn112 r))--happyReduce_372 = happySpecReduce_0  104# happyReduction_372-happyReduction_372  =  happyIn113-		 ([]-	)--happyReduce_373 = happyMonadReduce 1# 104# happyReduction_373-happyReduction_373 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut62 happy_x_1 of { happy_var_1 -> -	( patternSynArgs happy_var_1)}-	) (\r -> happyReturn (happyIn113 r))--happyReduce_374 = happySpecReduce_1  105# happyReduction_374-happyReduction_374 happy_x_1-	 =  case happyOut119 happy_x_1 of { happy_var_1 -> -	happyIn114-		 ([happy_var_1]-	)}--happyReduce_375 = happySpecReduce_2  105# happyReduction_375-happyReduction_375 happy_x_2-	happy_x_1-	 =  case happyOut114 happy_x_1 of { happy_var_1 -> -	case happyOut119 happy_x_2 of { happy_var_2 -> -	happyIn114-		 (happy_var_1 ++ [happy_var_2]-	)}}--happyReduce_376 = happySpecReduce_1  106# happyReduction_376-happyReduction_376 happy_x_1-	 =  case happyOut116 happy_x_1 of { happy_var_1 -> -	happyIn115-		 ([happy_var_1]-	)}--happyReduce_377 = happySpecReduce_2  106# happyReduction_377-happyReduction_377 happy_x_2-	happy_x_1-	 =  case happyOut115 happy_x_1 of { happy_var_1 -> -	case happyOut116 happy_x_2 of { happy_var_2 -> -	happyIn115-		 (happy_var_1 ++ [happy_var_2]-	)}}--happyReduce_378 = happySpecReduce_1  107# happyReduction_378-happyReduction_378 happy_x_1-	 =  case happyOut117 happy_x_1 of { happy_var_1 -> -	happyIn116-		 (defaultNamedArg happy_var_1-	)}--happyReduce_379 = happySpecReduce_3  107# happyReduction_379-happyReduction_379 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut118 happy_x_2 of { happy_var_2 -> -	happyIn116-		 (setHiding Hidden   $ defaultNamedArg happy_var_2-	)}--happyReduce_380 = happySpecReduce_3  107# happyReduction_380-happyReduction_380 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut118 happy_x_2 of { happy_var_2 -> -	happyIn116-		 (setHiding Instance $ defaultNamedArg happy_var_2-	)}--happyReduce_381 = happyReduce 5# 107# happyReduction_381-happyReduction_381 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_2 of { happy_var_2 -> -	case happyOut118 happy_x_4 of { happy_var_4 -> -	happyIn116-		 (setHiding Hidden   $ defaultArg $ named happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_382 = happyReduce 5# 107# happyReduction_382-happyReduction_382 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_2 of { happy_var_2 -> -	case happyOut118 happy_x_4 of { happy_var_4 -> -	happyIn116-		 (setHiding Instance $ defaultArg $ named happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_383 = happySpecReduce_1  108# happyReduction_383-happyReduction_383 happy_x_1-	 =  case happyOut119 happy_x_1 of { happy_var_1 -> -	happyIn117-		 (ExprHole (rangedThing happy_var_1)-	)}--happyReduce_384 = happyReduce 6# 108# happyReduction_384-happyReduction_384 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_3 of { happy_var_3 -> -	case happyOut119 happy_x_5 of { happy_var_5 -> -	happyIn117-		 (LambdaHole (rangedThing happy_var_3) (rangedThing happy_var_5)-	) `HappyStk` happyRest}}--happyReduce_385 = happyReduce 6# 108# happyReduction_385-happyReduction_385 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_5 of { happy_var_5 -> -	happyIn117-		 (LambdaHole "_" (rangedThing happy_var_5)-	) `HappyStk` happyRest}--happyReduce_386 = happySpecReduce_1  109# happyReduction_386-happyReduction_386 happy_x_1-	 =  case happyOut119 happy_x_1 of { happy_var_1 -> -	happyIn118-		 (ExprHole (rangedThing happy_var_1)-	)}--happyReduce_387 = happyReduce 4# 109# happyReduction_387-happyReduction_387 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_2 of { happy_var_2 -> -	case happyOut119 happy_x_4 of { happy_var_4 -> -	happyIn118-		 (LambdaHole (rangedThing happy_var_2) (rangedThing happy_var_4)-	) `HappyStk` happyRest}}--happyReduce_388 = happyReduce 4# 109# happyReduction_388-happyReduction_388 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut119 happy_x_4 of { happy_var_4 -> -	happyIn118-		 (LambdaHole "_" (rangedThing happy_var_4)-	) `HappyStk` happyRest}--happyReduce_389 = happySpecReduce_1  110# happyReduction_389-happyReduction_389 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokId happy_var_1) -> -	happyIn119-		 (Ranged (getRange $ fst happy_var_1) (stringToRawName $ snd happy_var_1)-	)}--happyReduce_390 = happySpecReduce_1  111# happyReduction_390-happyReduction_390 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> -	happyIn120-		 (Just (getRange happy_var_1)-	)}--happyReduce_391 = happySpecReduce_0  111# happyReduction_391-happyReduction_391  =  happyIn120-		 (Nothing-	)--happyReduce_392 = happyMonadReduce 5# 112# happyReduction_392-happyReduction_392 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut120 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokKeyword KwImport happy_var_2) -> -	case happyOut25 happy_x_3 of { happy_var_3 -> -	case happyOut122 happy_x_4 of { happy_var_4 -> -	case happyOut73 happy_x_5 of { happy_var_5 -> -	(-    let-    { doOpen = maybe DontOpen (const DoOpen) happy_var_1-    ; m   = happy_var_3-    ; es  = happy_var_4-    ; dir = happy_var_5-    ; r   = getRange (m, es, dir)-    ; mr  = getRange m-    ; unique = hashString $ show $ (Nothing :: 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 [ Id $ stringToRawName $ ".#" ++ show m ++ "-" ++ show unique ]-    ; impStm asR = Import mr m (Just (AsName fresh asR)) DontOpen defaultImportDir-    ; appStm m' es =-        let r = getRange (m, es) in-        Private r Inserted-          [ ModuleMacro r m'-             (SectionApp (getRange es) []-               (RawApp (getRange es) (Ident (QName fresh) : es)))-             doOpen dir-          ]-    ; (initArgs, last2Args) = splitAt (length es - 2) es-    ; parseAsClause = case last2Args of-      { [ Ident (QName (Name asR [Id x]))-        , Ident (QName m')-        ] | rawNameToString x == "as" -> Just (asR, m')-      ; _ -> Nothing-      }-    } in-    case es of-      { [] -> return [Import mr m Nothing doOpen dir]-      ; _ | Just (asR, m') <- parseAsClause ->-              if null initArgs then return-                 [ Import (getRange (m, asR, m', dir)) m-                     (Just (AsName m' asR)) doOpen dir-                 ]-              else return [ impStm asR, appStm m' initArgs ]-          | DontOpen <- doOpen -> parseErrorAt (fromJust $ rStart' $ getRange happy_var_2) "An import statement with module instantiation does not actually import the module.  This statement achieves nothing.  Either add the `open' keyword or bind the instantiated module with an `as' clause."-          | otherwise -> return-              [ impStm noRange-              , appStm (noName $ beginningOf $ getRange m) es-              ]-      })}}}}}-	) (\r -> happyReturn (happyIn121 r))--happyReduce_393 = happyReduce 4# 112# happyReduction_393-happyReduction_393 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut25 happy_x_2 of { happy_var_2 -> -	case happyOut122 happy_x_3 of { happy_var_3 -> -	case happyOut73 happy_x_4 of { happy_var_4 -> -	happyIn121-		 (let-    { m   = happy_var_2-    ; es  = happy_var_3-    ; dir = happy_var_4-    ; r   = getRange (m, es, dir)-    } in-    [ case es of-      { []  -> Open r m dir-      ; _   -> Private r Inserted-                 [ ModuleMacro r (noName $ beginningOf $ getRange m)-                             (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))-                             DoOpen dir-                 ]-      }-    ]-	) `HappyStk` happyRest}}}--happyReduce_394 = happyReduce 6# 112# happyReduction_394-happyReduction_394 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut25 happy_x_2 of { happy_var_2 -> -	case happyOut73 happy_x_6 of { happy_var_6 -> -	happyIn121-		 (let r = getRange happy_var_2 in-    [ Private r Inserted-      [ ModuleMacro r (noName $ beginningOf $ getRange happy_var_2) (RecordModuleIFS r happy_var_2) DoOpen happy_var_6-      ]-    ]-	) `HappyStk` happyRest}}--happyReduce_395 = happySpecReduce_0  113# happyReduction_395-happyReduction_395  =  happyIn122-		 ([]-	)--happyReduce_396 = happySpecReduce_2  113# happyReduction_396-happyReduction_396 happy_x_2-	happy_x_1-	 =  case happyOut46 happy_x_1 of { happy_var_1 -> -	case happyOut122 happy_x_2 of { happy_var_2 -> -	happyIn122-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_397 = happyReduce 4# 114# happyReduction_397-happyReduction_397 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut25 happy_x_1 of { happy_var_1 -> -	case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymEllipsis happy_var_3) -> -	case happyOut20 happy_x_4 of { happy_var_4 -> -	happyIn123-		 ((\ts ->-                    if null ts then return $ RecordModuleIFS (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_1-                    else parseError "No bindings allowed for record module with non-canonical implicits" )-	) `HappyStk` happyRest}}}}--happyReduce_398 = happySpecReduce_2  114# happyReduction_398-happyReduction_398 happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { happy_var_1 -> -	case happyOut122 happy_x_2 of { happy_var_2 -> -	happyIn123-		 ((\ts -> return $ SectionApp (getRange (happy_var_1, happy_var_2)) ts (RawApp (fuseRange happy_var_1 happy_var_2) (Ident happy_var_1 : happy_var_2)) )-	)}}--happyReduce_399 = happyMonadReduce 6# 115# happyReduction_399-happyReduction_399 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> -	case happyOut25 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOut123 happy_x_5 of { happy_var_5 -> -	case happyOut73 happy_x_6 of { happy_var_6 -> -	( do { ma <- happy_var_5 (map addType happy_var_3)-                          ; name <- ensureUnqual happy_var_2-                          ; return $ ModuleMacro (getRange (happy_var_1, happy_var_2, ma, happy_var_6)) name ma DontOpen happy_var_6 })}}}}}-	) (\r -> happyReturn (happyIn124 r))--happyReduce_400 = happyMonadReduce 7# 115# happyReduction_400-happyReduction_400 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwModule happy_var_2) -> -	case happyOut18 happy_x_3 of { happy_var_3 -> -	case happyOut70 happy_x_4 of { happy_var_4 -> -	case happyOut123 happy_x_6 of { happy_var_6 -> -	case happyOut73 happy_x_7 of { happy_var_7 -> -	( do {ma <- happy_var_6 (map addType happy_var_4); return $ ModuleMacro (getRange (happy_var_1, happy_var_2, happy_var_3, ma, happy_var_7)) happy_var_3 ma DoOpen happy_var_7 })}}}}}}-	) (\r -> happyReturn (happyIn124 r))--happyReduce_401 = happyReduce 5# 116# happyReduction_401-happyReduction_401 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> -	case happyOut25 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> -	case happyOut168 happy_x_5 of { happy_var_5 -> -	happyIn125-		 (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 (map addType happy_var_3) happy_var_5-	) `HappyStk` happyRest}}}}}--happyReduce_402 = happyReduce 5# 116# happyReduction_402-happyReduction_402 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> -	case happyOut126 happy_x_2 of { happy_var_2 -> -	case happyOut70 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> -	case happyOut168 happy_x_5 of { happy_var_5 -> -	happyIn125-		 (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) (QName happy_var_2) (map addType happy_var_3) happy_var_5-	) `HappyStk` happyRest}}}}}--happyReduce_403 = happySpecReduce_1  117# happyReduction_403-happyReduction_403 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> -	happyIn126-		 (noName (getRange happy_var_1)-	)}--happyReduce_404 = happySpecReduce_1  118# happyReduction_404-happyReduction_404 happy_x_1-	 =  case happyOut170 happy_x_1 of { happy_var_1 -> -	happyIn127-		 (figureOutTopLevelModule happy_var_1-	)}--happyReduce_405 = happySpecReduce_1  119# happyReduction_405-happyReduction_405 happy_x_1-	 =  case happyOut129 happy_x_1 of { happy_var_1 -> -	happyIn128-		 (Pragma happy_var_1-	)}--happyReduce_406 = happySpecReduce_1  120# happyReduction_406-happyReduction_406 happy_x_1-	 =  case happyOut131 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_407 = happySpecReduce_1  120# happyReduction_407-happyReduction_407 happy_x_1-	 =  case happyOut132 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_408 = happySpecReduce_1  120# happyReduction_408-happyReduction_408 happy_x_1-	 =  case happyOut133 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_409 = happySpecReduce_1  120# happyReduction_409-happyReduction_409 happy_x_1-	 =  case happyOut134 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_410 = happySpecReduce_1  120# happyReduction_410-happyReduction_410 happy_x_1-	 =  case happyOut137 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_411 = happySpecReduce_1  120# happyReduction_411-happyReduction_411 happy_x_1-	 =  case happyOut135 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_412 = happySpecReduce_1  120# happyReduction_412-happyReduction_412 happy_x_1-	 =  case happyOut136 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_413 = happySpecReduce_1  120# happyReduction_413-happyReduction_413 happy_x_1-	 =  case happyOut138 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_414 = happySpecReduce_1  120# happyReduction_414-happyReduction_414 happy_x_1-	 =  case happyOut139 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_415 = happySpecReduce_1  120# happyReduction_415-happyReduction_415 happy_x_1-	 =  case happyOut140 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_416 = happySpecReduce_1  120# happyReduction_416-happyReduction_416 happy_x_1-	 =  case happyOut141 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_417 = happySpecReduce_1  120# happyReduction_417-happyReduction_417 happy_x_1-	 =  case happyOut142 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_418 = happySpecReduce_1  120# happyReduction_418-happyReduction_418 happy_x_1-	 =  case happyOut143 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_419 = happySpecReduce_1  120# happyReduction_419-happyReduction_419 happy_x_1-	 =  case happyOut144 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_420 = happySpecReduce_1  120# happyReduction_420-happyReduction_420 happy_x_1-	 =  case happyOut151 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_421 = happySpecReduce_1  120# happyReduction_421-happyReduction_421 happy_x_1-	 =  case happyOut152 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_422 = happySpecReduce_1  120# happyReduction_422-happyReduction_422 happy_x_1-	 =  case happyOut153 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_423 = happySpecReduce_1  120# happyReduction_423-happyReduction_423 happy_x_1-	 =  case happyOut148 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_424 = happySpecReduce_1  120# happyReduction_424-happyReduction_424 happy_x_1-	 =  case happyOut147 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_425 = happySpecReduce_1  120# happyReduction_425-happyReduction_425 happy_x_1-	 =  case happyOut146 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_426 = happySpecReduce_1  120# happyReduction_426-happyReduction_426 happy_x_1-	 =  case happyOut149 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_427 = happySpecReduce_1  120# happyReduction_427-happyReduction_427 happy_x_1-	 =  case happyOut150 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_428 = happySpecReduce_1  120# happyReduction_428-happyReduction_428 happy_x_1-	 =  case happyOut145 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_429 = happySpecReduce_1  120# happyReduction_429-happyReduction_429 happy_x_1-	 =  case happyOut154 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_430 = happySpecReduce_1  120# happyReduction_430-happyReduction_430 happy_x_1-	 =  case happyOut155 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_431 = happySpecReduce_1  120# happyReduction_431-happyReduction_431 happy_x_1-	 =  case happyOut130 happy_x_1 of { happy_var_1 -> -	happyIn129-		 (happy_var_1-	)}--happyReduce_432 = happyReduce 4# 121# happyReduction_432-happyReduction_432 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwOPTIONS happy_var_2) -> -	case happyOut31 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn130-		 (OptionsPragma (getRange (happy_var_1,happy_var_2,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}}--happyReduce_433 = happyReduce 5# 122# happyReduction_433-happyReduction_433 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokString happy_var_3) -> -	case happyOut35 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn131-		 (BuiltinPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4,happy_var_5)) (snd happy_var_3) (Ident happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_434 = happyReduce 5# 122# happyReduction_434-happyReduction_434 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokKeyword KwREWRITE happy_var_3) -> -	case happyOut35 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn131-		 (BuiltinPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) "REWRITE" (Ident happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_435 = happyReduce 4# 123# happyReduction_435-happyReduction_435 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwREWRITE happy_var_2) -> -	case happyOut36 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn132-		 (RewritePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}}--happyReduce_436 = happyReduce 5# 124# happyReduction_436-happyReduction_436 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn133-		 (CompiledPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_437 = happyReduce 5# 125# happyReduction_437-happyReduction_437 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EXPORT happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut32 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn134-		 (CompiledExportPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 happy_var_4-	) `HappyStk` happyRest}}}}}--happyReduce_438 = happyReduce 5# 126# happyReduction_438-happyReduction_438 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_DECLARE_DATA happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn135-		 (CompiledDeclareDataPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_439 = happyReduce 5# 127# happyReduction_439-happyReduction_439 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_TYPE happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn136-		 (CompiledTypePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_440 = happyReduce 6# 128# happyReduction_440-happyReduction_440 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_DATA happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokString happy_var_4) -> -	case happyOut31 happy_x_5 of { happy_var_5 -> -	case happyOutTok happy_x_6 of { (TokSymbol SymClosePragma happy_var_6) -> -	happyIn137-		 (CompiledDataPragma (getRange (happy_var_1,happy_var_2,happy_var_3,fst happy_var_4,happy_var_6)) happy_var_3 (snd happy_var_4) happy_var_5-	) `HappyStk` happyRest}}}}}}--happyReduce_441 = happyReduce 5# 129# happyReduction_441-happyReduction_441 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EPIC happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn138-		 (CompiledEpicPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_442 = happyReduce 5# 130# happyReduction_442-happyReduction_442 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_JS happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn139-		 (CompiledJSPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_443 = happyReduce 5# 131# happyReduction_443-happyReduction_443 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_UHC happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn140-		 (CompiledUHCPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)-	) `HappyStk` happyRest}}}}}--happyReduce_444 = happyReduce 6# 132# happyReduction_444-happyReduction_444 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_DATA_UHC happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokString happy_var_4) -> -	case happyOut31 happy_x_5 of { happy_var_5 -> -	case happyOutTok happy_x_6 of { (TokSymbol SymClosePragma happy_var_6) -> -	happyIn141-		 (CompiledDataUHCPragma (getRange (happy_var_1,happy_var_2,happy_var_3,fst happy_var_4,happy_var_6)) happy_var_3 (snd happy_var_4) happy_var_5-	) `HappyStk` happyRest}}}}}}--happyReduce_445 = happyReduce 4# 133# happyReduction_445-happyReduction_445 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwHASKELL happy_var_2) -> -	case happyOut33 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn142-		 (HaskellCodePragma (getRange (happy_var_1, happy_var_2, happy_var_4)) (recoverLayout happy_var_3)-	) `HappyStk` happyRest}}}}--happyReduce_446 = happyReduce 4# 134# happyReduction_446-happyReduction_446 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwSTATIC happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn143-		 (StaticPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}}--happyReduce_447 = happyReduce 4# 135# happyReduction_447-happyReduction_447 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwINLINE happy_var_2) -> -	case happyOut35 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn144-		 (InlinePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3-	) `HappyStk` happyRest}}}}--happyReduce_448 = happyMonadReduce 5# 136# happyReduction_448-happyReduction_448 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_3 of { (TokString happy_var_3) -> -	case happyOut31 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	(-      let (r, s) = happy_var_3 in-      parseDisplayPragma (fuseRange happy_var_1 happy_var_5) (iStart r) (unwords (s : happy_var_4)))}}}}-	) (\r -> happyReturn (happyIn145 r))--happyReduce_449 = happySpecReduce_3  137# happyReduction_449-happyReduction_449 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn146-		 (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NoTerminationCheck-	)}}}--happyReduce_450 = happySpecReduce_3  138# happyReduction_450-happyReduction_450 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwNON_TERMINATING happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn147-		 (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NonTerminating-	)}}}--happyReduce_451 = happySpecReduce_3  139# happyReduction_451-happyReduction_451 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwTERMINATING happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn148-		 (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) Terminating-	)}}}--happyReduce_452 = happyReduce 4# 140# happyReduction_452-happyReduction_452 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwMEASURE happy_var_2) -> -	case happyOut34 happy_x_3 of { happy_var_3 -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	happyIn149-		 (let r = getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4) in-      TerminationCheckPragma r (TerminationMeasure r happy_var_3)-	) `HappyStk` happyRest}}}}--happyReduce_453 = happySpecReduce_3  141# happyReduction_453-happyReduction_453 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwCATCHALL happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn150-		 (CatchallPragma (getRange (happy_var_1,happy_var_2,happy_var_3))-	)}}}--happyReduce_454 = happyMonadReduce 4# 142# happyReduction_454-happyReduction_454 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwIMPORT happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokString happy_var_3) -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	( let s = snd happy_var_3 in-       if validHaskellModuleName s-       then return $ ImportPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4)) s-       else parseError $ "Malformed module name: " ++ s ++ ".")}}}}-	) (\r -> happyReturn (happyIn151 r))--happyReduce_455 = happyMonadReduce 4# 143# happyReduction_455-happyReduction_455 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwIMPORT_UHC happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokString happy_var_3) -> -	case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> -	( let s = snd happy_var_3 in-       if validHaskellModuleName s-       then return $ ImportUHCPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4)) s-       else parseError $ "Malformed module name: " ++ s ++ ".")}}}}-	) (\r -> happyReturn (happyIn152 r))--happyReduce_456 = happySpecReduce_3  144# happyReduction_456-happyReduction_456 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwIMPOSSIBLE happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn153-		 (ImpossiblePragma (getRange (happy_var_1,happy_var_2,happy_var_3))-	)}}}--happyReduce_457 = happySpecReduce_3  145# happyReduction_457-happyReduction_457 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwNO_POSITIVITY_CHECK happy_var_2) -> -	case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> -	happyIn154-		 (NoPositivityCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3))-	)}}}--happyReduce_458 = happyReduce 5# 146# happyReduction_458-happyReduction_458 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> -	case happyOutTok happy_x_2 of { (TokKeyword KwPOLARITY happy_var_2) -> -	case happyOut34 happy_x_3 of { happy_var_3 -> -	case happyOut156 happy_x_4 of { happy_var_4 -> -	case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> -	happyIn155-		 (let (rs, occs) = unzip (reverse happy_var_4) in-      PolarityPragma (getRange (happy_var_1,happy_var_2,happy_var_3,rs,happy_var_5)) happy_var_3 occs-	) `HappyStk` happyRest}}}}}--happyReduce_459 = happySpecReduce_0  147# happyReduction_459-happyReduction_459  =  happyIn156-		 ([]-	)--happyReduce_460 = happySpecReduce_2  147# happyReduction_460-happyReduction_460 happy_x_2-	happy_x_1-	 =  case happyOut156 happy_x_1 of { happy_var_1 -> -	case happyOut157 happy_x_2 of { happy_var_2 -> -	happyIn156-		 (happy_var_2 : happy_var_1-	)}}--happyReduce_461 = happyMonadReduce 1# 148# happyReduction_461-happyReduction_461 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> -	( polarity happy_var_1)}-	) (\r -> happyReturn (happyIn157 r))--happyReduce_462 = happySpecReduce_3  149# happyReduction_462-happyReduction_462 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut159 happy_x_2 of { happy_var_2 -> -	happyIn158-		 (reverse happy_var_2-	)}--happyReduce_463 = happySpecReduce_3  150# happyReduction_463-happyReduction_463 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut159 happy_x_1 of { happy_var_1 -> -	case happyOut92 happy_x_3 of { happy_var_3 -> -	happyIn159-		 (reverse happy_var_3 ++ happy_var_1-	)}}--happyReduce_464 = happySpecReduce_1  150# happyReduction_464-happyReduction_464 happy_x_1-	 =  case happyOut92 happy_x_1 of { happy_var_1 -> -	happyIn159-		 (reverse happy_var_1-	)}--happyReduce_465 = happySpecReduce_3  151# happyReduction_465-happyReduction_465 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut161 happy_x_2 of { happy_var_2 -> -	happyIn160-		 (reverse happy_var_2-	)}--happyReduce_466 = happySpecReduce_3  152# happyReduction_466-happyReduction_466 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut161 happy_x_1 of { happy_var_1 -> -	case happyOut93 happy_x_3 of { happy_var_3 -> -	happyIn161-		 (reverse happy_var_3 ++ happy_var_1-	)}}--happyReduce_467 = happySpecReduce_1  152# happyReduction_467-happyReduction_467 happy_x_1-	 =  case happyOut93 happy_x_1 of { happy_var_1 -> -	happyIn161-		 (reverse happy_var_1-	)}--happyReduce_468 = happyMonadReduce 3# 153# happyReduction_468-happyReduction_468 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut163 happy_x_2 of { happy_var_2 -> -	( ((,) `fmap` verifyRecordDirectives happy_var_2 <*> pure []))}-	) (\r -> happyReturn (happyIn162 r))--happyReduce_469 = happyMonadReduce 5# 153# happyReduction_469-happyReduction_469 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut163 happy_x_2 of { happy_var_2 -> -	case happyOut169 happy_x_4 of { happy_var_4 -> -	( ((,) `fmap` verifyRecordDirectives happy_var_2 <*> pure happy_var_4))}}-	) (\r -> happyReturn (happyIn162 r))--happyReduce_470 = happyMonadReduce 3# 153# happyReduction_470-happyReduction_470 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen (case happyOut169 happy_x_2 of { happy_var_2 -> -	( ((,) `fmap` verifyRecordDirectives [] <*> pure happy_var_2))}-	) (\r -> happyReturn (happyIn162 r))--happyReduce_471 = happySpecReduce_0  154# happyReduction_471-happyReduction_471  =  happyIn163-		 ([]-	)--happyReduce_472 = happySpecReduce_3  154# happyReduction_472-happyReduction_472 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut163 happy_x_1 of { happy_var_1 -> -	case happyOut164 happy_x_3 of { happy_var_3 -> -	happyIn163-		 (happy_var_3 : happy_var_1-	)}}--happyReduce_473 = happySpecReduce_1  154# happyReduction_473-happyReduction_473 happy_x_1-	 =  case happyOut164 happy_x_1 of { happy_var_1 -> -	happyIn163-		 ([happy_var_1]-	)}--happyReduce_474 = happySpecReduce_1  155# happyReduction_474-happyReduction_474 happy_x_1-	 =  case happyOut100 happy_x_1 of { happy_var_1 -> -	happyIn164-		 (Constructor happy_var_1-	)}--happyReduce_475 = happySpecReduce_1  155# happyReduction_475-happyReduction_475 happy_x_1-	 =  case happyOut166 happy_x_1 of { happy_var_1 -> -	happyIn164-		 (Induction happy_var_1-	)}--happyReduce_476 = happySpecReduce_1  155# happyReduction_476-happyReduction_476 happy_x_1-	 =  case happyOut165 happy_x_1 of { happy_var_1 -> -	happyIn164-		 (Eta happy_var_1-	)}--happyReduce_477 = happySpecReduce_1  156# happyReduction_477-happyReduction_477 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwEta happy_var_1) -> -	happyIn165-		 (Ranged (getRange happy_var_1) True-	)}--happyReduce_478 = happySpecReduce_1  156# happyReduction_478-happyReduction_478 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwNoEta happy_var_1) -> -	happyIn165-		 (Ranged (getRange happy_var_1) False-	)}--happyReduce_479 = happySpecReduce_1  157# happyReduction_479-happyReduction_479 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> -	happyIn166-		 (Ranged (getRange happy_var_1) Inductive-	)}--happyReduce_480 = happySpecReduce_1  157# happyReduction_480-happyReduction_480 happy_x_1-	 =  case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> -	happyIn166-		 (Ranged (getRange happy_var_1) CoInductive-	)}--happyReduce_481 = happySpecReduce_3  158# happyReduction_481-happyReduction_481 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut169 happy_x_2 of { happy_var_2 -> -	happyIn167-		 (happy_var_2-	)}--happyReduce_482 = happySpecReduce_2  159# happyReduction_482-happyReduction_482 happy_x_2-	happy_x_1-	 =  happyIn168-		 ([]-	)--happyReduce_483 = happySpecReduce_1  159# happyReduction_483-happyReduction_483 happy_x_1-	 =  case happyOut167 happy_x_1 of { happy_var_1 -> -	happyIn168-		 (happy_var_1-	)}--happyReduce_484 = happySpecReduce_3  160# happyReduction_484-happyReduction_484 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut91 happy_x_1 of { happy_var_1 -> -	case happyOut169 happy_x_3 of { happy_var_3 -> -	happyIn169-		 (happy_var_1 ++ happy_var_3-	)}}--happyReduce_485 = happySpecReduce_1  160# happyReduction_485-happyReduction_485 happy_x_1-	 =  case happyOut91 happy_x_1 of { happy_var_1 -> -	happyIn169-		 (happy_var_1-	)}--happyReduce_486 = happySpecReduce_0  161# happyReduction_486-happyReduction_486  =  happyIn170-		 ([]-	)--happyReduce_487 = happySpecReduce_1  161# happyReduction_487-happyReduction_487 happy_x_1-	 =  case happyOut169 happy_x_1 of { happy_var_1 -> -	happyIn170-		 (happy_var_1-	)}--happyNewToken action sts stk-	= lexer(\tk -> -	let cont i = happyDoAction i tk action sts stk in-	case tk of {-	TokEOF -> happyDoAction 105# tk action sts stk;-	TokKeyword KwAbstract happy_dollar_dollar -> cont 1#;-	TokKeyword KwCoData happy_dollar_dollar -> cont 2#;-	TokKeyword KwCoInductive happy_dollar_dollar -> cont 3#;-	TokKeyword KwConstructor happy_dollar_dollar -> cont 4#;-	TokKeyword KwData happy_dollar_dollar -> cont 5#;-	TokKeyword KwEta happy_dollar_dollar -> cont 6#;-	TokKeyword KwField happy_dollar_dollar -> cont 7#;-	TokKeyword KwForall happy_dollar_dollar -> cont 8#;-	TokKeyword KwHiding happy_dollar_dollar -> cont 9#;-	TokKeyword KwImport happy_dollar_dollar -> cont 10#;-	TokKeyword KwIn happy_dollar_dollar -> cont 11#;-	TokKeyword KwInductive happy_dollar_dollar -> cont 12#;-	TokKeyword KwInfix happy_dollar_dollar -> cont 13#;-	TokKeyword KwInfixL happy_dollar_dollar -> cont 14#;-	TokKeyword KwInfixR happy_dollar_dollar -> cont 15#;-	TokKeyword KwInstance happy_dollar_dollar -> cont 16#;-	TokKeyword KwOverlap happy_dollar_dollar -> cont 17#;-	TokKeyword KwLet happy_dollar_dollar -> cont 18#;-	TokKeyword KwMacro happy_dollar_dollar -> cont 19#;-	TokKeyword KwModule happy_dollar_dollar -> cont 20#;-	TokKeyword KwMutual happy_dollar_dollar -> cont 21#;-	TokKeyword KwNoEta happy_dollar_dollar -> cont 22#;-	TokKeyword KwOpen happy_dollar_dollar -> cont 23#;-	TokKeyword KwPatternSyn happy_dollar_dollar -> cont 24#;-	TokKeyword KwPostulate happy_dollar_dollar -> cont 25#;-	TokKeyword KwPrimitive happy_dollar_dollar -> cont 26#;-	TokKeyword KwPrivate happy_dollar_dollar -> cont 27#;-	TokKeyword KwProp happy_dollar_dollar -> cont 28#;-	TokKeyword KwPublic happy_dollar_dollar -> cont 29#;-	TokKeyword KwQuote happy_dollar_dollar -> cont 30#;-	TokKeyword KwQuoteContext happy_dollar_dollar -> cont 31#;-	TokKeyword KwQuoteGoal happy_dollar_dollar -> cont 32#;-	TokKeyword KwQuoteTerm happy_dollar_dollar -> cont 33#;-	TokKeyword KwRecord happy_dollar_dollar -> cont 34#;-	TokKeyword KwRenaming happy_dollar_dollar -> cont 35#;-	TokKeyword KwRewrite happy_dollar_dollar -> cont 36#;-	TokKeyword KwSet happy_dollar_dollar -> cont 37#;-	TokKeyword KwSyntax happy_dollar_dollar -> cont 38#;-	TokKeyword KwTactic happy_dollar_dollar -> cont 39#;-	TokKeyword KwTo happy_dollar_dollar -> cont 40#;-	TokKeyword KwUnquote happy_dollar_dollar -> cont 41#;-	TokKeyword KwUnquoteDecl happy_dollar_dollar -> cont 42#;-	TokKeyword KwUnquoteDef happy_dollar_dollar -> cont 43#;-	TokKeyword KwUsing happy_dollar_dollar -> cont 44#;-	TokKeyword KwWhere happy_dollar_dollar -> cont 45#;-	TokKeyword KwWith happy_dollar_dollar -> cont 46#;-	TokKeyword KwBUILTIN happy_dollar_dollar -> cont 47#;-	TokKeyword KwCATCHALL happy_dollar_dollar -> cont 48#;-	TokKeyword KwCOMPILED happy_dollar_dollar -> cont 49#;-	TokKeyword KwCOMPILED_DATA happy_dollar_dollar -> cont 50#;-	TokKeyword KwCOMPILED_DATA_UHC happy_dollar_dollar -> cont 51#;-	TokKeyword KwCOMPILED_DECLARE_DATA happy_dollar_dollar -> cont 52#;-	TokKeyword KwCOMPILED_EPIC happy_dollar_dollar -> cont 53#;-	TokKeyword KwCOMPILED_EXPORT happy_dollar_dollar -> cont 54#;-	TokKeyword KwCOMPILED_JS happy_dollar_dollar -> cont 55#;-	TokKeyword KwCOMPILED_TYPE happy_dollar_dollar -> cont 56#;-	TokKeyword KwCOMPILED_UHC happy_dollar_dollar -> cont 57#;-	TokKeyword KwHASKELL happy_dollar_dollar -> cont 58#;-	TokKeyword KwDISPLAY happy_dollar_dollar -> cont 59#;-	TokKeyword KwIMPORT happy_dollar_dollar -> cont 60#;-	TokKeyword KwIMPORT_UHC happy_dollar_dollar -> cont 61#;-	TokKeyword KwIMPOSSIBLE happy_dollar_dollar -> cont 62#;-	TokKeyword KwINLINE happy_dollar_dollar -> cont 63#;-	TokKeyword KwMEASURE happy_dollar_dollar -> cont 64#;-	TokKeyword KwNO_TERMINATION_CHECK happy_dollar_dollar -> cont 65#;-	TokKeyword KwNO_POSITIVITY_CHECK happy_dollar_dollar -> cont 66#;-	TokKeyword KwNON_TERMINATING happy_dollar_dollar -> cont 67#;-	TokKeyword KwOPTIONS happy_dollar_dollar -> cont 68#;-	TokKeyword KwPOLARITY happy_dollar_dollar -> cont 69#;-	TokKeyword KwREWRITE happy_dollar_dollar -> cont 70#;-	TokKeyword KwSTATIC happy_dollar_dollar -> cont 71#;-	TokKeyword KwTERMINATING happy_dollar_dollar -> cont 72#;-	TokSetN happy_dollar_dollar -> cont 73#;-	TokTeX happy_dollar_dollar -> cont 74#;-	TokComment happy_dollar_dollar -> cont 75#;-	TokSymbol SymEllipsis happy_dollar_dollar -> cont 76#;-	TokSymbol SymDotDot happy_dollar_dollar -> cont 77#;-	TokSymbol SymDot happy_dollar_dollar -> cont 78#;-	TokSymbol SymSemi happy_dollar_dollar -> cont 79#;-	TokSymbol SymColon happy_dollar_dollar -> cont 80#;-	TokSymbol SymEqual happy_dollar_dollar -> cont 81#;-	TokSymbol SymUnderscore happy_dollar_dollar -> cont 82#;-	TokSymbol SymQuestionMark happy_dollar_dollar -> cont 83#;-	TokSymbol SymArrow happy_dollar_dollar -> cont 84#;-	TokSymbol SymLambda happy_dollar_dollar -> cont 85#;-	TokSymbol SymAs happy_dollar_dollar -> cont 86#;-	TokSymbol SymBar happy_dollar_dollar -> cont 87#;-	TokSymbol SymOpenParen happy_dollar_dollar -> cont 88#;-	TokSymbol SymCloseParen happy_dollar_dollar -> cont 89#;-	TokSymbol SymOpenIdiomBracket happy_dollar_dollar -> cont 90#;-	TokSymbol SymCloseIdiomBracket happy_dollar_dollar -> cont 91#;-	TokSymbol SymDoubleOpenBrace happy_dollar_dollar -> cont 92#;-	TokSymbol SymDoubleCloseBrace happy_dollar_dollar -> cont 93#;-	TokSymbol SymOpenBrace happy_dollar_dollar -> cont 94#;-	TokSymbol SymCloseBrace happy_dollar_dollar -> cont 95#;-	TokSymbol SymOpenVirtualBrace happy_dollar_dollar -> cont 96#;-	TokSymbol SymCloseVirtualBrace happy_dollar_dollar -> cont 97#;-	TokSymbol SymVirtualSemi happy_dollar_dollar -> cont 98#;-	TokSymbol SymOpenPragma happy_dollar_dollar -> cont 99#;-	TokSymbol SymClosePragma happy_dollar_dollar -> cont 100#;-	TokId happy_dollar_dollar -> cont 101#;-	TokQId happy_dollar_dollar -> cont 102#;-	TokString happy_dollar_dollar -> cont 103#;-	TokLiteral happy_dollar_dollar -> cont 104#;-	_ -> happyError' tk-	})--happyError_ 105# tk = happyError' tk-happyError_ _ tk = happyError' tk--happyThen :: () => Parser a -> (a -> Parser b) -> Parser b-happyThen = (>>=)-happyReturn :: () => a -> Parser a-happyReturn = (return)-happyThen1 = happyThen-happyReturn1 :: () => a -> Parser a-happyReturn1 = happyReturn-happyError' :: () => (Token) -> Parser a-happyError' tk = (\token -> happyError) tk--tokensParser = happySomeParser where-  happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut9 x))--exprParser = happySomeParser where-  happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut37 x))--exprWhereParser = happySomeParser where-  happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut90 x))--moduleParser = happySomeParser where-  happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (happyOut12 x))--moduleNameParser = happySomeParser where-  happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (happyOut25 x))--funclauseParser = happySomeParser where-  happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (happyOut94 x))--happySeq = happyDontSeq---{---------------------------------------------------------------------------    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] -> ([Pragma], [Declaration])-takeOptionsPragmas = 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.-    (ds0, ds1)                      -> ds0 ++ [Module (getRange ds1) (QName noName_) [] 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) $ fail $ "a name cannot contain two consecutive underscores"-    return $ Name (getRange i) xs-    where-        isValidId Hole   = return ()-        isValidId (Id y) = do-          let x = rawNameToString y-          case parse defaultParseFlags [0] (lexer return) x of-            ParseOk _ (TokId _) -> return ()-            _                   -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"--        -- we know that there are no two Ids in a row-        alternating (Hole : Hole : _) = False-        alternating (_ : xs)          = alternating 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)---- | 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---- | Polarity parser.--polarity :: (Interval, String) -> Parser (Range, Occurrence)-polarity (i, s) =-  case s of-    "_"  -> ret Unused-    "++" -> ret StrictPos-    "+"  -> ret JustPos-    "-"  -> ret JustNeg-    "*"  -> ret Mixed-    _    -> fail $ "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  = genericReplicate (l2 - l1) '\n' ++ genericReplicate (max 0 (c2 - c0)) ' '-      | l1 == l2 = 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 = fail $ "expected " ++ s ++ ", found " ++ s'---- | Build a forall pi (forall x y z -> ...)-forallPi :: [LamBinding] -> Expr -> Expr-forallPi bs e = Pi (map addType bs) e---- | Build a telescoping let (let Ds)-tLet :: Range -> [Declaration] -> TypedBindings-tLet r = TypedBindings r . Arg defaultArgInfo . TLet r---- | Converts lambda bindings to typed bindings.-addType :: LamBinding -> TypedBindings-addType (DomainFull b)   = b-addType (DomainFree info x) = TypedBindings r $ Arg info $ TBind r [pure x] $ Underscore r Nothing-  where r = getRange x--mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective-mergeImportDirectives is = do-  i <- foldl merge (return defaultImportDir) is-  verifyImportDirective i-  where-    merge mi i2 = do-      i1 <- mi-      let err = parseError' (rStart' $ getRange i2) "Cannot mix using and hiding module directives"-      return $ ImportDirective-        { importDirRange = fuseRange i1 i2-        , using          = mappend (using i1) (using i2)-        , hiding         = hiding i1 ++ hiding i2-        , impRenaming    = impRenaming i1 ++ impRenaming i2-        , publicOpen     = publicOpen i1 || publicOpen i2 }---- | Check that an import directive doesn't contain repeated names-verifyImportDirective :: ImportDirective -> Parser ImportDirective-verifyImportDirective i =-    case filter ((>1) . length)-         $ group-         $ sort xs-    of-        []  -> return i-        yss -> let Just pos = rStart' $ getRange $ head $ concat yss in-               parseErrorAt pos $-                "Repeated name" ++ s ++ " in import directive: " ++-                concat (intersperse ", " $ map (show . head) yss)-            where-                s = case yss of-                        [_] -> ""-                        _   -> "s"-    where-        xs = names (using i) ++ hiding i ++ map renFrom (impRenaming i)-        names (Using xs)    = xs-        names UseEverything = []--data RecordDirective-   = Induction (Ranged Induction)-   | Constructor (Name, IsInstance)-   | Eta         (Ranged Bool)-   deriving (Eq,Show)--verifyRecordDirectives :: [RecordDirective] -> Parser (Maybe (Ranged Induction), Maybe Bool, Maybe (Name, IsInstance))-verifyRecordDirectives xs | null rs = return (ltm is, ltm es, ltm cs)-                          | otherwise = let Just pos = rStart' $ (head rs) in-                                          parseErrorAt pos $ "Repeated record directives at: \n" ++ intercalate "\n" (map show rs)-- where-  ltm :: [a] -> Maybe a-  ltm [] = Nothing-  ltm (x:xs) = Just x-  errorFromList [] = []-  errorFromList [x] = []-  errorFromList xs = map getRange xs-  rs = sort (concat ([errorFromList is, errorFromList es', errorFromList cs]))-  is = [ i | Induction i <- xs ]-  es' = [ i | Eta i <- xs ]-  es = map rangedThing es'-  cs = [ i | Constructor i <- xs ]----- | 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 ([Expr] -> [Expr] -> LHS)-exprToLHS e = case e of-  WithApp r e es -> LHS <$> exprToPattern e <*> mapM exprToPattern es-  _              -> LHS <$> exprToPattern e <*> return []---- | Turn an expression into a pattern. Fails if the expression is not a---   valid pattern.-exprToPattern :: Expr -> Parser Pattern-exprToPattern e = do-    let Just pos = rStart' $ getRange e-        failure = parseErrorAt pos $ "Not a valid pattern: " ++ show e-    case e of-        Ident x                 -> return $ IdentP x-        App _ e1 e2             -> AppP <$> exprToPattern e1-                                        <*> T.mapM (T.mapM exprToPattern) e2-        Paren r e               -> ParenP r-                                        <$> exprToPattern e-        Underscore r _          -> return $ WildP r-        Absurd r                -> return $ AbsurdP r-        As r x e                -> AsP r x <$> exprToPattern e-        Dot r (HiddenArg _ e)   -> return $ HiddenP r $ fmap (DotP r UserWritten) e-        Dot r e                 -> return $ DotP r UserWritten e-        Lit l                   -> return $ LitP l-        HiddenArg r e           -> HiddenP r <$> T.mapM exprToPattern e-        InstanceArg r e         -> InstanceP r <$> T.mapM exprToPattern e-        RawApp r es             -> RawAppP r <$> mapM exprToPattern es-        Quote r                 -> return $ QuoteP r-        Rec r es | Just fs <- mapM maybeLeft es -> do-          RecP r <$> T.mapM (T.mapM exprToPattern) fs-        _                       -> failure--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 =-  let Just pos = rStart' $ getRange e in-  parseErrorAt pos $ "Not a valid identifier: " ++ show e--stripSingletonRawApp :: Expr -> Expr-stripSingletonRawApp (RawApp _ [e]) = stripSingletonRawApp e-stripSingletonRawApp e = e--isEqual :: Expr -> Maybe (Expr, Expr)-isEqual e =-  case stripSingletonRawApp e of-    Equal _ a b -> Just (stripSingletonRawApp a, stripSingletonRawApp b)-    _           -> Nothing--maybeNamed :: Expr -> Named_ Expr-maybeNamed e =-  case isEqual e of-    Just (Ident (QName x), b) -> named (Ranged (getRange x) (nameToRawName x)) b-    _                         -> unnamed e--patternSynArgs :: [Either Hiding LamBinding] -> Parser [Arg Name]-patternSynArgs = mapM pSynArg-  where-    pSynArg Left{}                   = parseError "Absurd patterns are not allowed in pattern synonyms"-    pSynArg (Right DomainFull{})     = parseError "Unexpected type signature in pattern synonym argument"-    pSynArg (Right (DomainFree a x))-      | getHiding a `notElem` [Hidden, NotHidden] = parseError $ show (getHiding a) ++ " arguments not allowed to pattern synonyms"-      | getRelevance a /= Relevant                = parseError "Arguments to pattern synonyms must be relevant"-      | otherwise                                 = return $ Arg a (boundName x)--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 [(ArgInfo, Name)]-patternToNames p =-  case p of-    IdentP (QName i)         -> return [(defaultArgInfo, i)]-    WildP r                  -> return [(defaultArgInfo, C.noName r)]-    DotP _ _ (Ident (QName i)) -> return [(setRelevance Irrelevant defaultArgInfo, i)]-    RawAppP _ ps             -> concat <$> mapM patternToNames ps-    _                        -> parseError $-      "Illegal name in type signature: " ++ prettyShow p--funClauseOrTypeSigs :: LHS -> RHSOrTypeSigs -> WhereClause -> Parser [Declaration]-funClauseOrTypeSigs lhs mrhs wh = do-  -- traceShowM lhs-  case mrhs of-    JustRHS rhs   -> return [FunClause lhs rhs wh False]-    TypeSigsRHS e -> case wh of-      NoWhere -> case lhs of-        Ellipsis{}      -> parseError "The ellipsis ... cannot have a type signature"-        LHS _ _ _ (_:_) -> parseError "Illegal: with in type signature"-        LHS _ _ (_:_) _ -> parseError "Illegal: rewrite in type signature"-        LHS _ (_:_) _ _ -> parseError "Illegal: with patterns in type signature"-        LHS p [] [] []  -> map (\ (x, y) -> TypeSig x y e) <$> patternToNames p-      _ -> 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 #-}."-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 11 "<command-line>" #-}-{-# LINE 1 "/usr/local/stow/ghc-8.0.2-rc2/lib/ghc-8.0.1.20161213/include/ghcversion.h" #-}-------------------{-# LINE 11 "<command-line>" #-}-{-# LINE 1 "/tmp/ghc19165_0/ghc_2.h" #-}-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# LINE 11 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 13 "templates/GenericTemplate.hs" #-}-------- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ > 706-#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)-#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)-#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)-#else-#define LT(n,m) (n Happy_GHC_Exts.<# m)-#define GTE(n,m) (n Happy_GHC_Exts.>=# m)-#define EQ(n,m) (n Happy_GHC_Exts.==# m)-#endif-{-# LINE 46 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 67 "templates/GenericTemplate.hs" #-}--{-# LINE 77 "templates/GenericTemplate.hs" #-}--{-# LINE 86 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser).  We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-        happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = -        (happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st-        = {- nothing -}---          case action of-                0#           -> {- nothing -}-                                     happyFail i tk st-                -1#          -> {- nothing -}-                                     happyAccept i tk st-                n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}--                                                   (happyReduceArr Happy_Data_Array.! rule) i tk st-                                                   where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))-                n                 -> {- nothing -}---                                     happyShift new_state i tk st-                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))-   where off    = indexShortOffAddr happyActOffsets st-         off_i  = (off Happy_GHC_Exts.+# i)-         check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))-                  then EQ(indexShortOffAddr happyCheck off_i, i)-                  else False-         action-          | check     = indexShortOffAddr happyTable off_i-          | otherwise = indexShortOffAddr happyDefActions st---indexShortOffAddr (HappyA# arr) off =-        Happy_GHC_Exts.narrow16Int# i-  where-        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))-        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))-        off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 170 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =-     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---     trace "shifting the error token" $-     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =-     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk-     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')-     = let r = fn v1 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')-     = let r = fn v1 v2 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')-     = let r = fn v1 v2 v3 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk-     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of-         sts1@((HappyCons (st1@(action)) (_))) ->-                let r = fn stk in  -- it doesn't hurt to always seq here...-                happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =-      case happyDrop k (HappyCons (st) (sts)) of-        sts1@((HappyCons (st1@(action)) (_))) ->-          let drop_stk = happyDropStk k stk in-          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))--happyMonad2Reduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =-      case happyDrop k (HappyCons (st) (sts)) of-        sts1@((HappyCons (st1@(action)) (_))) ->-         let drop_stk = happyDropStk k stk--             off = indexShortOffAddr happyGotoOffsets st1-             off_i = (off Happy_GHC_Exts.+# nt)-             new_state = indexShortOffAddr happyTable off_i----          in-          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))--happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = -   {- nothing -}-   happyDoAction j tk new_state-   where off = indexShortOffAddr happyGotoOffsets st-         off_i = (off Happy_GHC_Exts.+# nt)-         new_state = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =-     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---      trace "failing" $ -        happyError_ i tk--{-  We don't need state discarding for our restricted implementation of-    "error".  In fact, it can cause some bogus parses, so I've disabled it-    for now --SDM---- discard a state-happyFail  0# tk old_st (HappyCons ((action)) (sts)) -                                                (saved_tok `HappyStk` _ `HappyStk` stk) =---      trace ("discarding state, depth " ++ show (length stk))  $-        happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,---                       save the old token and carry on.-happyFail  i tk (action) sts stk =---      trace "entering error recovery" $-        happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing.  If the --strict flag is given, then Happy emits ---      happySeq = happyDoSeq--- otherwise it emits---      happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq   a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template.  GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.
+ doc/release-notes/2.2.0.md view
@@ -0,0 +1,102 @@+Release notes for Agda 2 version 2.2.0+======================================++Important changes since 2.1.2 (which was released 2007-08-16):++Language+--------++* Exhaustive pattern checking. Agda complains if there are missing+  clauses in a function definition.++* Coinductive types are supported. This feature is under+  development/evaluation, and may change.++  http://wiki.portal.chalmers.se/agda/agda.php?n=ReferenceManual.Codatatypes++* Another experimental feature: Sized types, which can make it easier+  to explain why your code is terminating.++* Improved constraint solving for functions with constructor headed+  right hand sides.++  http://wiki.portal.chalmers.se/agda/agda.php?n=ReferenceManual.FindingTheValuesOfImplicitArguments++* A simple, well-typed foreign function interface, which allows use of+  Haskell functions in Agda code.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.FFI++* The tokens `forall`, `->` and `\` can be written as `∀`, `→` and+  `λ`.++* Absurd lambdas: `λ ()` and `λ {}`.++  http://thread.gmane.org/gmane.comp.lang.agda/440++* Record fields whose values can be inferred can be omitted.++* Agda complains if it spots an unreachable clause, or if a pattern+  variable "shadows" a hidden constructor of matching type.++  http://thread.gmane.org/gmane.comp.lang.agda/720++Tools+-----++* Case-split: The user interface can replace a pattern variable with+  the corresponding constructor patterns. You get one new left-hand+  side for every possible constructor.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode++* The MAlonzo compiler.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.MAlonzo++* A new Emacs input method, which contains bindings for many Unicode+  symbols, is by default activated in the Emacs mode.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.UnicodeInput++* Highlighted, hyperlinked HTML can be generated from Agda source+  code.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.HowToGenerateWebPagesFromSourceCode++* The command-line interactive mode (`agda -I`) is no longer+  supported, but should still work.++  http://thread.gmane.org/gmane.comp.lang.agda/245++* Reload times when working on large projects are now considerably+  better.++  http://thread.gmane.org/gmane.comp.lang.agda/551++Libraries+---------++* A standard library is under development.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Libraries.StandardLibrary++Documentation+-------------++* The Agda wiki is better organised. It should be easier for a+  newcomer to find relevant information now.++  http://wiki.portal.chalmers.se/agda/++Infrastructure+--------------++* Easy-to-install packages for Windows and Debian/Ubuntu have been+  prepared.++  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.Download++* Agda 2.2.0 is available from Hackage.++  http://hackage.haskell.org/
+ doc/release-notes/2.2.10.md view
@@ -0,0 +1,238 @@+Release notes for Agda 2 version 2.2.10+=======================================++Language+--------++* New flag: `--without-K`.++  This flag makes pattern matching more restricted. If the flag is+  activated, then Agda only accepts certain case-splits. If the type+  of the variable to be split is `D pars ixs`, where `D` is a data (or+  record) type, pars stands for the parameters, and `ixs` the indices,+  then the following requirements must be satisfied:++  - The indices `ixs` must be applications of constructors to distinct+    variables.++  - These variables must not be free in pars.++  The intended purpose of `--without-K` is to enable experiments with+  a propositional equality without the K rule. Let us define+  propositional equality as follows:++  ```agda+  data _≡_ {A : Set} : A → A → Set where+    refl : ∀ x → x ≡ x+  ```++  Then the obvious implementation of the J rule is accepted:++  ```agda+  J : {A : Set} (P : {x y : A} → x ≡ y → Set) →+      (∀ x → P (refl x)) →+      ∀ {x y} (x≡y : x ≡ y) → P x≡y+  J P p (refl x) = p x+  ```++  The same applies to Christine Paulin-Mohring's version of the J rule:++  ```agda+  J′ : {A : Set} {x : A} (P : {y : A} → x ≡ y → Set) →+       P (refl x) →+       ∀ {y} (x≡y : x ≡ y) → P x≡y+  J′ P p (refl x) = p+  ```++  On the other hand, the obvious implementation of the K rule is not+  accepted:++  ```agda+  K : {A : Set} (P : {x : A} → x ≡ x → Set) →+      (∀ x → P (refl x)) →+      ∀ {x} (x≡x : x ≡ x) → P x≡x+  K P p (refl x) = p x+  ```++  However, we have *not* proved that activation of `--without-K`+  ensures that the K rule cannot be proved in some other way.++* Irrelevant declarations.++  Postulates and functions can be marked as irrelevant by prefixing+  the name with a dot when the name is declared. Example:++  ```agda+  postulate+    .irrelevant : {A : Set} → .A → A+  ```++  Irrelevant names may only be used in irrelevant positions or in+  definitions of things which have been declared irrelevant.++  The axiom irrelevant above can be used to define a projection from+  an irrelevant record field:++  ```agda+  data Subset (A : Set) (P : A → Set) : Set where+    _#_ : (a : A) → .(P a) → Subset A P++  elem : ∀ {A P} → Subset A P → A+  elem (a # p) = a++  .certificate : ∀ {A P} (x : Subset A P) → P (elem x)+  certificate (a # p) = irrelevant p+  ```++  The right-hand side of certificate is relevant, so we cannot define++  ```agda+  certificate (a # p) = p+  ```++  (because `p` is irrelevant). However, certificate is declared to be+  irrelevant, so it can use the axiom irrelevant. Furthermore the+  first argument of the axiom is irrelevant, which means that+  irrelevant `p` is well-formed.++  As shown above the axiom irrelevant justifies irrelevant+  projections. Previously no projections were generated for irrelevant+  record fields, such as the field certificate in the following+  record type:++  ```agda+  record Subset (A : Set) (P : A → Set) : Set where+    constructor _#_+    field+      elem         : A+      .certificate : P elem+  ```++  Now projections are generated automatically for irrelevant fields+  (unless the flag `--no-irrelevant-projections` is used). Note that+  irrelevant projections are highly experimental.++* Termination checker recognises projections.++  Projections now preserve sizes, both in patterns and expressions.+  Example:++  ```agda+  record Wrap (A : Set) : Set where+    constructor wrap+    field+      unwrap : A++  open Wrap public++  data WNat : Set where+    zero : WNat+    suc  : Wrap WNat → WNat++  id : WNat → WNat+  id zero    = zero+  id (suc w) = suc (wrap (id (unwrap w)))+  ```++  In the structural ordering `unwrap w` ≤ `w`. This means that++  ```agda+    unwrap w ≤ w < suc w,+  ```++  and hence the recursive call to id is accepted.++  Projections also preserve guardedness.++Tools+-----++* Hyperlinks for top-level module names now point to the start of the+  module rather than to the declaration of the module name. This+  applies both to the Emacs mode and to the output of `agda --html`.++* Most occurrences of record field names are now highlighted as+  "fields". Previously many occurrences were highlighted as+  "functions".++* Emacs mode: It is no longer possible to change the behaviour of the+  `TAB` key by customising `agda2-indentation`.++* Epic compiler backend.++  A new compiler backend is being implemented. This backend makes use+  of Edwin Brady's language Epic+  (http://www.cs.st-andrews.ac.uk/~eb/epic.php) and its compiler. The+  backend should handle most Agda code, but is still at an+  experimental stage: more testing is needed, and some things written+  below may not be entirely true.++  The Epic compiler can be invoked from the command line using the+  flag `--epic`:++  ```+  agda --epic --epic-flag=<EPIC-FLAG> --compile-dir=<DIR> <FILE>.agda+  ```++  The `--epic-flag` flag can be given multiple times; each flag is+  given verbatim to the Epic compiler (in the given order). The+  resulting executable is named after the main module and placed in+  the directory specified by the `--compile-dir` flag (default: the+  project root). Intermediate files are placed in a subdirectory+  called `Epic`.++  The backend requires that there is a definition named main. This+  definition should be a value of type `IO Unit`, but at the moment+  this is not checked (so it is easy to produce a program which+  segfaults).  Currently the backend represents actions of type `IO A`+  as functions from `Unit` to `A`, and main is applied to the unit+  value.++  The Epic compiler compiles via C, not Haskell, so the pragmas+  related to the Haskell FFI (`IMPORT`, `COMPILED_DATA` and+  `COMPILED`) are not used by the Epic backend. Instead there is a new+  pragma `COMPILED_EPIC`. This pragma is used to give Epic code for+  postulated definitions (Epic code can in turn call C code). The form+  of the pragma is `{-# COMPILED_EPIC def code #-}`, where `def` is+  the name of an Agda postulate and `code` is some Epic code which+  should include the function arguments, return type and function+  body. As an example the `IO` monad can be defined as follows:++  ```agda+  postulate+    IO     : Set → Set+    return : ∀ {A} → A → IO A+    _>>=_  : ∀ {A B} → IO A → (A → IO B) → IO B++  {-# COMPILED_EPIC return (u : Unit, a : Any) -> Any =+                      ioreturn(a) #-}+  {-# COMPILED_EPIC+        _>>=_ (u1 : Unit, u2 : Unit, x : Any, f : Any) -> Any =+          iobind(x,f) #-}+  ```++  Here `ioreturn` and `iobind` are Epic functions which are defined in+  the file `AgdaPrelude.e` which is always included.++  By default the backend will remove so-called forced constructor+  arguments (and case-splitting on forced variables will be+  rewritten). This optimisation can be disabled by using the flag+  `--no-forcing`.++  All data types which look like unary natural numbers after forced+  constructor arguments have been removed (i.e. types with two+  constructors, one nullary and one with a single recursive argument)+  will be represented as "BigInts". This applies to the standard `Fin`+  type, for instance.++  The backend supports Agda's primitive functions and the BUILTIN+  pragmas. If the BUILTIN pragmas for unary natural numbers are used,+  then some operations, like addition and multiplication, will use+  more efficient "BigInt" operations.++  If you want to make use of the Epic backend you need to install some+  dependencies, see the README.++* The Emacs mode can compile using either the MAlonzo or the Epic+  backend. The variable `agda2-backend` controls which backend is+  used.
+ doc/release-notes/2.2.2.md view
@@ -0,0 +1,22 @@+Release notes for Agda 2 version 2.2.2+======================================++Tools+-----++* The `--malonzodir` option has been renamed to `--malonzo-dir`.++* The output of `agda --html` is by default placed in a directory+  called `html`.++Infrastructure+--------------++* The Emacs mode is included in the Agda Cabal package, and installed+  by `cabal install`. The recommended way to enable the Emacs mode is+  to include the following code in `.emacs`:++  ```elisp+  (load-file (let ((coding-system-for-read 'utf-8))+                  (shell-command-to-string "agda-mode locate")))+  ```
+ doc/release-notes/2.2.4.md view
@@ -0,0 +1,54 @@+Release notes for Agda 2 version 2.2.4+======================================++Important changes since 2.2.2:++* Change to the semantics of `open import` and `open module`. The+  declaration++  ```agda+  open import M <using/hiding/renaming>+  ```++  now translates to++  ```agda+  import A+  open A <using/hiding/renaming>+  ```++  instead of++  ```agda+  import A <using/hiding/renaming>+  open A+  ```++  The same translation is used for `open module M = E …`. Declarations+  involving the keywords as or public are changed in a corresponding+  way (`as` always goes with import, and `public` always with open).++  This change means that import directives do not affect the qualified+  names when open import/module is used. To get the old behaviour you+  can use the expanded version above.++* Names opened publicly in parameterised modules no longer inherit the+  module parameters. Example:++  ```agda+  module A where+    postulate X : Set++  module B (Y : Set) where+    open A public+  ```++  In Agda 2.2.2 `B.X` has type `(Y : Set) → Set`, whereas in+  Agda 2.2.4 `B.X` has type Set.++* Previously it was not possible to export a given constructor name+  through two different `open public` statements in the same module.+  This is now possible.++* Unicode subscript digits are now allowed for the hierarchy of+  universes (`Set₀`, `Set₁`, …): `Set₁` is equivalent to `Set1`.
+ doc/release-notes/2.2.6.md view
@@ -0,0 +1,290 @@+Release notes for Agda 2 version 2.2.6+======================================++Language+--------++* Universe polymorphism (experimental extension).++  To enable universe polymorphism give the flag+  `--universe-polymorphism` on the command line or (recommended) as an+  `OPTIONS` pragma.++  When universe polymorphism is enabled `Set` takes an argument which is+  the universe level. For instance, the type of universe polymorphic+  identity is++  ```agda+  id : {a : Level} {A : Set a} → A → A.+  ```++  The type Level is isomorphic to the unary natural numbers and should+  be specified using the BUILTINs `LEVEL`, `LEVELZERO`, and+  `LEVELSUC`:++  ```agda+  data Level : Set where+    zero : Level+    suc  : Level → Level++  {-# BUILTIN LEVEL     Level #-}+  {-# BUILTIN LEVELZERO zero  #-}+  {-# BUILTIN LEVELSUC  suc   #-}+  ```++  There is an additional BUILTIN `LEVELMAX` for taking the maximum of two+  levels:++  ```agda+  max : Level → Level → Level+  max  zero    m      = m+  max (suc n)  zero   = suc n+  max (suc n) (suc m) = suc (max n m)++  {-# BUILTIN LEVELMAX max #-}+  ```++  The non-polymorphic universe levels `Set`, `Set₁` and so on are+  sugar for `Set zero`, `Set (suc zero)`, etc.++  At present there is no automatic lifting of types from one level to+  another. It can still be done (rather clumsily) by defining types+  like the following one:++  ```agda+  data Lifted {a} (A : Set a) : Set (suc a) where+    lift : A → Lifted A+  ```++  However, it is likely that automatic lifting is introduced at some+  point in the future.++* Multiple constructors, record fields, postulates or primitives can+  be declared using a single type signature:++  ```agda+  data Bool : Set where+    false true : Bool++  postulate+    A B : Set+  ```++* Record fields can be implicit:++  ```agda+  record R : Set₁ where+    field+      {A}         : Set+      f           : A → A+      {B C} D {E} : Set+      g           : B → C → E+  ```++  By default implicit fields are not printed.++* Record constructors can be defined:++  ```agda+  record Σ (A : Set) (B : A → Set) : Set where+    constructor _,_+    field+      proj₁ : A+      proj₂ : B proj₁+  ```++  In this example `_,_` gets the type++  ```agda+   (proj₁ : A) → B proj₁ → Σ A B.+  ```++  For implicit fields the corresponding constructor arguments become+  implicit.++  Note that the constructor is defined in the *outer* scope, so any+  fixity declaration has to be given outside the record definition.+  The constructor is not in scope inside the record module.++  Note also that pattern matching for records has not been implemented+  yet.++* BUILTIN hooks for equality.++  The data type++  ```agda+  data _≡_ {A : Set} (x : A) : A → Set where+    refl : x ≡ x+  ```++  can be specified as the builtin equality type using the following+  pragmas:++  ```agda+  {-# BUILTIN EQUALITY _≡_  #-}+  {-# BUILTIN REFL     refl #-}+  ```++  The builtin equality is used for the new rewrite construct and+  the `primTrustMe` primitive described below.++* New `rewrite` construct.++  If `eqn : a ≡ b`, where `_≡_` is the builtin equality (see above) you+  can now write++  ```agda+  f ps rewrite eqn = rhs+  ```++  instead of++  ```agda+    f ps with a | eqn+    ... | ._ | refl = rhs+  ```++  The `rewrite` construct has the effect of rewriting the goal and the+  context by the given equation (left to right).++  You can rewrite using several equations (in sequence) by separating+  them with vertical bars (|):++  ```agda+  f ps rewrite eqn₁ | eqn₂ | … = rhs+  ```++  It is also possible to add `with`-clauses after rewriting:++  ```agda+  f ps rewrite eqns with e+  ... | p = rhs+  ```++  Note that pattern matching happens before rewriting—if you want to+  rewrite and then do pattern matching you can use a with after the+  rewrite.++  See `test/Succeed/Rewrite.agda` for some examples.++* A new primitive, `primTrustMe`, has been added:++  ```agda+    primTrustMe : {A : Set} {x y : A} → x ≡ y+  ```++  Here `_≡_` is the builtin equality (see BUILTIN hooks for equality,+  above).++  If `x` and `y` are definitionally equal, then+  `primTrustMe {x = x} {y = y}` reduces to `refl`.++  Note that the compiler replaces all uses of `primTrustMe` with the+  `REFL` builtin, without any check for definitional+  equality. Incorrect uses of `primTrustMe` can potentially lead to+  segfaults or similar problems.++  For an example of the use of `primTrustMe`, see `Data.String` in+  version 0.3 of the standard library, where it is used to implement+  decidable equality on strings using the primitive boolean equality.++* Changes to the syntax and semantics of IMPORT pragmas, which are+  used by the Haskell FFI. Such pragmas must now have the following+  form:++  ```agda+  {-# IMPORT <module name> #-}+  ```++  These pragmas are interpreted as *qualified* imports, so Haskell+  names need to be given qualified (unless they come from the Haskell+  prelude).++* The horizontal tab character (U+0009) is no longer treated as white+  space.++* Line pragmas are no longer supported.++* The `--include-path` flag can no longer be used as a pragma.++* The experimental and incomplete support for proof irrelevance has+  been disabled.++Tools+-----++* New `intro` command in the Emacs mode. When there is a canonical way+  of building something of the goal type (for instance, if the goal+  type is a pair), the goal can be refined in this way. The command+  works for the following goal types:++    - A data type where only one of its constructors can be used to+      construct an element of the goal type. (For instance, if the+      goal is a non-empty vector, a `cons` will be introduced.)++    - A record type. A record value will be introduced. Implicit+      fields will not be included unless showing of implicit arguments+      is switched on.++    - A function type. A lambda binding as many variables as possible+      will be introduced. The variable names will be chosen from the+      goal type if its normal form is a dependent function type,+      otherwise they will be variations on `x`. Implicit lambdas will+      only be inserted if showing of implicit arguments is switched+      on.++  This command can be invoked by using the `refine` command+  (`C-c C-r`) when the goal is empty. (The old behaviour of the refine+  command in this situation was to ask for an expression using the+  minibuffer.)++* The Emacs mode displays `Checked` in the mode line if the current+  file type checked successfully without any warnings.++* If a file `F` is loaded, and this file defines the module `M`, it is+  an error if `F` is not the file which defines `M` according to the+  include path.++  Note that the command-line tool and the Emacs mode define the+  meaning of relative include paths differently: the command-line tool+  interprets them relative to the current working directory, whereas+  the Emacs mode interprets them relative to the root directory of the+  current project. (As an example, if the module `A.B.C` is loaded+  from the file `<some-path>/A/B/C.agda`, then the root directory is+  `<some-path>`.)++* It is an error if there are several files on the include path which+  match a given module name.++* Interface files are relocatable. You can move around source trees as+  long as the include path is updated in a corresponding way. Note+  that a module `M` may be re-typechecked if its time stamp is+  strictly newer than that of the corresponding interface file+  (`M.agdai`).++* Type-checking is no longer done when an up-to-date interface exists.+  (Previously the initial module was always type-checked.)++* Syntax highlighting files for Emacs (`.agda.el`) are no longer used.+  The `--emacs` flag has been removed. (Syntax highlighting+  information is cached in the interface files.)++* The Agate and Alonzo compilers have been retired. The options+  `--agate`, `--alonzo` and `--malonzo` have been removed.++* The default directory for MAlonzo output is the project's root+  directory. The `--malonzo-dir` flag has been renamed to+  `--compile-dir`.++* Emacs mode: `C-c C-x C-d` no longer resets the type checking state.+  `C-c C-x C-r` can be used for a more complete reset. `C-c C-x C-s`+  (which used to reload the syntax highlighting information) has been+  removed. `C-c C-l` can be used instead.++* The Emacs mode used to define some "abbrevs", unless the user+  explicitly turned this feature off. The new default is *not* to add+  any abbrevs. The old default can be obtained by customising+  `agda2-mode-abbrevs-use-defaults` (a customisation buffer can be+  obtained by typing `M-x customize-group agda2 RET` after an Agda+  file has been loaded).
+ doc/release-notes/2.2.8.md view
@@ -0,0 +1,626 @@+Release notes for Agda 2 version 2.2.8+======================================++Language+--------++* Record pattern matching.++  It is now possible to pattern match on named record constructors.+  Example:++  ```agda+  record Σ (A : Set) (B : A → Set) : Set where+    constructor _,_+    field+      proj₁ : A+      proj₂ : B proj₁++  map : {A B : Set} {P : A → Set} {Q : B → Set}+        (f : A → B) → (∀ {x} → P x → Q (f x)) →+        Σ A P → Σ B Q+  map f g (x , y) = (f x , g y)+  ```++  The clause above is internally translated into the following one:++  ```agda+  map f g p = (f (Σ.proj₁ p) , g (Σ.proj₂ p))+  ```++  Record patterns containing data type patterns are not translated.+  Example:++  ```agda+  add : ℕ × ℕ → ℕ+  add (zero  , n) = n+  add (suc m , n) = suc (add (m , n))+  ```++  Record patterns which do not contain data type patterns, but which+  do contain dot patterns, are currently rejected. Example:++  ```agda+  Foo : {A : Set} (p₁ p₂ : A × A) → proj₁ p₁ ≡ proj₁ p₂ → Set₁+  Foo (x , y) (.x , y′) refl = Set+  ```++* Proof irrelevant function types.++  Agda now supports irrelevant non-dependent function types:++  ```agda+  f : .A → B+  ```++  This type implies that `f` does not depend computationally on its+  argument. One intended use case is data structures with embedded+  proofs, like sorted lists:++  ```agda+  postulate+    _≤_ : ℕ → ℕ → Set+    p₁  : 0 ≤ 1+    p₂  : 0 ≤ 1++  data SList (bound : ℕ) : Set where+    []    : SList bound+    scons : (head : ℕ) →+            .(head ≤ bound) →+            (tail : SList head) →+            SList bound+  ```++  The effect of the irrelevant type in the signature of `scons` is+  that `scons`'s second argument is never inspected after Agda has+  ensured that it has the right type. It is even thrown away, leading+  to smaller term sizes and hopefully some gain in efficiency. The+  type-checker ignores irrelevant arguments when checking equality, so+  two lists can be equal even if they contain different proofs:++  ```agda+  l₁ : SList 1+  l₁ = scons 0 p₁ []++  l₂ : SList 1+  l₂ = scons 0 p₂ []++  l₁≡l₂ : l₁ ≡ l₂+  l₁≡l₂ = refl+  ```++  Irrelevant arguments can only be used in irrelevant contexts.+  Consider the following subset type:++  ```agda+  data Subset (A : Set) (P : A → Set) : Set where+    _#_ : (elem : A) → .(P elem) → Subset A P+  ```++  The following two uses are fine:++  ```agda+  elimSubset : ∀ {A C : Set} {P} →+               Subset A P → ((a : A) → .(P a) → C) → C+  elimSubset (a # p) k = k a p++  elem : {A : Set} {P : A → Set} → Subset A P → A+  elem (x # p) = x+  ```++  However, if we try to project out the proof component, then Agda+  complains that `variable p is declared irrelevant, so it cannot be+  used here`:++  ```agda+  prjProof : ∀ {A P} (x : Subset A P) → P (elem x)+  prjProof (a # p) = p+  ```++  Matching against irrelevant arguments is also forbidden, except in+  the case of irrefutable matches (record constructor patterns which+  have been translated away). For instance, the match against the+  pattern `(p , q)` here is accepted:++  ```agda+  elim₂ : ∀ {A C : Set} {P Q : A → Set} →+          Subset A (λ x → Σ (P x) (λ _ → Q x)) →+          ((a : A) → .(P a) → .(Q a) → C) → C+  elim₂ (a # (p , q)) k = k a p q+  ```++  Absurd matches `()` are also allowed.++  Note that record fields can also be irrelevant. Example:++  ```agda+  record Subset (A : Set) (P : A → Set) : Set where+    constructor _#_+    field+      elem   : A+      .proof : P elem+  ```++  Irrelevant fields are never in scope, neither inside nor outside the+  record. This means that no record field can depend on an irrelevant+  field, and furthermore projections are not defined for such fields.+  Irrelevant fields can only be accessed using pattern matching, as in+  `elimSubset` above.++  Irrelevant function types were added very recently, and have not+  been subjected to much experimentation yet, so do not be surprised+  if something is changed before the next release. For instance,+  dependent irrelevant function spaces (`.(x : A) → B`) might be added+  in the future.++* Mixfix binders.++  It is now possible to declare user-defined syntax that binds+  identifiers. Example:++  ```agda+  postulate+    State  : Set → Set → Set+    put    : ∀ {S} → S → State S ⊤+    get    : ∀ {S} → State S S+    return : ∀ {A S} → A → State S A+    bind   : ∀ {A B S} → State S B → (B → State S A) → State S A++  syntax bind e₁ (λ x → e₂) = x ← e₁ , e₂++  increment : State ℕ ⊤+  increment = x ← get ,+              put (1 + x)+  ```++  The syntax declaration for `bind` implies that `x` is in scope in+  `e₂`, but not in `e₁`.++  You can give fixity declarations along with syntax declarations:++  ```agda+  infixr 40 bind+  syntax bind e₁ (λ x → e₂) = x ← e₁ , e₂+  ```++  The fixity applies to the syntax, not the name; syntax declarations+  are also restricted to ordinary, non-operator names. The following+  declaration is disallowed:++  ```agda+  syntax _==_ x y = x === y+  ```agda++  Syntax declarations must also be linear; the following declaration+  is disallowed:++  ```agda+  syntax wrong x = x + x+  ```++  Syntax declarations were added very recently, and have not been+  subjected to much experimentation yet, so do not be surprised if+  something is changed before the next release.++* `Prop` has been removed from the language.++  The experimental sort `Prop` has been disabled. Any program using+  `Prop` should typecheck if `Prop` is replaced by `Set₀`. Note that+  `Prop` is still a keyword.++* Injective type constructors off by default.++  Automatic injectivity of type constructors has been disabled (by+  default). To enable it, use the flag+  `--injective-type-constructors`, either on the command line or in an+  `OPTIONS` pragma. Note that this flag makes Agda anti-classical and+  possibly inconsistent:++    Agda with excluded middle is inconsistent+    http://thread.gmane.org/gmane.comp.lang.agda/1367++  See `test/Succeed/InjectiveTypeConstructors.agda` for an example.++* Termination checker can count.++  There is a new flag `--termination-depth=N` accepting values `N >=+  1` (with `N = 1` being the default) which influences the behavior of+  the termination checker. So far, the termination checker has only+  distinguished three cases when comparing the argument of a recursive+  call with the formal parameter of the callee.++  `<`: the argument is structurally smaller than the parameter++  `=`: they are equal++  `?`: the argument is bigger or unrelated to the parameter++  This behavior, which is still the default (`N = 1`), will not+  recognise the following functions as terminating.++   ```agda+   mutual++      f : ℕ → ℕ+      f zero          = zero+      f (suc zero)    = zero+      f (suc (suc n)) = aux n++      aux : ℕ → ℕ+      aux m = f (suc m)+  ```++  The call graph++  ```+  f --(<)--> aux --(?)--> f+  ```++  yields a recursive call from `f` to `f` via `aux` where the relation+  of call argument to callee parameter is computed as "unrelated"+  (composition of `<` and `?`).++  Setting `N >= 2` allows a finer analysis: `n` has two constructors+  less than `suc (suc n)`, and `suc m` has one more than `m`, so we get the+  call graph:++  ```+  f --(-2)--> aux --(+1)--> f+  ```++  The indirect call `f --> f` is now labeled with `(-1)`, and the+  termination checker can recognise that the call argument is+  decreasing on this path.++  Setting the termination depth to `N` means that the termination+  checker counts decrease up to `N` and increase up to `N-1`. The+  default, `N=1`, means that no increase is counted, every increase+  turns to "unrelated".++  In practice, examples like the one above sometimes arise when `with`+  is used. As an example, the program++  ```agda+  f : ℕ → ℕ+  f zero          = zero+  f (suc zero)    = zero+  f (suc (suc n)) with zero+  ... | _ = f (suc n)+  ```++  is internally represented as++  ```agda+  mutual++    f : ℕ → ℕ+    f zero          = zero+    f (suc zero)    = zero+    f (suc (suc n)) = aux n zero++    aux : ℕ → ℕ → ℕ+    aux m k = f (suc m)+  ```++  Thus, by default, the definition of `f` using `with` is not accepted+  by the termination checker, even though it looks structural (`suc n`+  is a subterm of `suc suc n`). Now, the termination checker is+  satisfied if the option `--termination-depth=2` is used.++  Caveats:++  - This is an experimental feature, hopefully being replaced by+    something smarter in the near future.++  - Increasing the termination depth will quickly lead to very long+    termination checking times. So, use with care. Setting termination+    depth to `100` by habit, just to be on the safe side, is not a good+    idea!++  - Increasing termination depth only makes sense for linear data+    types such as `ℕ` and `Size`. For other types, increase cannot be+    recognised. For instance, consider a similar example with lists.++    ```agda+    data List : Set where+      nil  : List+      cons : ℕ → List → List++    mutual+      f : List → List+      f nil                  = nil+      f (cons x nil)         = nil+      f (cons x (cons y ys)) = aux y ys++      aux : ℕ → List → List+      aux z zs = f (cons z zs)+    ```++    Here the termination checker compares `cons z zs` to `z` and also+    to `zs`. In both cases, the result will be "unrelated", no matter+    how high we set the termination depth. This is because when+    comparing `cons z zs` to `zs`, for instance, `z` is unrelated to+    `zs`, thus, `cons z zs` is also unrelated to `zs`. We cannot say+    it is just "one larger" since `z` could be a very large term. Note+    that this points to a weakness of untyped termination checking.++    To regain the benefit of increased termination depth, we need to+    index our lists by a linear type such as `ℕ` or `Size`. With+    termination depth `2`, the above example is accepted for vectors+    instead of lists.++* The `codata` keyword has been removed. To use coinduction, use the+  following new builtins: `INFINITY`, `SHARP` and `FLAT`. Example:++  ```agda+  {-# OPTIONS --universe-polymorphism #-}++  module Coinduction where++  open import Level++  infix 1000 ♯_++  postulate+    ∞  : ∀ {a} (A : Set a) → Set a+    ♯_ : ∀ {a} {A : Set a} → A → ∞ A+    ♭  : ∀ {a} {A : Set a} → ∞ A → A++  {-# BUILTIN INFINITY ∞  #-}+  {-# BUILTIN SHARP    ♯_ #-}+  {-# BUILTIN FLAT     ♭  #-}+  ```++  Note that (non-dependent) pattern matching on `SHARP` is no longer+  allowed.++  Note also that strange things might happen if you try to combine the+  pragmas above with `COMPILED_TYPE`, `COMPILED_DATA` or `COMPILED`+  pragmas, or if the pragmas do not occur right after the postulates.++  The compiler compiles the `INFINITY` builtin to nothing (more or+  less), so that the use of coinduction does not get in the way of FFI+  declarations:++  ```agda+  data Colist (A : Set) : Set where+    []  : Colist A+    _∷_ : (x : A) (xs : ∞ (Colist A)) → Colist A++  {-# COMPILED_DATA Colist [] [] (:) #-}+  ```++* Infinite types.++  If the new flag `--guardedness-preserving-type-constructors` is+  used, then type constructors are treated as inductive constructors+  when we check productivity (but only in parameters, and only if they+  are used strictly positively or not at all). This makes examples+  such as the following possible:++  ```agda+  data Rec (A : ∞ Set) : Set where+    fold : ♭ A → Rec A++  -- Σ cannot be a record type below.++  data Σ (A : Set) (B : A → Set) : Set where+    _,_ : (x : A) → B x → Σ A B++  syntax Σ A (λ x → B) = Σ[ x ∶ A ] B++  -- Corecursive definition of the W-type.++  W : (A : Set) → (A → Set) → Set+  W A B = Rec (♯ (Σ[ x ∶ A ] (B x → W A B)))++  syntax W A (λ x → B) = W[ x ∶ A ] B++  sup : {A : Set} {B : A → Set} (x : A) (f : B x → W A B) → W A B+  sup x f = fold (x , f)++  W-rec : {A : Set} {B : A → Set}+          (P : W A B → Set) →+          (∀ {x} {f : B x → W A B} → (∀ y → P (f y)) → P (sup x f)) →+          ∀ x → P x+  W-rec P h (fold (x , f)) = h (λ y → W-rec P h (f y))++  -- Induction-recursion encoded as corecursion-recursion.++  data Label : Set where+    ′0 ′1 ′2 ′σ ′π ′w : Label++  mutual++    U : Set+    U = Σ Label U′++    U′ : Label → Set+    U′ ′0 = ⊤+    U′ ′1 = ⊤+    U′ ′2 = ⊤+    U′ ′σ = Rec (♯ (Σ[ a ∶ U ] (El a → U)))+    U′ ′π = Rec (♯ (Σ[ a ∶ U ] (El a → U)))+    U′ ′w = Rec (♯ (Σ[ a ∶ U ] (El a → U)))++    El : U → Set+    El (′0 , _)            = ⊥+    El (′1 , _)            = ⊤+    El (′2 , _)            = Bool+    El (′σ , fold (a , b)) = Σ[ x ∶ El a ]  El (b x)+    El (′π , fold (a , b)) =   (x : El a) → El (b x)+    El (′w , fold (a , b)) = W[ x ∶ El a ]  El (b x)++  U-rec : (P : ∀ u → El u → Set) →+          P (′1 , _) tt →+          P (′2 , _) true →+          P (′2 , _) false →+          (∀ {a b x y} →+           P a x → P (b x) y → P (′σ , fold (a , b)) (x , y)) →+          (∀ {a b f} →+           (∀ x → P (b x) (f x)) → P (′π , fold (a , b)) f) →+          (∀ {a b x f} →+           (∀ y → P (′w , fold (a , b)) (f y)) →+           P (′w , fold (a , b)) (sup x f)) →+          ∀ u (x : El u) → P u x+  U-rec P P1 P2t P2f Pσ Pπ Pw = rec+    where+    rec : ∀ u (x : El u) → P u x+    rec (′0 , _)            ()+    rec (′1 , _)            _              = P1+    rec (′2 , _)            true           = P2t+    rec (′2 , _)            false          = P2f+    rec (′σ , fold (a , b)) (x , y)        = Pσ (rec _ x) (rec _ y)+    rec (′π , fold (a , b)) f              = Pπ (λ x → rec _ (f x))+    rec (′w , fold (a , b)) (fold (x , f)) = Pw (λ y → rec _ (f y))+  ```++  The `--guardedness-preserving-type-constructors` extension is based+  on a rather operational understanding of `∞`/`♯_`; it's not yet+  clear if this extension is consistent.++* Qualified constructors.++  Constructors can now be referred to qualified by their data type.+  For instance, given++  ```agda+  data Nat : Set where+    zero : Nat+    suc  : Nat → Nat++  data Fin : Nat → Set where+    zero : ∀ {n} → Fin (suc n)+    suc  : ∀ {n} → Fin n → Fin (suc n)+  ```++  you can refer to the constructors unambiguously as `Nat.zero`,+  `Nat.suc`, `Fin.zero`, and `Fin.suc` (`Nat` and `Fin` are modules+  containing the respective constructors). Example:++  ```agda+  inj : (n m : Nat) → Nat.suc n ≡ suc m → n ≡ m+  inj .m m refl = refl+  ```++  Previously you had to write something like++  ```agda+  inj : (n m : Nat) → _≡_ {Nat} (suc n) (suc m) → n ≡ m+  ```++  to make the type checker able to figure out that you wanted the+  natural number suc in this case.++* Reflection.++  There are two new constructs for reflection:++    - `quoteGoal x in e`++      In `e` the value of `x` will be a representation of the goal type+      (the type expected of the whole expression) as an element in a+      datatype of Agda terms (see below). For instance,++      ```agda+      example : ℕ+      example = quoteGoal x in {! at this point x = def (quote ℕ) [] !}+      ```++    - `quote x : Name`++      If `x` is the name of a definition (function, datatype, record,+      or a constructor), `quote x` gives you the representation of `x`+      as a value in the primitive type `Name` (see below).++  Quoted terms use the following BUILTINs and primitives (available+  from the standard library module `Reflection`):++  ```agda+  -- The type of Agda names.++  postulate Name : Set++  {-# BUILTIN QNAME Name #-}++  primitive primQNameEquality : Name → Name → Bool++  -- Arguments.++  Explicit? = Bool++  data Arg A : Set where+    arg : Explicit? → A → Arg A++  {-# BUILTIN ARG    Arg #-}+  {-# BUILTIN ARGARG arg #-}++  -- The type of Agda terms.++  data Term : Set where+    var     : ℕ → List (Arg Term) → Term+    con     : Name → List (Arg Term) → Term+    def     : Name → List (Arg Term) → Term+    lam     : Explicit? → Term → Term+    pi      : Arg Term → Term → Term+    sort    : Term+    unknown : Term++  {-# BUILTIN AGDATERM            Term    #-}+  {-# BUILTIN AGDATERMVAR         var     #-}+  {-# BUILTIN AGDATERMCON         con     #-}+  {-# BUILTIN AGDATERMDEF         def     #-}+  {-# BUILTIN AGDATERMLAM         lam     #-}+  {-# BUILTIN AGDATERMPI          pi      #-}+  {-# BUILTIN AGDATERMSORT        sort    #-}+  {-# BUILTIN AGDATERMUNSUPPORTED unknown #-}+  ```++  Reflection may be useful when working with internal decision+  procedures, such as the standard library's ring solver.++* Minor record definition improvement.++  The definition of a record type is now available when type checking+  record module definitions. This means that you can define things+  like the following:++  ```agda+  record Cat : Set₁ where+    field+      Obj  : Set+      _=>_ : Obj → Obj → Set+      -- ...++    -- not possible before:+    op : Cat+    op = record { Obj = Obj; _=>_ = λ A B → B => A }+  ```++Tools+-----++* The `Goal type and context` command now shows the goal type before+  the context, and the context is shown in reverse order. The `Goal+  type, context and inferred type` command has been modified in a+  similar way.++* Show module contents command.++  Given a module name `M` the Emacs mode can now display all the+  top-level modules and names inside `M`, along with types for the+  names. The command is activated using `C-c C-o` or the menus.++* Auto command.++  A command which searches for type inhabitants has been added. The+  command is invoked by pressing `C-C C-a` (or using the goal menu).+  There are several flags and parameters, e.g. `-c` which enables+  case-splitting in the search. For further information, see the Agda+  wiki:++    http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.Auto++* HTML generation is now possible for a module with unsolved+  meta-variables, provided that the `--allow-unsolved-metas` flag is+  used.
+ doc/release-notes/2.3.0.md view
@@ -0,0 +1,1124 @@+Release notes for Agda 2 version 2.3.0+======================================++Language+--------++* New more liberal syntax for mutually recursive definitions.++  It is no longer necessary to use the `mutual` keyword to define+  mutually recursive functions or datatypes. Instead, it is enough to+  declare things before they are used. Instead of++  ```agda+  mutual+    f : A+    f = a[f, g]++    g : B[f]+    g = b[f, g]+  ```++  you can now write++  ```agda+  f : A+  g : B[f]+  f = a[f, g]+  g = b[f, g].+  ```++  With the new style you have more freedom in choosing the order in+  which things are type checked (previously type signatures were+  always checked before definitions). Furthermore you can mix+  arbitrary declarations, such as modules and postulates, with+  mutually recursive definitions.++  For data types and records the following new syntax is used to+  separate the declaration from the definition:++  ```agda+  -- Declaration.+  data Vec (A : Set) : Nat → Set  -- Note the absence of 'where'.++  -- Definition.+  data Vec A where+    []   : Vec A zero+    _::_ : {n : Nat} → A → Vec A n → Vec A (suc n)++  -- Declaration.+  record Sigma (A : Set) (B : A → Set) : Set++  -- Definition.+  record Sigma A B where+    constructor _,_+    field fst : A+          snd : B fst+  ```++  When making separated declarations/definitions private or abstract+  you should attach the `private` keyword to the declaration and the+  `abstract` keyword to the definition. For instance, a private,+  abstract function can be defined as++  ```agda+  private+    f : A+  abstract+    f = e+  ```++  Finally it may be worth noting that the old style of mutually+  recursive definitions is still supported (it basically desugars into+  the new style).++* Pattern matching lambdas.++  Anonymous pattern matching functions can be defined using the syntax++  ```+  \ { p11 .. p1n -> e1 ; ... ; pm1 .. pmn -> em }+  ```++  (where, as usual, `\` and `->` can be replaced by `λ` and+  `→`). Internally this is translated into a function definition of+  the following form:++  ```+  .extlam p11 .. p1n = e1+  ...+  .extlam pm1 .. pmn = em+  ```++  This means that anonymous pattern matching functions are generative.+  For instance, `refl` will not be accepted as an inhabitant of the type++  ```agda+  (λ { true → true ; false → false }) ≡+  (λ { true → true ; false → false }),+  ```++  because this is equivalent to `extlam1 ≡ extlam2` for some distinct+  fresh names `extlam1` and `extlam2`.++  Currently the `where` and `with` constructions are not allowed in+  (the top-level clauses of) anonymous pattern matching functions.++  Examples:++  ```agda+  and : Bool → Bool → Bool+  and = λ { true x → x ; false _ → false }++  xor : Bool → Bool → Bool+  xor = λ { true  true  → false+          ; false false → false+          ; _     _     → true+          }++  fst : {A : Set} {B : A → Set} → Σ A B → A+  fst = λ { (a , b) → a }++  snd : {A : Set} {B : A → Set} (p : Σ A B) → B (fst p)+  snd = λ { (a , b) → b }+  ```++* Record update syntax.++  Assume that we have a record type and a corresponding value:++  ```agda+  record MyRecord : Set where+    field+      a b c : ℕ++  old : MyRecord+  old = record { a = 1; b = 2; c = 3 }+  ```++  Then we can update (some of) the record value's fields in the+  following way:++  ```agda+  new : MyRecord+  new = record old { a = 0; c = 5 }+  ```++  Here new normalises to `record { a = 0; b = 2; c = 5 }`. Any+  expression yielding a value of type `MyRecord` can be used instead of+  old.++  Record updating is not allowed to change types: the resulting value+  must have the same type as the original one, including the record+  parameters. Thus, the type of a record update can be inferred if the+  type of the original record can be inferred.++  The record update syntax is expanded before type checking. When the+  expression++  ```agda+  record old { upd-fields }+  ```++  is checked against a record type `R`, it is expanded to++  ```agda+  let r = old in record { new-fields },+  ```++  where old is required to have type `R` and new-fields is defined as+  follows: for each field `x` in `R`,++    - if `x = e` is contained in `upd-fields` then `x = e` is included in+      `new-fields`, and otherwise++    - if `x` is an explicit field then `x = R.x r` is included in+      `new-fields`, and++    - if `x` is an implicit or instance field, then it is omitted from+      `new-fields`.++  (Instance arguments are explained below.) The reason for treating+  implicit and instance fields specially is to allow code like the+  following:++  ```agda+  record R : Set where+    field+      {length} : ℕ+      vec      : Vec ℕ length+      -- More fields…++  xs : R+  xs = record { vec = 0 ∷ 1 ∷ 2 ∷ [] }++  ys = record xs { vec = 0 ∷ [] }+  ```++  Without the special treatment the last expression would need to+  include a new binding for length (for instance `length = _`).++* Record patterns which do not contain data type patterns, but which+  do contain dot patterns, are no longer rejected.++* When the `--without-K` flag is used literals are now treated as+  constructors.++* Under-applied functions can now reduce.++  Consider the following definition:++  ```agda+  id : {A : Set} → A → A+  id x = x+  ```++  Previously the expression `id` would not reduce. This has been+  changed so that it now reduces to `λ x → x`. Usually this makes+  little difference, but it can be important in conjunction with+  `with`. See Issue [#365](https://github.com/agda/agda/issues/365)+  for an example.++* Unused AgdaLight legacy syntax `(x y : A; z v : B)` for telescopes+  has been removed.++### Universe polymorphism++* Universe polymorphism is now enabled by default.  Use+  `--no-universe-polymorphism` to disable it.++* Universe levels are no longer defined as a data type.++  The basic level combinators can be introduced in the following way:++  ```agda+  postulate+    Level : Set+    zero  : Level+    suc   : Level → Level+    max   : Level → Level → Level++  {-# BUILTIN LEVEL     Level #-}+  {-# BUILTIN LEVELZERO zero  #-}+  {-# BUILTIN LEVELSUC  suc   #-}+  {-# BUILTIN LEVELMAX  max   #-}+  ```++* The BUILTIN equality is now required to be universe-polymorphic.++* `trustMe` is now universe-polymorphic.++### Meta-variables and unification++* Unsolved meta-variables are now frozen after every mutual block.+  This means that they cannot be instantiated by subsequent code. For+  instance,++  ```agda+  one : Nat+  one = _++  bla : one ≡ suc zero+  bla = refl+  ```++  leads to an error now, whereas previously it lead to the+  instantiation of `_` with `suc zero`. If you want to make use of the+  old behaviour, put the two definitions in a mutual block.++  All meta-variables are unfrozen during interactive editing, so that+  the user can fill holes interactively. Note that type-checking of+  interactively given terms is not perfect: Agda sometimes refuses to+  load a file, even though no complaints were raised during the+  interactive construction of the file. This is because certain checks+  (for instance, positivity) are only invoked when a file is loaded.++* Record types can now be inferred.++  If there is a unique known record type with fields matching the+  fields in a record expression, then the type of the expression will+  be inferred to be the record type applied to unknown parameters.++  If there is no known record type with the given fields the type+  checker will give an error instead of producing lots of unsolved+  meta-variables.++  Note that "known record type" refers to any record type in any+  imported module, not just types which are in scope.++* The occurrence checker distinguishes rigid and strongly rigid+  occurrences [Reed, LFMTP 2009; Abel & Pientka, TLCA 2011].++  The completeness checker now accepts the following code:++  ```agda+  h : (n : Nat) → n ≡ suc n → Nat+  h n ()+  ```++  Internally this generates a constraint `_n = suc _n` where the+  meta-variable `_n` occurs strongly rigidly, i.e. on a constructor+  path from the root, in its own defining term tree. This is never+  solvable.++  Weakly rigid recursive occurrences may have a solution [Jason Reed's+  PhD thesis, page 106]:++  ```agda+  test : (k : Nat) →+         let X : (Nat → Nat) → Nat+             X = _+         in+         (f : Nat → Nat) → X f ≡ suc (f (X (λ x → k)))+  test k f = refl+  ```++  The constraint `_X k f = suc (f (_X k (λ x → k)))` has the solution+  `_X k f = suc (f (suc k))`, despite the recursive occurrence of+  `_X`.  Here `_X` is not strongly rigid, because it occurs under the+  bound variable `f`. Previously Agda rejected this code; now it instead+  complains about an unsolved meta-variable.++* Equation constraints involving the same meta-variable in the head+  now trigger pruning [Pientka, PhD, Sec. 3.1.2; Abel & Pientka, TLCA+  2011]. Example:++  ```agda+  same : let X : A → A → A → A × A+             X = _+         in {x y z : A} → X x y y ≡ (x , y)+                        × X x x y ≡ X x y y+  same = refl , refl+  ```++  The second equation implies that `X` cannot depend on its second+  argument. After pruning the first equation is linear and can be+  solved.++* Instance arguments.++  A new type of hidden function arguments has been added: instance+  arguments. This new feature is based on influences from Scala's+  implicits and Agda's existing implicit arguments.++  Plain implicit arguments are marked by single braces: `{…}`. Instance+  arguments are instead marked by double braces: `{{…}}`. Example:++  ```agda+  postulate+    A : Set+    B : A → Set+    a : A+    f : {{a : A}} → B a+  ```++  Instead of the double braces you can use the symbols `⦃` and `⦄`,+  but these symbols must in many cases be surrounded by+  whitespace. (If you are using Emacs and the Agda input method, then+  you can conjure up the symbols by typing `\{{` and `\}}`,+  respectively.)++  Instance arguments behave as ordinary implicit arguments, except for+  one important aspect: resolution of arguments which are not provided+  explicitly. For instance, consider the following code:++  ```agda+    test = f+  ```++  Here Agda will notice that `f`'s instance argument was not provided+  explicitly, and try to infer it. All definitions in scope at `f`'s+  call site, as well as all variables in the context, are considered.+  If exactly one of these names has the required type `A`, then the+  instance argument will be instantiated to this name.++  This feature can be used as an alternative to Haskell type classes.+  If we define++  ```agda+  record Eq (A : Set) : Set where+    field equal : A → A → Bool,+  ```++  then we can define the following projection:++  ```agda+  equal : {A : Set} {{eq : Eq A}} → A → A → Bool+  equal {{eq}} = Eq.equal eq+  ```++  Now consider the following expression:++  ```agda+  equal false false ∨ equal 3 4+  ```++  If the following `Eq` "instances" for `Bool` and `ℕ` are in scope, and no+  others, then the expression is accepted:++  ```agda+  eq-Bool : Eq Bool+  eq-Bool = record { equal = … }++  eq-ℕ : Eq ℕ+  eq-ℕ = record { equal = … }+  ```++  A shorthand notation is provided to avoid the need to define+  projection functions manually:++  ```agda+  module Eq-with-implicits = Eq {{...}}+  ```++  This notation creates a variant of `Eq`'s record module, where the+  main `Eq` argument is an instance argument instead of an explicit one.+  It is equivalent to the following definition:++  ```agda+  module Eq-with-implicits {A : Set} {{eq : Eq A}} = Eq eq+  ```++  Note that the short-hand notation allows you to avoid naming the+  "-with-implicits" module:++  ```agda+  open Eq {{...}}+  ```++  Instance argument resolution is not recursive. As an example,+  consider the following "parametrised instance":++  ```agda+  eq-List : {A : Set} → Eq A → Eq (List A)+  eq-List {A} eq = record { equal = eq-List-A }+    where+    eq-List-A : List A → List A → Bool+    eq-List-A []       []       = true+    eq-List-A (a ∷ as) (b ∷ bs) = equal a b ∧ eq-List-A as bs+    eq-List-A _        _        = false+  ```++  Assume that the only `Eq` instances in scope are `eq-List` and+  `eq-ℕ`.  Then the following code does not type-check:++  ```agda+  test = equal (1 ∷ 2 ∷ []) (3 ∷ 4 ∷ [])+  ```++  However, we can make the code work by constructing a suitable+  instance manually:++  ```agda+  test′ = equal (1 ∷ 2 ∷ []) (3 ∷ 4 ∷ [])+    where eq-List-ℕ = eq-List eq-ℕ+  ```++  By restricting the "instance search" to be non-recursive we avoid+  introducing a new, compile-time-only evaluation model to Agda.++  For more information about instance arguments, see Devriese &+  Piessens [ICFP 2011]. Some examples are also available in the+  examples/instance-arguments subdirectory of the Agda distribution.++### Irrelevance++* Dependent irrelevant function types.++  Some examples illustrating the syntax of dependent irrelevant+  function types:++  ```+  .(x y : A) → B    .{x y z : A} → B+  ∀ x .y → B        ∀ x .{y} {z} .v → B+  ```++  The declaration++  ```+  f : .(x : A) → B[x]+  f x = t[x]+  ```++  requires that `x` is irrelevant both in `t[x]` and in `B[x]`. This+  is possible if, for instance, `B[x] = B′ x`, with `B′ : .A → Set`.++  Dependent irrelevance allows us to define the eliminator for the+  `Squash` type:++  ```agda+  record Squash (A : Set) : Set where+    constructor squash+    field+      .proof : A++  elim-Squash : {A : Set} (P : Squash A → Set)+                (ih : .(a : A) → P (squash a)) →+                (a⁻ : Squash A) → P a⁻+  elim-Squash P ih (squash a) = ih a+  ```++  Note that this would not type-check with++  ```agda+  (ih : (a : A) -> P (squash a)).+  ```++* Records with only irrelevant fields.++  The following now works:++  ```agda+  record IsEquivalence {A : Set} (_≈_ : A → A → Set) : Set where+    field+      .refl  : Reflexive _≈_+      .sym   : Symmetric _≈_+      .trans : Transitive _≈_++  record Setoid : Set₁ where+    infix 4 _≈_+    field+      Carrier        : Set+      _≈_            : Carrier → Carrier → Set+      .isEquivalence : IsEquivalence _≈_++    open IsEquivalence isEquivalence public+  ```++  Previously Agda complained about the application+  `IsEquivalence isEquivalence`, because `isEquivalence` is irrelevant+  and the `IsEquivalence` module expected a relevant argument. Now,+  when record modules are generated for records consisting solely of+  irrelevant arguments, the record parameter is made irrelevant:++   ```agda+  module IsEquivalence {A : Set} {_≈_ : A → A → Set}+                       .(r : IsEquivalence {A = A} _≈_) where+    …+  ```++* Irrelevant things are no longer erased internally. This means that+  they are printed as ordinary terms, not as `_` as before.++* The new flag `--experimental-irrelevance` enables irrelevant+  universe levels and matching on irrelevant data when only one+  constructor is available. These features are very experimental and+  likely to change or disappear.++### Reflection++* The reflection API has been extended to mirror features like+  irrelevance, instance arguments and universe polymorphism, and to+  give (limited) access to definitions. For completeness all the+  builtins and primitives are listed below:++  ```agda+  -- Names.++  postulate Name : Set++  {-# BUILTIN QNAME Name #-}++  primitive+    -- Equality of names.+    primQNameEquality : Name → Name → Bool++  -- Is the argument visible (explicit), hidden (implicit), or an+  -- instance argument?++  data Visibility : Set where+    visible hidden instance : Visibility++  {-# BUILTIN HIDING   Visibility #-}+  {-# BUILTIN VISIBLE  visible    #-}+  {-# BUILTIN HIDDEN   hidden     #-}+  {-# BUILTIN INSTANCE instance   #-}++  -- Arguments can be relevant or irrelevant.++  data Relevance : Set where+    relevant irrelevant : Relevance++  {-# BUILTIN RELEVANCE  Relevance  #-}+  {-# BUILTIN RELEVANT   relevant   #-}+  {-# BUILTIN IRRELEVANT irrelevant #-}++  -- Arguments.++  data Arg A : Set where+    arg : (v : Visibility) (r : Relevance) (x : A) → Arg A++  {-# BUILTIN ARG    Arg #-}+  {-# BUILTIN ARGARG arg #-}++  -- Terms.++  mutual+    data Term : Set where+      -- Variable applied to arguments.+      var     : (x : ℕ) (args : List (Arg Term)) → Term+      -- Constructor applied to arguments.+      con     : (c : Name) (args : List (Arg Term)) → Term+      -- Identifier applied to arguments.+      def     : (f : Name) (args : List (Arg Term)) → Term+      -- Different kinds of λ-abstraction.+      lam     : (v : Visibility) (t : Term) → Term+      -- Pi-type.+      pi      : (t₁ : Arg Type) (t₂ : Type) → Term+      -- A sort.+      sort    : Sort → Term+      -- Anything else.+      unknown : Term++    data Type : Set where+      el : (s : Sort) (t : Term) → Type++    data Sort : Set where+      -- A Set of a given (possibly neutral) level.+      set     : (t : Term) → Sort+      -- A Set of a given concrete level.+      lit     : (n : ℕ) → Sort+      -- Anything else.+      unknown : Sort++  {-# BUILTIN AGDASORT            Sort    #-}+  {-# BUILTIN AGDATYPE            Type    #-}+  {-# BUILTIN AGDATERM            Term    #-}+  {-# BUILTIN AGDATERMVAR         var     #-}+  {-# BUILTIN AGDATERMCON         con     #-}+  {-# BUILTIN AGDATERMDEF         def     #-}+  {-# BUILTIN AGDATERMLAM         lam     #-}+  {-# BUILTIN AGDATERMPI          pi      #-}+  {-# BUILTIN AGDATERMSORT        sort    #-}+  {-# BUILTIN AGDATERMUNSUPPORTED unknown #-}+  {-# BUILTIN AGDATYPEEL          el      #-}+  {-# BUILTIN AGDASORTSET         set     #-}+  {-# BUILTIN AGDASORTLIT         lit     #-}+  {-# BUILTIN AGDASORTUNSUPPORTED unknown #-}++  postulate+    -- Function definition.+    Function  : Set+    -- Data type definition.+    Data-type : Set+    -- Record type definition.+    Record    : Set++  {-# BUILTIN AGDAFUNDEF    Function  #-}+  {-# BUILTIN AGDADATADEF   Data-type #-}+  {-# BUILTIN AGDARECORDDEF Record    #-}++  -- Definitions.++  data Definition : Set where+    function     : Function  → Definition+    data-type    : Data-type → Definition+    record′      : Record    → Definition+    constructor′ : Definition+    axiom        : Definition+    primitive′   : Definition++  {-# BUILTIN AGDADEFINITION                Definition   #-}+  {-# BUILTIN AGDADEFINITIONFUNDEF          function     #-}+  {-# BUILTIN AGDADEFINITIONDATADEF         data-type    #-}+  {-# BUILTIN AGDADEFINITIONRECORDDEF       record′      #-}+  {-# BUILTIN AGDADEFINITIONDATACONSTRUCTOR constructor′ #-}+  {-# BUILTIN AGDADEFINITIONPOSTULATE       axiom        #-}+  {-# BUILTIN AGDADEFINITIONPRIMITIVE       primitive′   #-}++  primitive+    -- The type of the thing with the given name.+    primQNameType        : Name → Type+    -- The definition of the thing with the given name.+    primQNameDefinition  : Name → Definition+    -- The constructors of the given data type.+    primDataConstructors : Data-type → List Name+  ```++  As an example the expression++  ```agda+  primQNameType (quote zero)+  ```++  is definitionally equal to++  ```agda+  el (lit 0) (def (quote ℕ) [])+  ```++  (if `zero` is a constructor of the data type `ℕ`).++* New keyword: `unquote`.++  The construction `unquote t` converts a representation of an Agda term+  to actual Agda code in the following way:++  1. The argument `t` must have type `Term` (see the reflection API above).++  2. The argument is normalised.++  3. The entire construction is replaced by the normal form, which is+     treated as syntax written by the user and type-checked in the+     usual way.++  Examples:++  ```agda+  test : unquote (def (quote ℕ) []) ≡ ℕ+  test = refl++  id : (A : Set) → A → A+  id = unquote (lam visible (lam visible (var 0 [])))++  id-ok : id ≡ (λ A (x : A) → x)+  id-ok = refl+  ```++* New keyword: `quoteTerm`.++  The construction `quoteTerm t` is similar to `quote n`, but whereas+  `quote` is restricted to names `n`, `quoteTerm` accepts terms+  `t`. The construction is handled in the following way:++  1. The type of `t` is inferred. The term `t` must be type-correct.++  2. The term `t` is normalised.++  3. The construction is replaced by the Term representation (see the+     reflection API above) of the normal form. Any unsolved metavariables+     in the term are represented by the `unknown` term constructor.++  Examples:++  ```agda+  test₁ : quoteTerm (λ {A : Set} (x : A) → x) ≡+          lam hidden (lam visible (var 0 []))+  test₁ = refl++  -- Local variables are represented as de Bruijn indices.+  test₂ : (λ {A : Set} (x : A) → quoteTerm x) ≡ (λ x → var 0 [])+  test₂ = refl++  -- Terms are normalised before being quoted.+  test₃ : quoteTerm (0 + 0) ≡ con (quote zero) []+  test₃ = refl+  ```++Compiler backends+-----------------++### MAlonzo++* The MAlonzo backend's FFI now handles universe polymorphism in a+  better way.++  The translation of Agda types and kinds into Haskell now supports+  universe-polymorphic postulates. The core changes are that the+  translation of function types has been changed from++  ```+  T[[ Pi (x : A) B ]] =+    if A has a Haskell kind then+      forall x. () -> T[[ B ]]+    else if x in fv B then+      undef+    else+      T[[ A ]] -> T[[ B ]]+  ```++  into++  ```+  T[[ Pi (x : A) B ]] =+    if x in fv B then+      forall x. T[[ A ]] -> T[[ B ]]  -- Note: T[[A]] not Unit.+    else+      T[[ A ]] -> T[[ B ]],+  ```++  and that the translation of constants (postulates, constructors and+  literals) has been changed from++  ```+  T[[ k As ]] =+    if COMPILED_TYPE k T then+      T T[[ As ]]+    else+      undef+  ```++  into++  ```+  T[[ k As ]] =+    if COMPILED_TYPE k T then+      T T[[ As ]]+    else if COMPILED k E then+      ()+    else+      undef.+  ```++  For instance, assuming a Haskell definition++  ```haskell+    type AgdaIO a b = IO b,+  ```++  we can set up universe-polymorphic `IO` in the following way:++  ```agda+  postulate+    IO     : ∀ {ℓ} → Set ℓ → Set ℓ+    return : ∀ {a} {A : Set a} → A → IO A+    _>>=_  : ∀ {a b} {A : Set a} {B : Set b} →+             IO A → (A → IO B) → IO B++  {-# COMPILED_TYPE IO AgdaIO              #-}+  {-# COMPILED return  (\_ _ -> return)    #-}+  {-# COMPILED _>>=_   (\_ _ _ _ -> (>>=)) #-}+  ```++  This is accepted because (assuming that the universe level type is+  translated to the Haskell unit type `()`)++  ```haskell+  (\_ _ -> return)+    : forall a. () -> forall b. () -> b -> AgdaIO a b+    = T [[ ∀ {a} {A : Set a} → A → IO A ]]+  ```++  and++  ```haskell+  (\_ _ _ _ -> (>>=))+    : forall a. () -> forall b. () ->+        forall c. () -> forall d. () ->+          AgdaIO a c -> (c -> AgdaIO b d) -> AgdaIO b d+    = T [[ ∀ {a b} {A : Set a} {B : Set b} →+             IO A → (A → IO B) → IO B ]].+  ```++### Epic++* New Epic backend pragma: `STATIC`.++  In the Epic backend, functions marked with the `STATIC` pragma will be+  normalised before compilation. Example usage:++  ```+  {-# STATIC power #-}++  power : ℕ → ℕ → ℕ+  power 0       x = 1+  power 1       x = x+  power (suc n) x = power n x * x+  ```++  Occurrences of `power 4 x` will be replaced by `((x * x) * x) * x`.++* Some new optimisations have been implemented in the Epic backend:++  - Removal of unused arguments.++  A worker/wrapper transformation is performed so that unused+  arguments can be removed by Epic's inliner. For instance, the map+  function is transformed in the following way:++  ```agda+  map_wrap : (A B : Set) → (A → B) → List A → List B+  map_wrap A B f xs = map_work f xs++  map_work f []       = []+  map_work f (x ∷ xs) = f x ∷ map_work f xs+  ```++  If `map_wrap` is inlined (which it will be in any saturated call),+  then `A` and `B` disappear in the generated code.++  Unused arguments are found using abstract interpretation. The bodies+  of all functions in a module are inspected to decide which variables+  are used. The behaviour of postulates is approximated based on their+  types. Consider `return`, for instance:++  ```agda+  postulate return : {A : Set} → A → IO A+  ```++  The first argument of `return` can be removed, because it is of type+  Set and thus cannot affect the outcome of a program at runtime.++  - Injection detection.++  At runtime many functions may turn out to be inefficient variants of+  the identity function. This is especially true after forcing.+  Injection detection replaces some of these functions with more+  efficient versions. Example:++  ```agda+  inject : {n : ℕ} → Fin n → Fin (1 + n)+  inject {suc n} zero    = zero+  inject {suc n} (suc i) = suc (inject {n} i)+  ```++  Forcing removes the `Fin` constructors' `ℕ` arguments, so this+  function is an inefficient identity function that can be replaced by+  the following one:++  ```agda+  inject {_} x = x+  ```++  To actually find this function, we make the induction hypothesis+  that inject is an identity function in its second argument and look+  at the branches of the function to decide if this holds.++  Injection detection also works over data type barriers. Example:++  ```agda+  forget : {A : Set} {n : ℕ} → Vec A n → List A+  forget []       = []+  forget (x ∷ xs) = x ∷ forget xs+  ```++  Given that the constructor tags (in the compiled Epic code) for+  `Vec.[]` and `List.[]` are the same, and that the tags for `Vec._∷_`+  and `List._∷_` are also the same, this is also an identity+  function. We can hence replace the definition with the following+  one:++  ```agda+  forget {_} xs = xs+  ```++  To get this to apply as often as possible, constructor tags are+  chosen *after* injection detection has been run, in a way to make as+  many functions as possible injections.++  Constructor tags are chosen once per source file, so it may be+  advantageous to define conversion functions like forget in the same+  module as one of the data types. For instance, if `Vec.agda` imports+  `List.agda`, then the forget function should be put in `Vec.agda` to+  ensure that vectors and lists get the same tags (unless some other+  injection function, which puts different constraints on the tags, is+  prioritised).++  - Smashing.++  This optimisation finds types whose values are inferable at runtime:++    * A data type with only one constructor where all fields are+      inferable is itself inferable.++    * `Set ℓ` is inferable (as it has no runtime representation).++  A function returning an inferable data type can be smashed, which+  means that it is replaced by a function which simply returns the+  inferred value.++  An important example of an inferable type is the usual propositional+  equality type (`_≡_`). Any function returning a propositional+  equality can simply return the reflexivity constructor directly+  without computing anything.++  This optimisation makes more arguments unused. It also makes the+  Epic code size smaller, which in turn speeds up compilation.++### JavaScript++* ECMAScript compiler backend.++  A new compiler backend is being implemented, targetting ECMAScript+  (also known as JavaScript), with the goal of allowing Agda programs+  to be run in browsers or other ECMAScript environments.++  The backend is still at an experimental stage: the core language is+  implemented, but many features are still missing.++  The ECMAScript compiler can be invoked from the command line using+  the flag `--js`:++  ```+  agda --js --compile-dir=<DIR> <FILE>.agda+  ```++  Each source `<FILE>.agda` is compiled into an ECMAScript target+  `<DIR>/jAgda.<TOP-LEVEL MODULE NAME>.js`. The compiler can also be+  invoked using the Emacs mode (the variable `agda2-backend` controls+  which backend is used).++  Note that ECMAScript is a strict rather than lazy language. Since+  Agda programs are total, this should not impact program semantics,+  but it may impact their space or time usage.++  ECMAScript does not support algebraic datatypes or pattern-matching.+  These features are translated to a use of the visitor pattern. For+  instance, the standard library's `List` data type and `null`+  function are translated into the following code:++  ```javascript+  exports["List"] = {};+  exports["List"]["[]"] = function (x0) {+      return x0["[]"]();+    };+  exports["List"]["_∷_"] = function (x0) {+      return function (x1) {+        return function (x2) {+          return x2["_∷_"](x0, x1);+        };+      };+    };++  exports["null"] = function (x0) {+      return function (x1) {+        return function (x2) {+          return x2({+            "[]": function () {+              return jAgda_Data_Bool["Bool"]["true"];+            },+            "_∷_": function (x3, x4) {+              return jAgda_Data_Bool["Bool"]["false"];+            }+          });+        };+      };+    };+  ```++  Agda records are translated to ECMAScript objects, preserving field+  names.++  Top-level Agda modules are translated to ECMAScript modules,+  following the `common.js` module specification. A top-level Agda+  module `Foo.Bar` is translated to an ECMAScript module+  `jAgda.Foo.Bar`.++  The ECMAScript compiler does not compile to Haskell, so the pragmas+  related to the Haskell FFI (`IMPORT`, `COMPILED_DATA` and+  `COMPILED`) are not used by the ECMAScript backend. Instead, there+  is a `COMPILED_JS` pragma which may be applied to any+  declaration. For postulates, primitives, functions and values, it+  gives the ECMAScript code to be emitted by the compiler. For data+  types, it gives a function which is applied to a value of that type,+  and a visitor object. For instance, a binding of natural numbers to+  ECMAScript integers (ignoring overflow errors) is:++  ```agda+  data ℕ : Set where+    zero : ℕ+    suc  : ℕ → ℕ++  {-# COMPILED_JS ℕ function (x,v) {+      if (x < 1) { return v.zero(); } else { return v.suc(x-1); }+    } #-}+  {-# COMPILED_JS zero 0 #-}+  {-# COMPILED_JS suc function (x) { return x+1; } #-}++  _+_ : ℕ → ℕ → ℕ+  zero  + n = n+  suc m + n = suc (m + n)++  {-# COMPILED_JS _+_ function (x) { return function (y) {+                        return x+y; };+    } #-}+  ```++  To allow FFI code to be optimised, the ECMAScript in a `COMPILED_JS`+  declaration is parsed, using a simple parser that recognises a pure+  functional subset of ECMAScript, consisting of functions, function+  applications, return, if-statements, if-expressions,+  side-effect-free binary operators (no precedence, left associative),+  side-effect-free prefix operators, objects (where all member names+  are quoted), field accesses, and string and integer literals.+  Modules may be imported using the require (`<module-id>`) syntax: any+  impure code, or code outside the supported fragment, can be placed+  in a module and imported.++Tools+-----++* New flag `--safe`, which can be used to type-check untrusted code.++  This flag disables postulates, `primTrustMe`, and "unsafe" `OPTIONS`+  pragmas, some of which are known to make Agda inconsistent.++  Rejected pragmas:++  ```+  --allow-unsolved-metas+  --experimental-irrelevance+  --guardedness-preserving-type-construtors+  --injective-type-constructors+  --no-coverage-check+  --no-positivity-check+  --no-termination-check+  --sized-types+  --type-in-type+  ```++  Note that, at the moment, it is not possible to define the universe+  level or coinduction primitives when `--safe` is used (because they+  must be introduced as postulates). This can be worked around by+  type-checking trusted files in a first pass, without using `--safe`,+  and then using `--saf`e in a second pass. Modules which have already+  been type-checked are not re-type-checked just because `--safe` is+  used.++* Dependency graphs.++  The new flag `--dependency-graph=FILE` can be used to generate a DOT+  file containing a module dependency graph. The generated file (FILE)+  can be rendered using a tool like dot.++* The `--no-unreachable-check` flag has been removed.++* Projection functions are highlighted as functions instead of as+  fields. Field names (in record definitions and record values) are+  still highlighted as fields.++* Support for jumping to positions mentioned in the information+  buffer has been added.++* The `make install` command no longer installs Agda globally (by+  default).
+ doc/release-notes/2.3.2.1.md view
@@ -0,0 +1,16 @@+Release notes for Agda 2 version 2.3.2.1+========================================++Installation+------------++* Made it possible to compile Agda with more recent versions of+  hashable, QuickCheck and Win32.++* Excluded mtl-2.1.++Type checking+-------------++* Fixed bug in the termination checker+  (Issue [#754](https://github.com/agda/agda/issues/754)).
+ doc/release-notes/2.3.2.2.md view
@@ -0,0 +1,10 @@+Release notes for Agda 2 version 2.3.2.2+========================================++* Fixed a bug that sometimes made it tricky to use the Emacs mode on+  Windows [Issue [#757](https://github.com/agda/agda/issues/757)].++* Made Agda build with newer versions of some libraries.++* Fixed a bug that caused ambiguous parse error messages+  [Issue [#147](https://github.com/agda/agda/issues/147)].
+ doc/release-notes/2.3.2.md view
@@ -0,0 +1,806 @@+Release notes for Agda 2 version 2.3.2+======================================++Installation+------------++* The Agda-executable package has been removed.++  The executable is now provided as part of the Agda package.++* The Emacs mode no longer depends on haskell-mode or GHCi.++* Compilation of Emacs mode Lisp files.++  You can now compile the Emacs mode Lisp files by running `agda-mode+  compile`. This command is run by `make install`.++  Compilation can, in some cases, give a noticeable speedup.++  WARNING: If you reinstall the Agda mode without recompiling the+  Emacs Lisp files, then Emacs may continue using the old, compiled+  files.++Pragmas and options+-------------------++* The `--without-K` check now reconstructs constructor parameters.++  New specification of `--without-K`:++  If the flag is activated, then Agda only accepts certain+  case-splits. If the type of the variable to be split is+  `D pars ixs`, where `D` is a data (or record) type, `pars` stands+  for the parameters, and `ixs` the indices, then the following+  requirements must be satisfied:++  - The indices `ixs` must be applications of constructors (or+    literals) to distinct variables. Constructors are usually not+    applied to parameters, but for the purposes of this check+    constructor parameters are treated as other arguments.++  - These distinct variables must not be free in pars.++* Irrelevant arguments are printed as `_` by default now.  To turn on+  printing of irrelevant arguments, use option++  ```+  --show-irrelevant+  ```++* New: Pragma `NO_TERMINATION_CHECK` to switch off termination checker+  for individual function definitions and mutual blocks.++  The pragma must precede a function definition or a mutual block.+  Examples (see `test/Succeed/NoTerminationCheck.agda`):++  1. Skipping a single definition: before type signature.++     ```agda+     {-# NO_TERMINATION_CHECK #-}+     a : A+     a = a+     ```++  2. Skipping a single definition: before first clause.++     ```agda+     b : A+     {-# NO_TERMINATION_CHECK #-}+     b = b+     ```++  3. Skipping an old-style mutual block: Before `mutual` keyword.++     ```agda+     {-# NO_TERMINATION_CHECK #-}+     mutual+       c : A+       c = d++       d : A+       d = c+     ```++  4. Skipping a new-style mutual block: Anywhere before a type+     signature or first function clause in the block++     ```agda+     i : A+     j : A++     i = j+     {-# NO_TERMINATION_CHECK #-}+     j = i+     ```++  The pragma cannot be used in `--safe` mode.++Language+--------++* Let binding record patterns++  ```agda+  record _×_ (A B : Set) : Set where+    constructor _,_+    field+      fst : A+      snd : B+  open _×_++  let (x , (y , z)) = t+  in  u+  ```++  will now be interpreted as++  ```agda+  let x = fst t+      y = fst (snd t)+      z = snd (snd t)+  in  u+  ```++  Note that the type of `t` needs to be inferable. If you need to+  provide a type signature, you can write the following:++  ```agda+  let a : ...+      a = t+      (x , (y , z)) = a+  in  u+  ```++* Pattern synonyms++  A pattern synonym is a declaration that can be used on the left hand+  side (when pattern matching) as well as the right hand side (in+  expressions). For example:++  ```agda+  pattern z    = zero+  pattern ss x = suc (suc x)++  f : ℕ -> ℕ+  f z       = z+  f (suc z) = ss z+  f (ss n)  = n+  ```++  Pattern synonyms are implemented by substitution on the abstract+  syntax, so definitions are scope-checked but not type-checked. They+  are particularly useful for universe constructions.++* Qualified mixfix operators++  It is now possible to use a qualified mixfix operator by qualifying+  the first part of the name. For instance++  ```agda+  import Data.Nat as Nat+  import Data.Bool as Bool++  two = Bool.if true then 1 Nat.+ 1 else 0+  ```++* Sections [Issue [#735](https://github.com/agda/agda/issues/735)].+  Agda now parses anonymous modules as sections:++  ```agda+  module _ {a} (A : Set a) where++    data List : Set a where+      []  : List+      _∷_ : (x : A) (xs : List) → List++  module _ {a} {A : Set a} where++    _++_ : List A → List A → List A+    []       ++ ys = ys+    (x ∷ xs) ++ ys = x ∷ (xs ++ ys)++  test : List Nat+  test = (5 ∷ []) ++ (3 ∷ [])+  ```++  In general, now the syntax++  ```agda+  module _ parameters where+    declarations+  ```++  is accepted and has the same effect as++  ```agda+  private+    module M parameters where+      declarations+  open M public+  ```++  for a fresh name `M`.++* Instantiating a module in an open import statement+  [Issue [#481](https://github.com/agda/agda/issues/481)]. Now+  accepted:++  ```agda+  open import Path.Module args [using/hiding/renaming (...)]+  ```++  This only brings the imported identifiers from `Path.Module` into scope,+  not the module itself!  Consequently, the following is pointless, and raises+  an error:++  ```agda+    import Path.Module args [using/hiding/renaming (...)]+  ```++  You can give a private name `M` to the instantiated module via++  ```agda+  import Path.Module args as M [using/hiding/renaming (...)]+  open import Path.Module args as M [using/hiding/renaming (...)]+  ```++  Try to avoid `as` as part of the arguments.  `as` is not a keyword;+  the following can be legal, although slightly obfuscated Agda code:++  ```agda+  open import as as as as as as+  ```++* Implicit module parameters can be given by name. E.g.++  ```agda+  open M {namedArg = bla}+  ```++  This feature has been introduced in Agda 2.3.0 already.++* Multiple type signatures sharing a same type can now be written as a single+  type signature.++  ```agda+  one two : ℕ+  one = suc zero+  two = suc one+  ```++Goal and error display+----------------------++* Meta-variables that were introduced by hidden argument `arg` are now+  printed as `_arg_number` instead of just `_number`.+  [Issue [#526](https://github.com/agda/agda/issues/526)]++* Agda expands identifiers in anonymous modules when printing.  Should+  make some goals nicer to read.+  [Issue [#721](https://github.com/agda/agda/issues/721)]++* When a module identifier is ambiguous, Agda tells you if one of them+  is a data type module.+  [Issues [#318](https://github.com/agda/agda/issues/318),+  [#705](https://github.com/agda/agda/issues/705)]++Type checking+-------------++* Improved coverage checker. The coverage checker splits on arguments+  that have constructor or literal pattern, committing to the+  left-most split that makes progress.  Consider the lookup function+  for vectors:++  ```agda+  data Fin : Nat → Set where+    zero : {n : Nat} → Fin (suc n)+    suc  : {n : Nat} → Fin n → Fin (suc n)++  data Vec (A : Set) : Nat → Set where+    []  : Vec A zero+    _∷_ : {n : Nat} → A → Vec A n → Vec A (suc n)++  _!!_ : {A : Set}{n : Nat} → Vec A n → Fin n → A+  (x ∷ xs) !! zero  = x+  (x ∷ xs) !! suc i = xs !! i+  ```++  In Agda up to 2.3.0, this definition is rejected unless we add+  an absurd clause++  ```agda+  [] !! ()+  ```++  This is because the coverage checker committed on splitting on the+  vector argument, even though this inevitably lead to failed+  coverage, because a case for the empty vector `[]` is missing.++  The improvement to the coverage checker consists on committing only+  on splits that have a chance of covering, since all possible+  constructor patterns are present.  Thus, Agda will now split first+  on the `Fin` argument, since cases for both `zero` and `suc` are+  present.  Then, it can split on the `Vec` argument, since the empty+  vector is already ruled out by instantiating `n` to a `suc _`.++* Instance arguments resolution will now consider candidates which+  still expect hidden arguments. For example:++  ```agda+  record Eq (A : Set) : Set where+    field eq : A → A → Bool++  open Eq {{...}}++  eqFin : {n : ℕ} → Eq (Fin n)+  eqFin = record { eq = primEqFin }++  testFin : Bool+  testFin = eq fin1 fin2+  ```++  The type-checker will now resolve the instance argument of the `eq`+  function to `eqFin {_}`. This is only done for hidden arguments, not+  instance arguments, so that the instance search stays non-recursive.++* Constraint solving: Upgraded Miller patterns to record patterns.+  [Issue [#456](https://github.com/agda/agda/issues/456)]++  Agda now solves meta-variables that are applied to record patterns.+  A typical (but here, artificial) case is:++  ```agda+  record Sigma (A : Set)(B : A -> Set) : Set where+    constructor _,_+    field+      fst : A+      snd : B fst++  test : (A : Set)(B : A -> Set) ->+    let X : Sigma A B -> Sigma A B+        X = _+    in  (x : A)(y : B x) -> X (x , y) ≡ (x , y)+  test A B x y = refl+  ```++  This yields a constraint of the form++  ```+  _X A B (x , y) := t[x,y]+  ```++  (with `t[x,y] = (x, y)`) which is not a Miller pattern.+  However, Agda now solves this as++  ```+  _X A B z := t[fst z,snd z].+  ```++* Changed: solving recursive constraints.+  [Issue [#585](https://github.com/agda/agda/issues/585)]++  Until 2.3.0, Agda sometimes inferred values that did not pass the+  termination checker later, or would even make Agda loop. To prevent+  this, the occurs check now also looks into the definitions of the+  current mutual block, to avoid constructing recursive solutions. As+  a consequence, also terminating recursive solutions are no longer+  found automatically.++  This effects a programming pattern where the recursively computed+  type of a recursive function is left to Agda to solve.++  ```agda+  mutual++    T : D -> Set+    T pattern1 = _+    T pattern2 = _++    f : (d : D) -> T d+    f pattern1 = rhs1+    f pattern2 = rhs2+  ```++  This might no longer work from now on. See examples+  `test/Fail/Issue585*.agda`.++* Less eager introduction of implicit parameters.+  [Issue [#679](https://github.com/agda/agda/issues/679)]++  Until Agda 2.3.0, trailing hidden parameters were introduced eagerly+  on the left hand side of a definition.  For instance, one could not+  write++  ```agda+  test : {A : Set} -> Set+  test = \ {A} -> A+  ```++  because internally, the hidden argument `{A : Set}` was added to the+  left-hand side, yielding++  ```agda+  test {_} = \ {A} -> A+  ```++  which raised a type error.  Now, Agda only introduces the trailing+  implicit parameters it has to, in order to maintain uniform function+  arity.  For instance, in++  ```agda+  test : Bool -> {A B C : Set} -> Set+  test true {A}      = A+  test false {B = B} = B+  ```++  Agda will introduce parameters `A` and `B` in all clauses, but not+  `C`, resulting in++  ```agda+  test : Bool -> {A B C : Set} -> Set+  test true  {A} {_}     = A+  test false {_} {B = B} = B+  ```++  Note that for checking `where`-clauses, still all hidden trailing+  parameters are in scope.  For instance:++  ```agda+  id : {i : Level}{A : Set i} -> A -> A+  id = myId+    where myId : forall {A} -> A -> A+          myId x = x+  ```++  To be able to fill in the meta variable `_1` in++  ```agda+  myId : {A : Set _1} -> A -> A+  ```++  the hidden parameter `{i : Level}` needs to be in scope.++  As a result of this more lazy introduction of implicit parameters,+  the following code now passes.++  ```agda+  data Unit : Set where+    unit : Unit++  T : Unit → Set+  T unit = {u : Unit} → Unit++  test : (u : Unit) → T u+  test unit with unit+  ... | _ = λ {v} → v+  ```++  Before, Agda would eagerly introduce the hidden parameter `{v}` as+  unnamed left-hand side parameter, leaving no way to refer to it.++  The related Issue [#655](https://github.com/agda/agda/issues/655)+  has also been addressed.  It is now possible to make `synonym'+  definitions++  ```+  name = expression+  ```++  even when the type of expression begins with a hidden quantifier.+  Simple example:++  ```+  id2 = id+  ```++  That resulted in unsolved metas until 2.3.0.++* Agda detects unused arguments and ignores them during equality+  checking. [Issue [#691](https://github.com/agda/agda/issues/691),+  solves also Issue [#44](https://github.com/agda/agda/issues/44)]++  Agda's polarity checker now assigns 'Nonvariant' to arguments that+  are not actually used (except for absurd matches).  If `f`'s first+  argument is Nonvariant, then `f x` is definitionally equal to `f y`+  regardless of `x` and `y`.  It is similar to irrelevance, but does+  not require user annotation.++  For instance, unused module parameters do no longer get in the way:++  ```agda+  module M (x : Bool) where++    not : Bool → Bool+    not true  = false+    not false = true++  open M true+  open M false renaming (not to not′)++  test : (y : Bool) → not y ≡ not′ y+  test y = refl+  ```++  Matching against record or absurd patterns does not count as `use',+  so we get some form of proof irrelevance:++  ```agda+  data ⊥ : Set where+  record ⊤ : Set where+    constructor trivial++  data Bool : Set where+    true false : Bool++  True : Bool → Set+  True true  = ⊤+  True false = ⊥++  fun : (b : Bool) → True b → Bool+  fun true  trivial = true+  fun false ()++  test : (b : Bool) → (x y : True b) → fun b x ≡ fun b y+  test b x y = refl+  ```++  More examples in `test/Succeed/NonvariantPolarity.agda`.++  Phantom arguments:  Parameters of record and data types are considered+  `used' even if they are not actually used.  Consider:++  ```agda+  False : Nat → Set+  False zero    = ⊥+  False (suc n) = False n++  module Invariant where+    record Bla (n : Nat)(p : False n) : Set where++  module Nonvariant where+    Bla : (n : Nat) → False n → Set+    Bla n p = ⊤+  ```++  Even though record `Bla` does not use its parameters `n` and `p`,+  they are considered as used, allowing "phantom type" techniques.++  In contrast, the arguments of function `Bla` are recognized as+  unused.  The following code type-checks if we open `Invariant` but+  leaves unsolved metas if we open `Nonvariant`.++  ```agda+  drop-suc : {n : Nat}{p : False n} → Bla (suc n) p → Bla n p+  drop-suc _ = _++  bla : (n : Nat) → {p : False n} → Bla n p → ⊥+  bla zero {()} b+  bla (suc n) b = bla n (drop-suc b)+  ```++  If `Bla` is considered invariant, the hidden argument in the+  recursive call can be inferred to be `p`.  If it is considered+  non-variant, then `Bla n X = Bla n p` does not entail `X = p` and+  the hidden argument remains unsolved.  Since `bla` does not actually+  use its hidden argument, its value is not important and it could be+  searched for.  Unfortunately, polarity analysis of `bla` happens+  only after type checking, thus, the information that `bla` is+  non-variant in `p` is not available yet when meta-variables are+  solved.  (See+  `test/Fail/BrokenInferenceDueToNonvariantPolarity.agda`)++* Agda now expands simple definitions (one clause, terminating) to+  check whether a function is constructor+  headed. [Issue [#747](https://github.com/agda/agda/issues/747)] For+  instance, the following now also works:++  ```agda+  MyPair : Set -> Set -> Set+  MyPair A B = Pair A B++  Vec : Set -> Nat -> Set+  Vec A zero    = Unit+  Vec A (suc n) = MyPair A (Vec A n)+  ```++  Here, `Unit` and `Pair` are data or record types.++Compiler backends+-----------------++* `-Werror` is now overridable.++  To enable compilation of Haskell modules containing warnings, the+  `-Werror` flag for the MAlonzo backend has been made+  overridable. If, for example, `--ghc-flag=-Wwarn` is passed when+  compiling, one can get away with things like:++  ```agda+  data PartialBool : Set where+    true : PartialBool++  {-# COMPILED_DATA PartialBool Bool True #-}+  ```++  The default behavior remains as it used to be and rejects the above+  program.++Tools+-----++### Emacs mode++* Asynchronous Emacs mode.++  One can now use Emacs while a buffer is type-checked. If the buffer+  is edited while the type-checker runs, then syntax highlighting will+  not be updated when type-checking is complete.++* Interactive syntax highlighting.++  The syntax highlighting is updated while a buffer is type-checked:++  - At first the buffer is highlighted in a somewhat crude way+    (without go-to-definition information for overloaded+    constructors).++  - If the highlighting level is "interactive", then the piece of code+    that is currently being type-checked is highlighted as such. (The+    default is "non-interactive".)++  - When a mutual block has been type-checked it is highlighted+    properly (this highlighting includes warnings for potential+    non-termination).++  The highlighting level can be controlled via the new configuration+  variable `agda2-highlight-level`.++* Multiple case-splits can now be performed in one go.++  Consider the following example:++  ```agda+  _==_ : Bool → Bool → Bool+  b₁ == b₂ = {!!}+  ```++  If you split on `b₁ b₂`, then you get the following code:++  ```agda+  _==_ : Bool → Bool → Bool+  true == true = {!!}+  true == false = {!!}+  false == true = {!!}+  false == false = {!!}+  ```++  The order of the variables matters. Consider the following code:++  ```agda+  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A+  lookup xs i = {!!}+  ```++  If you split on `xs i`, then you get the following code:++  ```agda+  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A+  lookup [] ()+  lookup (x ∷ xs) zero = {!!}+  lookup (x ∷ xs) (suc i) = {!!}+  ```++  However, if you split on `i xs`, then you get the following code+  instead:++  ```agda+  lookup : ∀ {a n} {A : Set a} → Vec A n → Fin n → A+  lookup (x ∷ xs) zero = ?+  lookup (x ∷ xs) (suc i) = ?+  ```++  This code is rejected by Agda 2.3.0, but accepted by 2.3.2 thanks+  to improved coverage checking (see above).++* The Emacs mode now presents information about which module is+  currently being type-checked.++* New global menu entry: `Information about the character at point`.++  If this entry is selected, then information about the character at+  point is displayed, including (in many cases) information about how+  to type the character.++* Commenting/uncommenting the rest of the buffer.++  One can now comment or uncomment the rest of the buffer by typing+  `C-c C-x M-;` or by selecting the menu entry `Comment/uncomment` the+  rest of the buffer".++* The Emacs mode now uses the Agda executable instead of GHCi.++  The `*ghci*` buffer has been renamed to `*agda2*`.++  A new configuration variable has been introduced:+  `agda2-program-name`, the name of the Agda executable (by default+  `agda`).++  The variable `agda2-ghci-options` has been replaced by+  `agda2-program-args`: extra arguments given to the Agda executable+  (by default `none`).++  If you want to limit Agda's memory consumption you can add some+  arguments to `agda2-program-args`, for instance `+RTS -M1.5G -RTS`.++* The Emacs mode no longer depends on haskell-mode.++  Users who have customised certain haskell-mode variables (such as+  `haskell-ghci-program-args`) may want to update their configuration.++### LaTeX-backend++An experimental LaTeX-backend which does precise highlighting a la the+HTML-backend and code alignment a la lhs2TeX has been added.++Here is a sample input literate Agda file:++  ```latex+  \documentclass{article}++  \usepackage{agda}++  \begin{document}++  The following module declaration will be hidden in the output.++  \AgdaHide{+  \begin{code}+  module M where+  \end{code}+  }++  Two or more spaces can be used to make the backend align stuff.++  \begin{code}+  data ℕ : Set where+    zero  : ℕ+    suc   : ℕ → ℕ++  _+_ : ℕ → ℕ → ℕ+  zero   + n = n+  suc m  + n = suc (m + n)+  \end{code}++  \end{document}+  ```++To produce an output PDF issue the following commands:++  ```+  agda --latex -i . <file>.lagda+  pdflatex latex/<file>.tex+  ```++Only the top-most module is processed, like with lhs2tex and unlike+with the HTML-backend. If you want to process imported modules you+have to call `agda --latex` manually on each of those modules.++There are still issues related to formatting, see the bug tracker for+more information:++  https://code.google.com/p/agda/issues/detail?id=697++The default `agda.sty` might therefore change in backwards-incompatible+ways, as work proceeds in trying to resolve those problems.++Implemented features:++* Two or more spaces can be used to force alignment of things, like+  with lhs2tex. See example above.++* The highlighting information produced by the type checker is used to+  generate the output. For example, the data declaration in the+  example above, produces:++  ```agda+  \AgdaKeyword{data} \AgdaDatatype{ℕ} \AgdaSymbol{:}+      \AgdaPrimitiveType{Set} \AgdaKeyword{where}+  ```++  These LaTeX commands are defined in `agda.sty` (which is imported by+  `\usepackage{agda}`) and cause the highlighting.++* The LaTeX-backend checks if `agda.sty` is found by the LaTeX+  environment, if it isn't a default `agda.sty` is copied from Agda's+  `data-dir` into the working directory (and thus made available to+  the LaTeX environment).++  If the default `agda.sty` isn't satisfactory (colors, fonts,+  spacing, etc) then the user can modify it and make put it somewhere+  where the LaTeX environment can find it. Hopefully most aspects+  should be modifiable via `agda.sty` rather than having to tweak the+  implementation.++* `--latex-dir` can be used to change the default output directory.
+ doc/release-notes/2.4.0.1.md view
@@ -0,0 +1,8 @@+Release notes for Agda 2 version 2.4.0.1+========================================++* The option `--compile-no-main` has been renamed to `--no-main`.++* `COMPILED_DATA` pragmas can now be given for records.++* Various bug fixes.
+ doc/release-notes/2.4.0.2.md view
@@ -0,0 +1,90 @@+Release notes for Agda 2 version 2.4.0.2+========================================++* The Agda input mode now supports alphabetical super and subscripts,+  in addition to the numerical ones that were already present.+  [Issue [#1240](https://github.com/agda/agda/issues/1240)]++* New feature: Interactively split result.++  Make case (`C-c C-c`) with no variables given tries to split on the+  result to introduce projection patterns.  The hole needs to be of+  record type, of course.++  ```agda+  test : {A B : Set} (a : A) (b : B) → A × B+  test a b = ?+  ```++  Result-splitting `?` will produce the new clauses:++  ```agda+  proj₁ (test a b) = ?+  proj₂ (test a b) = ?+  ```++  If hole is of function type ending in a record type, the necessary+  pattern variables will be introduced before the split.  Thus, the+  same result can be obtained by starting from:++  ```agda+  test : {A B : Set} (a : A) (b : B) → A × B+  test = ?+  ```++* The so far undocumented `ETA` pragma now throws an error if applied to+  definitions that are not records.++  `ETA` can be used to force eta-equality at recursive record types,+  for which eta is not enabled automatically by Agda.  Here is such an+  example:++  ```agda+  mutual+    data Colist (A : Set) : Set where+      [] : Colist A+      _∷_ : A → ∞Colist A → Colist A++    record ∞Colist (A : Set) : Set where+      coinductive+      constructor delay+      field       force : Colist A++  open ∞Colist++  {-# ETA ∞Colist #-}++  test : {A : Set} (x : ∞Colist A) → x ≡ delay (force x)+  test x = refl+  ```++  Note: Unsafe use of `ETA` can make Agda loop, e.g. by triggering+  infinite eta expansion!++* Bugs fixed (see [bug tracker](https://github.com/agda/agda/issues)):++  [#1203](https://github.com/agda/agda/issues/1203)++  [#1205](https://github.com/agda/agda/issues/1205)++  [#1209](https://github.com/agda/agda/issues/1209)++  [#1213](https://github.com/agda/agda/issues/1213)++  [#1214](https://github.com/agda/agda/issues/1214)++  [#1216](https://github.com/agda/agda/issues/1216)++  [#1225](https://github.com/agda/agda/issues/1225)++  [#1226](https://github.com/agda/agda/issues/1226)++  [#1231](https://github.com/agda/agda/issues/1231)++  [#1233](https://github.com/agda/agda/issues/1233)++  [#1239](https://github.com/agda/agda/issues/1239)++  [#1241](https://github.com/agda/agda/issues/1241)++  [#1243](https://github.com/agda/agda/issues/1243)
+ doc/release-notes/2.4.0.md view
@@ -0,0 +1,1211 @@+Release notes for Agda 2 version 2.4.0+======================================++Installation and infrastructure+-------------------------------++* A new module called `Agda.Primitive` has been introduced. This+  module is available to all users, even if the standard library is+  not used.  Currently the module contains level primitives and their+  representation in Haskell when compiling with MAlonzo:++  ```agda+  infixl 6 _⊔_++  postulate+    Level : Set+    lzero : Level+    lsuc  : (ℓ : Level) → Level+    _⊔_   : (ℓ₁ ℓ₂ : Level) → Level++  {-# COMPILED_TYPE Level ()      #-}+  {-# COMPILED lzero ()           #-}+  {-# COMPILED lsuc  (\_ -> ())   #-}+  {-# COMPILED _⊔_   (\_ _ -> ()) #-}++  {-# BUILTIN LEVEL     Level  #-}+  {-# BUILTIN LEVELZERO lzero  #-}+  {-# BUILTIN LEVELSUC  lsuc   #-}+  {-# BUILTIN LEVELMAX  _⊔_    #-}+  ```++  To bring these declarations into scope you can use a declaration+  like the following one:++  ```agda+  open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)+  ```++  The standard library reexports these primitives (using the names+  `zero` and `suc` instead of `lzero` and `lsuc`) from the `Level`+  module.++  Existing developments using universe polymorphism might now trigger+  the following error message:++  ```+  Duplicate binding for built-in thing LEVEL, previous binding to+    .Agda.Primitive.Level+  ```++  To fix this problem, please remove the duplicate bindings.++  Technical details (perhaps relevant to those who build Agda+  packages):++  The include path now always contains a directory+  `<DATADIR>/lib/prim`, and this directory is supposed to contain a+  subdirectory Agda containing a file `Primitive.agda`.++  The standard location of `<DATADIR>` is system- and+  installation-specific.  E.g., in a Cabal `--user` installation of+  Agda-2.3.4 on a standard single-ghc Linux system it would be+  `$HOME/.cabal/share/Agda-2.3.4` or something similar.++  The location of the `<DATADIR>` directory can be configured at+  compile-time using Cabal flags (`--datadir` and `--datasubdir`).+  The location can also be set at run-time, using the `Agda_datadir`+  environment variable.++Pragmas and options+-------------------++* Pragma `NO_TERMINATION_CHECK` placed within a mutual block is now+  applied to the whole mutual block (rather than being discarded+  silently).  Adding to the uses 1.-4. outlined in the release notes+  for 2.3.2 we allow:++  3a. Skipping an old-style mutual block: Somewhere within `mutual`+      block before a type signature or first function clause.++   ```agda+   mutual+     {-# NO_TERMINATION_CHECK #-}+     c : A+     c = d++     d : A+     d = c+   ```++* New option `--no-pattern-matching`++  Disables all forms of pattern matching (for the current file).+  You can still import files that use pattern matching.++* New option `-v profile:7`++  Prints some stats on which phases Agda spends how much time.+  (Number might not be very reliable, due to garbage collection+  interruptions, and maybe due to laziness of Haskell.)++* New option `--no-sized-types`++  Option `--sized-types` is now default.  `--no-sized-types` will turn+  off an extra (inexpensive) analysis on data types used for subtyping+  of sized types.++Language+--------++* Experimental feature: `quoteContext`++  There is a new keyword `quoteContext` that gives users access to the+  list of names in the current local context. For instance:++  ```agda+  open import Data.Nat+  open import Data.List+  open import Reflection++  foo : ℕ → ℕ → ℕ+  foo 0 m = 0+  foo (suc n) m = quoteContext xs in ?+  ```++  In the remaining goal, the list `xs` will consist of two names, `n`+  and `m`, corresponding to the two local variables. At the moment it+  is not possible to access let bound variables (this feature may be+  added in the future).++* Experimental feature: Varying arity.+  Function clauses may now have different arity, e.g.,++  ```agda+  Sum : ℕ → Set+  Sum 0       = ℕ+  Sum (suc n) = ℕ → Sum n++  sum : (n : ℕ) → ℕ → Sum n+  sum 0       acc   = acc+  sum (suc n) acc m = sum n (m + acc)+  ```++  or,++  ```agda+  T : Bool → Set+  T true  = Bool+  T false = Bool → Bool++  f : (b : Bool) → T b+  f false true  = false+  f false false = true+  f true = true+  ```++  This feature is experimental.  Yet unsupported:+  - Varying arity and `with`.++  - Compilation of functions with varying arity to Haskell, JS, or Epic.++* Experimental feature: copatterns.  (Activated with option `--copatterns`)++  We can now define a record by explaining what happens if you project+  the record.  For instance:++  ```agda+  {-# OPTIONS --copatterns #-}++  record _×_ (A B : Set) : Set where+    constructor _,_+    field+      fst : A+      snd : B+  open _×_++  pair : {A B : Set} → A → B → A × B+  fst (pair a b) = a+  snd (pair a b) = b++  swap : {A B : Set} → A × B → B × A+  fst (swap p) = snd p+  snd (swap p) = fst p++  swap3 : {A B C : Set} → A × (B × C) → C × (B × A)+  fst (swap3 t)       = snd (snd t)+  fst (snd (swap3 t)) = fst (snd t)+  snd (snd (swap3 t)) = fst t+  ```++  Taking a projection on the left hand side (lhs) is called a+  projection pattern, applying to a pattern is called an application+  pattern.  (Alternative terms: projection/application copattern.)++  In the first example, the symbol `pair`, if applied to variable+  patterns `a` and `b` and then projected via `fst`, reduces to+  `a`. `pair` by itself does not reduce.++  A typical application are coinductive records such as streams:++  ```agda+  record Stream (A : Set) : Set where+    coinductive+    field+      head : A+      tail : Stream A+  open Stream++  repeat : {A : Set} (a : A) -> Stream A+  head (repeat a) = a+  tail (repeat a) = repeat a+  ```++  Again, `repeat a` by itself will not reduce, but you can take a+  projection (head or tail) and then it will reduce to the respective+  rhs.  This way, we get the lazy reduction behavior necessary to+  avoid looping corecursive programs.++  Application patterns do not need to be trivial (i.e., variable+  patterns), if we mix with projection patterns.  E.g., we can have++  ```agda+  nats : Nat -> Stream Nat+  head (nats zero) = zero+  tail (nats zero) = nats zero+  head (nats (suc x)) = x+  tail (nats (suc x)) = nats x+  ```++  Here is an example (not involving coinduction) which demostrates+  records with fields of function type:++  ```agda+  -- The State monad++  record State (S A : Set) : Set where+    constructor state+    field+      runState : S → A × S+  open State++  -- The Monad type class++  record Monad (M : Set → Set) : Set1 where+    constructor monad+    field+      return : {A : Set}   → A → M A+      _>>=_  : {A B : Set} → M A → (A → M B) → M B+++  -- State is an instance of Monad+  -- Demonstrates the interleaving of projection and application patterns++  stateMonad : {S : Set} → Monad (State S)+  runState (Monad.return stateMonad a  ) s  = a , s+  runState (Monad._>>=_  stateMonad m k) s₀ =+    let a , s₁ = runState m s₀+    in  runState (k a) s₁++  module MonadLawsForState {S : Set} where++    open Monad (stateMonad {S})++    leftId : {A B : Set}(a : A)(k : A → State S B) →+      (return a >>= k) ≡ k a+    leftId a k = refl++    rightId : {A B : Set}(m : State S A) →+      (m >>= return) ≡ m+    rightId m = refl++    assoc : {A B C : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →+      ((m >>= k) >>= l) ≡ (m >>= λ a → (k a >>= l))+    assoc m k l = refl+  ```++  Copatterns are yet experimental and the following does not work:++  - Copatterns and `with` clauses.++  - Compilation of copatterns to Haskell, JS, or Epic.++  - Projections generated by++    ```agda+    open R {{...}}+    ```++    are not handled properly on lhss yet.++  - Conversion checking is slower in the presence of copatterns, since+    stuck definitions of record type do no longer count as neutral,+    since they can become unstuck by applying a projection. Thus,+    comparing two neutrals currently requires comparing all they+    projections, which repeats a lot of work.++* Top-level module no longer required.++  The top-level module can be omitted from an Agda file. The module+  name is then inferred from the file name by dropping the path and+  the `.agda` extension. So, a module defined in `/A/B/C.agda` would get+  the name `C`.++  You can also suppress only the module name of the top-level module+  by writing++  ```agda+  module _ where+  ```++  This works also for parameterised modules.++* Module parameters are now always hidden arguments in projections.+  For instance:++  ```agda+  module M (A : Set) where++    record Prod (B : Set) : Set where+      constructor _,_+      field+        fst : A+        snd : B+    open Prod public++  open M+  ```++  Now, the types of `fst` and `snd` are++  ```agda+  fst : {A : Set}{B : Set} → Prod A B → A+  snd : {A : Set}{B : Set} → Prod A B → B+  ```++  Until 2.3.2, they were++  ```agda+  fst : (A : Set){B : Set} → Prod A B → A+  snd : (A : Set){B : Set} → Prod A B → B+  ```++  This change is a step towards symmetry of constructors and projections.+  (Constructors always took the module parameters as hidden arguments).++* Telescoping lets: Local bindings are now accepted in telescopes+  of modules, function types, and lambda-abstractions.++  The syntax of telescopes as been extended to support `let`:++  ```agda+  id : (let ★ = Set) (A : ★) → A → A+  id A x = x+  ```++  In particular one can now `open` modules inside telescopes:++  ```agda+  module Star where+    ★ : Set₁+    ★ = Set+++  module MEndo (let open Star) (A : ★) where+    Endo : ★+    Endo = A → A+  ```++  Finally a shortcut is provided for opening modules:++  ```agda+  module N (open Star) (A : ★) (open MEndo A) (f : Endo) where+    ...+  ```++  The semantics of the latter is++  ```agda+  module _ where+    open Star+    module _ (A : ★) where+      open MEndo A+      module N (f : Endo) where+        ...+  ```++  The semantics of telescoping lets in function types and lambda+  abstractions is just expanding them into ordinary lets.++* More liberal left-hand sides in lets+  [Issue [#1028](https://github.com/agda/agda/issues/1028)]:++  You can now write left-hand sides with arguments also for let+  bindings without a type signature. For instance,++  ```agda+  let f x = suc x in f zero+  ```++  Let bound functions still can't do pattern matching though.++* Ambiguous names in patterns are now optimistically resolved in favor+  of constructors. [Issue [#822](https://github.com/agda/agda/issues/822)]+  In particular, the following succeeds now:++  ```agda+  module M where++    data D : Set₁ where+      [_] : Set → D++  postulate [_] : Set → Set++  open M++  Foo : _ → Set+  Foo [ A ] = A+  ```++* Anonymous `where`-modules are opened+  public. [Issue [#848](https://github.com/agda/agda/issues/848)]++  ```+  <clauses>+  f args = rhs+    module _ telescope where+      body+  <more clauses>+  ```++  means the following (not proper Agda code, since you cannot put a+  module in-between clauses)++  ```+  <clauses>+  module _ {arg-telescope} telescope where+    body++  f args = rhs+  <more clauses>+  ```++  Example:++  ```agda+  A : Set1+  A = B module _ where+    B : Set1+    B = Set++  C : Set1+  C = B+  ```++* Builtin `ZERO` and `SUC` have been merged with `NATURAL`.++  When binding the `NATURAL` builtin, `ZERO` and `SUC` are bound to+  the appropriate constructors automatically. This means that instead+  of writing++  ```agda+  {-# BUILTIN NATURAL Nat #-}+  {-# BUILTIN ZERO zero #-}+  {-# BUILTIN SUC suc #-}+  ```++  you just write++  ```agda+  {-# BUILTIN NATURAL Nat #-}+  ```++* Pattern synonym can now have implicit+  arguments. [Issue [#860](https://github.com/agda/agda/issues/860)]++  For example,++  ```agda+  pattern tail=_ {x} xs = x ∷ xs++  len : ∀ {A} → List A → Nat+  len []         = 0+  len (tail= xs) = 1 + len xs+  ```++* Syntax declarations can now have implicit+  arguments. [Issue [#400](https://github.com/agda/agda/issues/400)]++  For example++  ```agda+  id : ∀ {a}{A : Set a} -> A -> A+  id x = x++  syntax id {A} x = x ∈ A+  ```++* Minor syntax changes++  - `-}` is now parsed as end-comment even if no comment was begun. As+    a consequence, the following definition gives a parse error++    ```agda+    f : {A- : Set} -> Set+    f {A-} = A-+    ```++    because Agda now sees `ID(f) LBRACE ID(A) END-COMMENT`, and no+    longer `ID(f) LBRACE ID(A-) RBRACE`.++    The rational is that the previous lexing was to context-sensitive,+    attempting to comment-out `f` using `{-` and `-}` lead to a parse+    error.++  - Fixities (binding strengths) can now be negative numbers as+    well. [Issue [#1109](https://github.com/agda/agda/issues/1109)]++    ```agda+    infix -1 _myop_+    ```++  - Postulates are now allowed in mutual+    blocks. [Issue [#977](https://github.com/agda/agda/issues/977)]++  - Empty where blocks are now+    allowed. [Issue [#947](https://github.com/agda/agda/issues/947)]++  - Pattern synonyms are now allowed in parameterised+    modules. [Issue [#941](https://github.com/agda/agda/issues/941)]++  - Empty hiding and renaming lists in module directives are now allowed.++  - Module directives `using`, `hiding`, `renaming` and `public` can+    now appear in arbitrary order. Multiple+    `using`/`hiding`/`renaming` directives are allowed, but you still+    cannot have both using and `hiding` (because that doesn't make+    sense). [Issue [#493](https://github.com/agda/agda/issues/493)]++Goal and error display+----------------------++* The error message `Refuse to construct infinite term` has been+  removed, instead one gets unsolved meta variables.  Reason: the+  error was thrown over-eagerly.+  [Issue [#795](https://github.com/agda/agda/issues/795)]++* If an interactive case split fails with message++  ```+    Since goal is solved, further case distinction is not supported;+    try `Solve constraints' instead+  ```++  then the associated interaction meta is assigned to a solution.+  Press `C-c C-=` (Show constraints) to view the solution and `C-c+  C-s` (Solve constraints) to apply it.+  [Issue [#289](https://github.com/agda/agda/issues/289)]++Type checking+-------------++* [ Issue [#376](https://github.com/agda/agda/issues/376) ]+  Implemented expansion of bound record variables during meta+  assignment.  Now Agda can solve for metas X that are applied to+  projected variables, e.g.:++  ```agda+  X (fst z) (snd z) = z++  X (fst z)         = fst z+  ```++  Technically, this is realized by substituting `(x , y)` for `z` with fresh+  bound variables `x` and `y`.  Here the full code for the examples:++  ```agda+  record Sigma (A : Set)(B : A -> Set) : Set where+    constructor _,_+    field+      fst : A+      snd : B fst+  open Sigma++  test : (A : Set) (B : A -> Set) ->+    let X : (x : A) (y : B x) -> Sigma A B+        X = _+    in  (z : Sigma A B) -> X (fst z) (snd z) ≡ z+  test A B z = refl++  test' : (A : Set) (B : A -> Set) ->+    let X : A -> A+        X = _+    in  (z : Sigma A B) -> X (fst z) ≡ fst z+  test' A B z = refl+  ```++  The fresh bound variables are named `fst(z)` and `snd(z)` and can appear+  in error messages, e.g.:++  ```agda+  fail : (A : Set) (B : A -> Set) ->+    let X : A -> Sigma A B+        X = _+    in  (z : Sigma A B) -> X (fst z) ≡ z+  fail A B z = refl+  ```++  results in error:++  ```+  Cannot instantiate the metavariable _7 to solution fst(z) , snd(z)+  since it contains the variable snd(z) which is not in scope of the+  metavariable or irrelevant in the metavariable but relevant in the+  solution+  when checking that the expression refl has type _7 A B (fst z) ≡ z+  ```++* Dependent record types and definitions by copatterns require+  reduction with previous function clauses while checking the current+  clause. [Issue [#907](https://github.com/agda/agda/issues/907)]++  For a simple example, consider++  ```agda+  test : ∀ {A} → Σ Nat λ n → Vec A n+  proj₁ test = zero+  proj₂ test = []+  ```++  For the second clause, the lhs and rhs are typed as++  ```agda+  proj₂ test : Vec A (proj₁ test)+  []         : Vec A zero+  ```++  In order for these types to match, we have to reduce the lhs type+  with the first function clause.++  Note that termination checking comes after type checking, so be+  careful to avoid non-termination!  Otherwise, the type checker+  might get into an infinite loop.++* The implementation of the primitive `primTrustMe` has changed.  It+  now only reduces to `REFL` if the two arguments `x` and `y` have the+  same computational normal form.  Before, it reduced when `x` and `y`+  were definitionally equal, which included type-directed equality+  laws such as eta-equality.  Yet because reduction is untyped,+  calling conversion from reduction lead to Agda crashes+  [Issue [#882](https://github.com/agda/agda/issues/882)].++  The amended description of `primTrustMe` is (cf. release notes+  for 2.2.6):++  ```agda+  primTrustMe : {A : Set} {x y : A} → x ≡ y+  ```++  Here `_≡_` is the builtin equality (see BUILTIN hooks for equality,+  above).++  If `x` and `y` have the same computational normal form, then+  `primTrustMe {x = x} {y = y}` reduces to `refl`.++  A note on `primTrustMe`'s runtime behavior: The MAlonzo compiler+  replaces all uses of `primTrustMe` with the `REFL` builtin, without+  any check for definitional equality. Incorrect uses of `primTrustMe`+  can potentially lead to segfaults or similar problems of the+  compiled code.++* Implicit patterns of record type are now only eta-expanded if there+  is a record constructor.+  [Issues [#473](https://github.com/agda/agda/issues/473),+  [#635](https://github.com/agda/agda/issues/635)]++  ```agda+  data D : Set where+    d : D++  data P : D → Set where+    p : P d++  record Rc : Set where+    constructor c+    field f : D++  works : {r : Rc} → P (Rc.f r) → Set+  works p = D+  ```++  This works since the implicit pattern `r` is eta-expanded to `c x`+  which allows the type of `p` to reduce to `P x` and `x` to be+  unified with `d`. The corresponding explicit version is:++  ```agda+  works' : (r : Rc) → P (Rc.f r) → Set+  works' (c .d) p = D+  ```++  However, if the record constructor is removed, the same example will+  fail:++  ```agda+  record R : Set where+    field f : D++  fails : {r : R} → P (R.f r) → Set+  fails p = D++  -- d != R.f r of type D+  -- when checking that the pattern p has type P (R.f r)+  ```++  The error is justified since there is no pattern we could write down+  for `r`.  It would have to look like++  ```agda+  record { f = .d }+  ```++  but anonymous record patterns are not part of the language.++* Absurd lambdas at different source locations are no longer+  different. [Issue [#857](https://github.com/agda/agda/issues/857)]+  In particular, the following code type-checks now:++  ```agda+  absurd-equality : _≡_ {A = ⊥ → ⊥} (λ()) λ()+  absurd-equality = refl+  ```++  Which is a good thing!++* Printing of named implicit function types.++  When printing terms in a context with bound variables Agda renames+  new bindings to avoid clashes with the previously bound names. For+  instance, if `A` is in scope, the type `(A : Set) → A` is printed as+  `(A₁ : Set) → A₁`. However, for implicit function types the name of+  the binding matters, since it can be used when giving implicit+  arguments.++  For this situation, the following new syntax has been introduced:+  `{x = y : A} → B` is an implicit function type whose bound variable+  (in scope in `B`) is `y`, but where the name of the argument is `x`+  for the purposes of giving it explicitly. For instance, with `A` in+  scope, the type `{A : Set} → A` is now printed as `{A = A₁ : Set} →+  A₁`.++  This syntax is only used when printing and is currently not being parsed.++* Changed the semantics of `--without-K`.+  [Issue [#712](https://github.com/agda/agda/issues/712),+  Issue [#865](https://github.com/agda/agda/issues/865),+  Issue [#1025](https://github.com/agda/agda/issues/1025)]++  New specification of `--without-K`:++  When `--without-K` is enabled, the unification of indices for+  pattern matching is restricted in two ways:++  1. Reflexive equations of the form `x == x` are no longer solved,+     instead Agda gives an error when such an equation is encountered.++  2. When unifying two same-headed constructor forms `c us` and `c vs`+     of type `D pars ixs`, the datatype indices `ixs` (but not the+     parameters) have to be *self-unifiable*, i.e. unification of+     `ixs` with itself should succeed positively. This is a nontrivial+     requirement because of point 1.++  Examples:++  - The J rule is accepted.++    ```agda+    J : {A : Set} (P : {x y : A} → x ≡ y → Set) →+        (∀ x → P (refl x)) →+        ∀ {x y} (x≡y : x ≡ y) → P x≡y+    J P p (refl x) = p x+    ```agda++    This definition is accepted since unification of `x` with `y`+    doesn't require deletion or injectivity.++  - The K rule is rejected.++    ```agda+    K : {A : Set} (P : {x : A} → x ≡ x → Set) →+        (∀ x → P (refl {x = x})) →+       ∀ {x} (x≡x : x ≡ x) → P x≡x+    K P p refl = p _+    ```++    Definition is rejected with the following error:++    ```+    Cannot eliminate reflexive equation x = x of type A because K has+    been disabled.+    when checking that the pattern refl has type x ≡ x+    ```++  - Symmetry of the new criterion.++    ```agda+    test₁ : {k l m : ℕ} → k + l ≡ m → ℕ+    test₁ refl = zero++    test₂ : {k l m : ℕ} → k ≡ l + m → ℕ+    test₂ refl = zero+    ```++    Both versions are now accepted (previously only the first one was).++  - Handling of parameters.++    ```agda+    cons-injective : {A : Set} (x y : A) → (x ∷ []) ≡ (y ∷ []) → x ≡ y+    cons-injective x .x refl = refl+    ```++    Parameters are not unified, so they are ignored by the new criterion.++  - A larger example: antisymmetry of ≤.++    ```agda+    data _≤_ : ℕ → ℕ → Set where+      lz : (n : ℕ) → zero ≤ n+      ls : (m n : ℕ) → m ≤ n → suc m ≤ suc n++    ≤-antisym : (m n : ℕ) → m ≤ n → n ≤ m → m ≡ n+    ≤-antisym .zero    .zero    (lz .zero) (lz .zero)   = refl+    ≤-antisym .(suc m) .(suc n) (ls m n p) (ls .n .m q) =+                 cong suc (≤-antisym m n p q)+    ```++  - [ Issue [#1025](https://github.com/agda/agda/issues/1025) ]++    ```agda+    postulate mySpace : Set+    postulate myPoint : mySpace++    data Foo : myPoint ≡ myPoint → Set where+      foo : Foo refl++    test : (i : foo ≡ foo) → i ≡ refl+    test refl = {!!}+    ```++    When applying injectivity to the equation `foo ≡ foo` of type `Foo+    refl`, it is checked that the index `refl` of type `myPoint ≡+    myPoint` is self-unifiable. The equation `refl ≡ refl` again+    requires injectivity, so now the index `myPoint` is checked for+    self-unifiability, hence the error:++    ```+    Cannot eliminate reflexive equation myPoint = myPoint of type+    mySpace because K has been disabled.+    when checking that the pattern refl has type foo ≡ foo+    ```++Termination checking+--------------------++* A buggy facility coined "matrix-shaped orders" that supported+  uncurried functions (which take tuples of arguments instead of one+  argument after another) has been removed from the termination+  checker. [Issue [#787](https://github.com/agda/agda/issues/787)]++* Definitions which fail the termination checker are not unfolded any+  longer to avoid loops or stack overflows in Agda.  However, the+  termination checker for a mutual block is only invoked after+  type-checking, so there can still be loops if you define a+  non-terminating function.  But termination checking now happens+  before the other supplementary checks: positivity, polarity,+  injectivity and projection-likeness.  Note that with the pragma `{-#+  NO_TERMINATION_CHECK #-}` you can make Agda treat any function as+  terminating.++* Termination checking of functions defined by `with` has been improved.++  Cases which previously required `--termination-depth` to pass the+  termination checker (due to use of `with`) no longer need the+  flag. For example++  ```agda+  merge : List A → List A → List A+  merge [] ys = ys+  merge xs [] = xs+  merge (x ∷ xs) (y ∷ ys) with x ≤ y+  merge (x ∷ xs) (y ∷ ys)    | false = y ∷ merge (x ∷ xs) ys+  merge (x ∷ xs) (y ∷ ys)    | true  = x ∷ merge xs (y ∷ ys)+  ```++  This failed to termination check previously, since the `with`+  expands to an auxiliary function `merge-aux`:++  ```agda+  merge-aux x y xs ys false = y ∷ merge (x ∷ xs) ys+  merge-aux x y xs ys true  = x ∷ merge xs (y ∷ ys)+  ```++  This function makes a call to `merge` in which the size of one of+  the arguments is increasing. To make this pass the termination+  checker now inlines the definition of `merge-aux` before checking,+  thus effectively termination checking the original source program.++  As a result of this transformation doing `with` on a variable no longer+  preserves termination. For instance, this does not termination check:++  ```agda+  bad : Nat → Nat+  bad n with n+  ... | zero  = zero+  ... | suc m = bad m+  ```++* The performance of the termination checker has been improved.  For+  higher `--termination-depth` the improvement is significant.  While+  the default `--termination-depth` is still 1, checking with higher+  `--termination-depth` should now be feasible.++Compiler backends+-----------------++* The MAlonzo compiler backend now has support for compiling modules+  that are not full programs (i.e. don't have a main function). The+  goal is that you can write part of a program in Agda and the rest in+  Haskell, and invoke the Agda functions from the Haskell code. The+  following features were added for this reason:++  - A new command-line option `--compile-no-main`: the command++    ```+    agda --compile-no-main Test.agda+    ```++    will compile `Test.agda` and all its dependencies to Haskell and+    compile the resulting Haskell files with `--make`, but (unlike+    `--compile`) not tell GHC to treat `Test.hs` as the main+    module. This type of compilation can be invoked from Emacs by+    customizing the `agda2-backend` variable to value `MAlonzoNoMain` and+    then calling `C-c C-x C-c` as before.++  - A new pragma `COMPILED_EXPORT` was added as part of the MAlonzo+    FFI. If we have an Agda file containing the following:++    ```agda+     module A.B where++     test : SomeType+     test = someImplementation++     {-# COMPILED_EXPORT test someHaskellId #-}+    ```++    then test will be compiled to a Haskell function called+    `someHaskellId` in module `MAlonzo.Code.A.B` that can be invoked+    from other Haskell code. Its type will be translated according to+    the normal MAlonzo rules.++Tools+-----++### Emacs mode++* A new goal command `Helper Function Type` (`C-c C-h`) has been added.++  If you write an application of an undefined function in a goal, the+  `Helper Function Type` command will print the type that the function+  needs to have in order for it to fit the goal. The type is also+  added to the Emacs kill-ring and can be pasted into the buffer using+  `C-y`.++  The application must be of the form `f args` where `f` is the name of the+  helper function you want to create. The arguments can use all the normal+  features like named implicits or instance arguments.++  Example:++  Here's a start on a naive reverse on vectors:++  ```agda+  reverse : ∀ {A n} → Vec A n → Vec A n+  reverse [] = []+  reverse (x ∷ xs) = {!snoc (reverse xs) x!}+  ```++  Calling `C-c C-h` in the goal prints++  ```agda+  snoc : ∀ {A} {n} → Vec A n → A → Vec A (suc n)+  ```++* A new command `Explain why a particular name is in scope` (`C-c+  C-w`) has been added.+  [Issue [#207](https://github.com/agda/agda/issues/207)]++  This command can be called from a goal or from the top-level and will as the+  name suggests explain why a particular name is in scope.++  For each definition or module that the given name can refer to a trace is+  printed of all open statements and module applications leading back to the+  original definition of the name.++  For example, given++  ```agda+  module A (X : Set₁) where+    data Foo : Set where+      mkFoo : Foo+  module B (Y : Set₁) where+    open A Y public+  module C = B Set+  open C+  ```++  Calling `C-c C-w` on `mkFoo` at the top-level prints++  ```+  mkFoo is in scope as+  * a constructor Issue207.C._.Foo.mkFoo brought into scope by+    - the opening of C at Issue207.agda:13,6-7+    - the application of B at Issue207.agda:11,12-13+    - the application of A at Issue207.agda:9,8-9+    - its definition at Issue207.agda:6,5-10+  ```++  This command is useful if Agda complains about an ambiguous name and+  you need to figure out how to hide the undesired interpretations.++* Improvements to the `make case` command (`C-c C-c`)++  - One can now also split on hidden variables, using the name+    (starting with `.`) with which they are printed.  Use `C-c C-`, to+    see all variables in context.++  - Concerning the printing of generated clauses:++    * Uses named implicit arguments to improve readability.++    * Picks explicit occurrences over implicit ones when there is a+      choice of binding site for a variable.++    * Avoids binding variables in implicit positions by replacing dot+      patterns that uses them by wildcards (`._`).++* Key bindings for lots of "mathematical" characters (examples: 𝐴𝑨𝒜𝓐𝔄)+  have been added to the Agda input method.  Example: type+  `\MiA\MIA\McA\MCA\MfA` to get 𝐴𝑨𝒜𝓐𝔄.++  Note: `\McB` does not exist in Unicode (as well as others in that style),+  but the `\MC` (bold) alphabet is complete.++* Key bindings for "blackboard bold" B (𝔹) and 0-9 (𝟘-𝟡) have been+  added to the Agda input method (`\bb` and `\b[0-9]`).++* Key bindings for controlling simplification/normalisation:++  Commands like `Goal type and context` (`C-c C-,`) could previously+  be invoked in two ways. By default the output was normalised, but if+  a prefix argument was used (for instance via `C-u C-c C-,`), then no+  explicit normalisation was performed. Now there are three options:++  - By default (`C-c C-,`) the output is simplified.++  - If `C-u` is used exactly once (`C-u C-c C-,`), then the result is+    neither (explicitly) normalised nor simplified.++  - If `C-u` is used twice (`C-u C-u C-c C-,`), then the result is+    normalised.++### LaTeX-backend++* Two new color scheme options were added to `agda.sty`:++  `\usepackage[bw]{agda}`, which highlights in black and white;+  `\usepackage[conor]{agda}`, which highlights using Conor's colors.++  The default (no options passed) is to use the standard colors.++* If `agda.sty` cannot be found by the LateX environment, it is now+  copied into the LateX output directory (`latex` by default) instead+  of the working directory. This means that the commands needed to+  produce a PDF now is++  ```+  agda --latex -i . <file>.lagda+  cd latex+  pdflatex <file>.tex+  ```++* The LaTeX-backend has been made more tool agnostic, in particular+  XeLaTeX and LuaLaTeX should now work. Here is a small example+  (`test/LaTeXAndHTML/succeed/UnicodeInput.lagda`):++  ```latex+  \documentclass{article}+  \usepackage{agda}+  \begin{document}++  \begin{code}+  data αβγδεζθικλμνξρστυφχψω : Set₁ where++  postulate+    →⇒⇛⇉⇄↦⇨↠⇀⇁ : Set+  \end{code}++  \[+  ∀X [ ∅ ∉ X ⇒ ∃f:X ⟶  ⋃ X\ ∀A ∈ X (f(A) ∈ A) ]+  \]+  \end{document}+  ```++  Compiled as follows, it should produce a nice looking PDF (tested with+  TeX Live 2012):++  ```+  agda --latex <file>.lagda+  cd latex+  xelatex <file>.tex (or lualatex <file>.tex)+  ```++  If symbols are missing or XeLaTeX/LuaLaTeX complains about the font+  missing, try setting a different font using:++  ```latex+  \setmathfont{<math-font>}+  ```++  Use the `fc-list` tool to list available fonts.++* Add experimental support for hyperlinks to identifiers++  If the `hyperref` LateX package is loaded before the Agda package+  and the links option is passed to the Agda package, then the Agda+  package provides a function called `\AgdaTarget`. Identifiers which+  have been declared targets, by the user, will become clickable+  hyperlinks in the rest of the document. Here is a small example+  (`test/LaTeXAndHTML/succeed/Links.lagda`):++  ```latex+  \documentclass{article}+  \usepackage{hyperref}+  \usepackage[links]{agda}+  \begin{document}++  \AgdaTarget{ℕ}+  \AgdaTarget{zero}+  \begin{code}+  data ℕ : Set where+    zero  : ℕ+    suc   : ℕ → ℕ+  \end{code}++  See next page for how to define \AgdaFunction{two} (doesn't turn into a+  link because the target hasn't been defined yet). We could do it+  manually though; \hyperlink{two}{\AgdaDatatype{two}}.++  \newpage++  \AgdaTarget{two}+  \hypertarget{two}{}+  \begin{code}+  two : ℕ+  two = suc (suc zero)+  \end{code}++  \AgdaInductiveConstructor{zero} is of type+  \AgdaDatatype{ℕ}. \AgdaInductiveConstructor{suc} has not been defined to+  be a target so it doesn't turn into a link.++  \newpage++  Now that the target for \AgdaFunction{two} has been defined the link+  works automatically.++  \begin{code}+  data Bool : Set where+    true false : Bool+  \end{code}++  The AgdaTarget command takes a list as input, enabling several+  targets to be specified as follows:++  \AgdaTarget{if, then, else, if\_then\_else\_}+  \begin{code}+  if_then_else_ : {A : Set} → Bool → A → A → A+  if true  then t else f = t+  if false then t else f = f+  \end{code}++  \newpage++  Mixfix identifier need their underscores escaped:+  \AgdaFunction{if\_then\_else\_}.++  \end{document}+  ```++  The boarders around the links can be suppressed using hyperref's+  hidelinks option:++  ```latex+    \usepackage[hidelinks]{hyperref}+  ```++  Note that the current approach to links does not keep track of scoping+  or types, and hence overloaded names might create links which point to+  the wrong place. Therefore it is recommended to not overload names+  when using the links option at the moment, this might get fixed in the+  future.
+ doc/release-notes/2.4.2.1.md view
@@ -0,0 +1,214 @@+Release notes for Agda version 2.4.2.1+======================================++Pragmas and options+-------------------++* New pragma `{-# TERMINATING #-}` replacing+  `{-# NO_TERMINATION_CHECK #-}`++  Complements the existing pragma `{-# NON_TERMINATING #-}`.  Skips+  termination check for the associated definitions and marks them as+  terminating.  Thus, it is a replacement for `{-#+  NO_TERMINATION_CHECK #-}` with the same semantics.++  You can no longer use pragma `{-# NO_TERMINATION_CHECK #-}` to skip+  the termination check, but must label your definitions as either+  `{-# TERMINATING #-}` or `{-# NON_TERMINATING #-}` instead.++  Note: `{-# OPTION --no-termination-check #-}` labels all your+  definitions as `{-# TERMINATING #-}`, putting you in the danger zone+  of a loop in the type checker.++Language+--------++* Referring to a local variable shadowed by module opening is now an+  error.  Previous behavior was preferring the local over the imported+  definitions. [Issue [#1266](https://github.com/agda/agda/issues/1266)]++  Note that module parameters are locals as well as variables bound by+  λ, dependent function type, patterns, and let.++  Example:++  ```agda+  module M where+    A = Set1++  test : (A : Set) → let open M in A+  ```++  The last `A` produces an error, since it could refer to the local+  variable `A` or to the definition imported from module `M`.++* `with` on a variable bound by a module telescope or a pattern of a+  parent function is now forbidden.+  [Issue [#1342](https://github.com/agda/agda/issues/1342)]++  ```agda+  data Unit : Set where+    unit : Unit++  id : (A : Set) → A → A+  id A a = a++  module M (x : Unit) where++    dx : Unit → Unit+    dx unit = x++    g : ∀ u → x ≡ dx u+    g with x+    g | unit  = id (∀ u → unit ≡ dx u) ?+  ```++  Even though this code looks right, Agda complains about the type+  expression `∀ u → unit ≡ dx u`.  If you ask Agda what should go+  there instead, it happily tells you that it wants `∀ u → unit ≡ dx+  u`. In fact what you do not see and Agda will never show you is that+  the two expressions actually differ in the invisible first argument+  to `dx`, which is visible only outside module `M`.  What Agda wants+  is an invisible `unit` after `dx`, but all you can write is an+  invisible `x` (which is inserted behind the scenes).++  To avoid those kinds of paradoxes, `with` is now outlawed on module+  parameters.  This should ensure that the invisible arguments are+  always exactly the module parameters.++  Since a `where` block is desugared as module with pattern variables+  of the parent clause as module parameters, the same strikes you for+  uses of `with` on pattern variables of the parent function.++  ```agda+  f : Unit → Unit+  f x = unit+    where+      dx : Unit → Unit+      dx unit = x++      g : ∀ u → x ≡ dx u+      g with x+      g | unit  = id ((u : Unit) → unit ≡ dx u) ?+  ```++  The `with` on pattern variable `x` of the parent clause `f x = unit`+  is outlawed now.++Type checking+-------------++* Termination check failure is now a proper error.++  We no longer continue type checking after termination check+  failures.  Use pragmas `{-# NON_TERMINATING #-}` and `{-#+  NO_TERMINATION_CHECK #-}` near the offending definitions if you want+  to do so.  Or switch off the termination checker altogether with+  `{-# OPTIONS --no-termination-check #-}` (at your own risk!).++* (Since Agda 2.4.2): Termination checking `--without-K` restricts+  structural descent to arguments ending in data types or `Size`.+  Likewise, guardedness is only tracked when result type is data or+  record type.++  ```agda+  mutual+    data WOne : Set where wrap : FOne → WOne+    FOne = ⊥ → WOne++  noo : (X : Set) → (WOne ≡ X) → X → ⊥+  noo .WOne refl (wrap f) = noo FOne iso f+  ```++  `noo` is rejected since at type `X` the structural descent+  `f < wrap f` is discounted `--without-K`.++  ```agda+  data Pandora : Set where+    C : ∞ ⊥ → Pandora++  loop : (A : Set) → A ≡ Pandora → A+  loop .Pandora refl = C (♯ (loop ⊥ foo))+  ```++  `loop` is rejected since guardedness is not tracked at type `A`+  `--without-K`.++  See issues [#1023](https://github.com/agda/agda/issues/1023),+  [#1264](https://github.com/agda/agda/issues/1264),+  [#1292](https://github.com/agda/agda/issues/1292).++Termination checking+--------------------++* The termination checker can now recognize simple subterms in dot+  patterns.++  ```agda+  data Subst : (d : Nat) → Set where+    c₁ : ∀ {d} → Subst d → Subst d+    c₂ : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (suc d₁ + d₂)++  postulate+    comp : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (d₁ + d₂)++  lookup : ∀ d → Nat → Subst d → Set₁+  lookup d             zero    (c₁ ρ)             = Set+  lookup d             (suc v) (c₁ ρ)             = lookup d v ρ+  lookup .(suc d₁ + d₂) v      (c₂ {d₁} {d₂} ρ σ) = lookup (d₁ + d₂) v (comp ρ σ)+  ```++  The dot pattern here is actually normalized, so it is++  ```agda+  suc (d₁ + d₂)+  ```++  and the corresponding recursive call argument is `(d₁ + d₂)`.  In+  such simple cases, Agda can now recognize that the pattern is+  constructor applied to call argument, which is valid descent.++  Note however, that Agda only looks for syntactic equality when+  identifying subterms, since it is not allowed to normalize terms on+  the rhs during termination checking.++  Actually writing the dot pattern has no effect, this works as well,+  and looks pretty magical... ;-)++  ```agda+  hidden : ∀{d} → Nat → Subst d → Set₁+  hidden zero    (c₁ ρ)   = Set+  hidden (suc v) (c₁ ρ)   = hidden v ρ+  hidden v       (c₂ ρ σ) = hidden v (comp ρ σ)+  ```++Tools+-----++### LaTeX-backend++* Fixed the issue of identifiers containing operators being typeset with+  excessive math spacing.++Bug fixes+---------++* Issue [#1194](https://github.com/agda/agda/issues/1194)++* Issue [#836](https://github.com/agda/agda/issues/836): Fields and+  constructors can be qualified by the record/data *type* as well as+  by their record/data module.  This now works also for record/data+  type imported from parametrized modules:++  ```agda+  module M (_ : Set₁) where++    record R : Set₁ where+      field+        X : Set++  open M Set using (R)  -- rather than using (module R)++  X : R → Set+  X = R.X+  ```
+ doc/release-notes/2.4.2.2.md view
@@ -0,0 +1,20 @@+Release notes for Agda version 2.4.2.2+======================================++Bug fixes+---------++* Compilation on Windows fixed.++* Other issues fixed (see+  [bug tracker](https://github.com/agda/agda/issues))++  [#1332](https://github.com/agda/agda/issues/1322)++  [#1353](https://github.com/agda/agda/issues/1353)++  [#1360](https://github.com/agda/agda/issues/1360)++  [#1366](https://github.com/agda/agda/issues/1366)++  [#1369](https://github.com/agda/agda/issues/1369)
+ doc/release-notes/2.4.2.3.md view
@@ -0,0 +1,303 @@+Release notes for Agda version 2.4.2.3+======================================++Installation and infrastructure+-------------------------------++* Added support for GHC 7.10.1.++* Removed support for GHC 7.0.4.++Language+--------++* `_ `is no longer a valid name for a definition.  The following fails+  now: [Issue [#1465](https://github.com/agda/agda/issues/1465)]++  ```agda+  postulate _ : Set+  ```++* Typed bindings can now contain hiding information+  [Issue [#1391](https://github.com/agda/agda/issues/1391)].  This+  means you can now write++  ```agda+  assoc : (xs {ys zs} : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs))+  ```++  instead of the longer++  ```agda+  assoc : (xs : List A) {ys zs : List A} → ...+  ```++  It also works with irrelevance++  ```agda+  .(xs {ys zs} : List A) → ...+  ```++  but of course does not make sense if there is hiding information already.+  Thus, this is (still) a parse error:++  ```agda+  {xs {ys zs} : List A} → ...+  ```++* The builtins for sized types no longer need accompanying postulates.+  The BUILTIN pragmas for size stuff now also declare the identifiers+  they bind to.++  ```agda+  {-# BUILTIN SIZEUNIV SizeUniv #-}  --  SizeUniv : SizeUniv+  {-# BUILTIN SIZE     Size     #-}  --  Size     : SizeUniv+  {-# BUILTIN SIZELT   Size<_   #-}  --  Size<_   : ..Size → SizeUniv+  {-# BUILTIN SIZESUC  ↑_       #-}  --  ↑_       : Size → Size+  {-# BUILTIN SIZEINF  ∞        #-}  --  ∞       : Size+  ```++  `Size` and `Size<` now live in the new universe `SizeUniv`.  It is+  forbidden to build function spaces in this universe, in order to+  prevent the malicious assumption of a size predecessor++  ```agda+  pred : (i : Size) → Size< i+  ```++  [Issue [#1428](https://github.com/agda/agda/issues/1428)].++* Unambiguous notations (coming from syntax declarations) that resolve+  to ambiguous names are now parsed unambiguously+  [Issue [#1194](https://github.com/agda/agda/issues/1194)].++* If only some instances of an overloaded name have a given associated+  notation (coming from syntax declarations), then this name can only+  be resolved to the given instances of the name, not to other+  instances [Issue [#1194](https://github.com/agda/agda/issues/1194)].++  Previously, if different instances of an overloaded name had+  *different* associated notations, then none of the notations could+  be used. Now all of them can be used.++  Note that notation identity does not only involve the right-hand+  side of the syntax declaration. For instance, the following+  notations are not seen as identical, because the implicit argument+  names are different:++  ```agda+  module A where++    data D : Set where+      c : {x y : D} → D++    syntax c {x = a} {y = b} = a ∙ b++  module B where++    data D : Set where+      c : {y x : D} → D++    syntax c {y = a} {x = b} = a ∙ b+  ```++* If an overloaded operator is in scope with at least two distinct+  fixities, then it gets the default fixity+  [Issue [#1436](https://github.com/agda/agda/issues/1436)].++  Similarly, if two or more identical notations for a given overloaded+  name are in scope, and these notations do not all have the+  same fixity, then they get the default fixity.++Type checking+-------------++* Functions of varying arity can now have with-clauses and use rewrite.++  Example:++  ```agda+  NPred : Nat → Set+  NPred 0       = Bool+  NPred (suc n) = Nat → NPred n++  const : Bool → ∀{n} → NPred n+  const b {0}       = b+  const b {suc n} m = const b {n}++  allOdd : ∀ n → NPred n+  allOdd 0 = true+  allOdd (suc n) m with even m+  ... | true  = const false+  ... | false = allOdd n+  ```++* Function defined by copattern matching can now have `with`-clauses+  and use `rewrite`.++  Example:++  ```agda+  {-# OPTIONS --copatterns #-}++  record Stream (A : Set) : Set where+    coinductive+    constructor delay+    field+      force : A × Stream A+  open Stream++  map : ∀{A B} → (A → B) → Stream A → Stream B+  force (map f s) with force s+  ... | a , as = f a , map f as++  record Bisim {A B} (R : A → B → Set) (s : Stream A) (t : Stream B) : Set where+    coinductive+    constructor ~delay+    field+      ~force : let a , as = force s+                   b , bs = force t+               in  R a b × Bisim R as bs+  open Bisim++  SEq : ∀{A} (s t : Stream A) → Set+  SEq = Bisim (_≡_)++  -- Slightly weird definition of symmetry to demonstrate rewrite.++  ~sym' : ∀{A} {s t : Stream A} → SEq s t → SEq t s+  ~force (~sym' {s = s} {t} p) with force s | force t | ~force p+  ... | a , as | b , bs | r , q rewrite r = refl , ~sym' q+  ```++* Instances can now be defined by copattern+  matching. [Issue [#1413](https://github.com/agda/agda/issues/1413)]+  The following example extends the one in+  [Abel, Pientka, Thibodeau, Setzer, POPL 2013, Section 2.2]:++  ```agda+  {-# OPTIONS --copatterns #-}++  -- The Monad type class++  record Monad (M : Set → Set) : Set1 where+    field+      return : {A : Set}   → A → M A+      _>>=_  : {A B : Set} → M A → (A → M B) → M B+  open Monad {{...}}++  -- The State newtype++  record State (S A : Set) : Set where+    field+      runState : S → A × S+  open State++  -- State is an instance of Monad++  instance+    stateMonad : {S : Set} → Monad (State S)+    runState (return {{stateMonad}} a  ) s  = a , s    -- NEW+    runState (_>>=_  {{stateMonad}} m k) s₀ =          -- NEW+      let a , s₁ = runState m s₀+      in  runState (k a) s₁++  -- stateMonad fulfills the monad laws++  leftId : {A B S : Set}(a : A)(k : A → State S B) →+    (return a >>= k) ≡ k a+  leftId a k = refl++  rightId : {A B S : Set}(m : State S A) →+    (m >>= return) ≡ m+  rightId m = refl++  assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →+     ((m >>= k) >>= l) ≡ (m >>= λ a → k a >>= l)+  assoc m k l = refl+  ```++Emacs mode+----------++* The new menu option `Switch to another version of Agda` tries to do+  what it says.++* Changed feature: Interactively split result.++  [ This is as before: ]+  Make-case (`C-c C-c`) with no variables given tries to split on the+  result to introduce projection patterns.  The hole needs to be of+  record type, of course.++  ```agda+  test : {A B : Set} (a : A) (b : B) → A × B+  test a b = ?+  ```++  Result-splitting `?` will produce the new clauses:++  ```agda+  proj₁ (test a b) = ?+  proj₂ (test a b) = ?+  ```++  [ This has changed: ]+  If hole is of function type, `make-case` will introduce only pattern+  variables (as much as it can).++  ```agda+  testFun : {A B : Set} (a : A) (b : B) → A × B+  testFun = ?+  ```++  Result-splitting `?` will produce the new clause:++  ```agda+  testFun a b = ?+  ```++  A second invocation of `make-case` will then introduce projection+  patterns.++Error messages+--------------++* Agda now suggests corrections of misspelled options, e.g.++  ```agda+  {-# OPTIONS+    --dont-termination-check+    --without-k+    --senf-gurke+    #-}+  ```++  Unrecognized options:++  ```+  --dont-termination-check (did you mean --no-termination-check ?)+  --without-k (did you mean --without-K ?)+  --senf-gurke+  ```++  Nothing close to `--senf-gurke`, I am afraid.++Compiler backends+-----------------++* The Epic backend has been removed+  [Issue [#1481](https://github.com/agda/agda/issues/1481)].++Bug fixes+---------++* Fixed bug with `unquoteDecl` not working in instance blocks+  [Issue [#1491](https://github.com/agda/agda/issues/1491)].++* Other issues fixed (see+  [bug tracker](https://github.com/agda/agda/issues)++  [#1497](https://github.com/agda/agda/issues/1497)++  [#1500](https://github.com/agda/agda/issues/1500)
+ doc/release-notes/2.4.2.4.md view
@@ -0,0 +1,295 @@+Release notes for Agda version 2.4.2.4+======================================++Installation and infrastructure+-------------------------------++* Removed support for GHC 7.4.2.++Pragmas and options+-------------------++* Option `--copatterns` is now on by default.  To switch off+  parsing of copatterns, use:++  ```agda+  {-# OPTIONS --no-copatterns #-}+  ```++* Option `--rewriting` is now needed to use `REWRITE` pragmas and+  rewriting during reduction.  Rewriting is not `--safe`.++  To use rewriting, first specify a relation symbol `R` that will+  later be used to add rewrite rules.  A canonical candidate would be+  propositional equality++  ```agda+  {-# BUILTIN REWRITE _≡_ #-}+  ```++  but any symbol `R` of type `Δ → A → A → Set i` for some `A` and `i`+  is accepted.  Then symbols `q` can be added to rewriting provided+  their type is of the form `Γ → R ds l r`.  This will add a rewrite+  rule++  ```+  Γ ⊢ l ↦ r : A[ds/Δ]+  ```++  to the signature, which fires whenever a term is an instance of `l`.+  For example, if++  ```agda+  plus0 : ∀ x → x + 0 ≡ x+  ```++  (ideally, there is a proof for `plus0`, but it could be a+  postulate), then++  ```agda+  {-# REWRITE plus0 #-}+  ```++  will prompt Agda to rewrite any well-typed term of the form `t + 0`+  to `t`.++  Some caveats: Agda accepts and applies rewrite rules naively, it is+  very easy to break consistency and termination of type checking.+  Some examples of rewrite rules that should *not* be added:++  ```agda+  refl     : ∀ x → x ≡ x             -- Agda loops+  plus-sym : ∀ x y → x + y ≡ y + x   -- Agda loops+  absurd   : true ≡ false            -- Breaks consistency+  ```++  Adding only proven equations should at least preserve consistency,+  but this is only a conjecture, so know what you are doing!  Using+  rewriting, you are entering into the wilderness, where you are on+  your own!++Language+--------++* `forall` / `∀` now parses like `λ`, i.e., the following parses now+  [Issue [#1583](https://github.com/agda/agda/issues/1538)]:++  ```agda+  ⊤ × ∀ (B : Set) → B → B+  ```++* The underscore pattern `_` can now also stand for an inaccessible+  pattern (dot pattern). This alleviates the need for writing `._`.+  [Issue #[1605](https://github.com/agda/agda/issues/1605)] Instead of++  ```agda+  transVOld : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c+  transVOld _ ._ ._ refl refl = refl+  ```++  one can now write++  ```agda+    transVNew : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c+    transVNew _ _ _ refl refl = refl+  ```++  and let Agda decide where to put the dots.  This was always possible+  by using hidden arguments++  ```agda+  transH : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c+  transH refl refl = refl+  ```++  which is now equivalent to++  ```agda+  transHNew : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c+  transHNew {a = _}{b = _}{c = _} refl refl = refl+  ```++  Before, underscore `_` stood for an unnamed variable that could not+  be instantiated by an inaccessible pattern.  If one no wants to+  prevent Agda from instantiating, one needs to use a variable name+  other than underscore (however, in practice this situation seems+  unlikely).++Type checking+-------------++* Polarity of phantom arguments to data and record types has+  changed. [Issue [#1596](https://github.com/agda/agda/issues/1596)]+  Polarity of size arguments is Nonvariant (both monotone and+  antitone).  Polarity of other arguments is Covariant (monotone).+  Both were Invariant before (neither monotone nor antitone).++  The following example type-checks now:++  ```agda+  open import Common.Size++  -- List should be monotone in both arguments+  -- (even when `cons' is missing).++  data List (i : Size) (A : Set) : Set where+    [] : List i A++  castLL : ∀{i A} → List i (List i A) → List ∞ (List ∞ A)+  castLL x = x++  -- Stream should be antitone in the first and monotone in the second argument+  -- (even with field `tail' missing).++  record Stream (i : Size) (A : Set) : Set where+    coinductive+    field+      head : A++  castSS : ∀{i A} → Stream ∞ (Stream ∞ A) → Stream i (Stream i A)+  castSS x = x+  ```++* `SIZELT` lambdas must be consistent+  [Issue [#1523](https://github.com/agda/agda/issues/1523), see Abel+  and Pientka, ICFP 2013].  When lambda-abstracting over type (`Size<+  size`) then `size` must be non-zero, for any valid instantiation of+  size variables.++  - The good:++    ```agda+    data Nat (i : Size) : Set where+      zero : ∀ (j : Size< i) → Nat i+      suc  : ∀ (j : Size< i) → Nat j → Nat i++    {-# TERMINATING #-}+    -- This definition is fine, the termination checker is too strict at the moment.+    fix : ∀ {C : Size → Set}+       → (∀ i → (∀ (j : Size< i) → Nat j -> C j) → Nat i → C i)+       → ∀ i → Nat i → C i+    fix t i (zero j)  = t i (λ (k : Size< i) → fix t k) (zero j)+    fix t i (suc j n) = t i (λ (k : Size< i) → fix t k) (suc j n)+    ```++    The `λ (k : Size< i)` is fine in both cases, as context++    ```agda+    i : Size, j : Size< i+    ```++    guarantees that `i` is non-zero.++  - The bad:++    ```agda+    record Stream {i : Size} (A : Set) : Set where+      coinductive+      constructor _∷ˢ_+      field+        head  : A+        tail  : ∀ {j : Size< i} → Stream {j} A+    open Stream public++    _++ˢ_ : ∀ {i A} → List A → Stream {i} A → Stream {i} A+    []        ++ˢ s = s+    (a ∷ as)  ++ˢ s = a ∷ˢ (as ++ˢ s)+    ```++    This fails, maybe unjustified, at++    ```agda+    i : Size, s : Stream {i} A+      ⊢+        a ∷ˢ (λ {j : Size< i} → as ++ˢ s)+    ```++    Fixed by defining the constructor by copattern matching:++    ```agda+    record Stream {i : Size} (A : Set) : Set where+      coinductive+      field+        head  : A+        tail  : ∀ {j : Size< i} → Stream {j} A+    open Stream public++    _∷ˢ_ : ∀ {i A} → A → Stream {i} A → Stream {↑ i} A+    head  (a ∷ˢ as) = a+    tail  (a ∷ˢ as) = as++    _++ˢ_ : ∀ {i A} → List A → Stream {i} A → Stream {i} A+    []        ++ˢ s = s+    (a ∷ as)  ++ˢ s = a ∷ˢ (as ++ˢ s)+    ```++  - The ugly:++    ```agda+    fix : ∀ {C : Size → Set}+       → (∀ i → (∀ (j : Size< i) → C j) → C i)+       → ∀ i → C i+    fix t i = t i λ (j : Size< i) → fix t j+    ```++    For `i=0`, there is no such `j` at runtime, leading to looping+    behavior.++Interaction+-----------++* Issue [#635](https://github.com/agda/agda/issues/635) has been+  fixed.  Case splitting does not spit out implicit record patterns+  any more.++  ```agda+  record Cont : Set₁ where+    constructor _◃_+    field+      Sh  : Set+      Pos : Sh → Set++  open Cont++  data W (C : Cont) : Set where+    sup : (s : Sh C) (k : Pos C s → W C) → W C++  bogus : {C : Cont} → W C → Set+  bogus w = {!w!}+  ```++  Case splitting on `w` yielded, since the fix of+  Issue [#473](https://github.com/agda/agda/issues/473),++  ```agda+  bogus {Sh ◃ Pos} (sup s k) = ?+  ```++  Now it gives, as expected,++  ```agda+  bogus (sup s k) = ?+  ```++Performance+-----------++* As one result of the 21st Agda Implementor's Meeting (AIM XXI),+  serialization of the standard library is 50% faster (time reduced by+  a third), without using additional disk space for the interface+  files.+++Bug fixes+---------++Issues fixed (see [bug tracker](https://github.com/agda/agda/issues)):++[#1546](https://github.com/agda/agda/issues/1546) (copattern matching+and with-clauses)++[#1560](https://github.com/agda/agda/issues/1560) (positivity checker+inefficiency)++[#1584](https://github.com/agda/agda/issues/1548) (let pattern with+trailing implicit)
+ doc/release-notes/2.4.2.5.md view
@@ -0,0 +1,78 @@+Release notes for Agda version 2.4.2.5+======================================++Installation and infrastructure+-------------------------------++* Added support for GHC 7.10.3.++* Added `cpphs` Cabal flag++  Turn on/off this flag to choose cpphs/cpp as the C preprocessor.++  This flag is turn on by default.++  (This flag was added in Agda 2.4.2.1 but it was not documented)++Pragmas and options+-------------------++* Termination pragmas are no longer allowed inside `where` clauses+  [Issue [#1137](https://github.com/agda/agda/issues/1137)].++Type checking+-------------++* `with`-abstraction is more aggressive, abstracts also in types of+  variables that are used in the `with`-expressions, unless they are+  also used in the types of the+  `with`-expressions. [Issue [#1692](https://github.com/agda/agda/issues/1692)]++  Example:++  ```agda+  test : (f : (x : A) → a ≡ x) (b : A) → b ≡ a+  test f b with a | f b+  test f b | .b | refl = f b+  ```++  Previously, `with` would not abstract in types of variables that+  appear in the `with`-expressions, in this case, both `f` and `b`,+  leaving their types unchanged.  Now, it tries to abstract in `f`, as+  only `b` appears in the types of the `with`-expressions which are+  `A` (of `a`) and `a ≡ b` (of `f b`).  As a result, the type of `f`+  changes to `(x : A) → b ≡ x` and the type of the goal to `b ≡ b` (as+  previously).++  This also affects `rewrite`, which is implemented in terms of+  `with`.++  ```agda+  test : (f : (x : A) → a ≡ x) (b : A) → b ≡ a+  test f b rewrite f b = f b+  ```++  As the new `with` is not fully backwards-compatible, some parts of+  your Agda developments using `with` or `rewrite` might need+  maintenance.++Fixed issues+------------++See [bug tracker](https://github.com/agda/agda/issues)++[#1407](https://github.com/agda/agda/issues/1497)++[#1518](https://github.com/agda/agda/issues/1518)++[#1670](https://github.com/agda/agda/issues/1670)++[#1677](https://github.com/agda/agda/issues/1677)++[#1698](https://github.com/agda/agda/issues/1698)++[#1701](https://github.com/agda/agda/issues/1701)++[#1710](https://github.com/agda/agda/issues/1710)++[#1718](https://github.com/agda/agda/issues/1718)
+ doc/release-notes/2.4.2.md view
@@ -0,0 +1,391 @@+Release notes for Agda version 2.4.2+====================================++Pragmas and options+-------------------++* New option: `--with-K`++  This can be used to override a global `--without-K` in a file, by+  adding a pragma `{-# OPTIONS --with-K #-}`.++* New pragma `{-# NON_TERMINATING #-}`++  This is a safer version of `NO_TERMINATION_CHECK` which doesn't+  treat the affected functions as terminating. This means that+  `NON_TERMINATING` functions do not reduce during type checking. They+  do reduce at run-time and when invoking `C-c C-n` at top-level (but+  not in a hole).++Language+--------++* Instance search is now more efficient and recursive (see+  Issue [#938](https://github.com/agda/agda/issues/938)) (but without+  termination check yet).++  A new keyword `instance` has been introduced (in the style of+  `abstract` and `private`) which must now be used for every+  definition/postulate that has to be taken into account during+  instance resolution. For example:++  ```agda+  record RawMonoid (A : Set) : Set where+    field+      nil  : A+      _++_ : A -> A -> A++  open RawMonoid {{...}}++  instance+    rawMonoidList : {A : Set} -> RawMonoid (List A)+    rawMonoidList = record { nil = []; _++_ = List._++_ }++    rawMonoidMaybe : {A : Set} {{m : RawMonoid A}} -> RawMonoid (Maybe A)+    rawMonoidMaybe {A} = record { nil = nothing ; _++_ = catMaybe }+      where+        catMaybe : Maybe A -> Maybe A -> Maybe A+        catMaybe nothing mb = mb+        catMaybe ma nothing = ma+        catMaybe (just a) (just b) = just (a ++ b)+  ```++  Moreover, each type of an instance must end in (something that reduces+  to) a named type (e.g. a record, a datatype or a postulate). This+  allows us to build a simple index structure++  ```+  data/record name  -->  possible instances+  ```++  that speeds up instance search.++  Instance search takes into account all local bindings and all global+  `instance` bindings and the search is recursive. For instance,+  searching for++  ```agda+  ? : RawMonoid (Maybe (List A))+  ```++  will consider the candidates {`rawMonoidList`, `rawMonoidMaybe`}, fail to+  unify the first one, succeeding with the second one++  ```agda+  ? = rawMonoidMaybe {A = List A} {{m = ?m}} : RawMonoid (Maybe (List A))+  ```++  and continue with goal++  ```agda+  ?m : RawMonoid (List A)+  ```++  This will then find++  ```agda+  ?m = rawMonoidList {A = A}+  ```++  and putting together we have the solution.++  Be careful that there is no termination check for now, you can+  easily make Agda loop by declaring the identity function as an+  instance. But it shouldn’t be possible to make Agda loop by only+  declaring structurally recursive instances (whatever that means).++  Additionally:++  - Uniqueness of instances is up to definitional equality (see+    Issue [#899](https://github.com/agda/agda/issues/899)).++  - Instances of the following form are allowed:++    ```agda+    EqSigma : {A : Set} {B : A → Set} {{EqA : Eq A}}+              {{EqB : {a : A} → Eq (B a)}}+              → Eq (Σ A B)+    ```++    When searching recursively for an instance of type `{a : A} → Eq+    (B a)`, a lambda will automatically be introduced and instance+    search will search for something of type `Eq (B a)` in the context+    extended by `a : A`. When searching for an instance, the `a`+    argument does not have to be implicit, but in the definition of+    `EqSigma`, instance search will only be able to use `EqB` if `a`+    is implicit.++  - There is no longer any attempt to solve irrelevant metas by instance+    search.++  - Constructors of records and datatypes are automatically added to the+    instance table.++* You can now use `quote` in patterns.++  For instance, here is a function that unquotes a (closed) natural+  number term.++  ```agda+  unquoteNat : Term → Maybe Nat+  unquoteNat (con (quote Nat.zero) [])            = just zero+  unquoteNat (con (quote Nat.suc) (arg _ n ∷ [])) = fmap suc (unquoteNat n)+  unquoteNat _                                    = nothing+  ```++* The builtin constructors `AGDATERMUNSUPPORTED` and+  `AGDASORTUNSUPPORTED` are now translated to meta variables when+  unquoting.++* New syntactic sugar `tactic e` and `tactic e | e1 | .. | en`.++  It desugars as follows and makes it less unwieldy to call+  reflection-based tactics.++  ```agda+  tactic e                --> quoteGoal g in unquote (e g)+  tactic e | e1 | .. | en --> quoteGoal g in unquote (e g) e1 .. en+  ```++  Note that in the second form the tactic function should generate a+  function from a number of new subgoals to the original goal. The+  type of `e` should be `Term -> Term` in both cases.++* New reflection builtins for literals.++  The term data type `AGDATERM` now needs an additional constructor+   `AGDATERMLIT` taking a reflected literal defined as follows (with+   appropriate builtin bindings for the types `Nat`, `Float`, etc).++  ```agda+  data Literal : Set where+    nat    : Nat    → Literal+    float  : Float  → Literal+    char   : Char   → Literal+    string : String → Literal+    qname  : QName  → Literal++  {-# BUILTIN AGDALITERAL   Literal #-}+  {-# BUILTIN AGDALITNAT    nat     #-}+  {-# BUILTIN AGDALITFLOAT  float   #-}+  {-# BUILTIN AGDALITCHAR   char    #-}+  {-# BUILTIN AGDALITSTRING string  #-}+  {-# BUILTIN AGDALITQNAME  qname   #-}+  ```++  When quoting (`quoteGoal` or `quoteTerm`) literals will be mapped to+  the `AGDATERMLIT` constructor. Previously natural number literals+  were quoted to `suc`/`zero` application and other literals were+  quoted to `AGDATERMUNSUPPORTED`.++* New reflection builtins for function definitions.++  `AGDAFUNDEF` should now map to a data type defined as follows++  (with+  ```agda+  {-# BUILTIN QNAME       QName   #-}+  {-# BUILTIN ARG         Arg     #-}+  {-# BUILTIN AGDATERM    Term    #-}+  {-# BUILTIN AGDATYPE    Type    #-}+  {-# BUILTIN AGDALITERAL Literal #-}+  ```+  ).++  ```agda+  data Pattern : Set where+    con    : QName → List (Arg Pattern) → Pattern+    dot    : Pattern+    var    : Pattern+    lit    : Literal → Pattern+    proj   : QName → Pattern+    absurd : Pattern++  {-# BUILTIN AGDAPATTERN   Pattern #-}+  {-# BUILTIN AGDAPATCON    con     #-}+  {-# BUILTIN AGDAPATDOT    dot     #-}+  {-# BUILTIN AGDAPATVAR    var     #-}+  {-# BUILTIN AGDAPATLIT    lit     #-}+  {-# BUILTIN AGDAPATPROJ   proj    #-}+  {-# BUILTIN AGDAPATABSURD absurd  #-}++  data Clause : Set where+    clause        : List (Arg Pattern) → Term → Clause+    absurd-clause : List (Arg Pattern) → Clause++  {-# BUILTIN AGDACLAUSE       Clause        #-}+  {-# BUILTIN AGDACLAUSECLAUSE clause        #-}+  {-# BUILTIN AGDACLAUSEABSURD absurd-clause #-}++  data FunDef : Set where+    fun-def : Type → List Clause → FunDef++  {-# BUILTIN AGDAFUNDEF    FunDef  #-}+  {-# BUILTIN AGDAFUNDEFCON fun-def #-}+  ```++* New reflection builtins for extended (pattern-matching) lambda.++  The `AGDATERM` data type has been augmented with a constructor++  ```agda+  AGDATERMEXTLAM : List AGDACLAUSE → List (ARG AGDATERM) → AGDATERM+  ```++  Absurd lambdas (`λ ()`) are quoted to extended lambdas with an+  absurd clause.++* Unquoting declarations.++  You can now define (recursive) functions by reflection using the new+  `unquoteDecl` declaration++  ```agda+  unquoteDecl x = e+  ```++  Here e should have type `AGDAFUNDEF` and evaluate to a closed+  value. This value is then spliced in as the definition of `x`. In+  the body `e`, `x` has type `QNAME` which lets you splice in+  recursive definitions.++  Standard modifiers, such as fixity declarations, can be applied to `x` as+  expected.++* Quoted levels++  Universe levels are now quoted properly instead of being quoted to+  `AGDASORTUNSUPPORTED`. `Setω` still gets an unsupported sort,+  however.++* Module applicants can now be operator applications.++  Example:++  ```agda+  postulate+    [_] : A -> B++  module M (b : B) where++  module N (a : A) = M [ a ]+  ```++  [See Issue [#1245](https://github.com/agda/agda/issues/1245)]++* Minor change in module application+  semantics. [Issue [#892](https://github.com/agda/agda/issues/892)]++  Previously re-exported functions were not redefined when+  instantiating a module. For instance++  ```agda+  module A where f = ...+  module B (X : Set) where+    open A public+  module C = B Nat+  ```++  In this example `C.f` would be an alias for `A.f`, so if both `A`+  and `C` were opened `f` would not be ambiguous. However, this+  behaviour is not correct when `A` and `B` share some module+  parameters+  (Issue [#892](https://github.com/agda/agda/issues/892)). To fix this+  `C` now defines its own copy of `f` (which evaluates to `A.f`),+  which means that opening `A` and `C` results in an ambiguous `f`.++Type checking+-------------++* Recursive records need to be declared as either `inductive` or+  `coinductive`.  `inductive` is no longer default for recursive+  records. Examples:++  ```agda+  record _×_ (A B : Set) : Set where+    constructor _,_+    field+      fst : A+      snd : B++  record Tree (A : Set) : Set where+    inductive+    constructor tree+    field+      elem     : A+      subtrees : List (Tree A)++  record Stream (A : Set) : Set where+    coinductive+    constructor _::_+    field+      head : A+      tail : Stream A+  ```++  If you are using old-style (musical) coinduction, a record may have+  to be declared as inductive, paradoxically.++  ```agda+  record Stream (A : Set) : Set where+    inductive -- YES, THIS IS INTENDED !+    constructor _∷_+    field+      head : A+      tail : ∞ (Stream A)+  ```++  This is because the "coinduction" happens in the use of `∞` and not+  in the use of `record`.++Tools+-----++### Emacs mode++* A new menu option `Display` can be used to display the version of+  the running Agda process.++### LaTeX-backend++* New experimental option `references` has been added. When specified,+  i.e.:++  ```latex+  \usepackage[references]{agda}+  ```++  a new command called `\AgdaRef` is provided, which lets you+  reference previously typeset commands, e.g.:++  Let us postulate `\AgdaRef{apa}`.++  ```agda+  \begin{code}+  postulate+    apa : Set+  \end{code}+  ```++  Above `apa` will be typeset (highlighted) the same in the text as in+  the code, provided that the LaTeX output is post-processed using+  `src/data/postprocess-latex.pl`, e.g.:++  ```+  cp $(dirname $(dirname $(agda-mode locate)))/postprocess-latex.pl .+  agda -i. --latex Example.lagda+  cd latex/+  perl ../postprocess-latex.pl Example.tex > Example.processed+  mv Example.processed Example.tex+  xelatex Example.tex+  ```++  Mix-fix and Unicode should work as expected (Unicode requires+  XeLaTeX/LuaLaTeX), but there are limitations:++  - Overloading identifiers should be avoided, if multiples exist+    `\AgdaRef` will typeset according to the first it finds.++  - Only the current module is used, should you need to reference+    identifiers in other modules then you need to specify which other+    module manually, i.e. `\AgdaRef[module]{identifier}`.
+ doc/release-notes/2.5.1.1.md view
@@ -0,0 +1,79 @@+Release notes for Agda version 2.5.1.1+======================================++Installation and infrastructure+-------------------------------++* Added support for GHC 8.0.1.++* Documentation is now built with Python >=3.3, as done by+  [readthedocs.org](https://readthedocs.org/).++Bug fixes+---------++* Fixed a serious performance problem with instance search++  Issues [#1952](https://github.com/agda/agda/issues/1952) and+  [#1998](https://github.com/agda/agda/issues/1998). Also related:+  [#1955](https://github.com/agda/agda/issues/1955) and+  [#2025](https://github.com/agda/agda/issues/2025)++* Interactively splitting variable with `C-c C-c` no longer introduces+  new trailing patterns.  This fixes+  Issue [#1950](https://github.com/agda/agda/issues/1950).++  ```agda+  data Ty : Set where+    _⇒_ : Ty → Ty → Ty++  ⟦_⟧ : Ty → Set+  ⟦ A ⇒ B ⟧ = ⟦ A ⟧ → ⟦ B ⟧++  data Term : Ty → Set where+    K : (A B : Ty) → Term (A ⇒ (B ⇒ A))++  test : (A : Ty) (a : Term A) → ⟦ A ⟧+  test A a = {!a!}+  ```++  Before change, case splitting on `a` would give++  ```agda+  test .(A ⇒ (B ⇒ A)) (K A B) x x₁ = ?+  ```++  Now, it yields++  ```agda+  test .(A ⇒ (B ⇒ A)) (K A B) = ?+  ```++* In literate TeX files, `\begin{code}` and `\end{code}` can be+  preceded (resp. followed) by TeX code on the same line. This fixes+  Issue [#2077](https://github.com/agda/agda/issues/2077).++* Other issues fixed (see+  [bug tracker](https://github.com/agda/agda/issues)):++  [#1951](https://github.com/agda/agda/issues/1951) (mixfix binders+  not working in 'syntax')++  [#1967](https://github.com/agda/agda/issues/1967) (too eager+  insteance search error)++  [#1974](https://github.com/agda/agda/issues/1974) (lost constraint+  dependencies)++  [#1982](https://github.com/agda/agda/issues/1982) (internal error in+  unifier)++  [#2034](https://github.com/agda/agda/issues/2034) (function type+  instance goals)++Compiler backends+-----------------++* UHC compiler backend++  Added support for UHC 1.1.9.4.
+ doc/release-notes/2.5.1.2.md view
@@ -0,0 +1,5 @@+Release notes for Agda version 2.5.1.2+======================================++* Fixed broken type signatures that were incorrectly accepted due to+  [GHC #12784](https://ghc.haskell.org/trac/ghc/ticket/12784).
+ doc/release-notes/2.5.1.md view
@@ -0,0 +1,1600 @@+Release notes for Agda version 2.5.1+====================================++Documentation+-------------++* There is now an official Agda User Manual:+  https://agda.readthedocs.io/++Installation and infrastructure+-------------------------------++* Builtins and primitives are now defined in a new set of modules available to+  all users, independent of any particular library. The modules are++  ```agda+  Agda.Builtin.Bool+  Agda.Builtin.Char+  Agda.Builtin.Coinduction+  Agda.Builtin.Equality+  Agda.Builtin.Float+  Agda.Builtin.FromNat+  Agda.Builtin.FromNeg+  Agda.Builtin.FromString+  Agda.Builtin.IO+  Agda.Builtin.Int+  Agda.Builtin.List+  Agda.Builtin.Nat+  Agda.Builtin.Reflection+  Agda.Builtin.Size+  Agda.Builtin.Strict+  Agda.Builtin.String+  Agda.Builtin.TrustMe+  Agda.Builtin.Unit+  ```++  The standard library reexports the primitives from the new modules.++  The `Agda.Builtin` modules are installed in the same way as+  `Agda.Primitive`, but unlike `Agda.Primitive` they are not loaded+  automatically.++Pragmas and options+-------------------++* Library management++  There is a new 'library' concept for managing include paths. A library+  consists of+    - a name,+    - a set of libraries it depends on, and+    - a set of include paths.++  A library is defined in a `.agda-lib` file using the following+  format:++  ```+  name: LIBRARY-NAME  -- Comment+  depend: LIB1 LIB2+    LIB3+    LIB4+  include: PATH1+    PATH2+    PATH3+  ```++  Dependencies are library names, not paths to `.agda-lib` files, and+  include paths are relative to the location of the library-file.++  To be useable, a library file has to be listed (with its full path)+  in `AGDA_DIR/libraries` (or `AGDA_DIR/libraries-VERSION`, for a+  given Agda version). `AGDA_DIR` defaults to `~/.agda` on Unix-like+  systems and `C:/Users/USERNAME/AppData/Roaming/agda` or similar on+  Windows, and can be overridden by setting the `AGDA_DIR` environment+  variable.++  Environment variables in the paths (of the form `$VAR` or `${VAR}`)+  are expanded. The location of the libraries file used can be+  overridden using the `--library-file=FILE` flag, although this is+  not expected to be very useful.++  You can find out the precise location of the 'libraries' file by+  calling `agda -l fjdsk Dummy.agda` and looking at the error message+  (assuming you don't have a library called fjdsk installed).++  There are three ways a library gets used:++    - You supply the `--library=LIB` (or `-l LIB`) option to+      Agda. This is equivalent to adding a `-iPATH` for each of the+      include paths of `LIB` and its (transitive) dependencies.++    - No explicit `--library` flag is given, and the current project+      root (of the Agda file that is being loaded) or one of its+      parent directories contains a `.agda-lib` file defining a+      library `LIB`. This library is used as if a `--librarary=LIB`+      option had been given, except that it is not necessary for the+      library to be listed in the `AGDA_DIR/libraries` file.++    - No explicit `--library` flag, and no `.agda-lib` file in the+      project root. In this case the file `AGDA_DIR/defaults` is read+      and all libraries listed are added to the path. The defaults+      file should contain a list of library names, each on a separate+      line. In this case the current directory is also added to the+      path.++      To disable default libraries, you can give the flag+      `--no-default-libraries`.++  Library names can end with a version number (for instance,+  `mylib-1.2.3`). When resolving a library name (given in a `--library`+  flag, or listed as a default library or library dependency) the+  following rules are followed:++    - If you don't give a version number, any version will do.++    - If you give a version number an exact match is required.++    - When there are multiple matches an exact match is preferred, and+      otherwise the latest matching version is chosen.++  For example, suppose you have the following libraries installed:+  `mylib`, `mylib-1.0`, `otherlib-2.1`, and `otherlib-2.3`. In this+  case, aside from the exact matches you can also say+  `--library=otherlib` to get `otherlib-2.3`.++* New Pragma `COMPILED_DECLARE_DATA` for binding recursively defined+  Haskell data types to recursively defined Agda data types.++  If you have a Haskell type like++  ```haskell+  {-# LANGUAGE GADTs #-}++  module Issue223 where++  data A where+    BA :: B -> A++  data B where+    AB :: A -> B+    BB :: B+  ```++  You can now bind it to corresponding mutual Agda inductive data+  types as follows:++  ```agda+  {-# IMPORT Issue223 #-}++  data A : Set+  {-# COMPILED_DECLARE_DATA A Issue223.A #-}+  data B : Set+  {-# COMPILED_DECLARE_DATA B Issue223.B #-}++  data A where+    BA : B → A++  {-# COMPILED_DATA A Issue223.A Issue223.BA #-}+  data B where+    AB : A → B+    BB : B++  {-# COMPILED_DATA B Issue223.B Issue223.AB Issue223.BB #-}+  ```++  This fixes Issue [#223](https://github.com/agda/agda/issues/223).++* New pragma `HASKELL` for adding inline Haskell code (GHC backend only)++  Arbitrary Haskell code can be added to a module using the `HASKELL`+  pragma. For instance,++  ```agda+  {-# HASKELL+    echo :: IO ()+    echo = getLine >>= putStrLn+  #-}++  postulate echo : IO ⊤+  {-# COMPILED echo echo #-}+  ```++* New option `--exact-split`.++  The `--exact-split` flag causes Agda to raise an error whenever a+  clause in a definition by pattern matching cannot be made to hold+  definitionally (i.e. as a reduction rule). Specific clauses can be+  excluded from this check by means of the `{-# CATCHALL #-}` pragma.++  For instance, the following definition will be rejected as the second clause+  cannot be made to hold definitionally:++  ```agda+  min : Nat → Nat → Nat+  min zero    y       = zero+  min x       zero    = zero+  min (suc x) (suc y) = suc (min x y+  ```++  Catchall clauses have to be marked as such, for instance:++  ```agda+  eq : Nat → Nat → Bool+  eq zero    zero    = true+  eq (suc m) (suc n) = eq m n+  {-# CATCHALL #-}+  eq _       _       = false+  ```++* New option: `--no-exact-split`.++  This option can be used to override a global `--exact-split` in a+  file, by adding a pragma `{-# OPTIONS --no-exact-split #-}`.++* New options: `--sharing` and `--no-sharing`.++  These options are used to enable/disable sharing and call-by-need+  evaluation.  The default is `--no-sharing`.++  Note that they cannot appear in an `OPTIONS` pragma, but have to be+  given as command line arguments or added to the Agda Program Args+  from Emacs with `M-x customize-group agda2`.++* New pragma `DISPLAY`.++  ```agda+  {-# DISPLAY f e1 .. en = e #-}+  ```++  This causes `f e1 .. en` to be printed in the same way as `e`, where+  `ei` can bind variables used in `e`. The expressions `ei` and `e`+  are scope checked, but not type checked.++  For example this can be used to print overloaded (instance) functions with+  the overloaded name:++  ```agda+  instance+    NumNat : Num Nat+    NumNat = record { ..; _+_ = natPlus }++  {-# DISPLAY natPlus a b = a + b #-}+  ```++  Limitations++  - Left-hand sides are restricted to variables, constructors, defined+    functions or types, and literals. In particular, lambdas are not+    allowed in left-hand sides.++  - Since `DISPLAY` pragmas are not type checked implicit argument+    insertion may not work properly if the type of `f` computes to an+    implicit function space after pattern matching.++* Removed pragma `{-# ETA R #-}`++  The pragma `{-# ETA R #-}` is replaced by the `eta-equality` directive+  inside record declarations.++* New option `--no-eta-equality`.++  The `--no-eta-equality` flag disables eta rules for declared record+  types.  It has the same effect as `no-eta-equality` inside each+  declaration of a record type `R`.++  If used with the `OPTIONS` pragma it will not affect records defined+  in other modules.++* The semantics of `{-# REWRITE r #-}` pragmas in parametrized modules+  has changed (see+  Issue [#1652](https://github.com/agda/agda/issues/1652)).++  Rewrite rules are no longer lifted to the top context. Instead, they+  now only apply to terms in (extensions of) the module context. If+  you want the old behaviour, you should put the `{-# REWRITE r #-}`+  pragma outside of the module (i.e. unindent it).++* New pragma `{-# INLINE f #-}` causes `f` to be inlined during+  compilation.++* The `STATIC` pragma is now taken into account during compilation.++  Calls to a function marked `STATIC` are normalised before+  compilation. The typical use case for this is to mark the+  interpreter of an embedded language as `STATIC`.++* Option `--type-in-type` no longer implies+  `--no-universe-polymorphism`, thus, it can be used with explicit+  universe+  levels. [Issue [#1764](https://github.com/agda/agda/issues/1764)] It+  simply turns off error reporting for any level mismatch now.+  Examples:++  ```agda+  {-# OPTIONS --type-in-type #-}++  Type : Set+  Type = Set++  data D {α} (A : Set α) : Set where+    d : A → D A++  data E α β : Set β where+    e : Set α → E α β+  ```++* New `NO_POSITIVITY_CHECK` pragma to switch off the positivity checker+  for data/record definitions and mutual blocks.++  The pragma must precede a data/record definition or a mutual block.++  The pragma cannot be used in `--safe` mode.++  Examples (see `Issue1614*.agda` and `Issue1760*.agda` in+  `test/Succeed/`):++  1. Skipping a single data definition.++     ```agda+     {-# NO_POSITIVITY_CHECK #-}+     data D : Set where+       lam : (D → D) → D+     ```++  2. Skipping a single record definition.++     ```agda+     {-# NO_POSITIVITY_CHECK #-}+     record U : Set where+       field ap : U → U+     ```++  3. Skipping an old-style mutual block: Somewhere within a `mutual`+     block before a data/record definition.++     ```agda+     mutual+       data D : Set where+         lam : (D → D) → D++       {-# NO_POSITIVITY_CHECK #-}+       record U : Set where+         field ap : U → U+     ```++  4. Skipping an old-style mutual block: Before the `mutual` keyword.++     ```agda+     {-# NO_POSITIVITY_CHECK #-}+     mutual+       data D : Set where+         lam : (D → D) → D++       record U : Set where+         field ap : U → U+     ```++  5. Skipping a new-style mutual block: Anywhere before the+     declaration or the definition of data/record in the block.++     ```agda+     record U : Set+     data D   : Set++     record U where+       field ap : U → U++     {-# NO_POSITIVITY_CHECK #-}+     data D where+       lam : (D → D) → D+     ```++* Removed `--no-coverage-check`+  option. [Issue [#1918](https://github.com/agda/agda/issues/1918)]++Language+--------++### Operator syntax++* The default fixity for syntax declarations has changed from -666 to 20.++* Sections.++  Operators can be sectioned by replacing arguments with underscores.+  There must not be any whitespace between these underscores and the+  adjacent nameparts. Examples:++  ```agda+  pred : ℕ → ℕ+  pred = _∸ 1++  T : Bool → Set+  T = if_then ⊤ else ⊥++  if : {A : Set} (b : Bool) → A → A → A+  if b = if b then_else_+  ```++  Sections are translated into lambda expressions. Examples:++  ```agda+  _∸ 1              ↦  λ section → section ∸ 1++  if_then ⊤ else ⊥  ↦  λ section → if section then ⊤ else ⊥++  if b then_else_   ↦  λ section section₁ →+                           if b then section else section₁+  ```++  Operator sections have the same fixity as the underlying operator+  (except in cases like `if b then_else_`, in which the section is+  "closed", but the operator is not).++  Operator sections are not supported in patterns (with the exception+  of dot patterns), and notations coming from syntax declarations+  cannot be sectioned.++* A long-standing operator fixity bug has been fixed. As a consequence+  some programs that used to parse no longer do.++  Previously each precedence level was (incorrectly) split up into+  five separate ones, ordered as follows, with the earlier ones+  binding less tightly than the later ones:++    - Non-associative operators.++    - Left associative operators.++    - Right associative operators.++    - Prefix operators.++    - Postfix operators.++  Now this problem has been addressed. It is no longer possible to mix+  operators of a given precedence level but different associativity.+  However, prefix and right associative operators are seen as having+  the same associativity, and similarly for postfix and left+  associative operators.++  Examples+  --------++  The following code is no longer accepted:++  ```agda+  infixl 6 _+_+  infix  6 _∸_++  rejected : ℕ+  rejected = 1 + 0 ∸ 1+  ```++  However, the following previously rejected code is accepted:++  ```agda+  infixr 4 _,_+  infix  4 ,_++  ,_ : {A : Set} {B : A → Set} {x : A} → B x → Σ A B+  , y = _ , y++  accepted : Σ ℕ λ i → Σ ℕ λ j → Σ (i ≡ j) λ _ → Σ ℕ λ k → j ≡ k+  accepted = 5 , , refl , , refl+  ```++* The classification of notations with binders into the categories+  infix, prefix, postfix or closed has+  changed. [Issue [#1450](https://github.com/agda/agda/issues/1450)]++  The difference is that, when classifying the notation, only+  *regular* holes are taken into account, not *binding* ones.++  Example: The notation++  ```agda+  syntax m >>= (λ x → f) = x <- m , f+  ```++  was previously treated as infix, but is now treated as prefix.++* Notation can now include wildcard binders.++  Example: `syntax Σ A (λ _ → B) = A × B`++* If an overloaded operator is in scope with several distinct+  precedence levels, then several instances of this operator will be+  included in the operator grammar, possibly leading to ambiguity.+  Previously the operator was given the default fixity+  [Issue [#1436](https://github.com/agda/agda/issues/1436)].++  There is an exception to this rule: If there are multiple precedences,+  but at most one is explicitly declared, then only one instance will be+  included in the grammar. If there are no explicitly declared+  precedences, then this instance will get the default precedence, and+  otherwise it will get the declared precedence.++  If multiple occurrences of an operator are "merged" in the grammar,+  and they have distinct associativities, then they are treated as+  being non-associative.++  The three paragraphs above also apply to identical notations (coming+  from syntax declarations) for a given overloaded name.++  Examples:++  ```agda+  module A where++    infixr 5 _∷_+    infixr 5 _∙_+    infixl 3 _+_+    infix  1 bind++    syntax bind c (λ x → d) = x ← c , d++  module B where++    infix  5 _∷_+    infixr 4 _∙_+    -- No fixity declaration for _+_.+    infixl 2 bind++    syntax bind c d = c ∙ d++  module C where++    infixr 2 bind++    syntax bind c d = c ∙ d++  open A+  open B+  open C++  -- _∷_ is infix 5.+  -- _∙_ has two fixities: infixr 4 and infixr 5.+  -- _+_ is infixl 3.+  -- A.bind's notation is infix 1.+  -- B.bind and C.bind's notations are infix 2.++  -- There is one instance of "_ ∷ _" in the grammar, and one+  -- instance of "_ + _".++  -- There are three instances of "_ ∙ _" in the grammar, one+  -- corresponding to A._∙_, one corresponding to B._∙_, and one+  -- corresponding to both B.bind and C.bind.+  ```++### Reflection++* The reflection framework has received a massive overhaul.++  A new type of reflected type checking computations supplants most of+  the old reflection primitives. The `quoteGoal`, `quoteContext` and+  tactic primitives are deprecated and will be removed in the future,+  and the `unquoteDecl` and `unquote` primitives have changed+  behaviour. Furthermore the following primitive functions have been+  replaced by builtin type checking computations:++  ```agda+  - primQNameType              --> AGDATCMGETTYPE+  - primQNameDefinition        --> AGDATCMGETDEFINITION+  - primDataConstructors       --> subsumed by AGDATCMGETDEFINITION+  - primDataNumberOfParameters --> subsumed by AGDATCMGETDEFINITION+  ```++  See below for details.++* Types are no longer packaged with a sort.++  The `AGDATYPE` and `AGDATYPEEL` built-ins have been+  removed. Reflected types are now simply terms.++* Reflected definitions have more information.++  The type for reflected definitions has changed to++  ```agda+  data Definition : Set where+    fun-def     : List Clause  → Definition+    data-type   : Nat → List Name → Definition -- parameters and constructors+    record-type : Name → Definition            -- name of the data/record type+    data-con    : Name → Definition            -- name of the constructor+    axiom       : Definition+    prim-fun    : Definition+  ```++  Correspondingly the built-ins for function, data and record+  definitions (`AGDAFUNDEF`, `AGDAFUNDEFCON`, `AGDADATADEF`,+  `AGDARECORDDEF`) have been removed.++* Reflected type checking computations.++  There is a primitive `TC` monad representing type checking+  computations. The `unquote`, `unquoteDecl`, and the new `unquoteDef`+  all expect computations in this monad (see below). The interface to+  the monad is the following++  ```agda+  -- Error messages can contain embedded names and terms.+  data ErrorPart : Set where+    strErr  : String → ErrorPart+    termErr : Term → ErrorPart+    nameErr : Name → ErrorPart++  {-# BUILTIN AGDAERRORPART       ErrorPart #-}+  {-# BUILTIN AGDAERRORPARTSTRING strErr    #-}+  {-# BUILTIN AGDAERRORPARTTERM   termErr   #-}+  {-# BUILTIN AGDAERRORPARTNAME   nameErr   #-}++  postulate+    TC         : ∀ {a} → Set a → Set a+    returnTC   : ∀ {a} {A : Set a} → A → TC A+    bindTC     : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B++    -- Unify two terms, potentially solving metavariables in the process.+    unify      : Term → Term → TC ⊤++    -- Throw a type error. Can be caught by catchTC.+    typeError  : ∀ {a} {A : Set a} → List ErrorPart → TC A++    -- Block a type checking computation on a metavariable. This will abort+    -- the computation and restart it (from the beginning) when the+    -- metavariable is solved.+    blockOnMeta : ∀ {a} {A : Set a} → Meta → TC A++    -- Backtrack and try the second argument if the first argument throws a+    -- type error.+    catchTC    : ∀ {a} {A : Set a} → TC A → TC A → TC A++    -- Infer the type of a given term+    inferType  : Term → TC Type++    -- Check a term against a given type. This may resolve implicit arguments+    -- in the term, so a new refined term is returned. Can be used to create+    -- new metavariables: newMeta t = checkType unknown t+    checkType  : Term → Type → TC Term++    -- Compute the normal form of a term.+    normalise  : Term → TC Term++    -- Get the current context.+    getContext : TC (List (Arg Type))++    -- Extend the current context with a variable of the given type.+    extendContext : ∀ {a} {A : Set a} → Arg Type → TC A → TC A++    -- Set the current context.+    inContext     : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A++    -- Quote a value, returning the corresponding Term.+    quoteTC : ∀ {a} {A : Set a} → A → TC Term++    -- Unquote a Term, returning the corresponding value.+    unquoteTC : ∀ {a} {A : Set a} → Term → TC A++    -- Create a fresh name.+    freshName  : String → TC QName++    -- Declare a new function of the given type. The function must be defined+    -- later using 'defineFun'. Takes an Arg Name to allow declaring instances+    -- and irrelevant functions. The Visibility of the Arg must not be hidden.+    declareDef : Arg QName → Type → TC ⊤++    -- Define a declared function. The function may have been declared using+    -- 'declareDef' or with an explicit type signature in the program.+    defineFun  : QName → List Clause → TC ⊤++    -- Get the type of a defined name. Replaces 'primQNameType'.+    getType    : QName → TC Type++    -- Get the definition of a defined name. Replaces 'primQNameDefinition'.+    getDefinition : QName → TC Definition++  {-# BUILTIN AGDATCM                   TC                 #-}+  {-# BUILTIN AGDATCMRETURN             returnTC           #-}+  {-# BUILTIN AGDATCMBIND               bindTC             #-}+  {-# BUILTIN AGDATCMUNIFY              unify              #-}+  {-# BUILTIN AGDATCMNEWMETA            newMeta            #-}+  {-# BUILTIN AGDATCMTYPEERROR          typeError          #-}+  {-# BUILTIN AGDATCMBLOCKONMETA        blockOnMeta        #-}+  {-# BUILTIN AGDATCMCATCHERROR         catchTC            #-}+  {-# BUILTIN AGDATCMINFERTYPE          inferType          #-}+  {-# BUILTIN AGDATCMCHECKTYPE          checkType          #-}+  {-# BUILTIN AGDATCMNORMALISE          normalise          #-}+  {-# BUILTIN AGDATCMGETCONTEXT         getContext         #-}+  {-# BUILTIN AGDATCMEXTENDCONTEXT      extendContext      #-}+  {-# BUILTIN AGDATCMINCONTEXT          inContext          #-}+  {-# BUILTIN AGDATCMQUOTETERM          quoteTC            #-}+  {-# BUILTIN AGDATCMUNQUOTETERM        unquoteTC          #-}+  {-# BUILTIN AGDATCMFRESHNAME          freshName          #-}+  {-# BUILTIN AGDATCMDECLAREDEF         declareDef         #-}+  {-# BUILTIN AGDATCMDEFINEFUN          defineFun          #-}+  {-# BUILTIN AGDATCMGETTYPE            getType            #-}+  {-# BUILTIN AGDATCMGETDEFINITION      getDefinition      #-}+  ```++* Builtin type for metavariables++  There is a new builtin type for metavariables used by the new reflection+  framework. It is declared as follows and comes with primitive equality,+  ordering and show.++  ```agda+  postulate Meta : Set+  {-# BUILTIN AGDAMETA Meta #-}+  primitive primMetaEquality : Meta → Meta → Bool+  primitive primMetaLess : Meta → Meta → Bool+  primitive primShowMeta : Meta → String+  ```++  There are corresponding new constructors in the `Term` and `Literal`+  data types:++  ```agda+  data Term : Set where+    ...+    meta : Meta → List (Arg Term) → Term++  {-# BUILTIN AGDATERMMETA meta #-}++  data Literal : Set where+    ...+    meta : Meta → Literal++  {-# BUILTIN AGDALITMETA meta #-}+  ```++* Builtin unit type++  The type checker needs to know about the unit type, which you can+  allow by++  ```agda+  record ⊤ : Set where+  {-# BUILTIN UNIT ⊤ #-}+  ```++* Changed behaviour of `unquote`++  The `unquote` primitive now expects a type checking computation+  instead of a pure term. In particular `unquote e` requires++  ```agda+  e : Term → TC ⊤+  ```++  where the argument is the representation of the hole in which the+  result should go. The old `unquote` behaviour (where `unquote`+  expected a `Term` argument) can be recovered by++  ```agda+  OLD: unquote v+  NEW: unquote λ hole → unify hole v+  ```++* Changed behaviour of `unquoteDecl`++  The `unquoteDecl` primitive now expects a type checking computation+  instead of a pure function definition. It is possible to define+  multiple (mutually recursive) functions at the same time. More+  specifically++  ```agda+  unquoteDecl x₁ .. xₙ = m+  ```++  requires `m : TC ⊤` and that `x₁ .. xₙ` are defined (using+  `declareDef` and `defineFun`) after executing `m`. As before `x₁+  .. xₙ : QName` in `m`, but have their declared types outside the+  `unquoteDecl`.++* New primitive `unquoteDef`++  There is a new declaration++  ```agda+  unquoteDef x₁ .. xₙ = m+  ```++  This works exactly as `unquoteDecl` (see above) with the exception+  that `x₁ ..  xₙ` are required to already be declared.++  The main advantage of `unquoteDef` over `unquoteDecl` is that+  `unquoteDef` is allowed in mutual blocks, allowing mutually+  recursion between generated definitions and hand-written+  definitions.++* The reflection interface now exposes the name hint (as a string)+  for variables. As before, the actual binding structure is with+  de Bruijn indices. The String value is just a hint used as a prefix+  to help display the variable. The type `Abs` is a new builtin type used+  for the constructors `Term.lam`, `Term.pi`, `Pattern.var`+  (bultins `AGDATERMLAM`, `AGDATERMPI` and `AGDAPATVAR`).++  ```agda+  data Abs (A : Set) : Set where+    abs : (s : String) (x : A) → Abs A+  {-# BUILTIN ABS    Abs #-}+  {-# BUILTIN ABSABS abs #-}+  ```++  Updated constructor types:++  ```agda+  Term.lam    : Hiding   → Abs Term → Term+  Term.pi     : Arg Type → Abs Type → Term+  Pattern.var : String   → Pattern+  ```++* Reflection-based macros++  Macros are functions of type `t1 → t2 → .. → Term → TC ⊤` that are+  defined in a `macro` block. Macro application is guided by the type+  of the macro, where `Term` arguments desugar into the `quoteTerm`+  syntax and `Name` arguments into the `quote` syntax. Arguments of+  any other type are preserved as-is. The last `Term` argument is the+  hole term given to `unquote` computation (see above).++  For example, the macro application `f u v w` where the macro `f` has+  the type `Term → Name → Bool → Term → TC ⊤` desugars into `unquote+  (f (quoteTerm u) (quote v) w)`++  Limitations:++    - Macros cannot be recursive. This can be worked around by defining the+      recursive function outside the macro block and have the macro call the+      recursive function.++  Silly example:++  ```agda+  macro+    plus-to-times : Term → Term → TC ⊤+    plus-to-times (def (quote _+_) (a ∷ b ∷ [])) hole = unify hole (def (quote _*_) (a ∷ b ∷ []))+    plus-to-times v hole = unify hole v++  thm : (a b : Nat) → plus-to-times (a + b) ≡ a * b+  thm a b = refl+  ```++  Macros are most useful when writing tactics, since they let you hide the+  reflection machinery. For instance, suppose you have a solver++  ```agda+  magic : Type → Term+  ```++  that takes a reflected goal and outputs a proof (when successful). You can+  then define the following macro++  ```agda+  macro+    by-magic : Term → TC ⊤+    by-magic hole =+      bindTC (inferType hole) λ goal →+      unify hole (magic goal)+  ```++  This lets you apply the magic tactic without any syntactic noise at all:++  ```agda+  thm : ¬ P ≡ NP+  thm = by-magic+  ```++### Literals and built-ins++* Overloaded number literals.++  You can now overload natural number literals using the new builtin+  `FROMNAT`:++  ```agda+  {-# BUILTIN FROMNAT fromNat #-}+  ```++  The target of the builtin should be a defined name. Typically you would do+  something like++  ```agda+  record Number (A : Set) : Set where+    field fromNat : Nat → A++  open Number {{...}} public++  {-# BUILTIN FROMNAT fromNat #-}+  ```++  This will cause number literals `n` to be desugared to `fromNat n`+  before type checking.++* Negative number literals.++  Number literals can now be negative. For floating point literals it+  works as expected. For integer literals there is a new builtin+  `FROMNEG` that enables negative integer literals:++  ```agda+  {-# BUILTIN FROMNEG fromNeg #-}+  ```++  This causes negative literals `-n` to be desugared to `fromNeg n`.++* Overloaded string literals.++  String literals can be overladed using the `FROMSTRING` builtin:++  ```agda+  {-# BUILTIN FROMSTRING fromString #-}+  ```++  The will cause string literals `s` to be desugared to `fromString s`+  before type checking.++* Change to builtin integers.++  The `INTEGER` builtin now needs to be bound to a datatype with two+  constructors that should be bound to the new builtins `INTEGERPOS`+  and `INTEGERNEGSUC` as follows:++  ```agda+  data Int : Set where+    pos    : Nat -> Int+    negsuc : Nat -> Int+  {-# BUILTIN INTEGER       Int    #-}+  {-# BUILTIN INTEGERPOS    pos    #-}+  {-# BUILTIN INTEGERNEGSUC negsuc #-}+  ```++  where `negsuc n` represents the integer `-n - 1`. For instance, `-5`+  is represented as `negsuc 4`. All primitive functions on integers+  except `primShowInteger` have been removed, since these can be+  defined without too much trouble on the above representation using+  the corresponding functions on natural numbers.++  The primitives that have been removed are++  ```agda+  primIntegerPlus+  primIntegerMinus+  primIntegerTimes+  primIntegerDiv+  primIntegerMod+  primIntegerEquality+  primIntegerLess+  primIntegerAbs+  primNatToInteger+  ```++* New primitives for strict evaluation++  ```agda+  primitive+    primForce      : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) → (∀ x → B x) → B x+    primForceLemma : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) (f : ∀ x → B x) → primForce x f ≡ f x+  ```++  `primForce x f` evaluates to `f x` if x is in weak head normal form,+  and `primForceLemma x f` evaluates to `refl` in the same+  situation. The following values are considered to be in weak head+  normal form:++    - constructor applications+    - literals+    - lambda abstractions+    - type constructor (data/record types) applications+    - function types+    - Set a++### Modules++* Modules in import directives++  When you use `using`/`hiding`/`renaming` on a name it now+  automatically applies to any module of the same name, unless you+  explicitly mention the module. For instance,++  ```agda+  open M using (D)+  ```++  is equivalent to++  ```agda+  open M using (D; module D)+  ```++  if `M` defines a module `D`. This is most useful for record and data+  types where you always get a module of the same name as the type.++  With this feature there is no longer useful to be able to qualify a+  constructor (or field) by the name of the data type even when it+  differs from the name of the corresponding module. The follow+  (weird) code used to work, but doesn't work anymore:++  ```agda+  module M where+    data D where+      c : D+  open M using (D) renaming (module D to MD)+  foo : D+  foo = D.c+  ```++  If you want to import only the type name and not the module you have to hide+  it explicitly:++  ```agda+  open M using (D) hiding (module D)+  ```++  See discussion on+  Issue [#836](https://github.com/agda/agda/issues/836).++* Private definitions of a module are no longer in scope at the Emacs+  mode top-level.++  The reason for this change is that `.agdai-files` are stripped of+  unused private definitions (which can yield significant performance+  improvements for module-heavy code).++  To test private definitions you can create a hole at the bottom of+  the module, in which private definitions will be visible.++### Records++* New record directives `eta-equality`/`no-eta-equality`++  The keywords `eta-equality`/`no-eta-equality` enable/disable eta+  rules for the (inductive) record type being declared.++  ```agda+  record Σ (A : Set) (B : A -> Set) : Set where+    no-eta-equality+    constructor _,_+    field+      fst : A+      snd : B fst+  open Σ++  -- fail : ∀ {A : Set}{B : A -> Set} → (x : Σ A B) → x ≡ (fst x , snd x)+  -- fail x = refl+  --+  -- x != fst x , snd x of type Σ .A .B+  -- when checking that the expression refl has type x ≡ (fst x , snd x)+  ```++* Building records from modules.++  The `record { <fields> }` syntax is now extended to accept module+  names as well. Fields are thus defined using the corresponding+  definitions from the given module.++  For instance assuming this record type `R` and module `M`:++  ```agda+  record R : Set where+    field+      x : X+      y : Y+      z : Z++  module M where+    x = {! ... !}+    y = {! ... !}++  r : R+  r = record { M; z = {! ... !} }+  ```++  Previously one had to write `record { x = M.x; y = M.y; z = {! ... !} }`.++  More precisely this construction now supports any combination of explicit+  field definitions and applied modules.++  If a field is both given explicitly and available in one of the modules,+  then the explicit one takes precedence.++  If a field is available in more than one module then this is ambiguous+  and therefore rejected. As a consequence the order of assignments does+  not matter.++  The modules can be both applied to arguments and have import directives+  such as `hiding`, `using`, and `renaming`. In particular this construct+  subsumes the record update construction.++  Here is an example of record update:++  ```agda+  -- Record update. Same as: record r { y = {! ... !} }+  r2 : R+  r2 = record { R r; y = {! ... !} }+  ```++  A contrived example showing the use of `hiding`/`renaming`:++  ```agda+  module M2 (a : A) where+    w = {! ... !}+    z = {! ... !}++  r3 : A → R+  r3 a = record { M hiding (y); M2 a renaming (w to y) }+  ```++* Record patterns are now accepted.++  Examples:++  ```agda+  swap : {A B : Set} (p : A × B) → B × A+  swap record{ proj₁ = a; proj₂ = b } = record{ proj₁ = b; proj₂ = a }++  thd3 : ...+  thd3 record{ proj₂ = record { proj₂ = c }} = c+  ```++* Record modules now properly hide all their parameters+  [Issue [#1759](https://github.com/agda/agda/issues/1759)]++  Previously parameters to parent modules were not hidden in the record+  module, resulting in different behaviour between++  ```agda+  module M (A : Set) where+    record R (B : Set) : Set where+  ```++  and++  ```agda+  module M where+    record R (A B : Set) : Set where+  ```++  where in the former case, `A` would be an explicit argument to the module+  `M.R`, but implicit in the latter case. Now `A` is implicit in both cases.++### Instance search++* Performance has been improved, recursive instance search which was+  previously exponential in the depth is now only quadratic.++* Constructors of records and datatypes are not anymore automatically+  considered as instances, you have to do so explicitely, for+  instance:++  ```agda+  -- only [b] is an instance of D+  data D : Set where+    a : D+    instance+      b : D+    c : D++  -- the constructor is now an instance+  record tt : Set where+    instance constructor tt+  ```++* Lambda-bound variables are no longer automatically considered+  instances.++  Lambda-bound variables need to be bound as instance arguments to be+  considered for instance search. For example,++  ```agda+  _==_ : {A : Set} {{_ : Eq A}} → A → A → Bool++  fails : {A : Set} → Eq A → A → Bool+  fails eqA x = x == x++  works : {A : Set} {{_ : Eq A}} → A → Bool+  works x = x == x+  ```++* Let-bound variables are no longer automatically considered+  instances.++  To make a let-bound variable available as an instance it needs to be+  declared with the `instance` keyword, just like top-level+  instances. For example,++  ```agda+  mkEq : {A : Set} → (A → A → Bool) → Eq A++  fails : {A : Set} → (A → A → Bool) → A → Bool+  fails eq x = let eqA = mkEq eq in x == x++  works : {A : Set} → (A → A → Bool) → A → Bool+  works eq x = let instance eqA = mkEq eq in x == x+  ```++* Record fields can be declared instances.++  For example,++  ```agda+  record EqSet : Set₁ where+    field+      set : Set+      instance eq : Eq set+  ```++  This causes the projection function `eq : (E : EqSet) → Eq (set E)`+  to be considered for instance search.++* Instance search can now find arguments in variable types (but such+  candidates can only be lambda-bound variables, they can’t be+  declared as instances)++  ```agda+  module _ {A : Set} (P : A → Set) where++    postulate+      bla : {x : A} {{_ : P x}} → Set → Set++    -- Works, the instance argument is found in the context+    test :  {x : A} {{_ : P x}} → Set → Set+    test B = bla B++    -- Still forbidden, because [P] could be instantiated later to anything+    instance+     postulate+      forbidden : {x : A} → P x+  ```++* Instance search now refuses to solve constraints with unconstrained+  metavariables, since this can lead to non-termination.++  See [Issue [#1532](https://github.com/agda/agda/issues/1523)] for an+  example.++* Top-level instances are now only considered if they are in+  scope. [Issue [#1913](https://github.com/agda/agda/issues/1913)]++  Note that lambda-bound instances need not be in scope.++### Other changes++* Unicode ellipsis character is allowed for the ellipsis token `...`+  in `with` expressions.++* `Prop` is no longer a reserved word.++Type checking+-------------++* Large indices.++  Force constructor arguments no longer count towards the size of a datatype.+  For instance, the definition of equality below is accepted.++  ```agda+  data _≡_ {a} {A : Set a} : A → A → Set where+    refl : ∀ x → x ≡ x+  ```++  This gets rid of the asymmetry that the version of equality which indexes+  only on the second argument could be small, but not the version above which+  indexes on both arguments.++* Detection of datatypes that satisfy K (i.e. sets)++  Agda will now try to detect datatypes that satisfy K when+  `--without-K` is enabled. A datatype satisfies K when it follows+  these three rules:++  - The types of all non-recursive constructor arguments should satisfy K.++  - All recursive constructor arguments should be first-order.++  - The types of all indices should satisfy K.++  For example, the types `Nat`, `List Nat`, and `x ≡ x` (where `x :+  Nat`) are all recognized by Agda as satisfying K.++* New unifier for case splitting++  The unifier used by Agda for case splitting has been completely+  rewritten. The new unifier takes a much more type-directed approach+  in order to avoid the problems in issues+  [#1406](https://github.com/agda/agda/issues/1406),+  [#1408](https://github.com/agda/agda/issues/1408),+  [#1427](https://github.com/agda/agda/issues/1427), and+  [#1435](https://github.com/agda/agda/issues/1435).++  The new unifier also has eta-equality for record types+  built-in. This should avoid unnecessary case splitting on record+  constructors and improve the performance of Agda on code that+  contains deeply nested record patterns (see issues+  [#473](https://github.com/agda/agda/issues/473),+  [#635](https://github.com/agda/agda/issues/635),+  [#1575](https://github.com/agda/agda/issues/1575),+  [#1603](https://github.com/agda/agda/issues/1603),+  [#1613](https://github.com/agda/agda/issues/1613), and+  [#1645](https://github.com/agda/agda/issues/1645)).++  In some cases, the locations of the dot patterns computed by the+  unifier did not correspond to the locations given by the user (see+  Issue [#1608](https://github.com/agda/agda/issues/1608)). This has+  now been fixed by adding an extra step after case splitting that+  checks whether the user-written patterns are compatible with the+  computed ones.++  In some rare cases, the new unifier is still too restrictive when+  `--without-K` is enabled because it cannot generalize over the+  datatype indices (yet). For example, the following code is rejected:++  ```agda+  data Bar : Set₁ where+    bar : Bar+    baz : (A : Set) → Bar++  data Foo : Bar → Set where+    foo : Foo bar++  test : foo ≡ foo → Set₁+  test refl = Set+  ```++* The aggressive behaviour of `with` introduced in 2.4.2.5 has been+  rolled back+  [Issue [#1692](https://github.com/agda/agda/issues/1692)]. With no+  longer abstracts in the types of variables appearing in the+  with-expressions. [Issue [#745](https://github.com/agda/agda/issues/745)]++  This means that the following example no longer works:++  ```agda+  fails : (f : (x : A) → a ≡ x) (b : A) → b ≡ a+  fails f b with a | f b+  fails f b | .b | refl = f b+  ```++  The `with` no longer abstracts the type of `f` over `a`, since `f`+  appears in the second with-expression `f b`. You can use a nested+  `with` to make this example work.++  This example does work again:++  ```agda+  test : ∀{A : Set}{a : A}{f : A → A} (p : f a ≡ a) → f (f a) ≡ a+  test p rewrite p = p+  ```++  After `rewrite p` the goal has changed to `f a ≡ a`, but the type+  of `p` has not been rewritten, thus, the final `p` solves the goal.++  The following, which worked in 2.4.2.5, no longer works:++  ```agda+  fails : (f : (x : A) → a ≡ x) (b : A) → b ≡ a+  fails f b rewrite f b = f b+  ```++  The rewrite with `f b : a ≡ b` is not applied to `f` as+  the latter is part of the rewrite expression `f b`.  Thus,+  the type of `f` remains untouched, and the changed goal+  `b ≡ b` is not solved by `f b`.++* When using `rewrite` on a term `eq` of type `lhs ≡ rhs`, the `lhs`+  is no longer abstracted in `rhs`+  [Issue [#520](https://github.com/agda/agda/issues/520)].  This means+  that++  ```agda+  f pats rewrite eq = body+  ```++  is more than syntactic sugar for++  ```agda+  f pats with lhs | eq+  f pats | _ | refl = body+  ```++  In particular, the following application of `rewrite` is now+  possible++  ```agda+  id : Bool → Bool+  id true  = true+  id false = false++  is-id : ∀ x → x ≡ id x+  is-id true  = refl+  is-id false = refl++  postulate+    P : Bool → Set+    b : Bool+    p : P (id b)++  proof : P b+  proof rewrite is-id b = p+  ```++  Previously, this was desugared to++  ```agda+  proof with b | is-id b+  proof | _ | refl = p+  ```++  which did not type check as `refl` does not have type `b ≡ id b`.+  Now, Agda gets the task of checking `refl : _ ≡ id b` leading to+  instantiation of `_` to `id b`.++Compiler backends+-----------------++* Major Bug Fixes:++  - Function clauses with different arities are now always compiled+    correctly by the GHC/UHC+    backends. (Issue [#727](https://github.com/agda/agda/issues/727))++* Co-patterns++  - The GHC/UHC backends now support co-patterns. (Issues+    [#1567](https://github.com/agda/agda/issues/1567),+    [#1632](https://github.com/agda/agda/issues/1632))++* Optimizations++  - Builtin naturals are now represented as arbitrary-precision+    Integers. See the user manual, section+    "Agda Compilers -> Optimizations" for details.++* GHC Haskell backend (MAlonzo)++  - Pragmas++    Since builtin naturals are compiled to `Integer` you can no longer+    give a `{-# COMPILED_DATA #-}` pragma for `Nat`. The same goes for+    builtin booleans, integers, floats, characters and strings which+    are now hard-wired to appropriate Haskell types.++* UHC compiler backend++  A new backend targeting the Utrecht Haskell Compiler (UHC) is+  available.  It targets the UHC Core language, and it's design is+  inspired by the Epic backend. See the user manual, section "Agda+  Compilers -> UHC Backend" for installation instructions.++  - FFI++    The UHC backend has a FFI to Haskell similar to MAlonzo's. The+    target Haskell code also needs to be compilable using UHC, which+    does not support the Haskell base library version 4.*.++    FFI pragmas for the UHC backend are not checked in any way. If the+    pragmas are wrong, bad things will happen.++  - Imports++    Additional Haskell modules can be brought into scope with the+    `IMPORT_UHC` pragma:++    ```agda+    {-# IMPORT_UHC Data.Char #-}+    ```++    The Haskell modules `UHC.Base` and `UHC.Agda.Builtins` are always in+    scope and don't need to be imported explicitly.++  - Datatypes++    Agda datatypes can be bound to Haskell datatypes as follows:++    Haskell:+    ```haskell+    data HsData a = HsCon1 | HsCon2 (HsData a)+    ```++    Agda:+    ```agda+    data AgdaData (A : Set) : Set where+      AgdaCon1 : AgdaData A+      AgdaCon2 : AgdaData A -> AgdaData A+    {-# COMPILED_DATA_UHC AgdaData HsData HsCon1 HsCon2 #-}+    ```++    The mapping has to cover all constructors of the used Haskell+    datatype, else runtime behavior is undefined!++    There are special reserved names to bind Agda datatypes to certain+    Haskell datatypes. For example, this binds an Agda datatype to+    Haskell's list datatype:++    Agda:+    ```agda+    data AgdaList (A : Set) : Set where+      Nil : AgdaList A+      Cons : A -> AgdaList A -> AgdaList A+    {-# COMPILED_DATA_UHC AgdaList __LIST__ __NIL__ __CONS__ #-}+    ```++    The following "magic" datatypes are available:++    ```+    HS Datatype | Datatype Pragma | HS Constructor | Constructor Pragma+    ()            __UNIT__          ()               __UNIT__+    List          __LIST__          (:)              __CONS__+                                    []               __NIL__+    Bool          __BOOL__          True             __TRUE__+                                    False            __FALSE__+    ```++  - Functions++    Agda postulates can be bound to Haskell functions. Similar as in+    MAlonzo, all arguments of type `Set` need to be dropped before+    calling Haskell functions. An example calling the return function:++    Agda:+    ```agda+    postulate hs-return : {A : Set} -> A -> IO A+    {-# COMPILED_UHC hs-return (\_ -> UHC.Agda.Builtins.primReturn) #-}+    ```++Emacs mode and interaction+--------------------------++* Module contents (`C-c C-o`) now also works for+  records. [See Issue [#1926](https://github.com/agda/agda/issues/1926) ]+  If you have an inferable expression of record type in an interaction+  point, you can invoke `C-c C-o` to see its fields and types.+  Example++  ```agda+  record R : Set where+    field f : A++  test : R → R+  test r = {!r!}  -- C-c C-o here+  ```++* Less aggressive error notification.++  Previously Emacs could jump to the position of an error even if the+  type-checking process was not initiated in the current buffer. Now+  this no longer happens: If the type-checking process was initiated+  in another buffer, then the cursor is moved to the position of the+  error in the buffer visiting the file (if any) and in every window+  displaying the file, but focus should not change from one file to+  another.++  In the cases where focus does change from one file to another, one+  can now use the go-back functionality to return to the previous+  position.++* Removed the `agda-include-dirs` customization parameter.++  Use `agda-program-args` with `-iDIR` or `-lLIB` instead, or add+  libraries to `~/.agda/defaults`+  (`C:/Users/USERNAME/AppData/Roaming/agda/defaults` or similar on+  Windows). See Library management, above, for more information.++Tools+-----++### LaTeX-backend++* The default font has been changed to XITS (which is part of TeX Live):++    http://www.ctan.org/tex-archive/fonts/xits/++  This font is more complete with respect to Unicode.++### agda-ghc-names++* New tool: The command++  ```+  agda-ghc-names fixprof <compile-dir> <ProgName>.prof+  ```++  converts `*.prof` files obtained from profiling runs of+  MAlonzo-compiled code to `*.agdaIdents.prof`, with the original Agda+  identifiers replacing the MAlonzo-generated Haskell identifiers.++  For usage and more details, see `src/agda-ghc-names/README.txt`.++Highlighting and textual backends+---------------------------------++* Names in import directives are now highlighted and are clickable.+  [Issue [#1714](https://github.com/agda/agda/issues/1714)] This leads+  also to nicer printing in the LaTeX and html backends.++Fixed issues+------------++See+[bug tracker (milestone 2.5.1)](https://github.com/agda/agda/issues?q=milestone%3A2.5.1+is%3Aclosed)
+ doc/release-notes/2.5.2.md view
@@ -0,0 +1,1184 @@+Release notes for Agda version 2.5.2+====================================++Installation and infrastructure+-------------------------------++* Modular support for literate programming++  Literate programming support has been moved out of the lexer and into the+  `Agda.Syntax.Parser.Literate` module.++  Files ending in `.lagda` are still interpreted as literate TeX.+  The extension `.lagda.tex` may now also be used for literate TeX files.++  Support for more literate code formats and extensions can be added+  modularly.++  By default, `.lagda.*` files are opened in the Emacs mode+  corresponding to their last extension.  One may switch to and from+  Agda mode manually.++* reStructuredText++  Literate Agda code can now be written in reStructuredText format, using+  the `.lagda.rst` extension.++  As a general rule, Agda will parse code following a line ending in `::`,+  as long as that line does not start with `..`. The module name must+  match the path of the file in the documentation, and must be given+  explicitly.  Several files have been converted already, for instance:++  - `language/mixfix-operators.lagda.rst`+  - `tools/compilers.lagda.rst`++  Note that:++  - Code blocks inside an rST comment block will be type-checked by Agda,+    but not rendered in the documentation.+  - Code blocks delimited by `.. code-block:: agda` will be rendered in+    the final documenation, but not type-checked by Agda.+  - All lines inside a codeblock must be further indented than the first line+    of the code block.+  - Indentation must be consistent between code blocks. In other+    words, the file as a whole must be a valid Agda file if all the+    literate text is replaced by white space.++* Documentation testing++  All documentation files in the `doc/user-manual` directory that end+  in `.lagda.rst` can be typechecked by running `make+  user-manual-test`, and also as part of the general test suite.++* Support installation through Stack++  The Agda sources now also include a configuration for the stack install tool+  (tested through continuous integration).++  It should hence be possible to repeatably build any future Agda version+  (including unreleased commits) from source by checking out that version and+  running `stack install` from the checkout directory.+  By using repeatable builds, this should keep selecting the same dependencies+  in the face of new releases on Hackage.++  For further motivation, see+  Issue [#2005](https://github.com/agda/agda/issues/2005).++* Removed the `--test` command-line option++  This option ran the internal test-suite. This test-suite was+  implemented using Cabal supports for+  test-suites. [Issue [#2083](https://github.com/agda/agda/issues/2083)].++* The `--no-default-libraries` flag has been split into two flags+  [Issue [#1937](https://github.com/agda/agda/issues/1937)]++  - `--no-default-libraries`: Ignore the defaults file but still look for local+    `.agda-lib` files+  - `--no-libraries`: Don't use any `.agda-lib` files (the previous behaviour+    of `--no-default-libraries`).++* If `agda` was built inside `git` repository, then the `--version` flag+  will display the hash of the commit used, and whether the tree was+  `-dirty` (i.e. there were uncommited changes in the working directory).+  Otherwise, only the version number is shown.++Language+--------++* Dot patterns are now optional++  Consider the following program++  ```agda+  data Vec (A : Set) : Nat → Set where+    []   : Vec A zero+    cons : ∀ n → A → Vec A n → Vec A (suc n)++  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n+  vmap .zero    f []            = []+  vmap .(suc m) f (cons m x xs) = cons m (f x) (vmap m f xs)+  ```++  If we don't care about the dot patterns they can (and could previously) be+  replaced by wildcards:++  ```agda+  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n+  vmap _ f []            = []+  vmap _ f (cons m x xs) = cons m (f x) (vmap m f xs)+  ```++  Now it is also allowed to give a variable pattern in place of the dot+  pattern. In this case the variable will be bound to the value of the dot+  pattern. For our example:++  ```agda+  vmap : ∀ {A B} n → (A → B) → Vec A n → Vec B n+  vmap n f []            = []+  vmap n f (cons m x xs) = cons m (f x) (vmap m f xs)+  ```++  In the first clause `n` reduces to `zero` and in the second clause+  `n` reduces to `suc m`.++* Module parameters can now be refined by pattern matching++  Previously, pattern matches that would refine a variable outside the+  current left-hand side was disallowed. For instance, the following+  would give an error, since matching on the vector would+  instantiate `n`.++  ```agda+  module _ {A : Set} {n : Nat} where+    f : Vec A n → Vec A n+    f []       = []+    f (x ∷ xs) = x ∷ xs+  ```++  Now this is no longer disallowed. Instead `n` is bound to the+  appropriate value in each clause.++* With-abstraction now abstracts also in module parameters++  The change that allows pattern matching to refine module parameters also+  allows with-abstraction to abstract in them. For instance,++  ```agda+  module _ (n : Nat) (xs : Vec Nat (n + n)) where+    f : Nat+    f with n + n+    f    | nn = ? -- xs : Vec Nat nn+  ```++  Note: Any function argument or lambda-bound variable bound outside a given+  function counts as a module parameter.++  To prevent abstraction in a parameter you can hide it inside a definition. In+  the above example,++  ```agda+  module _ (n : Nat) (xs : Vec Nat (n + n)) where++    ys : Vec Nat (n + n)+    ys = xs++    f : Nat+    f with n + n+    f    | nn = ? -- xs : Vec Nat nn, ys : Vec Nat (n + n)+  ```++* As-patterns [Issue [#78](https://github.com/agda/agda/issues/78)].++  As-patterns (`@`-patterns) are finally working and can be used to name a+  pattern. The name has the same scope as normal pattern variables (i.e. the+  right-hand side, where clause, and dot patterns). The name reduces to the+  value of the named pattern. For example::++  ```agda+  module _ {A : Set} (_<_ : A → A → Bool) where+    merge : List A → List A → List A+    merge xs [] = xs+    merge [] ys = ys+    merge xs@(x ∷ xs₁) ys@(y ∷ ys₁) =+      if x < y then x ∷ merge xs₁ ys+               else y ∷ merge xs ys₁+  ```++* Idiom brackets.++  There is new syntactic sugar for idiom brackets:++    `(| e a1 .. an |)` expands to++    `pure e <*> a1 <*> .. <*> an`++  The desugaring takes place before scope checking and only requires names+  `pure` and `_<*>_` in scope. Idiom brackets work well with operators, for+  instance++    `(| if a then b else c |)` desugars to++    `pure if_then_else_ <*> a <*> b <*> c`++  Limitations:++    - The top-level application inside idiom brackets cannot include+      implicit applications, so `(| foo {x = e} a b |)` is illegal. In+      the case `e` is pure you can write `(| (foo {x = e}) a b |)`+      which desugars to++        `pure (foo {x = e}) <*> a <*> b`++    - Binding syntax and operator sections cannot appear immediately inside+      idiom brackets.++* Layout for pattern matching lambdas.++  You can now write pattern matching lambdas using the syntax++  ```agda+  λ where false → true+          true  → false+  ```++  avoiding the need for explicit curly braces and semicolons.++* Overloaded projections+  [Issue [#1944](https://github.com/agda/agda/issues/1944)].++  Ambiguous projections are no longer a scope error.  Instead they get+  resolved based on the type of the record value they are+  eliminating.  This corresponds to constructors, which can be+  overloaded and get disambiguated based on the type they are+  introducing.  Example:++  ```agda+  module _ (A : Set) (a : A) where++  record R B : Set where+    field f : B+  open R public++  record S B : Set where+    field f : B+  open S public+  ```++  Exporting `f` twice from both `R` and `S` is now allowed.  Then,++  ```agda+  r : R A+  f r = a++  s : S A+  f s = f r+  ```++  disambiguates to:++  ```agda+  r : R A+  R.f r = a++  s : S A+  S.f s = R.f r+  ```++  If the type of the projection is known, it can also be disambiguated+  unapplied.++  ```agda+  unapplied : R A -> A+  unapplied = f+  ```++* Postfix projections+  [Issue [#1963](https://github.com/agda/agda/issues/1963)].++  Agda now supports a postfix syntax for projection application.+  This style is more in harmony with copatterns.  For example:++  ```agda+  record Stream (A : Set) : Set where+    coinductive+    field head : A+          tail : Stream A++  open Stream++  repeat : ∀{A} (a : A) → Stream A+  repeat a .head = a+  repeat a .tail = repeat a++  zipWith : ∀{A B C} (f : A → B → C) (s : Stream A) (t : Stream B) → Stream C+  zipWith f s t .head = f (s .head) (t .head)+  zipWith f s t .tail = zipWith f (s .tail) (t .tail)++  module Fib (Nat : Set) (zero one : Nat) (plus : Nat → Nat → Nat) where++    {-# TERMINATING #-}+    fib : Stream Nat+    fib .head = zero+    fib .tail .head = one+    fib .tail .tail = zipWith plus fib (fib .tail)+  ```++  The thing we eliminate with projection now is visibly the head,+  i.e., the left-most expression of the sequence (e.g. `repeat` in+  `repeat a .tail`).++  The syntax overlaps with dot patterns, but for type correct left+  hand sides there is no confusion: Dot patterns eliminate function+  types, while (postfix) projection patterns eliminate record types.++  By default, Agda prints system-generated projections (such as by+  eta-expansion or case splitting) prefix.  This can be changed with+  the new option:++  ```agda+  {-# OPTIONS --postfix-projections #-}+  ```++  Result splitting in extended lambdas (aka pattern lambdas) always+  produces postfix projections, as prefix projection pattern do not+  work here: a prefix projection needs to go left of the head, but the+  head is omitted in extended lambdas.++  ```agda+  dup : ∀{A : Set}(a : A) → A × A+  dup = λ{ a → ? }+  ```++  Result splitting (`C-c C-c RET`) here will yield:++  ```agda+  dup = λ{ a .proj₁ → ? ; a .proj₂ → ? }+  ```++* Projection parameters+  [Issue [#1954](https://github.com/agda/agda/issues/1954)].++  When copying a module, projection parameters will now stay hidden+  arguments, even if the module parameters are visible.+  This matches the situation we had for constructors since long.+  Example:++  ```agda+  module P (A : Set) where+    record R : Set where+      field f : A++  open module Q A = P A+  ```++  Parameter `A` is now hidden in `R.f`:++  ```agda+  test : ∀{A} → R A → A+  test r = R.f r+  ```++  Note that a module parameter that corresponds to the record value+  argument of a projection will not be hidden.++  ```agda+  module M (A : Set) (r : R A) where+    open R A r public++  test' : ∀{A} → R A → A+  test' r = M.f r+  ```++* Eager insertion of implicit arguments+  [Issue [#2001](https://github.com/agda/agda/issues/2001)]++  Implicit arguments are now (again) eagerly inserted in left-hand sides. The+  previous behaviour of inserting implicits for where blocks, but not+  right-hand sides was not type safe.++* Module applications can now be eta expanded/contracted without+  changing their behaviour+  [Issue #[1985](https://github.com/agda/agda/issues/1985)]++  Previously definitions exported using `open public` got the+  incorrect type for underapplied module applications.++  Example:++  ```agda+  module A where+    postulate A : Set++  module B (X : Set) where+    open A public++  module C₁ = B+  module C₂ (X : Set) = B X+  ```++  Here both `C₁.A` and `C₂.A` have type `(X : Set) → Set`.++* Polarity pragmas.++  Polarity pragmas can be attached to postulates. The polarities express+  how the postulate's arguments are used. The following polarities+  are available:++  `_`:  Unused.++  `++`: Strictly positive.++  `+`:  Positive.++  `-`:  Negative.++  `*`:  Unknown/mixed.++  Polarity pragmas have the form++  ```+  {-# POLARITY name <zero or more polarities> #-}+  ```++  and can be given wherever fixity declarations can be given. The+  listed polarities apply to the given postulate's arguments+  (explicit/implicit/instance), from left to right. Polarities+  currently cannot be given for module parameters. If the postulate+  takes n arguments (excluding module parameters), then the number of+  polarities given must be between 0 and n (inclusive).++  Polarity pragmas make it possible to use postulated type formers in+  recursive types in the following way:++  ```agda+  postulate+    ∥_∥ : Set → Set++  {-# POLARITY ∥_∥ ++ #-}++  data D : Set where+    c : ∥ D ∥ → D+  ```++  Note that one can use postulates that may seem benign, together with+  polarity pragmas, to prove that the empty type is inhabited:++  ```agda+  postulate+    _⇒_    : Set → Set → Set+    lambda : {A B : Set} → (A → B) → A ⇒ B+    apply  : {A B : Set} → A ⇒ B → A → B++  {-# POLARITY _⇒_ ++ #-}++  data ⊥ : Set where++  data D : Set where+    c : D ⇒ ⊥ → D++  not-inhabited : D → ⊥+  not-inhabited (c f) = apply f (c f)++  inhabited : D+  inhabited = c (lambda not-inhabited)++  bad : ⊥+  bad = not-inhabited inhabited+  ```++  Polarity pragmas are not allowed in safe mode.++* Declarations in a `where`-block are now+  private. [Issue [#2101](https://github.com/agda/agda/issues/2101)]+  This means that++  ```agda+  f ps = body where+    decls+  ```++  is now equivalent to++  ```agda+  f ps = body where+    private+      decls+  ```++  This changes little, since the `decls` were anyway not in scope+  outside `body`.  However, it makes a difference for abstract+  definitions, because private type signatures can see through+  abstract definitions.  Consider:++  ```agda+  record Wrap (A : Set) : Set where+    field unwrap : A++  postulate+    P : ∀{A : Set} → A → Set++  abstract++    unnamedWhere : (A : Set) → Set+    unnamedWhere A = A+      where  -- the following definitions are private!+      B : Set+      B = Wrap A++      postulate+        b : B+        test : P (Wrap.unwrap b)  -- succeeds+  ```++  The `abstract` is inherited in `where`-blocks from the parent (here:+  function `unnamedWhere`).  Thus, the definition of `B` is opaque and+  the type equation `B = Wrap A` cannot be used to check type+  signatures, not even of abstract definitions.  Thus, checking the+  type  `P (Wrap.unwrap b)` would fail.  However, if `test` is+  private, abstract definitions are translucent in its type, and+  checking succeeds.  With the implemented change, all+  `where`-definitions are private, in this case `B`, `b`, and `test`,+  and the example succeeds.++  Nothing changes for the named forms of `where`,++  ```agda+  module M where+  module _ where+  ```++  For instance, this still fails:++  ```agda+  abstract++    unnamedWhere : (A : Set) → Set+    unnamedWhere A = A+      module M where+      B : Set+      B = Wrap A++      postulate+        b : B+        test : P (Wrap.unwrap b)  -- fails+  ```++* Private anonymous modules now work as expected+  [Issue [#2199](https://github.com/agda/agda/issues/2199)]++  Previously the `private` was ignored for anonymous modules causing+  its definitions to be visible outside the module containing the+  anonymous module.  This is no longer the case. For instance,++  ```agda+  module M where+    private+      module _ (A : Set) where+        Id : Set+        Id = A++    foo : Set → Set+    foo = Id++  open M++  bar : Set → Set+  bar = Id -- Id is no longer in scope here+  ```++* Pattern synonyms are now expanded on left hand sides of DISPLAY+  pragmas [Issue [#2132](https://github.com/agda/agda/issues/2132)].+  Example:++  ```agda+  data D : Set where+    C c : D+    g : D → D++  pattern C′ = C++  {-# DISPLAY C′ = C′ #-}+  {-# DISPLAY g C′ = c #-}+  ```++  This now behaves as:++  ```agda+  {-# DISPLAY C = C′ #-}+  {-# DISPLAY g C = c #-}+  ```++  Expected error for++  ```agda+  test : C ≡ g C+  test = refl+  ```++  is thus:++  ```+  C′ != c of type D+  ```++* The built-in floats have new semantics to fix inconsistencies+  and to improve cross-platform portability.++  - Float equality has been split into two primitives.+    ``primFloatEquality`` is designed to establish+    decidable propositional equality while+    ``primFloatNumericalEquality`` is intended for numerical+    computations. They behave as follows:++    ```+    primFloatEquality NaN NaN = True+    primFloatEquality 0.0 -0.0 = False++    primFloatNumericalEquality NaN NaN = False+    primFloatNumericalEquality 0.0 -0.0 = True+    ```++    This change fixes an inconsistency, see [Issue [#2169](https://github.com/agda/agda/issues/2169)].+    For further detail see the [user manual](http://agda.readthedocs.io/en/v2.5.2/language/built-ins.html#floats).++  - Floats now have only one `NaN` value. This is necessary+    for proper Float support in the JavaScript backend,+    as JavaScript (and some other platforms) only support+    one `NaN` value.++  - The primitive function `primFloatLess` was renamed+    `primFloatNumericalLess`.++* Added new primitives to built-in floats:++  - `primFloatNegate : Float → Float`+    [Issue [#2194](https://github.com/agda/agda/issues/2194)]++  - Trigonometric primitives+    [Issue [#2200](https://github.com/agda/agda/issues/2200)]:++    ```agda+    primCos   : Float → Float+    primTan   : Float → Float+    primASin  : Float → Float+    primACos  : Float → Float+    primATan  : Float → Float+    primATan2 : Float → Float → Float+    ```++* Anonymous declarations+  [Issue [#1465](https://github.com/agda/agda/issues/1465)].++  A module can contain an arbitrary number of declarations+  named `_` which will scoped-checked and type-checked but+  won't be made available in the scope (nor exported). They+  cannot introduce arguments on the LHS (but one can use+  lambda-abstractions on the RHS) and they cannot be defined+  by recursion.++  ```agda+  _ : Set → Set+  _ = λ x → x+  ```++### Rewriting++* The REWRITE pragma can now handle several names.  E.g.:+  ```agda+  {-# REWRITE eq1 eq2 #-}+  ```++### Reflection++* You can now use macros in reflected terms+  [Issue [#2130](https://github.com/agda/agda/issues/2130)].++  For instance, given a macro++  ```agda+  macro+    some-tactic : Term → TC ⊤+    some-tactic = ...+  ```++  the term `def (quote some-tactic) []` represents a call to the+  macro. This makes it a lot easier to compose tactics.++* The reflection machinery now uses normalisation less often:++  * Macros no longer normalise the (automatically quoted) term+    arguments.++  * The TC primitives `inferType`, `checkType` and `quoteTC` no longer+    normalise their arguments.++  * The following deprecated constructions may also have been changed:+    `quoteGoal`, `quoteTerm`, `quoteContext` and `tactic`.++* New TC primitive: `withNormalisation`.++  To recover the old normalising behaviour of `inferType`, `checkType`,+  `quoteTC` and `getContext`, you can wrap them inside a call to+  `withNormalisation true`:++  ```agda+    withNormalisation : ∀ {a} {A : Set a} → Bool → TC A → TC A+  ```++* New TC primitive: `reduce`.++  ```agda+  reduce : Term → TC Term+  ```++  Reduces its argument to weak head normal form.++* Added new TC primitive: `isMacro`+  [Issue [#2182](https://github.com/agda/agda/issues/2182)]++  ```agda+  isMacro : Name → TC Bool+  ```++  Returns `true` if the name refers to a macro, otherwise `false`.++* The `record-type` constructor now has an extra argument containing+  information about the record type's fields:+  ```agda+    data Definition : Set where+      …+      record-type : (c : Name) (fs : List (Arg Name)) → Definition+      …+  ```++Type checking+-------------++* Files with open metas can be imported now+  [Issue [#964](https://github.com/agda/agda/issues/964)].  This+  should make simultaneous interactive development on several modules+  more pleasant.++  Requires option: `--allow-unsolved-metas`++  Internally, before serialization, open metas are turned into postulates named++  ```+    unsolved#meta.<nnn>+  ```++  where `<nnn>` is the internal meta variable number.++* The performance of the compile-time evaluator has been greatly improved.++  - Fixed a memory leak in evaluator+    (Issue [#2147](https://github.com/agda/agda/issues/2147)).++  - Reduction speed improved by an order of magnitude and is now+    comparable to the performance of GHCi. Still call-by-name though.++* The detection of types that satisfy K added in Agda 2.5.1 has been+  rolled back (see+  Issue [#2003](https://github.com/agda/agda/issues/2003)).++* Eta-equality for record types is now only on after the positivity+  checker has confirmed it is safe to have it.  Eta-equality for+  unguarded inductive records previously lead to looping of the type+  checker.+  [See Issue [#2197](https://github.com/agda/agda/issues/2197)]++  ```agda+  record R : Set where+    inductive+    field r : R++    loops : R+    loops = ?+  ```++  As a consequence of this change, the following example does not+  type-check any more:++  ```agda+  mutual+    record ⊤ : Set where++    test : ∀ {x y : ⊤} → x ≡ y+    test = refl+  ```++  It fails because the positivity checker is only run after the mutual+  block, thus, eta-equality for `⊤` is not available when checking+  test.++  One can declare eta-equality explicitly, though, to make this+  example work.++  ```agda+  mutual+    record ⊤ : Set where+      eta-equality++    test : ∀ {x y : ⊤} → x ≡ y+    test = refl+  ```++* Records with instance fields are now eta expanded before instance search.++  For instance, assuming `Eq` and `Ord` with boolean functions `_==_` and `_<_`+  respectively,++  ```agda+    record EqAndOrd (A : Set) : Set where+      field {{eq}}  : Eq A+            {{ord}} : Ord A+++    leq : {A : Set} {{_ : EqAndOrd A}} → A → A → Bool+    leq x y = x == y || x < y+  ```++  Here the `EqAndOrd` record is automatically unpacked before instance search,+  revealing the component `Eq` and `Ord` instances.++  This can be used to simulate superclass dependencies.++* Overlappable record instance fields.++  Instance fields in records can be marked as overlappable using the new+  `overlap` keyword:++  ```agda+    record Ord (A : Set) : Set where+      field+        _<_ : A → A → Bool+        overlap {{eqA}} : Eq A+  ```++  When instance search finds multiple candidates for a given instance goal and+  they are **all** overlappable it will pick the left-most candidate instead of+  refusing to solve the instance goal.++  This can be use to solve the problem arising from shared "superclass"+  dependencies. For instance, if you have, in addition to `Ord` above, a `Num`+  record that also has an `Eq` field and want to write a function requiring+  both `Ord` and `Num`, any `Eq` constraint will be solved by the `Eq` instance+  from whichever argument that comes first.++  ```agda+    record Num (A : Set) : Set where+      field+        fromNat : Nat → A+        overlap {{eqA}} : Eq A++    lessOrEqualFive : {A : Set} {{NumA : Num A}} {{OrdA : Ord A}} → A → Bool+    lessOrEqualFive x = x == fromNat 5 || x < fromNat 5+  ```++  In this example the call to `_==_` will use the `eqA` field from `NumA`+  rather than the one from `OrdA`. Note that these may well be different.++* Instance fields can be left out of copattern matches+  [Issue [#2288](https://github.com/agda/agda/issues/2288)]++  Missing cases for instance fields (marked `{{` `}}`) in copattern matches+  will be solved using instance search. This makes defining instances with+  superclass fields much nicer. For instance, we can define `Nat` instances of+  `Eq`, `Ord` and `Num` from above as follows:++  ```agda+    instance+      EqNat : Eq Nat+      _==_ {{EqNat}} n m = eqNat n m++      OrdNat : Ord Nat+      _<_ {{OrdNat}} n m = lessNat n m++      NumNat : Num Nat+      fromNat {{NumNat}} n = n+  ```++  The `eqA` fields of `Ord` and `Num` are filled in using instance search (with+  `EqNat` in this case).++* Limited instance search depth+  [Issue [#2269](https://github.com/agda/agda/issues/2269)]++  To prevent instance search from looping on bad instances+  (see [Issue #1743](https://github.com/agda/agda/issues/1743)) the search+  depth of instance search is now limited. The maximum depth can be set with+  the `--instance-search-depth` flag and the default value is `500`.++Emacs mode+----------++* New command `C-u C-u C-c C-n`: Use `show` to display the result of+  normalisation.++  Calling `C-u C-u C-c C-n` on an expression `e` (in a hole or at top level)+  normalises `show e` and prints the resulting string, or an error message if+  the expression does not normalise to a literal string.++  This is useful when working with complex data structures for which you have+  defined a nice `Show` instance.++  Note that the name `show` is hardwired into the command.++* Changed feature: Interactively split result.++  Make-case (`C-c C-c`) with no variables will now *either* introduce+  function arguments *or* do a copattern split (or fail).++  This is as before:++  ```agda+  test : {A B : Set} (a : A) (b : B) → A × B+  test a b = ?++  -- expected:+  -- proj₁ (test a b) = {!!}+  -- proj₂ (test a b) = {!!}++  testFun : {A B : Set} (a : A) (b : B) → A × B+  testFun = ?++  -- expected:+  -- testFun a b = {!!}+  ```++  This is has changed:++  ```agda+  record FunRec A : Set where+    field funField : A → A+  open FunRec++  testFunRec : ∀{A} → FunRec A+  testFunRec = ?++  -- expected (since 2016-05-03):+  -- funField testFunRec = {!!}++  -- used to be:+  -- funField testFunRec x = {!!}+  ```++* Changed feature: Split on hidden variables.++  Make-case (`C-c C-c`) will no longer split on the given hidden+  variables, but only make them visible. (Splitting can then be+  performed in a second go.)++  ```agda+  test : ∀{N M : Nat} → Nat → Nat → Nat+  test N M = {!.N N .M!}+  ```++  Invoking splitting will result in:++  ```agda+  test {N} {M} zero M₁ = ?+  test {N} {M} (suc N₁) M₁ = ?+  ```++  The hidden `.N` and `.M` have been brought into scope, the+  visible `N` has been split upon.++* Non-fatal errors/warnings.++  Non-fatal errors and warnings are now displayed in the info buffer+  and do not interrupt the typechecking of the file.++  Currently termination errors, unsolved metavariables, unsolved+  constraints, positivity errors, deprecated BUILTINs, and empty+  REWRITING pragmas are non-fatal errors.++* Highlighting for positivity check failures++  Negative occurences of a datatype in its definition are now+  highlighted in a way similar to termination errors.++* The abbrev for codata was replaced by an abbrev for code+  environments.++  If you type `c C-x '` (on a suitably standard setup), then Emacs+  will insert the following text:++  ```agda+  \begin{code}<newline>  <cursor><newline>\end{code}<newline>.+  ```++* The LaTeX backend can now be invoked from the Emacs mode.++  Using the compilation command (`C-c C-x C-c`).++  The flag `--latex-dir` can be used to set the output directory (by+  default: `latex`). Note that if this directory is a relative path,+  then it is interpreted relative to the "project root". (When the+  LaTeX backend is invoked from the command line the path is+  interpreted relative to the current working directory.) Example: If+  the module `A.B.C` is located in the file `/foo/A/B/C.agda`, then+  the project root is `/foo/`, and the default output directory is+  `/foo/latex/`.++* The compilation command (`C-c C-x C-c`) now by default asks for a+  backend.++  To avoid this question, set the customisation variable+  `agda2-backend` to an appropriate value.++* The command `agda2-measure-load-time` no longer "touches" the file,+  and the optional argument `DONT-TOUCH` has been removed.++* New command `C-u (C-u) C-c C-s`: Simplify or normalise the solution `C-c C-s` produces++  When writing examples, it is nice to have the hole filled in with+  a normalised version of the solution. Calling `C-c C-s` on++  ```agda+  _ : reverse (0 ∷ 1 ∷ []) ≡ ?+  _ = refl+  ```++  used to yield the non informative `reverse (0 ∷ 1 ∷ [])` when we would+  have hopped to get `1 ∷ 0 ∷ []` instead. We can now control finely the+  degree to which the solution is simplified.++* Changed feature: Solving the hole at point++  Calling `C-c C-s` inside a specific goal does not solve *all* the goals+  already instantiated internally anymore: it only solves the one at hand+  (if possible).++* New bindings: All the blackboard bold letters are now available+  [Pull Request [#2305](https://github.com/agda/agda/pull/2305)]++  The Agda input method only bound a handful of the blackboard bold letters+  but programmers were actually using more than these. They are now all+  available: lowercase and uppercase. Some previous bindings had to be+  modified for consistency. The naming scheme is as follows:++  * `\bx` for lowercase blackboard bold+  * `\bX` for uppercase blackboard bold+  * `\bGx` for lowercase greek blackboard bold (similar to `\Gx` for+    greeks)+  * `\bGX` for uppercase greek blackboard bold (similar to `\GX` for+    uppercase greeks)++* Replaced binding for go back++  Use `M-,` (instead of `M-*`) for go back in Emacs ≥ 25.1 (and+  continue using `M-*` with previous versions of Emacs).++Compiler backends+-----------------++* JS compiler backend++  The JavaScript backend has been (partially) rewritten. The+  JavaScript backend now supports most Agda features, notably+  copatterns can now be compiled to JavaScript. Furthermore, the+  existing optimizations from the other backends now apply to the+  JavaScript backend as well.++* GHC, JS and UHC compiler backends++  Added new primitives to built-in floats+  [Issues [#2194](https://github.com/agda/agda/issues/2194) and+  [#2200](https://github.com/agda/agda/issues/2200)]:++  ```agda+  primFloatNegate : Float → Float+  primCos         : Float → Float+  primTan         : Float → Float+  primASin        : Float → Float+  primACos        : Float → Float+  primATan        : Float → Float+  primATan2       : Float → Float → Float+  ```++LaTeX backend+-------------++* Code blocks are now (by default) surrounded by vertical space.+  [Issue [#2198](https://github.com/agda/agda/issues/2198)]++  Use `\AgdaNoSpaceAroundCode{}` to avoid this vertical space, and+  `\AgdaSpaceAroundCode{}` to reenable it.++  Note that, if `\AgdaNoSpaceAroundCode{}` is used, then empty lines+  before or after a code block will not necessarily lead to empty+  lines in the generated document. However, empty lines *inside* the+  code block do (by default) lead to empty lines in the output.++  If you prefer the previous behaviour, then you can use the `agda.sty`+  file that came with the previous version of Agda.++* `\AgdaHide{...}` now eats trailing spaces (using `\ignorespaces`).++* New environments: `AgdaAlign`, `AgdaSuppressSpace` and+  `AgdaMultiCode`.++  Sometimes one might want to break up a code block into multiple+  pieces, but keep code in different blocks aligned with respect to+  each other. Then one can use the `AgdaAlign` environment. Example+  usage:+  ```latex+    \begin{AgdaAlign}+    \begin{code}+      code+        code  (more code)+    \end{code}+    Explanation...+    \begin{code}+      aligned with "code"+        code  (aligned with (more code))+    \end{code}+    \end{AgdaAlign}+  ```+  Note that `AgdaAlign` environments should not be nested.++  Sometimes one might also want to hide code in the middle of a code+  block. This can be accomplished in the following way:+  ```latex+    \begin{AgdaAlign}+    \begin{code}+      visible+    \end{code}+    \AgdaHide{+    \begin{code}+      hidden+    \end{code}}+    \begin{code}+      visible+    \end{code}+    \end{AgdaAlign}+  ```+  However, the result may be ugly: extra space is perhaps inserted+  around the code blocks.++  The `AgdaSuppressSpace` environment ensures that extra space is only+  inserted before the first code block, and after the last one (but+  not if `\AgdaNoSpaceAroundCode{}` is used).++  The environment takes one argument, the number of wrapped code+  blocks (excluding hidden ones). Example usage:+  ```latex+    \begin{AgdaAlign}+    \begin{code}+      code+        more code+    \end{code}+    Explanation...+    \begin{AgdaSuppressSpace}{2}+    \begin{code}+      aligned with "code"+        aligned with "more code"+    \end{code}+    \AgdaHide{+    \begin{code}+      hidden code+    \end{code}}+    \begin{code}+        also aligned with "more code"+    \end{code}+    \end{AgdaSuppressSpace}+    \end{AgdaAlign}+  ```++  Note that `AgdaSuppressSpace` environments should not be nested.++  There is also a combined environment, `AgdaMultiCode`, that combines+  the effects of `AgdaAlign` and `AgdaSuppressSpace`.++Tools+-----++### agda-ghc-names++The `agda-ghc-names` now has its own repository at++  https://github.com/agda/agda-ghc-names++and is no longer distributed with Agda.
+ doc/release-notes/2.5.3.md view
@@ -0,0 +1,822 @@+Release notes for Agda version 2.5.3+====================================++Installation and infrastructure+-------------------------------++* Added support for GHC 8.0.2 and 8.2.1.++* Removed support for GHC 7.6.3.++* Markdown support for literate Agda+  \[PR [#2357](https://github.com/agda/agda/pull/2357)].++  Files ending in `.lagda.md` will be parsed as literate Markdown files.++  + Code blocks start with  ```` ``` ```` or ```` ```agda ```` in its own line, and end with+    ```` ``` ````, also in its own line.+  + Code blocks which should be type-checked by Agda but should not be visible+    when the Markdown is rendered may be enclosed in HTML comment delimiters+    (`<!--`  and `-->`).+  + Code blocks which should be ignored by Agda, but rendered in the final+    document may be indented by four spaces.+  + Note that inline code fragments are not supported due to the difficulty of+    interpreting their indentation level with respect to the rest of the file.++Language+--------++### Pattern matching++* Dot patterns.++  The dot in front of an inaccessible pattern can now be skipped if the+  pattern consists entirely of constructors or literals. For example:+  ```agda+    open import Agda.Builtin.Bool++    data D : Bool → Set where+      c : D true++    f : (x : Bool) → D x → Bool+    f true c = true++  ```+  Before this change, you had to write `f .true c = true`.++* With-clause patterns can be replaced by _+  [Issue [#2363](https://github.com/agda/agda/issues/2363)].+  Example:+  ```agda+    test : Nat → Set+    test zero    with zero+    test _       | _ = Nat+    test (suc x) with zero+    test _       | _ = Nat+  ```+  We do not have to spell out the pattern of the parent clause+  (`zero` / `suc x`) in the with-clause if we do not need the+  pattern variables.  Note that `x` is not in scope in the+  with-clause!++  A more elaborate example, which cannot be reduced to+  an ellipsis `...`:+  ```agda+    record R : Set where+      coinductive -- disallow matching+      field f : Bool+            n : Nat++    data P (r : R) : Nat → Set where+      fTrue  : R.f r ≡ true → P r zero+      nSuc   : P r (suc (R.n r))++    data Q : (b : Bool) (n : Nat) →  Set where+      true! : Q true zero+      suc!  : ∀{b n} → Q b (suc n)++    test : (r : R) {n : Nat} (p : P r n) → Q (R.f r) n+    test r nSuc       = suc!+    test r (fTrue p)  with R.f r+    test _ (fTrue ()) | false+    test _ _          | true = true!  -- underscore instead of (isTrue _)+  ```++* Pattern matching lambdas (also known as extended lambdas) can now be+  nullary, mirroring the behaviour for ordinary function definitions.+  [Issue [#2671](https://github.com/agda/agda/issues/2671)]++  This is useful for case splitting on the result inside an+  expression: given+  ```agda+  record _×_ (A B : Set) : Set where+    field+      π₁ : A+      π₂ : B+  open _×_+  ```+  one may case split on the result (C-c C-c RET) in a hole+  ```agda+    λ { → {!!}}+  ```+  of type A × B to produce+  ```agda+    λ { .π₁ → {!!} ; .π₂ → {!!}}+  ```++* Records with a field of an empty type are now recognized as empty by Agda.+  In particular, they can be matched against with an absurd pattern ().+  For example:+  ```agda+    data ⊥ : Set where++    record Empty : Set where+      field absurdity : ⊥++    magic : Empty → ⊥+    magic ()+  ```++* Injective pragmas.++  Injective pragmas can be used to mark a definition as injective for the+  pattern matching unifier. This can be used as a version of+  `--injective-type-constructors` that only applies to specific datatypes.+  For example:+  ```agda+    open import Agda.Builtin.Equality+    data Fin : Nat → Set where+      zero : {n : Nat} → Fin (suc n)+      suc  : {n : Nat} → Fin n → Fin (suc n)++    {-# INJECTIVE Fin #-}++    Fin-injective : {m n : Nat} → Fin m ≡ Fin n → m ≡ n+    Fin-injective refl = refl+  ```+  Aside from datatypes, this pragma can also be used to mark other definitions+  as being injective (for example postulates).++* Metavariables can no longer be instantiated during case splitting. This means+  Agda will refuse to split instead of taking the first constructor it finds.+  For example:+  ```agda+    open import Agda.Builtin.Nat++    data Vec (A : Set) : Nat → Set where+      nil : Vec A 0+      cons : {n : Nat} → A → Vec A n → Vec A (suc n)++    foo : Vec Nat _ → Nat+    foo x = {!x!}+  ```+  In Agda 2.5.2, case splitting on `x` produced the single clause+  `foo nil = {!!}`, but now Agda refuses to split.++### Reflection++* New TC primitive: `debugPrint`.++  ```agda+    debugPrint : String → Nat → List ErrorPart → TC ⊤+  ```++  This maps to the internal function `reportSDoc`. Debug output is enabled with+  the `-v` flag at the command line, or in an `OPTIONS` pragma. For instance,+  giving `-v a.b.c:10` enables printing from `debugPrint "a.b.c.d" 10 msg`. In the+  Emacs mode, debug output ends up in the `*Agda debug*` buffer.++### Built-ins++* BUILTIN REFL is now superfluous, subsumed by BUILTIN EQUALITY+  [Issue [#2389](https://github.com/agda/agda/issues/2389)].++* BUILTIN EQUALITY is now more liberal+  [Issue [#2386](https://github.com/agda/agda/issues/2386)].+  It accepts, among others, the following new definitions of equality:+  ```agda+    -- Non-universe polymorphic:+    data _≡_ {A : Set} (x : A) : A → Set where+      refl : x ≡ x++    -- ... with explicit argument to refl;+    data _≡_ {A : Set} : (x y : A) → Set where+      refl : {x : A} → x ≡ x++    -- ... even visible+    data _≡_ {A : Set} : (x y : A) → Set where+      refl : (x : A) → x ≡ x++    -- Equality in a different universe than domain:+    -- (also with explicit argument to refl)+    data _≡_ {a} {A : Set a} (x : A) : A → Set where+      refl : x ≡ x++  ```+  The standard definition is still:+  ```agda+    -- Equality in same universe as domain:+    data _≡_ {a} {A : Set a} (x : A) : A → Set a where+      refl : x ≡ x+  ```++### Miscellaneous++* Rule change for omitted top-level module headers.+  [Issue [#1077](https://github.com/agda/agda/issues/1077)]++  If your file is named `Bla.agda`, then the following content+  is rejected.+  ```agda+    foo = Set+    module Bla where+      bar = Set+  ```+  Before the fix of this issue, Agda would add the missing module+  header `module Bla where` at the top of the file.+  However, in this particular case it is more likely the user+  put the declaration `foo = Set` before the module start in error.+  Now you get the error+  ```+    Illegal declaration(s) before top-level module+  ```+  if the following conditions are met:++    1. There is at least one non-import declaration or non-toplevel pragma+       before the start of the first module.++    2. The module has the same name as the file.++    3. The module is the only module at this level+       (may have submodules, of course).++  If you should see this error, insert a top-level module+  before the illegal declarations, or move them inside the+  existing module.++Emacs mode+----------++* New warnings:++  - Unreachable clauses give rise to a simple warning. They are+    highlighted in gray.++  - Incomplete patterns are non-fatal warnings: it is possible+    to keep interacting with the file (the reduction will simply+    be stuck on arguments not matching any pattern).+    The definition with incomplete patterns are highlighted in+    wheat.++* Clauses which do not hold definitionally are now highlighted in white smoke.++* Fewer commands have the side effect that the buffer is saved.++* Aborting commands.++  Now one can (try to) abort an Agda command by using `C-c C-x C-a` or+  a menu entry. The effect is similar to that of restarting Agda (`C-c+  C-x C-r`), but some state is preserved, which could mean that it+  takes less time to reload the module.++  Warning: If a command is aborted while it is writing data to disk+  (for instance `.agdai` files or Haskell files generated by the GHC+  backend), then the resulting files may be corrupted. Note also that+  external commands (like GHC) are not aborted, and their output may+  continue to be sent to the Emacs mode.++* New bindings for the Agda input method:++  - All the bold digits are now available. The naming scheme is `\Bx` for digit `x`.++  - Typing `\:` you can now get a whole slew of colons.++    (The Agda input method originally only bound the standard unicode colon,+    which looks deceptively like the normal colon.)++* Case splitting now preserves underscores.+  [Issue [#819](https://github.com/agda/agda/issues/819)]+  ```agda+    data ⊥ : Set where++    test : {A B : Set} → A → ⊥ → B+    test _ x = {! x !}+  ```+  Splitting on `x` yields+  ```agda+    test _ ()+  ```++* Interactively expanding ellipsis.+  [Issue [#2589](https://github.com/agda/agda/issues/2589)]+  An ellipsis in a with-clause can be expanded by splitting on "variable" "." (dot).+  ```agda+    test0 : Nat → Nat+    test0 x with zero+    ... | q = {! . !}  -- C-c C-c+  ```+  Splitting on dot here yields:+  ```agda+    test0 x | q = ?+  ```++* New command to check an expression against the type of the hole+  it is in and see what it elaborates to.+  [Issue [#2700](https://github.com/agda/agda/issues/2700)]+  This is useful to determine e.g. what solution typeclass resolution yields.+  The command is bound to `C-c C-;` and respects the `C-u` modifier.++  ```agda+    record Pointed (A : Set) : Set where+      field point : A++    it : ∀ {A : Set} {{x : A}} → A+    it {{x}} = x++    instance _ = record { point = 3 - 4 }++    _ : Pointed Nat+    _ = {! it !} -- C-u C-u C-c C-;+  ```+  yields+  ```agda+    Goal: Pointed Nat+    Elaborates to: record { point = 0 }+  ```++* If `agda2-give` is called with a prefix, then giving is forced,+  i.e., the safety checks are skipped,+  including positivity, termination, and double type-checking.+  [Issue [#2730](https://github.com/agda/agda/issues/2730)]++  Invoke forced giving with key sequence `C-u C-c C-SPC`.+++Library management+------------------++* The `name` field in an `.agda-lib` file is now optional.+  [Issue [#2708](https://github.com/agda/agda/issues/2708)]++  This feature is convenient if you just want to specify the dependencies+  and include pathes for your local project in an `.agda-lib` file.++  Naturally, libraries without names cannot be depended on.+++Compiler backends+-----------------++* Unified compiler pragmas++  The compiler pragmas (`COMPILED`, `COMPILED_DATA`, etc.) have been unified across+  backends into two new pragmas:++  ```+    {-# COMPILE <Backend> <Name> <Text> #-}+    {-# FOREIGN <Backend> <Text> #-}+  ```++  The old pragmas still work, but will emit a warning if used. They will be+  removed completely in Agda 2.6.++  The translation of old pragmas into new ones is as follows:++  Old | New+  --- | ---+  `{-# COMPILED f e #-}` | `{-# COMPILE GHC f = e #-}`+  `{-# COMPILED_TYPE A T #-}` | `{-# COMPILE GHC A = type T #-}`+  `{-# COMPILED_DATA A D C1 .. CN #-}` | `{-# COMPILE GHC A = data D (C1 \| .. \| CN) #-}`+  `{-# COMPILED_DECLARE_DATA #-}` | obsolete, removed+  `{-# COMPILED_EXPORT f g #-}` | `{-# COMPILE GHC f as g #-}`+  `{-# IMPORT M #-}` | `{-# FOREIGN GHC import qualified M #-}`+  `{-# HASKELL code #-}` | `{-# FOREIGN GHC code #-}`+  `{-# COMPILED_UHC f e #-}` | `{-# COMPILE UHC f = e #-}`+  `{-# COMPILED_DATA_UHC A D C1 .. CN #-}` | `{-# COMPILE UHC A = data D (C1 \| .. \| CN) #-}`+  `{-# IMPORT_UHC M #-}` | `{-# FOREIGN UHC __IMPORT__ M #-}`+  `{-# COMPILED_JS f e #-}` | `{-# COMPILE JS f = e #-}`++* GHC Haskell backend++  The COMPILED pragma (and the corresponding COMPILE GHC pragma) is now also+  allowed for functions. This makes it possible to have both an Agda+  implementation and a native Haskell runtime implementation.++  The GHC file header pragmas `LANGUAGE`, `OPTIONS_GHC`, and `INCLUDE`+  inside a `FOREIGN GHC` pragma are recognized and printed correctly+  at the top of the generated Haskell file.+  [Issue [#2712](https://github.com/agda/agda/issues/2712)]+++* UHC compiler backend++  The UHC backend has been moved to its own repository+  [https://github.com/agda/agda-uhc] and is no longer part of the Agda+  distribution.++* Haskell imports are no longer transitively inherited from imported modules.++  The (now deprecated) IMPORT and IMPORT_UHC pragmas no longer cause import+  statements in modules importing the module containing the pragma.++  The same is true for the corresponding FOREIGN pragmas.++* Support for stand-alone backends.++  There is a new API in `Agda.Compiler.Backend` for creating stand-alone+  backends using Agda as a library. This allows prospective backend writers to+  experiment with new backends without having to change the Agda code base.++HTML backend+------------++* Anchors for identifiers (excluding bound variables) are now the+  identifiers themselves rather than just the file position+  [Issue [#2604](https://github.com/agda/agda/issues/2604)].++  Symbolic anchors look like+  ```html+  <a id="test1">+  <a id="M.bla">+  ```+  while other anchors just give the character position in the file:+  ```html+  <a id="42">+  ```++  Top-level module names do not get a symbolic anchor, since the position of+  a top-level module is defined to be the beginning of the file.++  Example:++  ```agda+  module Issue2604 where   -- Character position anchor++  test1 : Set₁             -- Issue2604.html#test1+  test1 = bla+    where+    bla = Set              -- Character position anchor++  test2 : Set₁             -- Issue2604.html#test2+  test2 = bla+    where+    bla = Set              -- Character position anchor++  test3 : Set₁             -- Issue2604.html#test3+  test3 = bla+    module M where         -- Issue2604.html#M+    bla = Set              -- Issue2604.html#M.bla++  module NamedModule where -- Issue2604.html#NamedModule+    test4 : Set₁           -- Issue2604.html#NamedModule.test4+    test4 = M.bla++  module _ where           -- Character position anchor+    test5 : Set₁           -- Character position anchor+    test5 = M.bla+  ```++* Some generated HTML files now have different file names [Issue+  [#2725](https://github.com/agda/agda/issues/2725)].++  Agda now uses an encoding that amounts to first converting the+  module names to UTF-8, and then percent-encoding the resulting+  bytes. For instance, HTML for the module `Σ` is placed in+  `%CE%A3.html`.++LaTeX backend+-------------++* The LaTeX backend now handles indentation in a different way [Issue+  [#1832](https://github.com/agda/agda/issues/1832)].++  A constraint on the indentation of the first token *t* on a line is+  determined as follows:+  * Let *T* be the set containing every previous token (in any code+    block) that is either the initial token on its line or preceded by+    at least one whitespace character.+  * Let *S* be the set containing all tokens in *T* that are not+    *shadowed* by other tokens in *T*. A token *t₁* is shadowed by+    *t₂* if *t₂* is further down than *t₁* and does not start to the+    right of *t₁*.+  * Let *L* be the set containing all tokens in *S* that start to the+    left of *t*, and *E* be the set containing all tokens in *S* that+    start in the same column as *t*.+  * The constraint is that *t* must be indented further than every+    token in *L*, and aligned with every token in *E*.++  Note that if any token in *L* or *E* belongs to a previous code+  block, then the constraint may not be satisfied unless (say) the+  `AgdaAlign` environment is used in an appropriate way.++  If custom settings are used, for instance if `\AgdaIndent` is+  redefined, then the constraint discussed above may not be satisfied.+  (Note that the meaning of the `\AgdaIndent` command's argument has+  changed, and that the command is now used in a different way in the+  generated LaTeX files.)++  Examples:+  * Here `C` is indented further than `B`:++    ```agda+    postulate+      A  B+          C : Set+    ```++  * Here `C` is not (necessarily) indented further than `B`, because+    `X` shadows `B`:++    ```agda+    postulate+      A  B  : Set+      X+          C : Set+    ```++  The new rule is inspired by, but not identical to, the one used by+  lhs2TeX's poly mode (see Section 8.4 of the [manual for lhs2TeX+  version 1.17](https://www.andres-loeh.de/lhs2tex/Guide2-1.17.pdf)).++* Some spacing issues+  [[#2353](https://github.com/agda/agda/issues/2353),+  [#2441](https://github.com/agda/agda/issues/2441),+  [#2733](https://github.com/agda/agda/issues/2733),+  [#2740](https://github.com/agda/agda/issues/2740)] have been fixed.++* The user can now control the typesetting of (certain) individual tokens+  by redefining the `\AgdaFormat` command. Example:+  ```latex+  \usepackage{ifthen}++  % Insert extra space before some tokens.+  \DeclareRobustCommand{\AgdaFormat}[2]{%+    \ifthenelse{+      \equal{#1}{≡⟨} \OR+      \equal{#1}{≡⟨⟩} \OR+      \equal{#1}{∎}+    }{\ }{}#2}+  ```+  Note the use of `\DeclareRobustCommand`. The first argument to+  `\AgdaFormat` is the token, and the second argument the thing to+  be typeset.++* One can now instruct the agda package not to select any fonts.++  If the `nofontsetup` option is used, then some font packages are+  loaded, but specific fonts are not selected:+  ```latex+  \usepackage[nofontsetup]{agda}+  ```++* The height of empty lines is now configurable+  [[#2734](https://github.com/agda/agda/issues/2734)].++  The height is controlled by the length `\AgdaEmptySkip`, which by+  default is `\baselineskip`.++* The alignment feature regards the string `+̲`, containing `+` and a+  combining character, as having length two. However, it seems more+  reasonable to treat it as having length one, as it occupies a single+  column, if displayed "properly" using a monospace font. The new flag+  `--count-clusters` is an attempt at fixing this. When this flag is+  enabled the backend counts ["extended grapheme+  clusters"](http://www.unicode.org/reports/tr29/#Grapheme_Cluster_Boundaries)+  rather than code points.++  Note that this fix is not perfect: a single extended grapheme+  cluster might be displayed in different ways by different programs,+  and might, in some cases, occupy more than one column. Here are some+  examples of extended grapheme clusters, all of which are treated as+  a single character by the alignment algorithm:+  ```+  │ │+  │+̲│+  │Ö̂│+  │நி│+  │ᄀힰᇹ│+  │ᄀᄀᄀᄀᄀᄀힰᇹᇹᇹᇹᇹᇹ│+  │ │+  ```++  Note also that the layout machinery does not count extended grapheme+  clusters, but code points. The following code is syntactically+  correct, but if `--count-clusters` is used, then the LaTeX backend+  does not align the two `field` keywords:+  ```agda+    record +̲ : Set₁ where  field A : Set+                            field B : Set+  ```++  The `--count-clusters` flag is not enabled in all builds of Agda,+  because the implementation depends on the+  [ICU](http://site.icu-project.org) library, the installation of+  which could cause extra trouble for some users. The presence of this+  flag is controlled by the Cabal flag `enable-cluster-counting`.++* A faster variant of the LaTeX backend: QuickLaTeX.++  When this variant of the backend is used the top-level module is not+  type-checked, only scope-checked. This implies that some+  highlighting information is not available. For instance, overloaded+  constructors are not resolved.++  QuickLaTeX can be invoked from the Emacs mode, or using `agda+  --latex --only-scope-checking`. If the module has already been+  type-checked successfully, then this information is reused; in this+  case QuickLaTeX behaves like the regular LaTeX backend.++  The `--only-scope-checking` flag can also be used independently, but+  it is perhaps unclear what purpose that would serve. (The flag can+  currently not be combined with `--html`, `--dependency-graph` or+  `--vim`.) The flag is not allowed in safe mode.++Pragmas and options+-------------------++* The `--safe` option is now a valid pragma.++  This makes it possible to declare a module as being part of the safe+  subset of the language by stating `{-# OPTIONS --safe #-}` at the top+  of the corresponding file. Incompatibilities between the `--safe` option+  and other options or language constructs are non-fatal errors.++* The `--no-main` option is now a valid pragma.++  One can now suppress the compiler warning about a missing main function by+  putting+  ```agda+    {-# OPTIONS --no-main #-}+  ```+  on top of the file.++* New command-line option and pragma `--warning=MODE` (or `-W MODE`) for+  setting the warning mode. Current options are+  - `warn` for displaying warnings (default)+  - `error` for turning warnings into errors+  - `ignore` for not displaying warnings++List of fixed issues+--------------------++For 2.5.3, the following issues have been fixed+(see [bug tracker](https://github.com/agda/agda/issues)):++  - [#142](https://github.com/agda/agda/issues/142): Inherited dot patterns in with functions are not checked+  - [#623](https://github.com/agda/agda/issues/623): Error message points to importing module rather than imported module+  - [#657](https://github.com/agda/agda/issues/657): Yet another display form problem+  - [#668](https://github.com/agda/agda/issues/668): Ability to stop, or restart, typechecking somehow+  - [#705](https://github.com/agda/agda/issues/705): confusing error message for ambiguous datatype module name+  - [#719](https://github.com/agda/agda/issues/719): Error message for duplicate module definition points to external module instead of internal module+  - [#776](https://github.com/agda/agda/issues/776): Unsolvable constraints should give error+  - [#819](https://github.com/agda/agda/issues/819): Case-splitting doesn't preserve underscores+  - [#883](https://github.com/agda/agda/issues/883): Rewrite loses type information+  - [#899](https://github.com/agda/agda/issues/899): Instance search fails if there are several definitionally equal values in scope+  - [#1077](https://github.com/agda/agda/issues/1077): problem with module syntax, with parametric module import+  - [#1126](https://github.com/agda/agda/issues/1126): Port optimizations from the Epic backend+  - [#1175](https://github.com/agda/agda/issues/1175): Internal Error in Auto+  - [#1544](https://github.com/agda/agda/issues/1544): Positivity polymorphism needed for compositional positivity analysis+  - [#1611](https://github.com/agda/agda/issues/1611): Interactive splitting instantiates meta+  - [#1664](https://github.com/agda/agda/issues/1664): Add Reflection primitives to expose precedence and fixity+  - [#1817](https://github.com/agda/agda/issues/1817): Solvable size constraints reported as unsolvable+  - [#1832](https://github.com/agda/agda/issues/1832): Insufficient indentation in LaTeX-rendered Agda code+  - [#1834](https://github.com/agda/agda/issues/1834): Copattern matching: order of clauses should not matter here+  - [#1886](https://github.com/agda/agda/issues/1886): Second copies of telescopes not checked?+  - [#1899](https://github.com/agda/agda/issues/1899): Positivity checker does not treat datatypes and record types in the same way+  - [#1975](https://github.com/agda/agda/issues/1975): Type-incorrect instantiated overloaded constructor accepted in pattern+  - [#1976](https://github.com/agda/agda/issues/1976): Type-incorrect instantiated projection accepted in pattern+  - [#2035](https://github.com/agda/agda/issues/2035): Matching on string causes solver to fail with internal error+  - [#2146](https://github.com/agda/agda/issues/2146): Unicode syntax for instance arguments+  - [#2217](https://github.com/agda/agda/issues/2217): Abort Agda without losing state+  - [#2229](https://github.com/agda/agda/issues/2229): Absence or presence of top-level module header affects scope+  - [#2253](https://github.com/agda/agda/issues/2253): Wrong scope error for abstract constructors+  - [#2261](https://github.com/agda/agda/issues/2261): Internal error in Auto/CaseSplit.hs:284+  - [#2270](https://github.com/agda/agda/issues/2270): Printer does not use sections.+  - [#2329](https://github.com/agda/agda/issues/2329): Size solver does not use type `Size< i` to gain the necessary information+  - [#2354](https://github.com/agda/agda/issues/2354): Interaction between instance search, size solver, and ordinary constraint solver.+  - [#2355](https://github.com/agda/agda/issues/2355): Literate Agda parser does not recognize TeX comments+  - [#2360](https://github.com/agda/agda/issues/2360): With clause stripping chokes on ambiguous projection+  - [#2362](https://github.com/agda/agda/issues/2362): Printing of parent patterns when with-clause does not match+  - [#2363](https://github.com/agda/agda/issues/2363): Allow underscore in with-clause patterns+  - [#2366](https://github.com/agda/agda/issues/2366): With-clause patterns renamed in error message+  - [#2368](https://github.com/agda/agda/issues/2368): Internal error after refining a tactic @ MetaVars.hs:267+  - [#2371](https://github.com/agda/agda/issues/2371): Shadowed module parameter crashes interaction+  - [#2372](https://github.com/agda/agda/issues/2372): problems when instances are declared with inferred types+  - [#2374](https://github.com/agda/agda/issues/2374): Ambiguous projection pattern could be disambiguated by visibility+  - [#2376](https://github.com/agda/agda/issues/2376): Termination checking interacts badly with eta-contraction+  - [#2377](https://github.com/agda/agda/issues/2377): open public is useless before module header+  - [#2381](https://github.com/agda/agda/issues/2381): Search (`C-c C-z`) panics on pattern synonyms+  - [#2386](https://github.com/agda/agda/issues/2386): Relax requirements of BUILTIN EQUALITY+  - [#2389](https://github.com/agda/agda/issues/2389): BUILTIN REFL not needed+  - [#2400](https://github.com/agda/agda/issues/2400): LaTeX backend error on LaTeX comments+  - [#2402](https://github.com/agda/agda/issues/2402): Parameters not dropped when reporting incomplete patterns+  - [#2403](https://github.com/agda/agda/issues/2403): Termination checker should reduce arguments in structural order check+  - [#2405](https://github.com/agda/agda/issues/2405): instance search failing in parameterized module+  - [#2408](https://github.com/agda/agda/issues/2408): DLub sorts are not serialized+  - [#2412](https://github.com/agda/agda/issues/2412): Problem with checking  with sized types+  - [#2413](https://github.com/agda/agda/issues/2413): Agda crashes on x@y pattern+  - [#2415](https://github.com/agda/agda/issues/2415): Size solver reports "inconsistent upper bound" even though there is a solution+  - [#2416](https://github.com/agda/agda/issues/2416): Cannot give size as computed by solver+  - [#2422](https://github.com/agda/agda/issues/2422): Overloaded inherited projections don't resolve+  - [#2423](https://github.com/agda/agda/issues/2423): Inherited projection on lhs+  - [#2426](https://github.com/agda/agda/issues/2426): On just warning about missing cases+  - [#2429](https://github.com/agda/agda/issues/2429): Irrelevant lambda should be accepted when relevant lambda is expected+  - [#2430](https://github.com/agda/agda/issues/2430): Another regression related to parameter refinement?+  - [#2433](https://github.com/agda/agda/issues/2433): rebindLocalRewriteRules re-adds global rewrite rules+  - [#2434](https://github.com/agda/agda/issues/2434): Exact split analysis is too strict when matching on eta record constructor+  - [#2441](https://github.com/agda/agda/issues/2441): Incorrect alignement in latex using the new ACM format+  - [#2444](https://github.com/agda/agda/issues/2444): Generalising compiler pragmas+  - [#2445](https://github.com/agda/agda/issues/2445): The LaTeX backend is slow+  - [#2447](https://github.com/agda/agda/issues/2447): Cache loaded interfaces even if a type error is encountered+  - [#2449](https://github.com/agda/agda/issues/2449): Agda depends on additional C library icu+  - [#2451](https://github.com/agda/agda/issues/2451): Agda panics when attempting to rewrite a typeclass Eq+  - [#2456](https://github.com/agda/agda/issues/2456): Internal error when postulating instance+  - [#2458](https://github.com/agda/agda/issues/2458): Regression: Agda-2.5.3 loops where Agda-2.5.2 passes+  - [#2462](https://github.com/agda/agda/issues/2462): Overloaded postfix projection does not resolve+  - [#2464](https://github.com/agda/agda/issues/2464): Eta contraction for irrelevant functions breaks subject reduction+  - [#2466](https://github.com/agda/agda/issues/2466): Case split to make hidden variable visible does not work+  - [#2467](https://github.com/agda/agda/issues/2467): REWRITE without BUILTIN REWRITE crashes+  - [#2469](https://github.com/agda/agda/issues/2469): "Partial" pattern match causes segfault at runtime+  - [#2472](https://github.com/agda/agda/issues/2472): Regression related to the auto command+  - [#2477](https://github.com/agda/agda/issues/2477): Sized data type analysis brittle, does not reduce size+  - [#2478](https://github.com/agda/agda/issues/2478): Multiply defined labels on the user manual (pdf)+  - [#2479](https://github.com/agda/agda/issues/2479): "Occurs check" error in generated Haskell code+  - [#2480](https://github.com/agda/agda/issues/2480): Agda accepts incorrect (?) code, subject reduction broken+  - [#2482](https://github.com/agda/agda/issues/2482): Wrong counting of data parameters with new-style mutual blocks+  - [#2483](https://github.com/agda/agda/issues/2483): Files are sometimes truncated to a size of 201 bytes+  - [#2486](https://github.com/agda/agda/issues/2486): Imports via FOREIGN are not transitively inherited anymore+  - [#2488](https://github.com/agda/agda/issues/2488): Instance search inhibits holes for instance fields+  - [#2493](https://github.com/agda/agda/issues/2493): Regression: Agda seems to loop when expression is given+  - [#2494](https://github.com/agda/agda/issues/2494): Instance fields sometimes have incorrect goal types+  - [#2495](https://github.com/agda/agda/issues/2495): Regression: termination checker of Agda-2.5.3 seemingly loops where Agda-2.5.2 passes+  - [#2500](https://github.com/agda/agda/issues/2500): Adding fields to a record can cause Agda to reject previous definitions+  - [#2510](https://github.com/agda/agda/issues/2510): Wrong error with --no-pattern-matching+  - [#2517](https://github.com/agda/agda/issues/2517): "Not a variable error"+  - [#2518](https://github.com/agda/agda/issues/2518): CopatternReductions in TreeLess+  - [#2523](https://github.com/agda/agda/issues/2523): The documentation of `--without-K` is outdated+  - [#2529](https://github.com/agda/agda/issues/2529): Unable to install Agda on Windows.+  - [#2537](https://github.com/agda/agda/issues/2537): case splitting with 'with' creates {_} instead of replicating the arguments it found.+  - [#2538](https://github.com/agda/agda/issues/2538): Internal error when parsing as-pattern+  - [#2543](https://github.com/agda/agda/issues/2543): Case splitting with ellipsis produces spurious parentheses+  - [#2545](https://github.com/agda/agda/issues/2545): Race condition in api tests+  - [#2549](https://github.com/agda/agda/issues/2549): Rewrite rule for higher path constructor does not fire+  - [#2550](https://github.com/agda/agda/issues/2550): Internal error in Agda.TypeChecking.Substitute+  - [#2552](https://github.com/agda/agda/issues/2552): Let bindings in module telescopes crash Agda.Interaction.BasicOps+  - [#2553](https://github.com/agda/agda/issues/2553): Internal error in Agda.TypeChecking.CheckInternal+  - [#2554](https://github.com/agda/agda/issues/2554): More flexible size-assignment in successor style+  - [#2555](https://github.com/agda/agda/issues/2555): Why does the positivity checker care about non-recursive occurrences?+  - [#2558](https://github.com/agda/agda/issues/2558): Internal error in Warshall Solver+  - [#2560](https://github.com/agda/agda/issues/2560): Internal Error in Reduce.Fast+  - [#2564](https://github.com/agda/agda/issues/2564): Non-exact-split highlighting makes other highlighting disappear+  - [#2568](https://github.com/agda/agda/issues/2568): agda2-infer-type-maybe-toplevel (in hole) does not respect "single-solution" requirement of instance resolution+  - [#2571](https://github.com/agda/agda/issues/2571): Record pattern translation does not eta contract+  - [#2573](https://github.com/agda/agda/issues/2573): Rewrite rules fail depending on unrelated changes+  - [#2574](https://github.com/agda/agda/issues/2574): No link attached to module without toplevel name+  - [#2575](https://github.com/agda/agda/issues/2575): Internal error, related to caching+  - [#2577](https://github.com/agda/agda/issues/2577): deBruijn fail for higher order instance problem+  - [#2578](https://github.com/agda/agda/issues/2578): Catch-all clause face used incorrectly for parent with pattern+  - [#2579](https://github.com/agda/agda/issues/2579): Import statements with module instantiation should not trigger an error message+  - [#2580](https://github.com/agda/agda/issues/2580): Implicit absurd match is NonVariant, explicit not+  - [#2583](https://github.com/agda/agda/issues/2583): Wrong de Bruijn index introduced by absurd pattern+  - [#2584](https://github.com/agda/agda/issues/2584): Duplicate warning printing+  - [#2585](https://github.com/agda/agda/issues/2585): Definition by copatterns not modulo eta+  - [#2586](https://github.com/agda/agda/issues/2586): "λ where" with single absurd clause not parsed+  - [#2588](https://github.com/agda/agda/issues/2588): `agda --latex` produces invalid LaTeX when there are block comments+  - [#2592](https://github.com/agda/agda/issues/2592): Internal Error in Agda/TypeChecking/Serialise/Instances/Common.hs+  - [#2597](https://github.com/agda/agda/issues/2597): Inline record definitions confuse the reflection API+  - [#2602](https://github.com/agda/agda/issues/2602): Debug output messes up AgdaInfo buffer+  - [#2603](https://github.com/agda/agda/issues/2603): Internal error in MetaVars.hs+  - [#2604](https://github.com/agda/agda/issues/2604): Use QNames as anchors in generated HTML+  - [#2605](https://github.com/agda/agda/issues/2605): HTML backend generates anchors for whitespace+  - [#2606](https://github.com/agda/agda/issues/2606): Check that LHS of a rewrite rule doesn't reduce is too strict+  - [#2612](https://github.com/agda/agda/issues/2612): `exact-split` documentation is outdated and incomplete+  - [#2613](https://github.com/agda/agda/issues/2613): Parametrised modules, with-abstraction and termination+  - [#2620](https://github.com/agda/agda/issues/2620): Internal error in auto.+  - [#2621](https://github.com/agda/agda/issues/2621): Case splitting instantiates meta+  - [#2626](https://github.com/agda/agda/issues/2626): triggered internal error with sized types in MetaVars module+  - [#2629](https://github.com/agda/agda/issues/2629): Exact splitting should not complain about absurd clauses+  - [#2631](https://github.com/agda/agda/issues/2631): docs for auto aren't clear on how to use flags/options+  - [#2632](https://github.com/agda/agda/issues/2632): some flags to auto dont seem to work in current agda 2.5.2+  - [#2637](https://github.com/agda/agda/issues/2637): Internal error in Agda.TypeChecking.Pretty, possibly related to sized types+  - [#2639](https://github.com/agda/agda/issues/2639): Performance regression, possibly related to the size solver+  - [#2641](https://github.com/agda/agda/issues/2641): Required instance of FromNat when compiling imported files+  - [#2642](https://github.com/agda/agda/issues/2642): Records with duplicate fields+  - [#2644](https://github.com/agda/agda/issues/2644): Wrong substitution in expandRecordVar+  - [#2645](https://github.com/agda/agda/issues/2645): Agda accepts postulated fields in a record+  - [#2646](https://github.com/agda/agda/issues/2646): Only warn if fixities for undefined symbols are given+  - [#2649](https://github.com/agda/agda/issues/2649): Empty list of "previous definition" in duplicate definition error+  - [#2652](https://github.com/agda/agda/issues/2652): Added a new variant of the colon to the Agda input method+  - [#2653](https://github.com/agda/agda/issues/2653): agda-mode: "cannot refine" inside instance argument even though term to be refined typechecks there+  - [#2654](https://github.com/agda/agda/issues/2654): Internal error on result splitting without --postfix-projections+  - [#2664](https://github.com/agda/agda/issues/2664): Segmentation fault with compiled programs using mutual record+  - [#2665](https://github.com/agda/agda/issues/2665): Documentation: Record update syntax in wrong location+  - [#2666](https://github.com/agda/agda/issues/2666): Internal error at Agda/Syntax/Abstract/Name.hs:113+  - [#2667](https://github.com/agda/agda/issues/2667): Panic error on unbound variable.+  - [#2669](https://github.com/agda/agda/issues/2669): Interaction: incorrect field variable name generation+  - [#2671](https://github.com/agda/agda/issues/2671): Feature request: nullary pattern matching lambdas+  - [#2679](https://github.com/agda/agda/issues/2679): Internal error at "Typechecking/Abstract.hs:133" and "TypeChecking/Telescope.hs:68"+  - [#2682](https://github.com/agda/agda/issues/2682): What are the rules for projections of abstract records?+  - [#2684](https://github.com/agda/agda/issues/2684): Bad error message for abstract constructor+  - [#2686](https://github.com/agda/agda/issues/2686): Abstract constructors should be ignored when resolving overloading+  - [#2690](https://github.com/agda/agda/issues/2690): [regression?] Agda engages in deep search instead of immediately failing+  - [#2700](https://github.com/agda/agda/issues/2700): Add a command to check against goal type (and normalise)+  - [#2703](https://github.com/agda/agda/issues/2703): Regression: Internal error for underapplied indexed constructor+  - [#2705](https://github.com/agda/agda/issues/2705): The GHC backend might diverge in infinite file creation+  - [#2708](https://github.com/agda/agda/issues/2708): Why is the `name` field in .agda-lib files mandatory?+  - [#2710](https://github.com/agda/agda/issues/2710): Type checker hangs+  - [#2712](https://github.com/agda/agda/issues/2712): Compiler Pragma for headers+  - [#2714](https://github.com/agda/agda/issues/2714): Option --no-main should be allowed as file-local option+  - [#2717](https://github.com/agda/agda/issues/2717): internal error at DisplayForm.hs:197+  - [#2718](https://github.com/agda/agda/issues/2718): Interactive 'give' doesn't insert enough parenthesis+  - [#2721](https://github.com/agda/agda/issues/2721): Without-K doesn't prevent heterogeneous conflict between literals+  - [#2723](https://github.com/agda/agda/issues/2723): Unreachable clauses in definition by copattern matching trip clause compiler+  - [#2725](https://github.com/agda/agda/issues/2725): File names for generated HTML files+  - [#2726](https://github.com/agda/agda/issues/2726): Old regression related to with+  - [#2727](https://github.com/agda/agda/issues/2727): Internal errors related to rewrite+  - [#2729](https://github.com/agda/agda/issues/2729): Regression: case splitting uses variable name variants instead of the unused original names+  - [#2730](https://github.com/agda/agda/issues/2730): Command to give in spite of termination errors+  - [#2731](https://github.com/agda/agda/issues/2731): Agda fails to build with happy 1.19.6+  - [#2733](https://github.com/agda/agda/issues/2733): Avoid some uses of \AgdaIndent?+  - [#2734](https://github.com/agda/agda/issues/2734): Make height of empty lines configurable+  - [#2736](https://github.com/agda/agda/issues/2736): Segfault using Alex 3.2.2 and cpphs+  - [#2740](https://github.com/agda/agda/issues/2740): Indenting every line of code should be a no-op
+ doc/release-notes/2.5.4.1.md view
@@ -0,0 +1,16 @@+Release notes for Agda version 2.5.4.1+======================================++Installation and infrastructure+-------------------------------++* Generated the interface file for the `Sigma.agda` built-in when+  installing Agda+  [Issue [#3128](https://github.com/agda/agda/issues/3128)].++Emacs mode+----------++* Light highlighting is no longer applied continuously, but only when+  the file is saved [Issue+  [#3119](https://github.com/agda/agda/issues/3119)].
+ doc/release-notes/2.5.4.2.md view
@@ -0,0 +1,23 @@+Release notes for Agda version 2.5.4.2+======================================++Installation and infrastructure+-------------------------------++* Fixed installation with some old versions of `cabal-install`+  [Issue [#3225](https://github.com/agda/agda/issues/3225)].++* Using `cpp` instead of `cpphs` as the default preprocessor+  [Issue [#3223](https://github.com/agda/agda/issues/3223)].++* Added support for GHC 8.4.4.++Other closed issues+--------------------++For 2.5.4.2 the following issues have also been closed+(see [bug tracker](https://github.com/agda/agda/issues)):++  - [#3177](https://github.com/agda/agda/issues/3177): Slow typechecking with unsolved instance constraint+  - [#3199](https://github.com/agda/agda/issues/3199): Panics when serialising absolute paths+  - [#3312](https://github.com/agda/agda/issues/3312): Crash in Substitute.hs
+ doc/release-notes/2.5.4.md view
@@ -0,0 +1,859 @@+Release notes for Agda version 2.5.4+====================================++Installation and infrastructure+-------------------------------++* Added support for GHC 8.2.2 and GHC 8.4.3.++  Note that GHC 8.4.* requires `cabal-install` ≥ 2.2.0.0.++* Removed support for GHC 7.8.4.++* Included user manual in PDF format in `doc/user-manual.pdf`.++Language+--------++* Call-by-need reduction.++  Compile-time weak-head evaluation is now call-by-need, but each weak-head+  reduction has a local heap, so sharing is not maintained between different+  reductions.++  The reduction machine has been rewritten from scratch and should be faster+  than the old one in all cases, even those not exploiting laziness.++* Compile-time inlining.++  Simple definitions (that don't do any pattern matching) marked as INLINE are+  now also inlined at compile time, whereas before they were only inlined by+  the compiler backends. Inlining only triggers in function bodies and not in+  type signatures, to preserve goal types as far as possible.++* Automatic inlining.++  Definitions satisfying the following criteria are now automatically inlined+  (can be disabled using the new NOINLINE pragma):++    - No pattern matching.+    - Uses each argument at most once.+    - Does not use all its arguments.++  Automatic inlining can be turned off using the flag `--no-auto-inline`. This+  can be useful when debugging tactics that may be affected by whether or not+  a particular definition is being inlined.++### Syntax++* Do-notation.++  There is now builtin do-notation syntax. This means that `do` is a reserved+  keyword and cannot be used as an identifier.++  Do-blocks support lets and pattern matching binds. If the pattern in a bind+  is non-exhaustive the other patterns need to be handled in a `where`-clause+  (see example below).++  Example:++  ```agda+  filter : {A : Set} → (A → Bool) → List A → List A+  filter p xs = do+    x    ← xs+    true ← return (p x)+      where false → []+    return x+  ```++  Do-blocks desugar to `_>>=_` and `_>>_` before scope checking, so whatever+  definitions of these two functions are in scope of the do-block will be used.++  More precisely:++  - Simple bind++    ```agda+    do x ← m+       m'+    ```+    desugars to `m >>= λ x → m'`.++  - Pattern bind++    ```agda+    do p ← m where pᵢ → mᵢ+       m'+    ```+    desugars to `m >>= λ { p → m'; pᵢ → mᵢ }`, where `pᵢ → mᵢ` is an arbitrary+    sequence of clauses and follows the usual layout rules for `where`. If `p`+    is exhaustive the `where` clause can be omitted.++  - Non-binding operation++    ```agda+    do m+       m'+    ```+    desugars to `m >> m'`.++  - Let++    ```agda+    do let ds+       m+    ```+    desugars to `let ds in m`, where `ds` is an arbitrary sequence of valid let-declarations.++  - The last statement in the do block must be a plain expression (no let or bind).++  Bind statements can use either `←` or `<-`. Neither of these are reserved, so+  code outside do-blocks can use identifiers with these names, but inside a+  do-block they would need to be used qualified or under different names.++* Infix let declarations. [Issue [#917](https://github.com/agda/agda/issues/917)]++  Let declarations can now be defined in infix (or mixfix) style. For instance:++  ```agda+    f : Nat → Nat+    f n = let _!_ : Nat → Nat → Nat+              x ! y = 2 * x + y+          in n ! n+  ```++* Overloaded pattern synonyms. [Issue [#2787](https://github.com/agda/agda/issues/2787)]++  Pattern synonyms can now be overloaded if all candidates have the same+  *shape*. Two pattern synonym definitions have the same shape if they are+  equal up to variable and constructor names. Shapes are checked at resolution+  time.++  For instance, the following is accepted:++  ```agda+    open import Agda.Builtin.Nat++    data List (A : Set) : Set where+      lnil  : List A+      lcons : A → List A → List A++    data Vec (A : Set) : Nat → Set where+      vnil  : Vec A 0+      vcons : ∀ {n} → A → Vec A n → Vec A (suc n)++    pattern [] = lnil+    pattern [] = vnil++    pattern _∷_ x xs = lcons x xs+    pattern _∷_ y ys = vcons y ys++    lmap : ∀ {A B} → (A → B) → List A → List B+    lmap f []       = []+    lmap f (x ∷ xs) = f x ∷ lmap f xs++    vmap : ∀ {A B n} → (A → B) → Vec A n → Vec B n+    vmap f []       = []+    vmap f (x ∷ xs) = f x ∷ vmap f xs+  ```++* If the file has no top-level module header, the first module+  cannot have the same name as the file.+  [Issues [#2808](https://github.com/agda/agda/issues/2808)+   and [#1077](https://github.com/agda/agda/issues/1077)]++  This means that the following file `File.agda` is rejected:+  ```agda+    -- no module header+    postulate A : Set+    module File where -- inner module with the same name as the file+  ```+  Agda reports `Illegal declarations(s) before top-level module`+  at the `postulate`.+  This is to avoid confusing scope errors in similar situations.++  If a top-level module header is inserted manually, the file is accepted:++  ```agda+    module _ where    -- user written module header+    postulate A : Set+    module File where -- inner module with the same name as the file, ok+  ```++### Pattern matching++* Forced constructor patterns.++  Constructor patterns can now be dotted to indicate that Agda should not case+  split on them but rather their value is forced by the type of the other+  patterns. The difference between this and a regular dot pattern is that+  forced constructor patterns can still bind variables in their arguments.+  For example,++  ```agda+    open import Agda.Builtin.Nat++    data Vec (A : Set) : Nat → Set where+      nil  : Vec A zero+      cons : (n : Nat) → A → Vec A n → Vec A (suc n)++    append : {A : Set} (m n : Nat) → Vec A m → Vec A n → Vec A (m + n)+    append .zero    n nil            ys = ys+    append (.suc m) n (cons .m x xs) ys = cons (m + n) x (append m n xs ys)+  ```++* Inferring the type of a function based on its patterns++  Agda no longer infers the type of a function based on the patterns used in+  its definition. [Issue [#2834](https://github.com/agda/agda/issues/2834)]++  This means that the following Agda program is no longer accepted:+  ```agda+    open import Agda.Builtin.Nat++    f : _ → _+    f zero    = zero+    f (suc n) = n+  ```+  Agda now requires the type of the argument of `f` to be given explicitly.++* Improved constraint solving for pattern matching functions++  Constraint solving for functions where each right-hand side has a distinct+  rigid head has been extended to also cover the case where some clauses return+  an argument of the function. A typical example is append on lists:++  ```agda+    _++_ : {A : Set} → List A → List A → List A+    []       ++ ys = ys+    (x ∷ xs) ++ ys = x ∷ (xs ++ ys)+  ```++  Agda can now solve constraints like `?X ++ ys == 1 ∷ ys` when `ys` is a+  neutral term.++* Record expressions translated to copatterns++  Definitions of the form++  ```agda+    f ps = record { f₁ = e₁; ..; fₙ = eₙ }+  ```++  are translated internally to use copatterns:++  ```agda+    f ps .f₁ = e₁+    ...+    f ps .fₙ = eₙ+  ```++  This means that `f ps` does not reduce, but thanks to η-equality the two+  definitions are equivalent.++  The change should lead to fewer big record expressions showing up in goal+  types, and potentially significant performance improvement in some cases.++  This may have a minor impact on with-abstraction and code using `--rewriting`+  since η-equality is not used in these cases.++* When using `with`, it is now allowed to replace any pattern from the parent+  clause by a variable in the with clause. For example:++  ```agda+    f : List ℕ → List ℕ+    f [] = []+    f (x ∷ xs) with x ≤? 10+    f xs | p = {!!}+  ```++  In the with clause, `xs` is treated as a let-bound variable with value+  `.x ∷ .xs` (where `.x : ℕ` and `.xs : List ℕ` are out of scope) and+  `p : Dec (.x ≤ 10)`.++  Since with-abstraction may change the type of variables, instantiations+  of variables in the with clause are type checked again after with-abstraction.++### Builtins++* Added support for built-in 64-bit machine words.++  These are defined in `Agda.Builtin.Word` and come with two primitive+  operations to convert to and from natural numbers.++  ```agda+    Word64 : Set+    primWord64ToNat   : Word64 → Nat+    primWord64FromNat : Nat → Word64+  ```++  Converting to a natural number is the trivial embedding, and converting from a natural number+  gives you the remainder modulo 2^64. The proofs of these theorems are not+  primitive, but can be defined in a library using `primTrustMe`.++  Basic arithmetic operations can be defined on `Word64` by converting to+  natural numbers, peforming the corresponding operation, and then converting+  back. The compiler will optimise these to use 64-bit arithmetic. For+  instance,++  ```agda+    addWord : Word64 → Word64 → Word64+    addWord a b = primWord64FromNat (primWord64ToNat a + primWord64ToNat b)++    subWord : Word64 → Word64 → Word64+    subWord a b = primWord64FromNat (primWord64ToNat a + 18446744073709551616 - primWord64ToNat b)+  ```++  These compiles (in the GHC backend) to addition and subtraction on+  `Data.Word.Word64`.++* New primitive primFloatLess and changed semantics of primFloatNumericalLess.++  `primFloatNumericalLess` now uses standard IEEE `<`, so for instance+  `NaN < x = x < NaN = false`.++  On the other hand `primFloatLess` provides a total order on `Float`, with+  `-Inf < NaN < -1.0 < -0.0 < 0.0 < 1.0 < Inf`.++* The `SIZEINF` builtin is now given the name `∞` in+  `Agda.Builtin.Size` [Issue+  [#2931](https://github.com/agda/agda/issues/2931)].++  Previously it was given the name `ω`.++### Reflection++* New TC primitive: `declarePostulate`. [Issue+  [#2782](https://github.com/agda/agda/issues/2782)]++  ```agda+    declarePostulate : Arg Name → Type → TC ⊤+  ```++  This can be used to declare new postulates. The Visibility of the+  Arg must not be hidden. This feature fails when executed with+  `--safe` flag from command-line.++Pragmas and options+-------------------++* The `--caching` option is ON by default and is also a valid pragma.+  Caching can (sometimes) speed up re-typechecking in `--interaction`+  mode by reusing the result of the previous typechecking for the+  prefix of the file that has not changed (with a granularity at the+  level of declarations/mutual blocks).++  It can be turned off by passing ```--no-caching``` to ```agda``` or+  with the following at the top of your file.++  ```agda+    {-# OPTIONS --no-caching #-}+  ```++* The `--sharing` and `--no-sharing` options have been deprecated and do+  nothing.++  Compile-time evaluation is now always call-by-need.++* BUILTIN pragmas can now appear before the top-level module header+  and in parametrized modules.+  [Issue [#2824](https://github.com/agda/agda/issues/2824)]+  ```agda+    {-# OPTIONS --rewriting #-}+    open import Agda.Builtin.Equality+    {-# BUILTIN REWRITE _≡_ #-}  -- here+    module TopLevel (A : Set) where+    {-# BUILTIN REWRITE _≡_ #-}  -- or here+  ```+  Note that it is still the case that built-ins cannot be bound if+  they depend on module parameters from an enclosing module. For+  instance, the following is illegal:+  ```agda+    module _ {a} {A : Set a} where+      data _≡_ (x : A) : A → Set a where+        refl : x ≡ x+      {-# BUILTIN EQUALITY _≡_ #-}+  ```++* Builtin `NIL` and `CONS` have been merged with `LIST`.++  When binding the `LIST` builtin, `NIL` and `CONS` are bound to+  the appropriate constructors automatically. This means that instead+  of writing++  ```agda+  {-# BUILTIN LIST List #-}+  {-# BUILTIN NIL  []   #-}+  {-# BUILTIN CONS _∷_  #-}+  ```++  you just write++  ```agda+  {-# BUILTIN LIST List #-}+  ```++  Attempting to bind `NIL` or `CONS` results in a warning and has otherwise no+  effect.++* The `--no-unicode` pragma prevents Agda from introducing unicode characters+  when pretty printing a term. Lambda, Arrows and Forall quantifiers are all+  replaced by their ascii only version. Instead of resorting to subscript+  suffixes, Agda uses ascii digit characters.++* New option `--inversion-max-depth=N`.++  The depth is used to avoid looping due to inverting pattern matching for+  unsatisfiable constraints [Issue [#431](https://github.com/agda/agda/issues/431)].+  This option is only expected to be necessary in pathological cases.++* New option `--no-print-pattern-synonyms`.++  This disables the use of pattern synonyms in output from Agda.+  See [Issue [#2902](https://github.com/agda/agda/issues/2902)] for situations+  where this might be desirable.++* New fine-grained control over the warning machinery: ability to (en/dis)able+  warnings on a one-by-one basis.++* The command line option `--help` now takes an optional argument which+  allows the user to request more specific usage information about particular+  topics. The only one added so far is `warning`.++* New pragma NOINLINE.++  ```agda+  {-# NOINLINE f #-}+  ```++  Disables automatic inlining of `f`.++* New pragma WARNING_ON_USAGE++  ```+  {-# WARNING_ON_USAGE QName Message #}+  ```++  Prints Message whenever QName is used.++Emacs mode+----------++* Banana brackets have been added to the Agda input method.+  ```+    \((   #x2985  LEFT  WHITE PARENTHESIS+    \))   #x2986  RIGHT WHITE PARENTHESIS+  ```++* Result splitting will introduce the trailing hidden arguments,+  if there is nothing else todo+  [Issue [#2871](https://github.com/agda/agda/issues/2871)].+  Example:+  ```agda+    data Fun (A : Set) : Set where+      mkFun : (A → A) → Fun A++    test : {A : Set} → Fun A+    test = ?++  ```+  Splitting on the result here (`C-c C-c RET`) will append+  `{A}` to the left hand side.+  ```agda+    test {A} = ?+  ```++* Light highlighting is performed dynamically, even if the file is not+  loaded [Issue [#2794](https://github.com/agda/agda/issues/2794)].++  This light highlighting is based on the token stream generated by+  Agda's lexer: the code is only highlighted if the file is lexically+  correct. If the Agda backend is not busy with something else, then+  the code is highlighted automatically in certain situations:++  * When the file is saved.++  * When Emacs has been idle, continuously, for a certain period of+    time (by default 0.2 s) after the last modification of the file,+    and the file has not been saved (or marked as being unmodified).+    This functionality can be turned off, and the time period can be+    customised.++* Highlighting of comments is no longer handled by Font Lock mode+  [Issue [#2794](https://github.com/agda/agda/issues/2794)].++* The Emacs mode's syntax table has been changed.++  Previously `_` was treated as punctuation. Now it is treated in the+  same way as most other characters: if the standard syntax table+  assigns it the syntax class "whitespace", "open parenthesis" or+  "close parenthesis", then it gets that syntax class, and otherwise+  it gets the syntax class "word constituent".++Compiler backends+-----------------++* The GHC backend now automatically compiles BUILTIN LIST to Haskell lists.++  This means that it's no longer necessary to give a COMPILE GHC pragma for the+  builtin list type. Indeed, doing so has no effect on the compilation and+  results in a warning.++* The GHC backend performance improvements.++  Generated Haskell code now contains approximate type signatures, which lets+  GHC get rid of many of the `unsafeCoerce`s. This leads to performance+  improvements of up to 50% of compiled code.++* The GHC backend now compiles the `INFINITY`, `SHARP` and `FLAT`+  builtins in a different way [Issue+  [#2909](https://github.com/agda/agda/issues/2909)].++  Previously these were compiled to (basically) nothing. Now the+  `INFINITY` builtin is compiled to `Infinity`, available from+  `MAlonzo.RTE`:++  ```haskell+  data Inf a            = Sharp { flat :: a }+  type Infinity level a = Inf a+  ```++  The `SHARP` builtin is compiled to `Sharp`, and the `FLAT` builtin+  is (by default) compiled to a corresponding destructor.++  Note that code that interacts with Haskell libraries may have to be+  updated. As an example, here is one way to print colists of+  characters using the Haskell function `putStr`:++  ```agda+  open import Agda.Builtin.Char+  open import Agda.Builtin.Coinduction+  open import Agda.Builtin.IO+  open import Agda.Builtin.Unit++  data Colist {a} (A : Set a) : Set a where+    []  : Colist A+    _∷_ : A → ∞ (Colist A) → Colist A++  {-# FOREIGN GHC+    data Colist a    = Nil | Cons a (MAlonzo.RTE.Inf (Colist a))+    type Colist' l a = Colist a++    fromColist :: Colist a -> [a]+    fromColist Nil         = []+    fromColist (Cons x xs) = x : fromColist (MAlonzo.RTE.flat xs)+    #-}++  {-# COMPILE GHC Colist = data Colist' (Nil | Cons) #-}++  postulate+    putStr : Colist Char → IO ⊤++  {-# COMPILE GHC putStr = putStr . fromColist #-}+  ```++* `COMPILE GHC` pragmas have been included for the size primitives+  [Issue [#2879](https://github.com/agda/agda/issues/2879)].++LaTeX backend+-------------++* The `code` environment can now take arguments [Issues+  [#2744](https://github.com/agda/agda/issues/2744) and+  [#2453](https://github.com/agda/agda/issues/2453)].++  Everything from \begin{code} to the end of the line is preserved in+  the generated LaTeX code, and not treated as Agda code.++  The default implementation of the `code` environment recognises one+  optional argument, `hide`, which can be used for code that should be+  type-checked, but not typeset:+  ```latex+  \begin{code}[hide]+    open import Module+  \end{code}+  ```++  The `AgdaHide` macro has not been removed, but has been deprecated+  in favour of `[hide]`.++* The `AgdaSuppressSpace` and `AgdaMultiCode` environments no longer+  take an argument.++  Instead some documents need to be compiled multiple times.++* The `--count-clusters` flag can now be given in `OPTIONS` pragmas.++* The `nofontsetup` option to the LaTeX package `agda` was broken, and+  has (hopefully) been fixed+  [Issue [#2773](https://github.com/agda/agda/issues/2773)].++  Fewer packages than before are loaded when `nofontsetup` is used,+  see `agda.sty` for details. Furthermore, if LuaLaTeX or XeLaTeX are+  not used, then the font encoding is no longer changed.++* The new option `noinputencodingsetup` instructs the LaTeX package+  `agda` to not change the input encoding, and to not load the `ucs`+  package.++* Underscores are now typeset using `\AgdaUnderscore{}`.++  The default implementation is `\_` (the command that was previously+  generated for underscores). Note that it is possible to override+  this implementation.++* OtherAspects (unsolved meta variables, catchall clauses, etc.) are+  now correctly highlighted in the LaTeX backend (and the HTML one).+  [Issue [#2474](https://github.com/agda/agda/issues/2474)]++* `postprocess-latex.pl` does not add extra spaces around tagged `\Agda*{}`+  commands anymore.++HTML backend+------------++* An identifier (excluding bound variables),+  gets the identifier itself as an anchor,+  _in addition_ to the file position+  [Issue [#2756](https://github.com/agda/agda/issues/2756)].+  In Agda 2.5.3, the identifier anchor would _replace_ the file position anchor+  [Issue [#2604](https://github.com/agda/agda/issues/2604)].++  Symbolic anchors look like+  ```html+  <a id="test1">+  <a id="M.bla">+  ```+  while file position anchors just give the character position in the file:+  ```html+  <a id="42">+  ```++  Top-level module names do not get a symbolic anchor, since the position of+  a top-level module is defined to be the beginning of the file.++  Example:++  ```agda+  module Issue2604 where   -- Character position anchor++  test1 : Set₁             -- Issue2604.html#test1+  test1 = bla+    where+    bla = Set              -- Only character position anchor++  test2 : Set₁             -- Issue2604.html#test2+  test2 = bla+    where+    bla = Set              -- Only character position anchor++  test3 : Set₁             -- Issue2604.html#test3+  test3 = bla+    module M where         -- Issue2604.html#M+    bla = Set              -- Issue2604.html#M.bla++  module NamedModule where -- Issue2604.html#NamedModule+    test4 : Set₁           -- Issue2604.html#NamedModule.test4+    test4 = M.bla++  module _ where           -- Only character position anchor+    test5 : Set₁           -- Only character position anchor+    test5 = M.bla+  ```++List of closed issues+---------------------++For 2.5.4, the following issues have been closed+(see [bug tracker](https://github.com/agda/agda/issues)):++  - [#351](https://github.com/agda/agda/issues/351): Constraint solving for irrelevant metas+  - [#421](https://github.com/agda/agda/issues/421): Higher order positivity+  - [#431](https://github.com/agda/agda/issues/431): Constructor-headed function makes type-checker diverge+  - [#437](https://github.com/agda/agda/issues/437): Detect when something cannot be a function type+  - [#488](https://github.com/agda/agda/issues/488): Refining on user defined syntax mixes up the order of the subgoals+  - [#681](https://github.com/agda/agda/issues/681): Lack of visual state indicators in new Emacs mode+  - [#689](https://github.com/agda/agda/issues/689): Contradictory constraints should yield error+  - [#708](https://github.com/agda/agda/issues/708): Coverage checker not taking literal patterns into account properly+  - [#875](https://github.com/agda/agda/issues/875): Nonstrict irrelevance violated by implicit inference+  - [#964](https://github.com/agda/agda/issues/964): Allow unsolved metas in imported files+  - [#987](https://github.com/agda/agda/issues/987): --html anchors could be more informative+  - [#1054](https://github.com/agda/agda/issues/1054): Inlined Agda code in LaTeX backend+  - [#1131](https://github.com/agda/agda/issues/1131): Infix definitions not allowed in let definitions+  - [#1169](https://github.com/agda/agda/issues/1169): Auto fails with non-terminating function+  - [#1268](https://github.com/agda/agda/issues/1268): Hard to print type of variable if the type starts with an instance argument+  - [#1384](https://github.com/agda/agda/issues/1384): Order of constructor arguments matters for coverage checker+  - [#1425](https://github.com/agda/agda/issues/1425): Instances with relevant recursive instance arguments are not considered in irrelevant positions+  - [#1548](https://github.com/agda/agda/issues/1548): Confusing error about ambiguous definition with parametrized modules+  - [#1884](https://github.com/agda/agda/issues/1884): what is the format of the libraries and defaults files+  - [#1906](https://github.com/agda/agda/issues/1906): Possible performance problem+  - [#2056](https://github.com/agda/agda/issues/2056): Cannot instantiate meta to solution...: Pattern checking done too early in where block+  - [#2067](https://github.com/agda/agda/issues/2067): Display forms in parameterised module too general+  - [#2183](https://github.com/agda/agda/issues/2183): Allow splitting on dotted variables+  - [#2226](https://github.com/agda/agda/issues/2226): open {{...}} gets hiding wrong+  - [#2255](https://github.com/agda/agda/issues/2255): Performance issue with deeply-nested lambdas+  - [#2306](https://github.com/agda/agda/issues/2306): Commands in the emacs-mode get confused if we add question marks to the file+  - [#2384](https://github.com/agda/agda/issues/2384): More fine-grained blocking in constraint solver+  - [#2401](https://github.com/agda/agda/issues/2401): LaTeX backend error+  - [#2404](https://github.com/agda/agda/issues/2404): checkType doesn't accept a type-checking definition checked with the same type+  - [#2420](https://github.com/agda/agda/issues/2420): Failed to solve level constraints in record type with hole+  - [#2421](https://github.com/agda/agda/issues/2421): After emacs starts up, Agda does not process file without restart of Agda+  - [#2436](https://github.com/agda/agda/issues/2436): Agda allows coinductive records with eta-equality+  - [#2450](https://github.com/agda/agda/issues/2450): Irrelevant variables are pruned too eagerly+  - [#2474](https://github.com/agda/agda/issues/2474): The LaTeX and HTML backends do not highlight (all) unsolved metas+  - [#2484](https://github.com/agda/agda/issues/2484): Regression related to sized types+  - [#2526](https://github.com/agda/agda/issues/2526): Better documentation of record modules+  - [#2536](https://github.com/agda/agda/issues/2536): UTF8 parsed incorrectly for literate agda files+  - [#2565](https://github.com/agda/agda/issues/2565): Options for the interaction action give to keep the overloaded literals and sections?+  - [#2576](https://github.com/agda/agda/issues/2576): Shadowing data decl by data sig produces Missing type signature error+  - [#2594](https://github.com/agda/agda/issues/2594): Valid partial cover rejected: "Cannot split on argument of non-datatype"+  - [#2600](https://github.com/agda/agda/issues/2600): Stack complains about Agda.cabal+  - [#2607](https://github.com/agda/agda/issues/2607): Instance search confused when an instance argument is sourced from a record+  - [#2617](https://github.com/agda/agda/issues/2617): Installation instructions+  - [#2623](https://github.com/agda/agda/issues/2623): Incorrect indentation when \AgdaHide is used+  - [#2634](https://github.com/agda/agda/issues/2634): Fixity declaration ignored in definitions in record+  - [#2636](https://github.com/agda/agda/issues/2636): The positivity checker complains when a new definition is added in the same where clause+  - [#2640](https://github.com/agda/agda/issues/2640): Unifier dots the relevant pattern variables when it should dot the irrelevant ones+  - [#2668](https://github.com/agda/agda/issues/2668): Changing the visibility of a module parameter breaks `with`+  - [#2728](https://github.com/agda/agda/issues/2728): Bad interaction between caching and the warning machinery+  - [#2738](https://github.com/agda/agda/issues/2738): Update Stackage LTS from 9.1 to version supporting Alex 3.2.3+  - [#2744](https://github.com/agda/agda/issues/2744): It should be possible to give arguments to the code environment+  - [#2745](https://github.com/agda/agda/issues/2745): Broken build with GHC 7.8.4 due to (new) version 1.2.2.0 of hashtables+  - [#2749](https://github.com/agda/agda/issues/2749): Add --no-unicode cli option to Agda+  - [#2751](https://github.com/agda/agda/issues/2751): Unsolved constraints, but no highlighting+  - [#2752](https://github.com/agda/agda/issues/2752): Mutual blocks inside instance blocks+  - [#2753](https://github.com/agda/agda/issues/2753): Unsolved constraint, related to instance arguments and sized types+  - [#2756](https://github.com/agda/agda/issues/2756): HTML backend generates broken links+  - [#2758](https://github.com/agda/agda/issues/2758): Relevant meta is instantiated with irrelevant solution+  - [#2759](https://github.com/agda/agda/issues/2759): Empty mutual blocks should be warning rather than error+  - [#2762](https://github.com/agda/agda/issues/2762): Automatically generate DISPLAY pragmas to fold pattern synonyms+  - [#2763](https://github.com/agda/agda/issues/2763): Internal Error at "src/full/Agda/TypeChecking/Abstract.hs:138"+  - [#2765](https://github.com/agda/agda/issues/2765): Inferred level expressions are often "reversed"+  - [#2769](https://github.com/agda/agda/issues/2769): Agda prints ill-formed expression, record argument dropped+  - [#2771](https://github.com/agda/agda/issues/2771): Erroneous 'with' error message+  - [#2773](https://github.com/agda/agda/issues/2773): The nofontsetup option does not work as advertised+  - [#2775](https://github.com/agda/agda/issues/2775): Irrelevance to be taken into account in 'with' abstraction.+  - [#2776](https://github.com/agda/agda/issues/2776): Dotted variable in inferred type+  - [#2780](https://github.com/agda/agda/issues/2780): Improve level constraint solving for groups of inequality constraints+  - [#2782](https://github.com/agda/agda/issues/2782): Extending Agda reflection to introduce postulates+  - [#2785](https://github.com/agda/agda/issues/2785): internal error @ ConcreteToAbstract.hs:721+  - [#2787](https://github.com/agda/agda/issues/2787): Overloaded pattern synonyms+  - [#2792](https://github.com/agda/agda/issues/2792): Safe modules can sometimes not be imported from unsafe modules+  - [#2794](https://github.com/agda/agda/issues/2794): Using \texttt{-} destroys code coloring in literate file+  - [#2796](https://github.com/agda/agda/issues/2796): Overloaded (inherited) projection resolution fails with parametrized record+  - [#2798](https://github.com/agda/agda/issues/2798): The LaTeX backend ignores the "operator" aspect+  - [#2802](https://github.com/agda/agda/issues/2802): Printing of overloaded functions broken due to eager normalization of projections+  - [#2803](https://github.com/agda/agda/issues/2803): Case splitting loses names of hidden arguments+  - [#2808](https://github.com/agda/agda/issues/2808): Confusing error when inserting declaration before top-level module+  - [#2810](https://github.com/agda/agda/issues/2810): Make `--caching` a pragma option+  - [#2811](https://github.com/agda/agda/issues/2811): OPTION --caching allowed in file (Issue #2810)+  - [#2819](https://github.com/agda/agda/issues/2819): Forcing analysis doesn't consider relevance+  - [#2821](https://github.com/agda/agda/issues/2821): BUILTIN BOOL gremlin+  - [#2824](https://github.com/agda/agda/issues/2824): Allow {-# BUILTIN #-} in preamble and in parametrized modules+  - [#2826](https://github.com/agda/agda/issues/2826): Case splitting on earlier variable uses duplicate variable name+  - [#2827](https://github.com/agda/agda/issues/2827): Variables off in with-clauses.  Parameter refinement?+  - [#2831](https://github.com/agda/agda/issues/2831): NO_POSITIVITY_CHECK pragma can be written before a mutual block without data or record types+  - [#2832](https://github.com/agda/agda/issues/2832): BUILTIN NIL and CONS are not needed+  - [#2834](https://github.com/agda/agda/issues/2834): Disambiguation of type based on pattern leads to non-unique meta solution+  - [#2836](https://github.com/agda/agda/issues/2836): The Emacs mode does not handle .lagda.tex files+  - [#2840](https://github.com/agda/agda/issues/2840): Internal error in positivity with modules/datatype definitions+  - [#2841](https://github.com/agda/agda/issues/2841): Opting out of idiom brackets+  - [#2844](https://github.com/agda/agda/issues/2844): Root documentation URL redirects to version 2.5.2+  - [#2849](https://github.com/agda/agda/issues/2849): Internal error at absurd pattern followed by `rewrite`+  - [#2854](https://github.com/agda/agda/issues/2854): Agda worries about possibly empty type of sizes even when no builtins for size are active+  - [#2855](https://github.com/agda/agda/issues/2855): Single-clause definition is both unreachable and incomplete+  - [#2856](https://github.com/agda/agda/issues/2856): Panic: unbound variable+  - [#2859](https://github.com/agda/agda/issues/2859): Error "pattern variable shadows constructor" caused by parameter refinement+  - [#2862](https://github.com/agda/agda/issues/2862): inconsistency from a mutual datatype declaration and module definition+  - [#2867](https://github.com/agda/agda/issues/2867): Give does not insert parenthesis for module parameters+  - [#2868](https://github.com/agda/agda/issues/2868): With --postfix-projections, record fields are printed preceded by a dot when working within the record+  - [#2870](https://github.com/agda/agda/issues/2870): Lexical error for \- (hyphen)+  - [#2871](https://github.com/agda/agda/issues/2871): Introduce just trailing hidden arguments by result splitting+  - [#2873](https://github.com/agda/agda/issues/2873): Refinement problem in presence of overloaded constructors+  - [#2874](https://github.com/agda/agda/issues/2874): Internal error in src/full/Agda/TypeChecking/Coverage/Match.hs:312+  - [#2878](https://github.com/agda/agda/issues/2878): Support for GHC 8.4.1+  - [#2879](https://github.com/agda/agda/issues/2879): Include COMPILE GHC pragmas for size primitives+  - [#2881](https://github.com/agda/agda/issues/2881): Internal error in BasicOps+  - [#2883](https://github.com/agda/agda/issues/2883): "internal error in TypeChecking/Substitute.hs:379"+  - [#2884](https://github.com/agda/agda/issues/2884): Missing PDF user manual in the tarball+  - [#2888](https://github.com/agda/agda/issues/2888): Internal error caused by new forcing translation+  - [#2894](https://github.com/agda/agda/issues/2894): Unifier tries to eta expand non-eta record+  - [#2896](https://github.com/agda/agda/issues/2896): Unifier throws away pattern+  - [#2897](https://github.com/agda/agda/issues/2897): Internal error for local modules with refined parameters+  - [#2904](https://github.com/agda/agda/issues/2904): No tab completion for GHCNoMain+  - [#2906](https://github.com/agda/agda/issues/2906): Confusing "cannot be translated to a Haskell type" error message+  - [#2908](https://github.com/agda/agda/issues/2908): primForce is compiled away+  - [#2909](https://github.com/agda/agda/issues/2909): Agda uses newtypes incorrectly, causing wellformed programs to loop+  - [#2911](https://github.com/agda/agda/issues/2911): Inferring missing instance clause panics in refined context+  - [#2912](https://github.com/agda/agda/issues/2912): Add fine-grained control over the displayed warnings+  - [#2914](https://github.com/agda/agda/issues/2914): Slicing ignores as pragma?+  - [#2916](https://github.com/agda/agda/issues/2916): The GHC backend generates code with an incorrect number of constructor arguments+  - [#2917](https://github.com/agda/agda/issues/2917): Very slow due to unsolved size?+  - [#2919](https://github.com/agda/agda/issues/2919): Internal error in Agda.TypeChecking.Forcing+  - [#2921](https://github.com/agda/agda/issues/2921): COMPILE data for data types with erased constructor arguments+  - [#2923](https://github.com/agda/agda/issues/2923): Word.agda not included as builtin+  - [#2925](https://github.com/agda/agda/issues/2925): Allow adding the same rewrite rules multiple times+  - [#2927](https://github.com/agda/agda/issues/2927): Panic related to sized types+  - [#2928](https://github.com/agda/agda/issues/2928): Internal error in Agda.TypeChecking.Rules.LHS+  - [#2931](https://github.com/agda/agda/issues/2931): Rename Agda.Builtin.Size.ω to ∞?+  - [#2941](https://github.com/agda/agda/issues/2941): "coinductive" record inconsistent+  - [#2944](https://github.com/agda/agda/issues/2944): Regression, seemingly related to record expressions+  - [#2945](https://github.com/agda/agda/issues/2945): Inversion warning in code that used to be accepted+  - [#2947](https://github.com/agda/agda/issues/2947): Internal error in Agda.TypeChecking.Forcing+  - [#2952](https://github.com/agda/agda/issues/2952): Wrong compilation of pattern matching to Haskell+  - [#2953](https://github.com/agda/agda/issues/2953): Generated Haskell code does not typecheck+  - [#2954](https://github.com/agda/agda/issues/2954): Pattern matching on string gives unexpected unreachable clause+  - [#2957](https://github.com/agda/agda/issues/2957): Support for async 2.2.1+  - [#2958](https://github.com/agda/agda/issues/2958): `as` names being duplicated in buffer after `with`+  - [#2959](https://github.com/agda/agda/issues/2959): Repeating a successful command after revert + reload fails with caching enabled+  - [#2960](https://github.com/agda/agda/issues/2960): Uncommenting indented lines doesn't work+  - [#2963](https://github.com/agda/agda/issues/2963): Extended lambdas bypass positivity checking in records+  - [#2966](https://github.com/agda/agda/issues/2966): Internal error in Auto+  - [#2968](https://github.com/agda/agda/issues/2968): Bad Interaction with copatterns and eta?, leads to ill-typed terms in error messages.+  - [#2971](https://github.com/agda/agda/issues/2971): Copattern split with `--no-irrelevant-projections` panics+  - [#2974](https://github.com/agda/agda/issues/2974): Copatterns break canonicity+  - [#2975](https://github.com/agda/agda/issues/2975): Termination checker runs too early for definitions inside record (or: positivity checker runs too late)+  - [#2976](https://github.com/agda/agda/issues/2976): Emacs mode reports errors in connection with highlighting comments+  - [#2978](https://github.com/agda/agda/issues/2978): Double solving of meta+  - [#2985](https://github.com/agda/agda/issues/2985): The termination checker accepts non-terminating code+  - [#2989](https://github.com/agda/agda/issues/2989): Internal error when checking record match in let expr+  - [#2990](https://github.com/agda/agda/issues/2990): Performance regression related to the abstract machine+  - [#2994](https://github.com/agda/agda/issues/2994): Solution accepted in hole is subsequently rejected on reload+  - [#2996](https://github.com/agda/agda/issues/2996): Internal error with -v tc.cover:20+  - [#2997](https://github.com/agda/agda/issues/2997): Internal error in Agda.TypeChecking.Rules.LHS+  - [#2998](https://github.com/agda/agda/issues/2998): Regression: With clause pattern x is not an instance of its parent pattern "eta expansion of x"+  - [#3002](https://github.com/agda/agda/issues/3002): Spurious 1 after simplification+  - [#3004](https://github.com/agda/agda/issues/3004): Agda hangs on extended lambda+  - [#3007](https://github.com/agda/agda/issues/3007): Internal error in Parser+  - [#3012](https://github.com/agda/agda/issues/3012): Internal Error at : "src/full/Agda/TypeChecking/Reduce/Fast.hs:1030"+  - [#3014](https://github.com/agda/agda/issues/3014): Internal error in Rules.LHS+  - [#3020](https://github.com/agda/agda/issues/3020): Missing highlighting in record modules+  - [#3023](https://github.com/agda/agda/issues/3023): Support for GHC 8.4.2+  - [#3024](https://github.com/agda/agda/issues/3024): Postfix projection patterns not highlighted correctly with agda --latex+  - [#3030](https://github.com/agda/agda/issues/3030): [ warning ] user defined warnings+  - [#3031](https://github.com/agda/agda/issues/3031): Eta failure for record meta with irrelevant fields+  - [#3033](https://github.com/agda/agda/issues/3033): Giving and solving don't insert parenthesis for applications in dot pattern+  - [#3044](https://github.com/agda/agda/issues/3044): Internal error in src/full/Agda/TypeChecking/Substitute/Class.hs:209+  - [#3045](https://github.com/agda/agda/issues/3045): GHC backend generates type without enough arguments+  - [#3046](https://github.com/agda/agda/issues/3046): do-notation causes parse errors in subsequent where clauses+  - [#3049](https://github.com/agda/agda/issues/3049): Positivity unsoundness+  - [#3050](https://github.com/agda/agda/issues/3050): We revert back to call-by-name during positivity checking+  - [#3051](https://github.com/agda/agda/issues/3051): Pattern synonyms should be allowed in mutual blocks+  - [#3052](https://github.com/agda/agda/issues/3052): Another recent inference change+  - [#3062](https://github.com/agda/agda/issues/3062): Literal match does not respect first-match semantics+  - [#3063](https://github.com/agda/agda/issues/3063): Internal error in Agda.TypeChecking.Forcing+  - [#3064](https://github.com/agda/agda/issues/3064): Coverage checker bogus on literals combined with copatterns+  - [#3065](https://github.com/agda/agda/issues/3065): Internal error in coverage checker triggered by literal dot pattern+  - [#3067](https://github.com/agda/agda/issues/3067): checking hangs on invalid program+  - [#3072](https://github.com/agda/agda/issues/3072): invalid section printing+  - [#3074](https://github.com/agda/agda/issues/3074): Wrong hiding causes internal error in LHS checker+  - [#3075](https://github.com/agda/agda/issues/3075): Automatic inlining and tactics+  - [#3078](https://github.com/agda/agda/issues/3078): Error building with GHC 7.10.2: Missing transformers library+  - [#3079](https://github.com/agda/agda/issues/3079): Wrong parameter hiding for instance open+  - [#3080](https://github.com/agda/agda/issues/3080): Case splitting prints out-of-scope pattern synonyms+  - [#3082](https://github.com/agda/agda/issues/3082): Emacs mode regression: a ? inserted before existing hole hijacks its interaction point+  - [#3083](https://github.com/agda/agda/issues/3083): Wrong hiding in module application+  - [#3084](https://github.com/agda/agda/issues/3084): Changes to mode line do not take effect immediately+  - [#3085](https://github.com/agda/agda/issues/3085): Postpone checking a pattern let binding when type is blocked+  - [#3090](https://github.com/agda/agda/issues/3090): Internal error in parser when using parentheses in BUILTIN pragma+  - [#3096](https://github.com/agda/agda/issues/3096): Support GHC 8.4.3
+ doc/release-notes/2.6.0.1.md view
@@ -0,0 +1,22 @@+Release notes for Agda version 2.6.0.1+======================================++Installation and infrastructure+-------------------------------++* Added support for GHC 8.6.5.++List of all closed issues+-------------------------++For 2.6.0.1, the following issues have been closed+(see [bug tracker](https://github.com/agda/agda/issues)):++  -  [#3685](https://github.com/agda/agda/issues/3685): Support GHC 8.6.5+  -  [#3692](https://github.com/agda/agda/issues/3692): Omission of absurd patterns in automatically added absurd clauses causes too optimistic polarity.+  -  [#3694](https://github.com/agda/agda/issues/3694): Importing Agda.Builtin.Size in one module affects another module+  -  [#3696](https://github.com/agda/agda/issues/3696): Make `AgdaAny` polykinded?+  -  [#3697](https://github.com/agda/agda/issues/3697): Panic when checking non-Setω data definitions with --type-in-type+  -  [#3701](https://github.com/agda/agda/issues/3701): [ re agda/agda-stdlib#710 ] toNat for machine words is injective+  -  [#3731](https://github.com/agda/agda/issues/3731): GHC backend thinks that a constructor called 'main' is the main program+  -  [#3742](https://github.com/agda/agda/issues/3742): Strange error message for code that combines mutual and abstract
+ doc/release-notes/2.6.0.md view
@@ -0,0 +1,849 @@+Release notes for Agda version 2.6.0+====================================++Highlights+----------++* Added support for [Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.0/language/cubical.html)+  which adds new features such as univalence and higher inductive+  types to Agda.++* Added support for ML-style [automatic generalization of+  variables](https://agda.readthedocs.io/en/v2.6.0/language/generalization-of-declared-variables.html).++* Added a new sort ``Prop`` of [definitionally proof-irrelevant+  propositions](https://agda.readthedocs.io/en/v2.6.0/language/prop.html).++* The implementation of [instance+  search](https://agda.readthedocs.io/en/v2.6.0/language/instance-arguments.html)+  got a major overhaul and no longer supports overlapping instances+  (unless enabled by a flag).++Installation and infrastructure+-------------------------------++* Added support for GHC 8.6.4.++* Interface files for all builtin and primitive files are now+  re-generated each time Agda is installed.++Syntax+------++* Agda now supports implicit generalization of declared+  variables. Variables to be generalized can declared with the new+  keyword `variable`.  For example:++  ```agda+    postulate+      Con : Set++    variable+      Γ Δ θ : Con+  ```++  Declared variables are automatically generalized in type signatures,+  module telescopes and data type and record parameters and indices:++  ```agda+    postulate+      Sub : Con → Con → Set++      id  : Sub Γ Γ+   -- -- equivalent to+   -- id  : {Γ : Con} → Sub Γ Γ++      _∘_ : Sub Θ Δ → Sub Γ Θ → Sub Γ Δ+   -- -- equivalent to+   -- _∘_ : {Γ Δ Θ : Con} → Sub Θ Δ → Sub Γ Θ → Sub Γ Δ+  ```++  See the [user manual](https://agda.readthedocs.io/en/v2.6.0/language/generalization-of-declared-variables.html)+  for more details.++* Data type and record definitions separated from their type signatures can no+  longer repeat the types of the parameters, but can bind implicit parameters+  by name [Issue [#1886](https://github.com/agda/agda/issues/1886)].++  This is now allowed+  ```agda+    data D {a b} (A : Set a) (B : Set b) : Set (a ⊔ lsuc b)+    data D {b = b} A B where+      mkD : (A → Set b) → D A B+  ```+  but this is not+  ```agda+    data I (A : Set) : Set+    data I (A : Set) where+  ```++* The label used for named implicit arguments can now be different from the+  name of the bound variable [Issue [#952](https://github.com/agda/agda/issues/952)].++  Example,+  ```agda+    id₁ : {A = X : Set} → X → X+    id₁ x = x++    id₂ : ∀ {B = X} → X → X+    id₂ {B = X} x = id₁ {A = X} x++    test : Nat+    test = id₁ {A = Nat} 5 + id₂ {B = Nat} 6+  ```+  Only implicit and instance arguments can have a label and either or both of+  the label and bound variable can be `_`. Labeled bindings with a type+  signature can only bind a single variable. For instance, the type `Set` has+  to be repeated here:+  ```agda+    const : {A = X : Set} {B = Y : Set} → X → Y → X+    const x _ = x+  ```++* The rules for parsing of patterns have changed slightly [Issue+  [#3400](https://github.com/agda/agda/issues/3400)].++  Now projections are treated similarly to constructors: In a pattern+  name parts coming from projections can only be used as part of+  projections, constructors or pattern synonyms. They cannot be used+  as variables, or as part of the name of the defined value.++  Examples:++  * The following code used to be syntactically ambiguous, but is now+    parsed, because A can no longer be used as a variable:+    ```agda+    record R : Set₂ where+      field+        _A : Set₁++    open R++    r : R+    r A = Set+    ```++  * On the other hand the following code is no longer parsed:+    ```agda+    record R : Set₁ where+      field+        ⟨_+_⟩ : Set++    open R++    + : Set → Set+    + A = A+    ```+++Type checking+-------------++* Agda now supports a cubical mode which adds new features from+  [Cubical Type Theory](https://arxiv.org/abs/1611.02108), including+  univalence and higher inductive types. Option `--cubical` enables+  the cubical mode, and cubical primitives are defined in the module+  `Agda.Primitive.Cubical`.  See the [user+  manual](https://agda.readthedocs.io/en/v2.6.0/language/cubical.html)+  for more info.++* Agda now supports the new sort ``Prop`` of [definitionally+  proof-irrelevant propositions](https://hal.inria.fr/hal-01859964).+  Option `--prop` enables the `Prop` universe but is off by default.+  Option `--no-prop` disables the `Prop` universe.  See the [user+  manual](https://agda.readthedocs.io/en/v2.6.0/language/prop.html)+  for more details.++  In the absense of `Prop`, the sort `Set` is the lowest sort, thus,+  the sort annotation `: Set` can be ommitted if the sort is+  constrained to be weakly below `Set`.  For instance:++  ```agda+  {-# OPTIONS --no-prop #-}++  data Wrap A : Set where+    wrap : A → Wrap A+  ```++  In contrast, when `--prop` is enabled the sort of `A` could be+  either `Set` or `Prop` so this code no longer typechecks.++* Agda now allows omitting absurd clauses in case one of the pattern+  variable inhabits an obviously empty type+  [Issue [#1086](https://github.com/agda/agda/issues/1086)].+  For example:+  ```agda+  f : Fin 1 → Nat+  f zero = 0+  -- f (suc ())   -- this clause is no longer required+  ```+  Absurd clauses are still required in case deep pattern matching is+  needed to expose the absurd variable, or if there are no non-absurd+  clauses.++  Due to the changes to the coverage checker required for this new+  feature, Agda will now sometimes construct a different case tree when+  there are multiple valid splitting orders. In some cases this may+  impact the constraints that Agda is able to solve (for example, see+  [#673](https://github.com/agda/agda-stdlib/pull/673) on the+  standard library).++* Since Agda 2.5.3, the hiding is considered part of the name in the+  insertion of implicit arguments.  Until Agda 2.5.2, the following+  code was rejected:+  ```agda+    test : {{X : Set}} {X : Set} → Set+    test {X = X} = X+  ```+  The rationale was that named argument `X` is given with the wrong hiding.+  The new rationale is that the hiding is considered part of the name,+  distinguishing `{{X}}` from `{X}`.+  This language change was accidential and has not been documented in+  the 2.5.3 release notes.++* Agda no longer allows case splitting on irrelevant arguments of+  record types (see Issue+  [#3056](https://github.com/agda/agda/issues/3056)).++* Metavariables in module telescopes are now sometimes frozen later+  [Issue [#1063](https://github.com/agda/agda/issues/1063)].++  Metavariables created in the types of module parameters used to be+  frozen right after the module's first mutual block had been+  type-checked (unless, perhaps, if the module itself was contained in+  a mutual block). Now they are instead frozen at the end of the+  module (with a similar caveat regarding an outer mutual block).++* When `--without-K` is enabled, Agda no longer allows datatypes with+  large indices. For example, the following definition of equality is+  now forbidden when `--without-K` is enabled:+  ```agda+    data _≡₀_ {ℓ} {A : Set ℓ} (x : A) : A → Set where+      refl : x ≡₀ x+  ```++* The termination checker now also looks for recursive calls in the type of definitions.+  This fixes an issue where Agda allowed very dependent types+  [Issue [#1556](https://github.com/agda/agda/issues/1556)].++  This change affects induction-induction, e.g.+  ```agda+    mutual+      data Cxt : Set where+        ε    :  Cxt+        _,_  :  (Γ : Cxt) (A : Ty Γ) → Cxt++      data Ty : (Γ : Cxt) → Set where+        u  :  ∀ Γ → Ty Γ+        Π  :  ∀ Γ (A : Ty Γ) (B : Ty (Γ , A)) → Ty Γ++    mutual+      f : Cxt → Cxt+      f ε        =  ε+      f (Γ , T)  =  (f Γ , g Γ T)++      g : ∀ Γ → Ty Γ → Ty (f Γ)+      g Γ (u .Γ)      =  u (f Γ)+      g Γ (Π .Γ A B)  =  Π (f Γ) (g Γ A) (g (Γ , A) B)++  ```+  The type of `g` contains a call `g Γ _ --> f Γ` which is now taken+  into account during termination checking.++Instance search+---------------++* Instance argument resolution now also applies when there are+  unconstrained metavariables in the type of the argument. For+  example, if there is a single instance `eqBool : Eq Bool` in scope,+  then an instance argument `{{eq : Eq _}}` will be solved to+  `eqBool`, setting the value of the metavariable `_` to `Bool` in the+  process.++* By default, Agda no longer allows overlapping instances. Two+  instances are defined to overlap if they could both solve the+  instance goal when given appropriate solutions for their recursive+  (instance) arguments. Agda used to choose between undecidable+  instances based on the result of recursive instance search, but this+  lead to an exponential slowdown in instance resolution. Overlapping+  instances can be enabled with the flag `--overlapping-instances`.++* Explicit arguments are no longer automatically turned into instance+  arguments for the purpose of recursive instance search. Instead,+  explicit arguments are left unresolved and will thus never be used+  for instance search.++  If an instance is declared which has explicit arguments, Agda will+  raise a warning that this instance will never be considered by+  instance search.++* Instance arguments that are already solved by conversion checking+  are no longer ignored by instance search. Thus the constructor of+  the unit type must now be explicitly be declared as an instance in+  order to be considered by instance search:+  ```agda+    record ⊤ : Set where+      instance constructor tt+  ```++* Instances are now (correctly) required to be in scope to be eligible+  (see Issue [#1913](https://github.com/agda/agda/issues/1913)+   and Issue [#2489](https://github.com/agda/agda/issues/2489)+  ).+  This means that you can no longer import instances from parameterised modules by+  ```agda+    import Some.Module Arg₁ Arg2+  ```+  without opening or naming the module.++Reflection+----------++* New TC primitive `noConstraints` [Issue+  [#2351](https://github.com/agda/agda/issues/2351)]:++  ```agda+    noConstraints : ∀ {a} {A : Set a} → TC A → TC A+  ```++  The computation `noConstraints m` fails if `m` gives rise to new,+  unsolved+  ["blocking"](https://github.com/agda/agda/blob/4900ef5fc61776381f3a5e9c94ef776375e9e1f1/src/full/Agda/TypeChecking/Monad/Constraints.hs#L160-L174)+  constraints.++* New TC primitive `runSpeculative` [Issue+  [#3346](https://github.com/agda/agda/issues/3346)]:++  ```+    runSpeculative : ∀ {a} {A : Set a} → TC (Σ A λ _ → Bool) → TC A+  ```++  The computation `runSpeculative m` runs `m` and either keeps the new+  TC state (if the second component is `true`) or resets to the old TC+  state (if it is `false`).+++Interaction and error reporting+-------------------------------++* A new command `agda2-elaborate-give` (C-c C-m) normalizes a goal input+  (it respects the C-u prefixes), type checks, and inserts the normalized+  term into the goal.++* 'Solve constraints' (C-c C-s) now turns unsolved metavariables into new+  interaction holes (see Issue [#2273](https://github.com/agda/agda/issues/2273)).++* Out-of-scope identifiers are no longer prefixed by a '.' dot [Issue+  [#3127](https://github.com/agda/agda/issues/3127)].  This notation+  could be confused with dot patterns, postfix projections, and+  irrelevance. Now Agda will do its best to make up fresh names for+  out-of-scope identifiers that do not conflict with any existing+  names. In addition, these names are marked as "(out of scope)" when+  printing the context.++  The change affects the printing of terms, e.g. in error messages and+  interaction, and the parsing of out-of-scope variables for+  case splitting (`C-c C-c` in emacs).++* Shadowed local variables are now assigned fresh names in error+  messages and interactive goals [Issue+  [#572](https://github.com/agda/agda/issues/572)]. For example,+  consider the following piece of code:+  ```agda+    postulate P : Set -> Set++    test : (B : Set) -> P B -> P B+    test = λ p p -> {!!}+  ```+  When asking for the goal type, Agda will now print the following:+  ```+    Goal: P p₁+    ————————————————————————————————————————————————————————————+    p      : P p₁+    p = p₁ : Set  (not in scope)+  ```+  Shadowed top-level identifiers are printed using the qualified name,+  for example in+  ```agda+    module M where++      postulate A : Set++      test : Set → A+      test A = {!!}+  ```+  Agda will now show the goal type as+  ```+    Goal: M.A+    ————————————————————————————————————————————————————————————+    A : Set+  ```++* When case splitting (`C-c C-c` in emacs), Agda will now filter out+  impossible cases (i.e. ones where at least one of the variables+  could be replaced by an absurd pattern `()`). If all the clauses+  produced by a case split are impossible, Agda will not filter out+  any of them.++Pragmas and options+-------------------++* Consistency checking of options used.++  Agda now checks that options used in imported modules are consistent+  with each other, e.g. a module using `--safe`, `--without-K`,+  `--no-universe-polymorphism` or `--no-sized-types` may only import+  modules with the same option, and modules using `--cubical` or+  `--prop` must in turn use the same option. If an interface file has+  been generated using different options compared to the current ones,+  Agda will now re-typecheck the file.+  [Issue [#2487](https://github.com/agda/agda/issues/2487)].++* New option `--cubical` to enable Cubical Agda.++* New option `--prop` to enable the ``Prop`` sort, and `--no-prop` to+  disable it (default).++* New options `--guardedness` and `--no-guardedness` [Issue+  [#1209](https://github.com/agda/agda/issues/1209)].++  Constructor-based guarded corecursion is now only (meant to be)+  allowed if the `--guardedness` option is active. This option is+  active by default. The combination of constructor-based guarded+  corecursion and sized types is not allowed if `--safe` is used,+  and activating `--safe` turns off both `--guardedness` and+  `--sized-types` (because this combination is known to be+  inconsistent in the current implementation). If you want to use+  either constructor-based guarded corecursion or sized types in+  safe mode, then you can use `--safe --guardedness` or `--safe+  --sized-types` respectively (in this order).++  The option `--no-guardedness` turns off constructor-based guarded+  corecursion.++* Option `--irrelevant-projections` is now off by default and+  not considered `--safe` any longer.+  Reason: There are consistency issues that may be systemic+  [Issue [#2170](https://github.com/agda/agda/issues/2170)].++* New option `--no-syntactic-equality` disables the syntactic equality+  shortcut used by the conversion checker. This will slow down+  typechecking in most cases, but makes the performance more+  predictable and stable under minor changes.++* New option `--overlapping-instances` enables overlapping instances+  by performing recursive instance search during pruning of instance+  candidates (this used to be the default behaviour). Overlapping+  instances can be disabled with `--no-overlapping-instances`+  (default).++* Option (and experimental feature)+  `--guardedness-preserving-type-constructors`+  has been removed.+  [Issue [#3180](https://github.com/agda/agda/issues/3180)].++* Deprecated options `--sharing` and `--no-sharing` now raise an error.++* New primitive `primErase`. It takes a proof of equality and returns a proof of+  the same equality. `primErase eq` reduces to `refl` on the diagonal. `trustMe`+  is not a primitive anymore, it is implemented using `primErase`.++  The primitive is declared in `Agda.Builtin.Equality.Erase`.++* The `REWRITE` builtin is now bound to the builtin equality type from+  `Agda.Builtin.Equality` in `Agda.Builtin.Equality.Rewrite` [Issue+  [#3318](https://github.com/agda/agda/issues/3318)].++* New primitives `primCharToNatInjective` and `primStringToListInjective`+  internalising the fact that `primCharToNat` and `primStringtoList` are+  injective functions. They are respectively bound in `Agda.Builtin.Char.Properties`+  and `Agda.Builtin.String.Properties`.++* The option `--only-scope-checking` is now allowed together with `--safe`.++* The option `--ignore-interfaces` no longer ignores the interfaces of+  builtin and primitive modules. For experts, there is the option+  `--ignore-all-interfaces` which also rechecks builtin and primitive+  files.++* The following deprecated compiler pragmas have been removed:++  ```+    {-# COMPILED f e #-}+    {-# COMPILED_TYPE A T #-}+    {-# COMPILED_DATA A D C1 .. CN #-}+    {-# COMPILED_DECLARE_DATA #-}+    {-# COMPILED_EXPORT f g #-}+    {-# IMPORT M #-}+    {-# HASKELL code #-}+    {-# COMPILED_UHC f e #-}+    {-# COMPILED_DATA_UHC A D C1 .. CN #-}+    {-# IMPORT_UHC M #-}+    {-# COMPILED_JS f e #-}+  ```++  See the [user manual](https://agda.readthedocs.io/en/v2.6.0/language/foreign-function-interface.html)+  for how to use the `COMPILE` and `FOREIGN` pragmas that replaced these in Agda 2.5.++### New warnings++* A declaration of the form `f : A` without an accompanying definition+  is no longer an error, but instead raises a warning.++* A clause that has both an absurd pattern and a right-hand side is no+  longer an error, but instead raises a warning.++* An import statement for `M` that mentions names not exported by `M`+  (in either `using`, `hiding`, or `renaming`) is no longer an+  error. Instead, Agda will raise a warning and ignore the names.++* Pragma, primitive, module or import statements in a mutual block+  are no longer errors. Instead, Agda will raise a warning and ignore+  these statements.++### Pragmas and options concerning universes++* New pragma `{-# NO_UNIVERSE_CHECK #-}`.++  The pragma `{-# NO_UNIVERSE_CHECK #-}` can be put in front of a data+  or record type to disable universe consistency checking locally.+  Example:+  ```agda+    {-# NO_UNIVERSE_CHECK #-}+    data U : Set where+      el : Set → U+  ```+  Like the similar pragmas for disabling termination and positivity+  checking, `{-# NO_UNIVERSE_CHECK #-}` cannot be used with `--safe`.++* New builtin `SETOMEGA`.++  Agda's top sort `Setω` is now defined as a builtin in `Agda.Primitive`+  and can be renamed when importing that module.++* New option `--omega-in-omega`.++  The option `--omega-in-omega` enables the typing rule `Setω : Setω`.+  Example:+  ```agda+  {-# OPTIONS --omega-in-omega #-}+  open import Agda.Primitive++  data Type : Setω where+    el : ∀ {ℓ} → Set ℓ → Type+  ```+  Like `--type-in-type`, this makes Agda inconsistent. However, code+  written using `--omega-in-omega` is still compatible with normal+  universe-polymorphic code and can be used in such files.++Emacs mode+----------++* Jump-to-definition now works for record field names in record expressions+  and patterns. [Issue [#3120](https://github.com/agda/agda/issues/3120)]+  ```agda+    record R : Set₂ where+      field f : Set₁++    exp : R+    exp = record { f = Set }++    pat : R → R+    pat r@record { f = X } = record r { f = X }+  ```+  Jump-to-definition (`M-.` or middle-click) on any of these `f`s+  now jumps to the field declaration.++* Commas "ʻ،⸲⸴⹁⹉、︐︑﹐﹑，､" and semi-colons "؛⁏፤꛶；︔﹔⍮⸵;" added+  to the input mode.++* It is now possible to customise the highlighting of more text in+  pragmas [Issue [#2452](https://github.com/agda/agda/issues/2452)].++  Some text was already highlighted. Now there is a specific face for+  the remaining text (`agda2-highlight-pragma-face`).++LaTeX backend+-------------++* The code environment has two new options, `inline` and `inline*`.++  These options are for typesetting inline code. The implementation of+  these options is a bit of a hack. Only use these options for+  typesetting a single line of code without multiple consecutive+  whitespace characters (except at the beginning of the line).++  When the option `inline*` is used space (`\AgdaSpace{}`) is added at+  the end of the code, and when `inline` is used space is not added.++* Now highlighting commands for things like "this is an unsolved+  meta-variable" are applied on the outside of highlighting commands+  for things like "this is a postulate" [Issue+  [#2474](https://github.com/agda/agda/issues/2474)].++  Example: Instead of generating+  `\AgdaPostulate{\AgdaUnsolvedMeta{F}}` Agda now generates+  `\AgdaUnsolvedMeta{\AgdaPostulate{F}}`.++* The package `agda.sty` no longer selects any fonts, and no longer+  changes the input or font encodings [Issue+  [#3224](https://github.com/agda/agda/issues/3224)].++  The new behaviour is the same as the old behaviour with the options+  `nofontsetup` and `noinputencodingsetup`. These options have been+  removed.++  One reason for this change is that several persons have received+  complaints from reviewers because they have unwittingly used+  non-standard fonts in submitted papers. Another is that the `utf8x`+  option to `inputenc` is now deprecated.++  Note that Agda code is now less likely to typeset properly out of+  the box. See the documentation for some hints about what to do if+  this affects you.++* Some text was by default typeset in math mode when LuaLaTeX or+  XeLaTeX were used, and in text mode when pdfLaTeX was used. Now text+  mode is the default for all of these engines.++* Typesetting of pragmas should now work better [Issue+  [#2452](https://github.com/agda/agda/issues/2452)].++  The `\AgdaOption` command and `AgdaOption` colour have been replaced+  by `\AgdaPragma` and `AgdaPragma`. The `\AgdaPragma` command is used+  where `\AgdaOption` used to be used (for certain options), but also+  in other cases (for other options and certain other text in+  pragmas).++* There is no longer any special treatment of the character `-` [Issue+  [#2452](https://github.com/agda/agda/issues/2452)].++  This might, depending on things like what font your are using, mean+  that the token `--` is typeset like an en dash (–). However, this is+  not the case for at least one common monospace font (in at least one+  setting).++* The default value of `\AgdaEmptySkip` has been changed from+  `\baselineskip` to `\abovedisplayskip`. This could mean that less+  vertical space is used to render empty lines in code blocks.++HTML backend+------------++* New option `--html-highlight=[code,all,auto]`.++  The option `--html-highlight=code` makes the HTML-backend generate+  files with:++  0. No HTML footer/header+  1. Agda codes highlighted+  2. Non-Agda code parts as-is+  3. Output file extension as-is (i.e. `.lagda.md` becomes `.md`)+  4. For ReStructuredText, a `.. raw:: html\n` will be inserted+     before every code blocks++  This makes it possible to use an ordinary Markdown/ReStructuredText+  processor to render the generated HTML.++  This will affect all the files involved in one compilation, making+  pure Agda code files rendered without HTML footer/header as well.+  To use `code` with literate Agda files and `all` with pure Agda+  files, use `--html-highlight=auto`, which means auto-detection.++  The old and default behaviour is still `--html-highlight=all`.++List of all closed issues+-------------------------++For 2.6.0, the following issues have been closed+(see [bug tracker](https://github.com/agda/agda/issues)):++  -  [#572](https://github.com/agda/agda/issues/572): Shadowed identifiers should be preceded by a dot when printed+  -  [#723](https://github.com/agda/agda/issues/723): Instance search needs to know whether a meta must be a function type+  -  [#758](https://github.com/agda/agda/issues/758): No highlighting for syntax declarations+  -  [#887](https://github.com/agda/agda/issues/887): Case-split causes problems for coverage checker+  -  [#952](https://github.com/agda/agda/issues/952): Parse named implicit pi {x = y : A} -> B+  -  [#1003](https://github.com/agda/agda/issues/1003): No highlighting for ambiguous instance argument+  -  [#1063](https://github.com/agda/agda/issues/1063): Freeze metas in module telescope after checking the module?+  -  [#1086](https://github.com/agda/agda/issues/1086): Make absurd patterns not needed at toplevel+  -  [#1209](https://github.com/agda/agda/issues/1209): Guardedness checker inconsistency with copatterns+  -  [#1581](https://github.com/agda/agda/issues/1581): Fields of opened records sometimes highlighted, sometimes not+  -  [#1602](https://github.com/agda/agda/issues/1602): NonStrict arguments should be allowed to occur relevantly in the type+  -  [#1706](https://github.com/agda/agda/issues/1706): Feature request: ML-style forall-generalization+  -  [#1764](https://github.com/agda/agda/issues/1764): Type in type and universe polymorphism+  -  [#1886](https://github.com/agda/agda/issues/1886): Second copies of telescopes not checked?+  -  [#1909](https://github.com/agda/agda/issues/1909): parameters are not dropped from reflected pattern lambda+  -  [#1913](https://github.com/agda/agda/issues/1913): Names that are not in scope can sometimes be candidates for instance resolution+  -  [#1995](https://github.com/agda/agda/issues/1995): Correct names in goal types after multiple renaming imports.+  -  [#2044](https://github.com/agda/agda/issues/2044): Better diagnosis for failed instance search+  -  [#2089](https://github.com/agda/agda/issues/2089): ''No such module'' is a rude error message for private modules+  -  [#2153](https://github.com/agda/agda/issues/2153): PDF version of Language Documentation on readthedocs lacks most Unicode characters+  -  [#2273](https://github.com/agda/agda/issues/2273): C-c C-s should put new goals instead of underscores for unknown subterms+  -  [#2351](https://github.com/agda/agda/issues/2351): expose noConstraints to reflection framework+  -  [#2452](https://github.com/agda/agda/issues/2452): The LaTeX backend does not handle options very well+  -  [#2473](https://github.com/agda/agda/issues/2473): Don't reread the source code without checking that it is unchanged+  -  [#2487](https://github.com/agda/agda/issues/2487): Options used for different modules must be consistent with each other, and options used when loading an interface must be consistent with those used when the interface was created+  -  [#2489](https://github.com/agda/agda/issues/2489): Where clauses in functions leak instances to global instance search+  -  [#2490](https://github.com/agda/agda/issues/2490): possible non-terminating inference of instance arguments?+  -  [#2513](https://github.com/agda/agda/issues/2513): Extensible syntax for function space annotations+  -  [#2548](https://github.com/agda/agda/issues/2548): Move the "Old Reference Manual" to the current documentation+  -  [#2563](https://github.com/agda/agda/issues/2563): Improve documentation and error reporting related to instance resolution (especially unconstrained metavariables)+  -  [#2579](https://github.com/agda/agda/issues/2579): Import statements with module instantiation should not trigger an error message+  -  [#2618](https://github.com/agda/agda/issues/2618): Reflection and pattern-matching lambdas+  -  [#2670](https://github.com/agda/agda/issues/2670): Instance arguments and multi-sorted algebras+  -  [#2757](https://github.com/agda/agda/issues/2757): Proposal: split non-strict relevance into shape-irrelevance, parametricity, and runtime-irrelevance+  -  [#2760](https://github.com/agda/agda/issues/2760): Relax instance search restriction on unconstrained metas+  -  [#2774](https://github.com/agda/agda/issues/2774): Internal error with sized types+  -  [#2783](https://github.com/agda/agda/issues/2783): Make more primitive/builtin modules safe?+  -  [#2789](https://github.com/agda/agda/issues/2789): Narrow and broad options+  -  [#2791](https://github.com/agda/agda/issues/2791): More illtyped meta solutions+  -  [#2797](https://github.com/agda/agda/issues/2797): Relevance check missed for overloaded projection+  -  [#2833](https://github.com/agda/agda/issues/2833): Coverage checker splits on result too eagerly+  -  [#2837](https://github.com/agda/agda/issues/2837): The Emacs mode only handles LaTeX-based literate Agda+  -  [#2872](https://github.com/agda/agda/issues/2872): Case splitting adds a dot in front of pattern matches on Chars+  -  [#2880](https://github.com/agda/agda/issues/2880): Disallow FFI binding for defined functions when --safe is used+  -  [#2892](https://github.com/agda/agda/issues/2892): 'With' should also abstract over the type of stripped dot patterns+  -  [#2893](https://github.com/agda/agda/issues/2893): Display warnings also when an error is encountered+  -  [#2899](https://github.com/agda/agda/issues/2899): Add a warning for infix notations without corresponding fixity declaration+  -  [#2929](https://github.com/agda/agda/issues/2929): Turn "missing definition" into a warning+  -  [#2936](https://github.com/agda/agda/issues/2936): Sort warning flags alphabetically in user manual+  -  [#2939](https://github.com/agda/agda/issues/2939): make install-bin on a Mac can fail to install text-icu+  -  [#2964](https://github.com/agda/agda/issues/2964): Mismatch between order of matching in clauses and case tree; subject reduction broken+  -  [#2969](https://github.com/agda/agda/issues/2969): Module parameter is erased from dot pattern+  -  [#2979](https://github.com/agda/agda/issues/2979): Rewriting matching does not respect eta rules+  -  [#2993](https://github.com/agda/agda/issues/2993): Quadratic (failing) instance search+  -  [#3010](https://github.com/agda/agda/issues/3010): Field of opened record does not get highlighted+  -  [#3032](https://github.com/agda/agda/issues/3032): spurious meta in dot pattern+  -  [#3056](https://github.com/agda/agda/issues/3056): Matching on irrelevant variable of dependent record type should not be allowed+  -  [#3057](https://github.com/agda/agda/issues/3057): A module can export two definitions with the same name+  -  [#3068](https://github.com/agda/agda/issues/3068): Add option to turn off syntactic equality check+  -  [#3095](https://github.com/agda/agda/issues/3095): Would like to make hidden variable visible but it is created ambiguous+  -  [#3102](https://github.com/agda/agda/issues/3102): Performance regression: very slow reduction in the presence of many module parameters+  -  [#3114](https://github.com/agda/agda/issues/3114): Missing alpha-renaming when printing constraints+  -  [#3120](https://github.com/agda/agda/issues/3120): No tooltips for record field names in record expressions+  -  [#3122](https://github.com/agda/agda/issues/3122): Hidden record fields are not picked up from module in record expression+  -  [#3124](https://github.com/agda/agda/issues/3124): De Bruijn index in lhs checking error message+  -  [#3125](https://github.com/agda/agda/issues/3125): Internal error in InstanceArguments.hs:292+  -  [#3127](https://github.com/agda/agda/issues/3127): Notation for out-of-scope variables conflicts with notation for irrelevance+  -  [#3128](https://github.com/agda/agda/issues/3128): Sigma builtin not added to setup, agdai file missing.+  -  [#3130](https://github.com/agda/agda/issues/3130): Conflict between dot pattern and postfix projection+  -  [#3137](https://github.com/agda/agda/issues/3137): Preserve Markdown as-is when outputting HTML+  -  [#3138](https://github.com/agda/agda/issues/3138): Result splitter introduces pattern variable that conflicts with constructor+  -  [#3139](https://github.com/agda/agda/issues/3139): Internal error in parser+  -  [#3147](https://github.com/agda/agda/issues/3147): Non-linear as-patterns+  -  [#3152](https://github.com/agda/agda/issues/3152): `give` in a do-block inserts spurious parentheses+  -  [#3153](https://github.com/agda/agda/issues/3153): Type checker fails to infer missing signature of module parameter.+  -  [#3161](https://github.com/agda/agda/issues/3161): Case splitter produces end-of-comment+  -  [#3169](https://github.com/agda/agda/issues/3169): Doc for rewriting+  -  [#3170](https://github.com/agda/agda/issues/3170): UnicodeDeclare fails with pdflatex from TeX Live 2018+  -  [#3175](https://github.com/agda/agda/issues/3175): Instance resolution fails with defined method+  -  [#3176](https://github.com/agda/agda/issues/3176): Empty lambdas are sometimes considered definitionally equal, other times not+  -  [#3180](https://github.com/agda/agda/issues/3180): Remove feature `--guardedness-preserving-type-constructors`+  -  [#3188](https://github.com/agda/agda/issues/3188): Warnings disappear when fatal error is encountered+  -  [#3195](https://github.com/agda/agda/issues/3195): Internal error at Auto/Typecheck.hs:373+  -  [#3196](https://github.com/agda/agda/issues/3196): Turning MissingDefinition into a warning+  -  [#3200](https://github.com/agda/agda/issues/3200): Function marked as irrelevant when it isn't+  -  [#3201](https://github.com/agda/agda/issues/3201): [ warning ] AbsurdPatternRequiresNoRHS+  -  [#3205](https://github.com/agda/agda/issues/3205): [ cleanup + warning ] ModuleDoesntExport can be recovered from+  -  [#3224](https://github.com/agda/agda/issues/3224): Switch from utf8x to utf8? Make agda.sty easier to maintain?+  -  [#3235](https://github.com/agda/agda/issues/3235): Cannot pass backend flags via emacs variable `agda2-program-args`+  -  [#3247](https://github.com/agda/agda/issues/3247): Support cabal-install >= 2.4.1.0 in the Makefile+  -  [#3248](https://github.com/agda/agda/issues/3248): Max of two sizes less than i+  -  [#3253](https://github.com/agda/agda/issues/3253): [ fix ] ignore duplicate declarations of libraries+  -  [#3254](https://github.com/agda/agda/issues/3254): `cpphs` doesn't build with GHC 8.6.*+  -  [#3256](https://github.com/agda/agda/issues/3256): Internal error at src/full/Agda/TypeChecking/Reduce.hs:148+  -  [#3257](https://github.com/agda/agda/issues/3257): Anonymous top-level modules can have names with multiple components+  -  [#3258](https://github.com/agda/agda/issues/3258): Ordering the constructor names at Definition.+  -  [#3262](https://github.com/agda/agda/issues/3262): Suboptimal placement of "missing with-clauses" error+  -  [#3264](https://github.com/agda/agda/issues/3264): When refine leads to a termination error it should say so rather than "cannot refine"+  -  [#3268](https://github.com/agda/agda/issues/3268): [ haddock ] Fix haddock formatting+  -  [#3285](https://github.com/agda/agda/issues/3285): Internal error for syntax declaration+  -  [#3302](https://github.com/agda/agda/issues/3302): Multiple definitions called _ are sometimes allowed, sometimes not+  -  [#3307](https://github.com/agda/agda/issues/3307): `--no-unicode` bug: case splitting inside a pattern matching lambda still produces unicode arrows+  -  [#3309](https://github.com/agda/agda/issues/3309): Use of irrelevant arguments with copatterns and irrelevant fields+  -  [#3313](https://github.com/agda/agda/issues/3313): Add --html-highlight support for the HTML backend+  -  [#3315](https://github.com/agda/agda/issues/3315): The primErase primitive is not safe+  -  [#3318](https://github.com/agda/agda/issues/3318): Lots of primitives and builtins are not declared in the primitive/builtin modules+  -  [#3320](https://github.com/agda/agda/issues/3320): Extra indentation when code is hidden+  -  [#3323](https://github.com/agda/agda/issues/3323): Internal error with inconsistent irrelevance info between declaration and definition of data type+  -  [#3338](https://github.com/agda/agda/issues/3338): Missing Definitions not recognised in instance search+  -  [#3342](https://github.com/agda/agda/issues/3342): GHC panic on stack and GHC 7.10.3+  -  [#3344](https://github.com/agda/agda/issues/3344): Disable compilation with GHC 8.6.1+  -  [#3356](https://github.com/agda/agda/issues/3356): C-c C-s prints postfix projections by default+  -  [#3363](https://github.com/agda/agda/issues/3363): The wiki should support HTTPS+  -  [#3364](https://github.com/agda/agda/issues/3364): Funny scope error when trying to import as qualified+  -  [#3366](https://github.com/agda/agda/issues/3366): Add a command line flag to change the extension of the files generated by the HTML backend+  -  [#3368](https://github.com/agda/agda/issues/3368): Support GHC 8.6.2+  -  [#3370](https://github.com/agda/agda/issues/3370): [ fix ] < and > need to be in math mode in latex+  -  [#3371](https://github.com/agda/agda/issues/3371): Document common LaTeX backend pitfalls+  -  [#3372](https://github.com/agda/agda/issues/3372): Provide some simple LaTeX backend templates+  -  [#3373](https://github.com/agda/agda/issues/3373): Wrap HTML in `raw` directive when working with ReStructuredText+  -  [#3379](https://github.com/agda/agda/issues/3379): Adding a tutorial set in the readthedocs frontpage+  -  [#3380](https://github.com/agda/agda/issues/3380): Too much erasure in strict backends+  -  [#3394](https://github.com/agda/agda/issues/3394): Internal error in mutual block with unsolved implicit argument in termination checker+  -  [#3400](https://github.com/agda/agda/issues/3400): Obscure parse error with copattern and infix field+  -  [#3403](https://github.com/agda/agda/issues/3403): Internal error in Agda.TypeChecking.Rules.Term+  -  [#3404](https://github.com/agda/agda/issues/3404): Positivity checker marks postulates as constant in mutual block+  -  [#3407](https://github.com/agda/agda/issues/3407): Internal error at "src/full/Agda/TypeChecking/Reduce/Fast.hs:1338"+  -  [#3409](https://github.com/agda/agda/issues/3409): No error if mapping the empty type to non-empty Haskell type+  -  [#3410](https://github.com/agda/agda/issues/3410): ghc backend generates program that segfaults+  -  [#3419](https://github.com/agda/agda/issues/3419): Allow unconstrained instances & disallow overlapping instances+  -  [#3420](https://github.com/agda/agda/issues/3420): Inductive definitions live in a larger set --without-K+  -  [#3425](https://github.com/agda/agda/issues/3425): Internal error at src/full/Agda/Termination/Monad.hs:177+  -  [#3426](https://github.com/agda/agda/issues/3426): Termination checking false positive when using "where"+  -  [#3428](https://github.com/agda/agda/issues/3428): Another interal error in Substitute:72 when filling a hole+  -  [#3431](https://github.com/agda/agda/issues/3431): Rewrite rule doesn't fire during conversion checking+  -  [#3434](https://github.com/agda/agda/issues/3434): Regression related to instance resolution+  -  [#3435](https://github.com/agda/agda/issues/3435): Performance regression+  -  [#3439](https://github.com/agda/agda/issues/3439): Setω doesn’t respect --type-in-type+  -  [#3441](https://github.com/agda/agda/issues/3441): Generate Level expressions with fewer parentheses+  -  [#3442](https://github.com/agda/agda/issues/3442): Support GHC 8.6.3+  -  [#3443](https://github.com/agda/agda/issues/3443): "internal error" in Agda of December 7, 2018+  -  [#3444](https://github.com/agda/agda/issues/3444): `Setup.hs` is not generating the interface files+  -  [#3445](https://github.com/agda/agda/issues/3445): case splitting attempts to shadow constructor+  -  [#3451](https://github.com/agda/agda/issues/3451): The --no-sized-types option is broken+  -  [#3452](https://github.com/agda/agda/issues/3452): Case split on irrelevant argument goes through but is later rejected+  -  [#3454](https://github.com/agda/agda/issues/3454): Highlighting for incomplete pattern matching should be above highliting for non-exact split+  -  [#3456](https://github.com/agda/agda/issues/3456): [ new ] Injectivity of prim(NatToChar/StringToList)+  -  [#3461](https://github.com/agda/agda/issues/3461): Macro loop+  -  [#3463](https://github.com/agda/agda/issues/3463): Impossible to give certain instance arguments by name?+  -  [#3466](https://github.com/agda/agda/issues/3466): two definitionally equal terms are not equal+  -  [#3471](https://github.com/agda/agda/issues/3471): Can't install via cabal-install on current Haskell Platform+  -  [#3480](https://github.com/agda/agda/issues/3480): Parse error at EOF should be reported before EOF (especially if there is a long comment before EOF)+  -  [#3483](https://github.com/agda/agda/issues/3483): Internal error at TypeChecking/Monad/Signature.hs:732+  -  [#3485](https://github.com/agda/agda/issues/3485): [ warnings ] for empty primitive blocks+  -  [#3491](https://github.com/agda/agda/issues/3491): Internal error src/full/Agda/TypeChecking/Rules/LHS.hs:294 after pattern matching+  -  [#3498](https://github.com/agda/agda/issues/3498): Internal error in activateLoadedFileCache+  -  [#3501](https://github.com/agda/agda/issues/3501): Case split in let clause causes internal error+  -  [#3503](https://github.com/agda/agda/issues/3503): Internal error in BasicOps+  -  [#3514](https://github.com/agda/agda/issues/3514): Accidential language change in 2.5.3: hiding is now part of name when resolving hidden argument insertion+  -  [#3517](https://github.com/agda/agda/issues/3517): Option consistency checking bug+  -  [#3518](https://github.com/agda/agda/issues/3518): Performance regression+  -  [#3521](https://github.com/agda/agda/issues/3521): Documentation: fixes a plural issue in copatterns+  -  [#3526](https://github.com/agda/agda/issues/3526): Do not generate trivially impossible clause when case-splitting+  -  [#3533](https://github.com/agda/agda/issues/3533): [ fix #3526 ] Remove trivially impossible clauses from case-split+  -  [#3534](https://github.com/agda/agda/issues/3534): Problem finding higher-order instances+  -  [#3536](https://github.com/agda/agda/issues/3536): Patternmatching on coinductive record fields breaks+  -  [#3544](https://github.com/agda/agda/issues/3544): internal error @ TypeChecking/Forcing.hs:227+  -  [#3548](https://github.com/agda/agda/issues/3548): [ new ] Add support for compiling literate Org documents+  -  [#3554](https://github.com/agda/agda/issues/3554): Type checker explosion+  -  [#3561](https://github.com/agda/agda/issues/3561): fix typo: "FreBSD" => "FreeBSD"+  -  [#3566](https://github.com/agda/agda/issues/3566): Missing name when printing type of definition of a record+  -  [#3578](https://github.com/agda/agda/issues/3578): Pattern matching unifier normalizes too much+  -  [#3586](https://github.com/agda/agda/issues/3586): Internal error in ConcreteToAbstract.hs:2217+  -  [#3590](https://github.com/agda/agda/issues/3590): Superlinear time required for simple code+  -  [#3597](https://github.com/agda/agda/issues/3597): Agda loops on simple code with a record and a hole+  -  [#3600](https://github.com/agda/agda/issues/3600): Size solver complains, explicit sizes work+  -  [#3610](https://github.com/agda/agda/issues/3610): Support GHC 8.6.4+  -  [#3621](https://github.com/agda/agda/issues/3621): performance problem+  -  [#3631](https://github.com/agda/agda/issues/3631): Performance with --no-universe-polymorphism+  -  [#3638](https://github.com/agda/agda/issues/3638): Rewrite rules do not fire in goal normalization in parametrized module+  -  [#3639](https://github.com/agda/agda/issues/3639): Argument to function created by tactic is lost+  -  [#3640](https://github.com/agda/agda/issues/3640): Polarity: Size index check crashes due to wrong parameter number calculation+  -  [#3641](https://github.com/agda/agda/issues/3641): Remove old compiler pragmas+  -  [#3648](https://github.com/agda/agda/issues/3648): Agda could fail to build if a .agda-lib file exists in a parent directory+  -  [#3651](https://github.com/agda/agda/issues/3651): internal error ghc backend+  -  [#3657](https://github.com/agda/agda/issues/3657): Disable compilation with Windows and GHC 8.6.3+  -  [#3678](https://github.com/agda/agda/issues/3678): Two out-of-scope variables are given the same name+  -  [#3687](https://github.com/agda/agda/issues/3687): Show module contents (C-c C-o) prints garbled names in clause
+ doc/release-notes/2.6.1.1.md view
@@ -0,0 +1,4 @@+Release notes for Agda version 2.6.1.1+======================================++* Added support for GHC 8.8.4 and GHC 8.10.2
+ doc/release-notes/2.6.1.2.md view
@@ -0,0 +1,8 @@+Release notes for Agda version 2.6.1.2+======================================++* Build with latest versions of hackage packages:+  - aeson (1.5.3), [issue #4838](https://github.com/agda/agda/issues/4838)+  - strict (0.4), [commit 0497ec9](https://github.com/agda/agda/commit/0497ec9fdde159a56ee42821e500b52d66374201)++* Build with dynamic linking, [issue #4569](https://github.com/agda/agda/issues/4569)
+ doc/release-notes/2.6.1.3.md view
@@ -0,0 +1,4 @@+Release notes for Agda version 2.6.1.3+======================================++* Added support for GHC 8.10.3.
+ doc/release-notes/2.6.1.md view
@@ -0,0 +1,850 @@+Release notes for Agda version 2.6.1+====================================++General+-------++* Agda now has an official logo: [![The official Agda+  logo](../../doc/user-manual/agda.svg)](https://github.com/agda/agda/blob/master/doc/user-manual/agda.svg). The+  logo was chosen by the Agda community from a list of candidates. The+  winning design was submitted by Miëtek Bak. The list of candidates+  and the outcome of the poll can be consulted+  [here](https://civs.cs.cornell.edu/cgi-bin/results.pl?id=E_ce6fe5e2a518ac98).+++Installation and infrastructure+-------------------------------++* Added support for GHC 8.8.2+  [Issue [#4285](https://github.com/agda/agda/issues/4285)].++* Removed support for GHC 7.10.3.++* Interface files are now written in directory `_build/VERSION/agda/` at+  the project root (the closest enclosing directory where an `.agda-lib`+  file is present). If there is no project root then the interface file+  is written alongside the module it corresponds to.+  The flag `--local-interfaces` forces Agda to revert back to storing+  interface files alongside module files no matter what.++* Agda now uses the default RTS options `-M3.5G -I0`.  If+  you run Agda on a 32-bit system or a system with less than 8GB of+  RAM, it is recommended to set the RTS options explicitly to a lower+  value by running `agda` with option `+RTS -M1.2G -RTS`+  (for example) or by setting the GHCRTS enviroment variable. See the+  [GHC User's Guide](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/runtime_control.html#setting-rts-options)+  for more information.++* If Agda is compiled using GHC 8.4 or later, then one can expect to+  see substantially lower memory consumption+  [Issues [#4457](https://github.com/agda/agda/issues/4457)+  and [#4316](https://github.com/agda/agda/issues/4316)].++  This is due to the use of ["compact+  regions"](https://hackage.haskell.org/package/ghc-compact-0.1.0.0/docs/GHC-Compact.html).++* The `CHANGELOG.md` was split. Changes to previous versions of Agda+  are in the directory `doc/release-notes`.++Pragmas and options+-------------------++* New pragma `WARNING_ON_IMPORT` to let module authors raise a warning+  when a module is imported. This can be use to tell users deprecations.++* New option `--confluence-check` (off by default) enables confluence+  checking of user-defined rewrite rules (this only has an effect when+  `--rewriting` is also enabled).++* New option `--no-projection-like` to turn off the analysis whether a+  type signature likens that of a projection.+  Projection-likeness is an optimization that reduces the size of+  terms by dropping parameter-like reconstructible function arguments.+  Thus, it is advisable to leave this optimization on, the flag is+  meant for debugging Agda.++* Option `--no-forcing` is now a pragma option, i.e., the forcing analysis+  can be switched off on a per-file basis via++  ```agda+  {-# OPTIONS --no-forcing #-}+  ```++  at the beginning of the file+  [Issue [#3872](https://github.com/agda/agda/issues/3872)].++* New pragma option `--no-flat-split` disables pattern matching on `@♭` arguments.++* New pragma option `--allow-incomplete-matches`. It is similar to+  `--allow-unsolved-metas`: modules containing partial function definitions+  can be imported. Its local equivalent is the `NON_COVERING` pragma to+  be placed before the function (or the block of mutually defined functions)+  which the user knows to be partial.++* Option `--interaction-json` now brings more information about goals,+  unsolved metas, warnings, errors.+  It also displays pretty-printed terms.++* New pragma option `--keep-pattern-variables` to prevent case+  splitting from replacing variables with dot patterns.++* Pragma `{-# ETA <record name> #-}` is no longer considered `--safe`.+  See [Issue [#4450](https://github.com/agda/agda/issues/4450)].++* New pragma options `--subtyping` and `--no-subtyping` (default) to+  turn on/off subtyping rules globally [see+  Issue_[#4474](https://github.com/agda/agda/issues/4474)]. Currently,+  this includes subtyping for irrelevance, erasure, and flat+  modalities. Additionally, `--subtyping` is implied by+  `--cumulativity` (see below). `--subtyping` is currently NOT implied+  by `--sized-types`, and subtyping for sized types is used even when+  `--subtyping` is not enabled.++* New profiling options to measure time spent per module or top-level+  definition.++  - `-v profile.modules:10` prints a breakdown per top-level module+  - `-v profile.definitions:10` prints a breakdown per top-level+    definition++Language+--------++### Syntax++* Fractional precedence levels are now supported, see+  Issue [#3991](https://github.com/agda/agda/issues/3991). Example:++  ```agda+  infix 3.14 _<_+  ```+  Note that this includes a respective change in the reflected Agda syntax.++* Fixities can now be changed during import in a `renaming` directive,+  see+  Issue [#1346](https://github.com/agda/agda/issues/1346). Example:++  ```agda+  open M using (_∙_)+  open M renaming (_∙_ to infixl 10 _*_)+  ```+  After this, `_∙_` is in scope with its original fixity, and as `_*_` as left+  associative operator of precedence 10.++* Implicit non-dependent function spaces `{A} → B` and `{{A}} → B` are now supported.++* Idiom brackets++  Idiom brackets can accommodate none or multiple applications separated by a vertical bar `|`+  if there are two additional operations+  ```agda+  empty : ∀ {A} → F A+  _<|>_ : ∀ {A} → F A → F A → F A+  ```+  i.e. an Alternative type class in Haskell.+  As usual, the new idiom brackets desugar before scope checking.++  Idiom brackets with multiple applications+  ```agda+  (| e₁ a₁ .. aₙ | e₂ a₁ .. aₘ | .. | eₖ a₁ .. aₗ |)+  ```+  expand to (assuming right associative `_<|>_`)+  ```agda+  (pure e₁ <*> a₁ <*> .. <*> aₙ) <|> ((pure e₂ <*> a₁ <*> .. <*> aₘ) <|> (pure eₖ <*> a₁ <*> .. <*> aₗ))+  ```+  Idiom brackets with no application `(|)` or `⦇⦈` are equivalent to `empty`.+++* Irrefutable With++  Users can now match on irrefutable patterns on the LHS using a+  pattern-matching `with`. An expression of the form:++  ```agda+  f xs with p1 <- e1 | ... | pn <- en+       with q1 <- f1 | ... | qm <- fm = rhs+  ```++  is translated to nested `with` clauses, essentially equivalent to:++  ```agda+  f xs with e1 | ... | en+  ... | p1 | ... | pn+       with f1 | ... | fm+  ... | q1 | ... | qm = rhs+  ```++* Record patterns in telescopes++  Users can now use record patterns in telescope and lambda abstractions.+  The type of the second projection from a dependent pair is the prototypical+  example It can be defined as follows:++  ```agda+  snd : ((a , _) : Σ A B) → B a+  ```++  And this second projection can be implemented with a lamba-abstraction using+  one of these irrefutable patterns:++  ```agda+  snd = λ (a , b) → b+  ```++  Using an as-pattern, users can get a name for the value as well as for its+  subparts. We can for instance prove that any pair is equal to the pairing+  of its first and second projections:++  ```agda+  eta : (p@(a , b) : Σ A B) → p ≡ (a , b)+  eta p = refl+  ```++* Absurd match in a do block+  The last expression in a do block can now also be an absurd match `() <- f`.++* Named `where` modules are now in scope in the rhs of the clause (see+  Issue [#4050](https://github.com/agda/agda/issues/4050)).  Example:++  ```agda+  record Wrap : Set₂ where+    field wrapped : Set₁++  test : Wrap+  test = record { M }+    module M where+      wrapped : Set₁+      wrapped = Set+  ```++* `{{-` is now lexed as `{ {-` rather than `{{ -`,+  see Issue [#3962](https://github.com/agda/agda/issues/3962).++* Syntax for large numbers: you can now separate groups of 3 digits using `_`.+  e.g. write `1_000_000` instead of `1000000`.++* `quoteGoal` and `quoteContext` are no longer keywords.++* Record constructors can no longer be qualified by the record module.+  (See Issue [#4189](https://github.com/agda/agda/issues/4189).)++  ```agda+  record Foo : Set where+    constructor foo++  works = foo+  fails = Foo.foo+  ```++* `codata` definitions have been removed from the concrete syntax+  Previously they got accepted syntactically, but resulted in errors.++* Imports can now be anonymous.+  (See Issue_[#3727](https://github.com/agda/agda/issues/3727).)+  For example, the following will **not** bring `Agda.Builtin.Unit` into scope:+  ```agda+  open import Agda.Builtin.Unit as _+  blah :: ⊤+  blah = tt+  ```++### Type checking++* Type inference for record expressions no longer considers record types from+  modules that have not been imported (Issue [#4267](https://github.com/agda/agda/issues/4267)).++  For instance,+  ```agda+  -- A.agda+  module A where+    record R : Set₁ where+      field f : Set+  ```+  ```agda+  -- B.agda+  module B where+    import A+  ```+  ```agda+  -- C.agda+  module C where+    import B+    fails : Set → _+    fails X = record {f = X}  -- import A required to infer record type R+  ```++* The fix of issue [#3903](https://github.com/agda/agda/issues/3903) changes+  the algorithm computing the order of case splits, which in some cases may+  lead to unsolved metavariables in previously working code. See issue+  [#4353](https://github.com/agda/agda/issues/4353).++### Modalities++* New Flat Modality++  New modality `@♭/@flat` (previously only available in the branch "flat").+  An idempotent comonadic modality modeled after spatial/crisp type theory.+  See [Flat Modality](https://agda.readthedocs.io/en/v2.6.1/language/flat.html)+  in the documentation for more.++* New run-time erasure modality (`@0` / `@erased`).+  Terms marked as erased cannot influence computations and are erased+  at run time+  [Issue [#3855](https://github.com/agda/agda/issues/3855)]. See+  [Run-time+  Irrelevance](https://agda.readthedocs.io/en/v2.6.1/language/runtime-irrelevance.html)+  in the documentation for more information.++  Note that this feature can cause previously solved metavariables to become+  unsolved even in code that doesn't use run-time erasure (see issue+  [#4174](https://github.com/agda/agda/issues/4174)).++* Subtyping rules for modalities are by default no longer used (see+  Issue_[#4390](https://github.com/agda/agda/issues/4390)). For+  example, if `f : .A → A`, Agda no longer accepts `f` at type `A →+  A`. Instead, Agda accepts `λ x → f x : A → A`. The same holds for+  erasure (`@0`) and flat (`@♭`) modalities. Consequently, it may be+  required to eta-expand certain functions in order to make old code+  work with Agda 2.6.1. Alternatively, enabling the new `--subtyping`+  flag will restore the old behaviour but might negatively impact+  typechecking performance.++### Universe levels++* New (experimental) option `--cumulativity`++  When the ``--cumulativity`` flag is enabled, Agda uses the subtyping+  rule ``Set i =< Set j`` whenever ``i =< j``. For example, in+  addition to its usual type ``Set``, ``Nat`` also has the type+  ``Set₁`` and even ``Set i`` for any ``i : Level``. More information+  about this new option can be found in section+  [Cumulativity](https://agda.readthedocs.io/en/v2.6.1/language/cumulativity.html)+  of the user manual.++### Termination checking++* The "with inlining" feature of the termination checker has been+  removed. As a consequence, some functions defined using `with` are+  no longer accepted as terminating. See+  Issue [#59](https://github.com/agda/agda/issues/59) for why this+  feature was originally introduced and+  [#3604](https://github.com/agda/agda/issues/3604) for why it had to+  be removed.++  The easiest way to fix termination problems caused by `with` is to abstract+  over the offending recursive call before any other `with`s. For example++  ```agda+  data D : Set where+    [_] : Nat → D++  fails : D → Nat+  fails [ zero  ] = zero+  fails [ suc n ] with some-stuff+  ... | _ = fails [ n ]+  ```++  This fails termination because the relation between `[ suc n ]` and `[ n ]`+  is lost since the generated with-function only gets passed `n`. To fix it we+  can abstract over the recursive call:++  ```agda+  fixed : D → Nat+  fixed [ zero  ] = zero+  fixed [ suc n ] with fixed [ n ] | some-stuff+  ... | rec | _ = rec+  ```++  If the function takes more arguments you might need to abstract over a+  partial application to just the structurally recursive argument. For instance,++  ```agda+  fails : Nat → D → Nat+  fails _ [ zero  ] = zero+  fails _ [ suc n ] with some-stuff+  ... | m = fails m [ n ]++  fixed : Nat → D → Nat+  fixed _ [ zero  ] = zero+  fixed _ [ suc n ] with (λ m → fixed m [ n ]) | some-stuff+  ... | rec | m = rec m+  ```++  A possible complication is that later `with`-abstractions might change the+  type of the abstracted recursive call:++  ```agda+  T      : D → Set+  suc-T  : ∀ {n} → T [ n ] → T [ suc n ]+  zero-T : T [ zero ]++  fails : (d : D) → T d+  fails [ zero  ] = zero-T+  fails [ suc n ] with some-stuff+  ... | _ with [ n ]+  ...   | z = suc-T (fails [ n ])++  still-fails : (d : D) → T d+  still-fails [ zero ] = zero-T+  still-fails [ suc n ] with still-fails [ n ] | some-stuff+  ... | rec | _ with [ n ]+  ...   | z = suc-T rec -- Type error because rec : T z+  ```++  To solve this problem you can add `rec` to the with-abstraction messing up+  its type. This will prevent it from having its type changed:++  ```agda+  fixed : (d : D) → T d+  fixed [ zero ] = zero-T+  fixed [ suc n ] with fixed [ n ] | some-stuff+  ... | rec | _ with rec | [ n ]+  ...   | _ | z = suc-T rec+  ```++* The termination checker will now try to dispose of recursive calls+  by reducing with the non-recursive function clauses.+  This eliminates false positives common for definitions by copatterns+  using dependent types,+  see Issue [#906](https://github.com/agda/agda/issues/906).++  For example, consider the following example using a dependent+  coinductive record `Tree`:+  ```agda+  data Fin : Nat → Set where+    fzero : ∀ n → Fin (suc n)+    fsuc  : ∀ n (i : Fin n) → Fin (suc n)++  toNat : ∀ n → Fin n → Nat+  toNat .(suc n) (fzero n)  = zero+  toNat .(suc n) (fsuc n i) = suc (toNat n i)++  record Tree : Set where+    coinductive+    field label : Nat+          child : Fin label → Tree+  open Tree++  tree : Nat → Tree+  tree n .label   = n+  tree n .child i = tree (n + toNat _ i)+  ```+  Agda solves the underscore by `tree n .label`, which is a corecursive+  call in a non-guarded position, violating the guardedness criterion.+  This lead to a complaint of the termination checker.+  Now this call is reduced to `n` first using the non-recursive clause+  `tree n .label = n`, which leaves us only with the guarded call+  `tree (n + toNat n i)`, and the termination checker is happy.++  Note: Similar false positives arose already for non-recursive dependent+  records, e.g., when trying to define an inhabitant of the Σ-type by+  copattern matching on the projects.+  See Issue_[#2068](https://github.com/agda/agda/issues/2068) for a+  non-recursive example.++### Irrelevance and Prop++* Agda will no longer reduce irrelevant definitions and definitions+  with a type in `Prop`. This does not have an effect on the+  semantics, but should lead to improved performance (see Issues+  [#4115](https://github.com/agda/agda/issues/4115),+  [#4118](https://github.com/agda/agda/issues/4118),+  [#4120](https://github.com/agda/agda/issues/4120),+  [#4122](https://github.com/agda/agda/issues/4122)).++* Terms of a type in `Prop` are now printed as `_`. To show the actual+  term, you can use the `--show-irrelevant` flag (see+  Issue [#3337](https://github.com/agda/agda/issues/3337).++### Rewrite rules++* Rewrite rules (option `--rewriting`) with data or record types as+  the head symbol are no longer allowed (see+  Issue [#3846](https://github.com/agda/agda/issues/3846)).++### Tactics & Reflection++* Implicit arguments solved by user-defined tactics++  You can declare tactics to be used to solve a particular implicit argument+  using the following syntax:++  ```agda+  example : {@(tactic f) x : A} → B+  ```++  where `f : Term → TC ⊤`. At calls to `example`, `f` is called on the+  metavariable inserted for `x`. `f` can be an arbitrary term and may depend on+  previous arguments to the function. For instance,++  ```agda+  example₂ : (depth : Nat) {@(tactic search depth) x : A} → B+  ```++  Record fields can also be annotated with a tactic, allowing them to be+  omitted in constructor applications, record constructions and co-pattern+  matches:++  ```agda+  record Example : Set where+    constructor mkExample+    field x : A+          @(tactic solveP x) {y} : P x+  ```++  where `solveP : (x : A) → Term → TC ⊤` is a tactic that tries to+  prove `P x`+  [Issue [#4124](https://github.com/agda/agda/issues/4124)].++* The legacy reflection framework using `quoteGoal` and `quoteContext` has been+  removed.++### Builtins++* New primitives++  ```agda+  primWord64ToNatInjective    : ∀ a b → primWord64ToNat a ≡ primWord64ToNat b → a ≡ b++  primFloatToWord64           : Float → Word64+  primFloatToWord64Injective  : ∀ a b → primFloatToWord64 a ≡ primFloatToWord64 b → a ≡ b++  primMetaToNat               : Meta → Nat+  primMetaToNatInjective      : ∀ a b → primMetaToNat a ≡ primMetaToNat b → a ≡ b++  primQNameToWord64s          : Name → Word64 × Word64+  primQNameToWord64sInjective : ∀ a b → primQNameToWord64s a ≡ primQNameToWord64s b → a ≡ b+  ```++  These can be used to define safe decidable propositional equality, see Issue [agda-stdlib#698](https://github.com/agda/agda-stdlib/issues/698).++* New Primitive for showing Natural numbers:++  ```agda+  primShowNat : Nat → String+  ```++  placed in Agda.Builtin.String.++* The builtin `IO` has been declared strictly positive in both its+  level and type argument.++### Warnings++* New warning for a variable shadowing another in a telescope. If the two+  variables are introduced in different telescopes then the warning is not+  raised.++  ```agda+  f : {a : Level} {A : Set a} (a : A) → A   -- warning raised: repeated a+  g : {a : Level} {A : Set a} → (a : A) → A -- warning not raised: two distinct telescopes+  ```++  Note that this warning is turned off by default (you can use+  `-WShadowingInTelescope` or `--warning ShadowingInTelescope` to turn+  it on, `-Wall` would also naturally work).+++Emacs mode+----------++* Agda input method: new key bindings `\ G h` and `\ G H` for `η` and+  `H` (capital η)+  [Issue [#3856](https://github.com/agda/agda/issues/3856)].++* Syntax highlighting: in literate modes, the pure texts+  (other than Agda code and the code-text separators) are no longer highlighted+  (it was highlighted as comments before).+  This somehow provides more information about how Agda lexes literate files.++* Agda now also displays the values of let-bound variables in the+  context instead of just their types+  [Issue [#4199](https://github.com/agda/agda/issues/4199)].++* Agda will now try to preserve the ellipsis (`...`) during case+  splitting when possible. To manually expand the ellipsis, you may+  ask Agda to case split on the special identifier `.`.+  [Issue [#2589](https://github.com/agda/agda/issues/2589)]++* Agda will now also show variables named `_` in the context if they+  are instance arguments (see+  [#4307](https://github.com/agda/agda/issues/4307)). Instance+  arguments are now also marked as `(instance)` in the context. Example:++  ```agda+  f : {{_ : A}} → A+  f = ?+  ```++  Agda will now display the goal as follows:++  ```+  Goal: A+  ————————————————————————————————————————————————————————————+  _ : A   (instance)+  ```++* It is now possible to ask Agda to terminate itself after any+  previously invoked commands have completed, by giving a prefix+  argument to `agda2-term`.++* The command `agda2-measure-load-time` has been removed.++GHC Backend+-----------++* Types which have a COMPILE GHC pragma are no longer erased+  [Issue [#3732](https://github.com/agda/agda/issues/3732)].++  ```agda+  data I : Set where+    bar : I++  {-# FOREIGN GHC data I = Bar     #-}+  {-# COMPILE GHC I = data I (Bar) #-}++  data S : Set where+    foo :  I → S++  {-# FOREIGN GHC data S = Foo I #-}+  {-# COMPILE GHC S = data S (Foo) #-}+  ```+  Previously [Issue [#2921](https://github.com/agda/agda/issues/2921)],+  the last binding was incorrect, since the argument of+  singleton type `I` was erased from the constructor `foo` during+  compilation.  The required shape of `S` was previously+  ```+  {-# FOREIGN GHC data S = Foo #-}+  ```+  i.e., constructor `Foo` had to have no arguments.++  For the sake of transparency, Haskell constructors bound to+  Agda constructors now take the same arguments.+  This is especially important if Haskell bindings are to be+  produced automatically by third party tool.++LaTeX backend+-------------++* Now the code environment complains if it is given unrecognised options.++  It is also possible to write, say, `hide=true` instead of `hide`,+  and `hide=false` means that the `hide` option should not be used.+  Furthermore the same option can be given multiple times, in which+  case later choices take precedence over earlier ones.++* The code environment has a new option, `number`.++  When the option `number` is used an equation number is generated for+  the code listing. The number is set to the right, centered+  vertically. By default the number is set in parentheses, but this+  can be changed by redefining `\AgdaFormatCodeNumber`.++  The option can optionally be given an argument: when `number=l` is+  used a label `l`, referring to the code listing, is generated. It is+  possible to use this option several times with different labels.++  The option has no effect if used together with `hide`, `inline` or+  `inline*`.++API+----+* Removed module `Agda.Utils.HashMap`. It only re-exported `Data.HashMap.Strict`+  from the package `unordered-containers`. Use `Data.HashMap.Strict` instead.++* Removed module `Agda.Utils.Char`. It used to provide functions converting a+  `Char` in base 8, 10, and 16 to the corresponding `Int`. Use `digitToInt` in+  `Data.Char` instead. The rest of module was about Unicode test which was not+  used.++* `Agda.Utils.List` no longer provides `headMaybe`.+  Use `listToMaybe` in `Data.Maybe` instead.++* `Agda.Utils.Either` no longer provides `mapEither`. Use `bimap` in+  `Data.Bifunctor` instead.++* `Agda.Utils.Map` no longer provides `unionWithM`, `insertWithKeyM`,+  `allWithKey`, `unzip`, and `unzip3`.++Other issues+------------++For 2.6.1, the following issues were also closed (see [bug+tracker](https://github.com/agda/agda/issues)):++  -  [#470](https://github.com/agda/agda/issues/470): Constraint solving in heterogenous situations+  -  [#471](https://github.com/agda/agda/issues/471): Emacs command to show goal with constraints on it+  -  [#500](https://github.com/agda/agda/issues/500): Allow creation of implicit parameters in with blocks+  -  [#543](https://github.com/agda/agda/issues/543): Irrelevant projections are inconsistent+  -  [#760](https://github.com/agda/agda/issues/760): Warning for open public in an abstract block+  -  [#1073](https://github.com/agda/agda/issues/1073): Solve C-c C-s inserts variables that are not in scope+  -  [#1097](https://github.com/agda/agda/issues/1097): Allow record patterns in lambda-bound positions+  -  [#1182](https://github.com/agda/agda/issues/1182): Request: allowing the use of patterns in syntax-bound variables+  -  [#1381](https://github.com/agda/agda/issues/1381): Termination checker rejects function with with-clause+  -  [#1445](https://github.com/agda/agda/issues/1445): Lack of subject reduction with REWRITE+  -  [#1820](https://github.com/agda/agda/issues/1820): Case splitting should preserve existing names+  -  [#2068](https://github.com/agda/agda/issues/2068): Copattern matching: Hyvernat termination would succeed+  -  [#2148](https://github.com/agda/agda/issues/2148): Option to use use `stack exec` for GHC backend+  -  [#2170](https://github.com/agda/agda/issues/2170): Two equal irrelevant definitions: one is type checked, the other is not+  -  [#2284](https://github.com/agda/agda/issues/2284): Disallow duplicate bound variable in lambda and pi+  -  [#2414](https://github.com/agda/agda/issues/2414): Case splitting loses as-patterns+  -  [#2498](https://github.com/agda/agda/issues/2498): Resolution of unnamed instances+  -  [#2512](https://github.com/agda/agda/issues/2512): Propose: Split the changelog+  -  [#2530](https://github.com/agda/agda/issues/2530): --ignore-interfaces should not recompile Primitive.agda+  -  [#2535](https://github.com/agda/agda/issues/2535): Expose name id in reflection API+  -  [#2589](https://github.com/agda/agda/issues/2589): Preserve the ellipsis (dots) when case splitting "with" arguments+  -  [#2610](https://github.com/agda/agda/issues/2610): Avoid rechecking by storing interfaces in separate directories?+  -  [#2619](https://github.com/agda/agda/issues/2619): Feature request: link to `renaming` clause+  -  [#2902](https://github.com/agda/agda/issues/2902): Case-splitting should not generate patterns containing pattern synonyms+  -  [#3034](https://github.com/agda/agda/issues/3034): Pattern matching without K seemingly illogical for the inductive family of squares+  -  [#3073](https://github.com/agda/agda/issues/3073): type-in-type and spurious levels+  -  [#3081](https://github.com/agda/agda/issues/3081): Termination problem: copatterns and without-K+  -  [#3089](https://github.com/agda/agda/issues/3089): Nicer syntax for implicit @-patterns+  -  [#3095](https://github.com/agda/agda/issues/3095): Would like to make hidden variable visible but it is created ambiguous+  -  [#3136](https://github.com/agda/agda/issues/3136): Spurious module parameters printed in extended lambda in termination error+  -  [#3189](https://github.com/agda/agda/issues/3189): No information about which warnings are enabled by default+  -  [#3233](https://github.com/agda/agda/issues/3233): Type declarations not accompanied by a definition should be highlighted in the emacs mode+  -  [#3238](https://github.com/agda/agda/issues/3238): Printing of inserted hidden lambdas+  -  [#3293](https://github.com/agda/agda/issues/3293): Absurd match in a do block+  -  [#3295](https://github.com/agda/agda/issues/3295): Allow import of files with incomplete pattern matching+  -  [#3353](https://github.com/agda/agda/issues/3353): Case splitting turns named arguments into positional arguments+  -  [#3383](https://github.com/agda/agda/issues/3383): Document the DISPLAY pragma+  -  [#3417](https://github.com/agda/agda/issues/3417): No highlighting for code that fails termination checking when an error is encountered+  -  [#3423](https://github.com/agda/agda/issues/3423): Implicit arguments with custom macro for resolution+  -  [#3432](https://github.com/agda/agda/issues/3432): Highlighting does not work for pattern synonyms in import lists+  -  [#3493](https://github.com/agda/agda/issues/3493): Impossible to normalize elements in a proposition+  -  [#3525](https://github.com/agda/agda/issues/3525): Rewrite rules with non-linear patterns do not work in presence of Prop+  -  [#3545](https://github.com/agda/agda/issues/3545): JavaScript backend: mapping a function that returns Set fails+  -  [#3574](https://github.com/agda/agda/issues/3574): Support precedent rebind / changing the precedents in builtin library+  -  [#3582](https://github.com/agda/agda/issues/3582): Error message referring to Set instead of Prop+  -  [#3594](https://github.com/agda/agda/issues/3594): Occurs check throws error when a solution is possible by eta expansion+  -  [#3599](https://github.com/agda/agda/issues/3599): Bad performance on pathToEquiv+  -  [#3606](https://github.com/agda/agda/issues/3606): Do not create/display superfluous metas and show constraints in a readable way+  -  [#3654](https://github.com/agda/agda/issues/3654): Show non-blocked constraints first in list of unsolved constraints+  -  [#3695](https://github.com/agda/agda/issues/3695): Generalisation introduces multiple explicit arguments for one generalisable variable+  -  [#3698](https://github.com/agda/agda/issues/3698): Remove primComp?+  -  [#3712](https://github.com/agda/agda/issues/3712): Sigma not listed in Built-ins documentation+  -  [#3724](https://github.com/agda/agda/issues/3724): Internal error with Prop and inductive-inductive type+  -  [#3725](https://github.com/agda/agda/issues/3725): Support GHC 8.8.1+  -  [#3730](https://github.com/agda/agda/issues/3730): Internal error resulting from unused implicit argument+  -  [#3735](https://github.com/agda/agda/issues/3735): Incorrect context when generalisable variable is used+  -  [#3736](https://github.com/agda/agda/issues/3736): Safe decidability equality support for Name and Meta+  -  [#3745](https://github.com/agda/agda/issues/3745): Update user manual on built-ins+  -  [#3749](https://github.com/agda/agda/issues/3749): Inconsistency: Rounding op differentiates NaNs+  -  [#3759](https://github.com/agda/agda/issues/3759): Change the default RTS options?+  -  [#3774](https://github.com/agda/agda/issues/3774): de Bruijn index out of scope with rewrite rules+  -  [#3776](https://github.com/agda/agda/issues/3776): Conversion check fails too quickly when type could be eta unit type+  -  [#3779](https://github.com/agda/agda/issues/3779): Incorrectly ordered generalised variables+  -  [#3785](https://github.com/agda/agda/issues/3785): Comparison of blocked terms doesn't respect eta+  -  [#3791](https://github.com/agda/agda/issues/3791): Asking Agda to solve a constraint inside a macro+  -  [#3803](https://github.com/agda/agda/issues/3803): Parse empty field lists+  -  [#3805](https://github.com/agda/agda/issues/3805): Agda prelude: Internal error at src/full/Agda/TypeChecking/Reduce/Fast.hs:1347+  -  [#3807](https://github.com/agda/agda/issues/3807): Internal error related to generalisable variables+  -  [#3812](https://github.com/agda/agda/issues/3812): Rewriting projected symbols leads to loss of subject reduction+  -  [#3813](https://github.com/agda/agda/issues/3813): Destructuring leads to invalid premises+  -  [#3818](https://github.com/agda/agda/issues/3818): For open import M, Agda should remember that M is an external module+  -  [#3824](https://github.com/agda/agda/issues/3824): rewrite drops named where module+  -  [#3825](https://github.com/agda/agda/issues/3825): record{M} syntax reports unsolved metas in module M instead of in record expression+  -  [#3828](https://github.com/agda/agda/issues/3828): Internal error in Agda/TypeChecking/Coverage.hs:467+  -  [#3829](https://github.com/agda/agda/issues/3829): Case-split: don't generate pattern covered by unreachable clause+  -  [#3830](https://github.com/agda/agda/issues/3830): primShow(Char/String) display spurious square brackets+  -  [#3831](https://github.com/agda/agda/issues/3831): Wrong de Bruijn indices for reflected variables inside an extended context+  -  [#3843](https://github.com/agda/agda/issues/3843): Internal error with-clause and unification+  -  [#3851](https://github.com/agda/agda/issues/3851): C-c C-h should default to AsIs rather than Simplified+  -  [#3866](https://github.com/agda/agda/issues/3866): `--no-unicode` option producing unicode variable names+  -  [#3878](https://github.com/agda/agda/issues/3878): Case splitting should respect existing input+  -  [#3879](https://github.com/agda/agda/issues/3879): Only unqualified pattern synonyms should be used for resugaring+  -  [#3882](https://github.com/agda/agda/issues/3882): de Bruijn index out of scope+  -  [#3892](https://github.com/agda/agda/issues/3892): Internal error with `data .. where` definitions+  -  [#3898](https://github.com/agda/agda/issues/3898): Forcing analysis sensitive to normalization+  -  [#3900](https://github.com/agda/agda/issues/3900): Abstract constructor not usable in function definition involving "with"+  -  [#3901](https://github.com/agda/agda/issues/3901): Unnamed implicit non-dependent function space {A} -> B and {{A}} -> B+  -  [#3912](https://github.com/agda/agda/issues/3912): Generalisable variables generate unknown and explicit parameters+  -  [#3919](https://github.com/agda/agda/issues/3919): Case splitting fails in parameterized module+  -  [#3927](https://github.com/agda/agda/issues/3927): `import … hiding …` should be documented+  -  [#3928](https://github.com/agda/agda/issues/3928): The error message `Hiding … has no effect` should be improved+  -  [#3930](https://github.com/agda/agda/issues/3930): BUILTIN NATURAL internal error at Forcing.hs:232+  -  [#3932](https://github.com/agda/agda/issues/3932): Internal error when mixing implicit and explicit mutual blocks+  -  [#3937](https://github.com/agda/agda/issues/3937): Internal error at "ConcreteToAbstract:1372"+  -  [#3940](https://github.com/agda/agda/issues/3940): Weird error with piSort and generalization+  -  [#3943](https://github.com/agda/agda/issues/3943): Print also hidden problematic unification terms+  -  [#3955](https://github.com/agda/agda/issues/3955): Document module keyword in using/hiding/renaming+  -  [#3956](https://github.com/agda/agda/issues/3956): Duplicate name in environment buffer with @-pattern+  -  [#3964](https://github.com/agda/agda/issues/3964): Agda overwrites user-written dotted pattern+  -  [#3965](https://github.com/agda/agda/issues/3965): Wrong indication of unreachable clauses+  -  [#3966](https://github.com/agda/agda/issues/3966): All clauses marked when one clause has unification error+  -  [#3972](https://github.com/agda/agda/issues/3972): Unreachable clause leads to internal error at Serialise/Instances/Internal.hs:94 (MetaV)+  -  [#3974](https://github.com/agda/agda/issues/3974): Range for unexpected implicit argument on lhs too big+  -  [#3983](https://github.com/agda/agda/issues/3983): TERMINATING accepted with --safe if hidden in a block+  -  [#3989](https://github.com/agda/agda/issues/3989): Warn about duplicate bindings in a single telescope+  -  [#4000](https://github.com/agda/agda/issues/4000): How to get Agda to ignore `~/.agda`?+  -  [#4006](https://github.com/agda/agda/issues/4006): Internal error related to abstract and variable+  -  [#4007](https://github.com/agda/agda/issues/4007): Cannot give pattern-matching lambda in abstract setting+  -  [#4010](https://github.com/agda/agda/issues/4010): unquoteDef fails in abstract block+  -  [#4012](https://github.com/agda/agda/issues/4012): Internal error when accessing abstract definitions created by unquoteDef/Decl+  -  [#4020](https://github.com/agda/agda/issues/4020): Rewriting incorrectly considers level variables under lambdas as unbound in the LHS+  -  [#4032](https://github.com/agda/agda/issues/4032): Loss of subject reduction involving --rewriting even when --confluence-check is on and everything passes the confluence checker+  -  [#4038](https://github.com/agda/agda/issues/4038): Rewriting sometimes fails to rewrite in the presence of unsolved metas+  -  [#4044](https://github.com/agda/agda/issues/4044): Equality checking uses too much memory in 2.6.0 (compared to 2.5.4)+  -  [#4046](https://github.com/agda/agda/issues/4046): Remove (deprecated) codata keyword+  -  [#4048](https://github.com/agda/agda/issues/4048): Rewriting rule fails to trigger+  -  [#4049](https://github.com/agda/agda/issues/4049): Internal error with sized types if the target type of a constructor is an alias+  -  [#4051](https://github.com/agda/agda/issues/4051): Internal error when importing a module with a hole in a type+  -  [#4053](https://github.com/agda/agda/issues/4053): Emacs-mode: Case split leaves part of old line behind+  -  [#4059](https://github.com/agda/agda/issues/4059): Two variants of irrefutable with?+  -  [#4066](https://github.com/agda/agda/issues/4066): Regression related to instance resolution+  -  [#4116](https://github.com/agda/agda/issues/4116): Internal error Forcing.hs:232+  -  [#4121](https://github.com/agda/agda/issues/4121): Pattern synonyms cannot be made private+  -  [#4125](https://github.com/agda/agda/issues/4125): Type checker normalizes too much+  -  [#4134](https://github.com/agda/agda/issues/4134): Internal error triggered by missing check for irrelevant meta dependencies+  -  [#4136](https://github.com/agda/agda/issues/4136): Overzealous pruning of metavariable with irrelevant argument+  -  [#4141](https://github.com/agda/agda/issues/4141): Printing of DontCare should not use dot syntax+  -  [#4142](https://github.com/agda/agda/issues/4142): defCopatternLHS needs to be set when record expression were translated to copatterns+  -  [#4148](https://github.com/agda/agda/issues/4148): Internal error related to records and type-level indices+  -  [#4152](https://github.com/agda/agda/issues/4152): Variables in Prop position should not raise hard error in occurs check+  -  [#4154](https://github.com/agda/agda/issues/4154): Renaming declarations within a module may cause name clash+  -  [#4158](https://github.com/agda/agda/issues/4158): Double check failure (unaware of rewrite rule)+  -  [#4163](https://github.com/agda/agda/issues/4163): pattern matching in parametrized module leads to ill-typed definitions in where modules.+  -  [#4170](https://github.com/agda/agda/issues/4170): Tactic causes Agda to enter into an infinite loop+  -  [#4179](https://github.com/agda/agda/issues/4179): Coverage check false positive+  -  [#4185](https://github.com/agda/agda/issues/4185): Agda uses η-equality for record types defined with no-eta-equality+  -  [#4205](https://github.com/agda/agda/issues/4205): Internal error in connection with with, copatterns, and open record+  -  [#4211](https://github.com/agda/agda/issues/4211): Cannot add as-pattern on literal pattern+  -  [#4214](https://github.com/agda/agda/issues/4214): `with` abstraction fails with HIT constructors in the goal+  -  [#4215](https://github.com/agda/agda/issues/4215): Case splitting should respect Nat literals+  -  [#4255](https://github.com/agda/agda/issues/4255): Hole filler accepted, but type check error on reload+  -  [#4261](https://github.com/agda/agda/issues/4261): Order of arguments affects lambda pattern matching+  -  [#4268](https://github.com/agda/agda/issues/4268): Give failure with large quantification+  -  [#4269](https://github.com/agda/agda/issues/4269): Universe levels are not solved+  -  [#4283](https://github.com/agda/agda/issues/4283): DeBruijn issue(?) in standard library tests+  -  [#4289](https://github.com/agda/agda/issues/4289): datatype scope and import guidelines+  -  [#4297](https://github.com/agda/agda/issues/4297): Missing documentation: NO_UNIVERSE_CHECK pragma+  -  [#4310](https://github.com/agda/agda/issues/4310): Anonymous .. binder should not lead to a parse error+  -  [#4314](https://github.com/agda/agda/issues/4314): Internal error with generalize+  -  [#4320](https://github.com/agda/agda/issues/4320): Path constructor overloading+  -  [#4323](https://github.com/agda/agda/issues/4323): Internal error (Rewriting.hs:395) with generalize and rewrite rules+  -  [#4330](https://github.com/agda/agda/issues/4330): Equations for cubical subtypes+  -  [#4348](https://github.com/agda/agda/issues/4348): Seemingly needless repetition of highlighting of warnings+  -  [#4360](https://github.com/agda/agda/issues/4360): Missing warning for declaring constructor instances for records with explicit fields+  -  [#4361](https://github.com/agda/agda/issues/4361): Inconsistent highlighting of BUILTING EQUALITY/REWRITE+  -  [#4371](https://github.com/agda/agda/issues/4371): Inconsistency with rewrite rules and assumptions in Prop+  -  [#4373](https://github.com/agda/agda/issues/4373): Non-imported instances are used for instance resolution+  -  [#4375](https://github.com/agda/agda/issues/4375): Internal error in Agda/TypeChecking/Monad/Context.hs:120+  -  [#4380](https://github.com/agda/agda/issues/4380): Parse error with instance constructor and end of file+  -  [#4382](https://github.com/agda/agda/issues/4382): Rewriting and records with eta+  -  [#4387](https://github.com/agda/agda/issues/4387): Less responsive Emacs mode in v2.6.1 release candidate 1+  -  [#4390](https://github.com/agda/agda/issues/4390): Unification finds solution with bound variable used at wrong modality+  -  [#4391](https://github.com/agda/agda/issues/4391): Termination checking failed with guardedness+  -  [#4399](https://github.com/agda/agda/issues/4399): Case split on unnamed argument produces non-sensical code+  -  [#4401](https://github.com/agda/agda/issues/4401): Missing check on context variables leads to Set:Set with --cumulativity+  -  [#4404](https://github.com/agda/agda/issues/4404): Disambiguation fails in Cubical Agda+  -  [#4410](https://github.com/agda/agda/issues/4410): Rewrite rule matching does not respect Prop+  -  [#4447](https://github.com/agda/agda/issues/4447): Positivity: internal error with projection in constructor type+  -  [#4451](https://github.com/agda/agda/issues/4451): Highlighting: use several lookups rather than merging hash-maps?+  -  [#4452](https://github.com/agda/agda/issues/4452): Compiler error when using REWRITE+  -  [#4469](https://github.com/agda/agda/issues/4469): The warning machinery does not work correctly when interface files are involved+++The following previously closed issues were reopened:++  -  [#1556](https://github.com/agda/agda/issues/1556): Agda allows "very dependent" types
+ doc/release-notes/2.6.2.1.md view
@@ -0,0 +1,149 @@+Release notes for Agda version 2.6.2.1+======================================++Highlights+----------++* Agda 2.6.2.1 catches up to changes in the Haskell ecosystem+  (GHC 9.2.1, `aeson-2.0`, `hashable-1.4.`).++* Fixes some regressions introduced in 2.6.1:+  [#5283](https://github.com/agda/agda/issues/5283)+  [#5506](https://github.com/agda/agda/issues/5506)+  [#5610](https://github.com/agda/agda/issues/5610)++* Fixes some regressions introduced in 2.6.2:+  [#5508](https://github.com/agda/agda/issues/5508)+  [#5544](https://github.com/agda/agda/issues/5544)+  [#5565](https://github.com/agda/agda/issues/5565)+  [#5584](https://github.com/agda/agda/issues/5584)+  [#5620](https://github.com/agda/agda/issues/5620)+  [#5638](https://github.com/agda/agda/issues/5638)+  [#5657](https://github.com/agda/agda/issues/5657)++* Improvements to the compiler backends (see below).++* Feature preview: `--ghc-strict`.++Installation and infrastructure+-------------------------------++Agda 2.6.2.1 is expected to build with GHC versions 8.0 to 9.2.+It has been tested with the latest minor version releases of GHC for+each of these major versions:++  - 8.0.2+  - 8.2.2+  - 8.4.4+  - 8.6.5+  - 8.8.4+  - 8.10.7: Issue [#5539](https://github.com/agda/agda/issues/5539).+  - 9.0.1+  - 9.2.1:+    Issue [#5442](https://github.com/agda/agda/issues/5442),+    stackage issue [#6318](https://github.com/commercialhaskell/stackage/pull/6318).++Agda 2.6.2.1 has been adapted to recent changes in the Haskell ecosystem, including:++  - `Cabal-3.6.2`+  - `aeson-2.0`:+    Issue [#5593](https://github.com/agda/agda/issues/5593),+    stackage issue [#6217](https://github.com/commercialhaskell/stackage/issues/6217).+  - `hashable-1.4`:+    Stackage issue [#6268](https://github.com/commercialhaskell/stackage/issues/6268).+  - `transformers-0.6`++Compiler backends+-----------------++* Both the GHC and JS backends now refuse to compile code that uses+  `--cubical`.++* The new option `--ghc-strict-data`, which is inspired by the GHC+  language extension `StrictData`, makes the GHC backend compile+  inductive data and record constructors to constructors with strict+  arguments.++  This does not apply to certain builtin types—lists, the maybe type,+  and some types related to reflection—and might not apply to types+  with `COMPILE GHC … = data …` pragmas.++  This feature is experimental.++* The new option `--ghc-strict`, which is inspired by the GHC language+  extension `Strict`, makes the GHC backend generate mostly strict+  code.++  Functions might not be strict in unused arguments.++  Function definitions coming from `COMPILE GHC` pragmas are not+  affected.++  This flag implies `--ghc-strict-data`, and the exceptions of that+  flag applies to this flag as well.++  Note that this option requires the use of GHC 9 or later.++  This feature is experimental.++* JS backend now uses the native `BigInt` instead of the+  [biginteger.js](https://github.com/silentmatt/javascript-biginteger).+  Fixes [#4878](https://github.com/agda/agda/issues/4878).++LaTeX backend+-------------++* Files `agda.sty` and `postprocess-latex.pl` are now found in the `latex/`+  subdirectory of the Agda data directory (`agda --print-agda-dir`).++* `agda.sty` is now versioned (printed to the `.log` file by `latex`)+  (see [#5473](https://github.com/agda/agda/issues/5473)).++* Italics correction (inserted by `\textit` e.g. in `\AgdaBound`) now works,+  thanks to moving the `\textcolor` wrapping to the outside in `agda.sty`+  (see [#5471](https://github.com/agda/agda/issues/5471)).++List of closed issues+---------------------++For 2.6.2.1, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.1+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++  - [#4878](https://github.com/agda/agda/issues/4878): Replace biginteger.js with native BigInt+  - [#5283](https://github.com/agda/agda/issues/5283): Tactic command runs forever+  - [#5291](https://github.com/agda/agda/issues/5291): `match` doesn't work for non-prefix-free cases+  - [#5302](https://github.com/agda/agda/issues/5302): building tests with cabal+  - [#5396](https://github.com/agda/agda/issues/5396): Internal error for rewriting without --confluence-check+  - [#5398](https://github.com/agda/agda/issues/5398): Problem with LaTeX code for multi-line comments with blank lines+  - [#5420](https://github.com/agda/agda/issues/5420): The JS backend generates incorrect code for Agda code that uses reflection+  - [#5421](https://github.com/agda/agda/issues/5421): The GHC backend generates incorrect code for Agda code that uses reflection+  - [#5431](https://github.com/agda/agda/issues/5431): --ghc-strict-data and --ghc-strict+  - [#5433](https://github.com/agda/agda/issues/5433): The JS backend "installs" highlight-hover.js+  - [#5440](https://github.com/agda/agda/issues/5440): (Re)Documenting `catchfilebetweentags` method of building latex files with Agda+  - [#5442](https://github.com/agda/agda/issues/5442): Support GHC 9.2+  - [#5463](https://github.com/agda/agda/issues/5463): Hole in the middle of a record is malformed+  - [#5465](https://github.com/agda/agda/issues/5465): Compilation of Parser.y depends on the locale on Debian too+  - [#5469](https://github.com/agda/agda/issues/5469): `onlyReduceDefs` should not prevent evaluation of macros+  - [#5470](https://github.com/agda/agda/issues/5470): Internal error when using `REWRITE` in `private` block+  - [#5471](https://github.com/agda/agda/issues/5471): LaTeX backend: italics correction+  - [#5473](https://github.com/agda/agda/issues/5473): agda.sty has no version+  - [#5478](https://github.com/agda/agda/issues/5478): Open goal inside record causes internal error (eta-contraction)+  - [#5481](https://github.com/agda/agda/issues/5481): Pattern-matching on records in Prop allows eliminating into Set+  - [#5489](https://github.com/agda/agda/issues/5489): C-c C-x C-a (abort) does not communicate well+  - [#5490](https://github.com/agda/agda/issues/5490): Why does abort (C-c C-x C-a) remove highlighting from the buffer?+  - [#5506](https://github.com/agda/agda/issues/5506): Agda panic: Pattern match failure+  - [#5508](https://github.com/agda/agda/issues/5508): Internal error typechecking non-terminating function on case-insensitive filesystem+  - [#5514](https://github.com/agda/agda/issues/5514): Support GHC 8.10.6+  - [#5531](https://github.com/agda/agda/issues/5531): Internal bug: TypeChecking/Sort+  - [#5532](https://github.com/agda/agda/issues/5532): "The module was successfully compiled" should mention with which backend+  - [#5539](https://github.com/agda/agda/issues/5539): Support GHC 8.10.7+  - [#5544](https://github.com/agda/agda/issues/5544): Internal error caused by addition of `Checkpoints` to `OpenThing`+  - [#5557](https://github.com/agda/agda/issues/5557): Allow Agda to output data files+  - [#5565](https://github.com/agda/agda/issues/5565): Internal error in Agda.TypeChecking.MetaVars+  - [#5593](https://github.com/agda/agda/issues/5593): Compilation failure with `aeson-2`+  - [#5602](https://github.com/agda/agda/issues/5602): The JS backend does not reduce constructor type signatures+  - [#5610](https://github.com/agda/agda/issues/5610): Panic when checking pragma BUILTIN SHARP+  - [#5620](https://github.com/agda/agda/issues/5620): Seemingly incorrect warning for abstract definition without type signature+  - [#5633](https://github.com/agda/agda/issues/5633): Case splitting inserts one with pattern too much (regression in 2.6.2)+  - [#5657](https://github.com/agda/agda/issues/5657): Internal error with postfix projection
+ 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.2.md view
@@ -0,0 +1,1250 @@+Release notes for Agda version 2.6.2+====================================++Highlights+----------++* Several improvements and bug-fixes related to [Run-time+  Irrelevance](https://agda.readthedocs.io/en/v2.6.2/language/runtime-irrelevance.html).++* Several improvements and bug-fixes related to the [JavaScript+  Backend](https://agda.readthedocs.io/en/v2.6.2/tools/compilers.html#javascript-backend).++* Added experimental support for [Guarded Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.2/language/guarded-cubical.html).++* The [Primitive+  Sorts](https://agda.readthedocs.io/en/v2.6.2/language/built-ins.html#sorts)+  of Agda (`Set` and `Prop`) are no longer keywords and can be renamed+  when importing `Agda.Primitive`.++* Added native support for the [Inspect+  Idiom](https://agda.readthedocs.io/en/v2.6.2/language/with-abstraction.html#with-abstraction-equality).++* Added support for making [System+  Calls](https://agda.readthedocs.io/en/v2.6.2/language/reflection.html#system-calls)+  from the reflection API.++Installation and infrastructure+-------------------------------++* Added support for GHC 8.10.5 and 9.0.1.++* Some expensive optimisations are now off by default+  (see [#4521](https://github.com/agda/agda/issues/4521)).++  These optimisations can in some cases make Agda substantially+  faster, but they can also make the compilation of the Agda program+  take more time and space.++  The optimisations can be turned on manually (Cabal:+  `-foptimise-heavily`, Stack: `--flag Agda:optimise-heavily`). They+  are turned on (by default) when Agda is installed using `make+  install`.++  If the optimisations are turned on it might make sense to limit+  GHC's memory usage (using something like `--ghc-options="+RTS -M6G+  -RTS"`).++Pragmas and options+-------------------++* New option `--auto-inline` turns on automatic compile-time inlining+  of simple functions. This was previously enabled by default.++  Note that the absence of automatic inlining can make typechecking+  substantially slower.++  The new default has repercussions on termination checking, for instance+  (see [#4702](https://github.com/agda/agda/issues/4702)).+  The following formulation of `plus` termination checks with `--auto-inline`+  but not without:+  ```agda+  open import Agda.Builtin.Nat++  case_of_ : {A B : Set} → A → (A → B) → B+  case x of f = f x++  plus : Nat → Nat → Nat+  plus m n = case m of λ+     { zero    → n+     ; (suc m) → suc (plus m n)+     }+  ```+  In this particular case, we can work around the limitation of the+  termination checker with pragma `{-# INLINE case_of_ #-}`.++* New options `--qualified-instances` (default) and+  `--no-qualified-instances`. When `--no-qualified-instances` is+  enabled, Agda will only consider candidates for instance search that+  are in scope under an unqualified name (see+  [#4522](https://github.com/agda/agda/pull/4522)).++* New option `--call-by-name` turns off call-by-need evaluation at type+  checking time.++* New option `--highlight-occurrences` (off by default) enables the HTML+  backend to include a JavaScript file that highlights all occurrences of+  the mouse-hovered symbol (see+  [#4535](https://github.com/agda/agda/pull/4535)).++* New option `--no-import-sorts` disables the implicit `open+  import Agda.Primitive using (Set; Prop)` at the top of each file+  (see below).++* New option `--local-confluence-check` to restore the old behaviour+  of the `--confluence-check` flag (see below for the new behaviour).++* New primitive `primStringFromListInjective` internalising the fact that+  `primStringFromList` is an injective function. It is bound in+  `Agda.Builtin.String.Properties`.++* New option `--allow-exec` enables the use of system calls during+  type checking using the `AGDATCMEXECTC` builtin.++* New option `--show-identity-substitutions` shows all arguments of+  metavariables when pretty-printing a term, even if they amount to+  just applying all the variables in the context.++* The option `--rewriting` is now considered infective: if a module has+  `--rewriting` enabled, then all modules importing it must also have+  `--rewriting` enabled.++* New option `--no-double-check` (default), opposite of the existing+  `--double-check`.++* Due to several known soundness issues with sized types (see+  [#1201](https://github.com/agda/agda/issues/1201),+  [#1946](https://github.com/agda/agda/issues/1946),+  [#2820](https://github.com/agda/agda/issues/2820),+  [#3026](https://github.com/agda/agda/issues/3026)), the+  `--sized-types` flag can no longer be used while `--safe` is active.++* New option `--guarded` turns on the Guarded Cubical extension of Agda.++  See [Guarded Cubical](https://agda.readthedocs.io/en/v2.6.2/language/guarded-cubical.html)+  in the documentation for more.++* The flags `--guardedness` and `--sized-types` are no longer enabled+  by default.++Command-line interaction+------------------------++* In the previous release, Agda exited with either status 0 when the+  program type checks successfully, or status 1 when encountering any+  kind of error.  Now Agda exits with status 42 for type errors, 71+  for errors in the commandline arguments, and 154 for impossible+  errors. Exit status 1 may be returned under other circumstances; for+  instance, an incomplete pattern matching, or an error generated by+  the Haskell runtime.  See PR+  [#4540](https://github.com/agda/agda/pull/4540).++Lexical syntax+--------------++* Layout handling has been improved so that block starters can be+  stacked on the same line+  [#1145](https://github.com/agda/agda/issues/1145).++  If several layout blocks are started by layout keywords without line+  break in between (where line breaks inside block comments do not+  count), then those blocks indented *more* than the last block go+  passive, meaning they cannot be further extended by new statements.+  ```agda+    private module M where postulate+              A : Set                 -- module-block goes passive+              B : Set                 -- postulate-block can still be extended+            module N where            -- private-block can still be extended+  ```+  Previously, this was a parse error.++Language+--------++* Inductive records without η-equality no longer support both matching+  on the record constructor and construction of record elements by+  copattern matching.  It has been discovered that the combination of+  both leads to loss of subject reduction, i.e., reduction does not+  preserve typing.  See issue+  [#4560](https://github.com/agda/agda/issues/4560).++  η-equality for a record can be turned off manually with directive+  `no-eta-equality` or command-line option `--no-eta-equality`, but it+  is also automatically turned off for some recursive records.  For+  records without η, matching on the record constructor is now off by+  default and construction by copattern matching is on.  If you want+  the converse, you can add the new record directive `pattern`.++  Example with record pattern:+  ```agda+  record N : Set where+    inductive+    no-eta-equality+    pattern+    field out : Maybe N++  pred : N → Maybe N+  pred record{ out = m } = m+  ```+  Example with record constructor and use of `;` instead of newline:+  ```agda+  record N : Set where+    inductive; no-eta-equality+    pattern; constructor inn+    field out : Maybe N++  pred : N → Maybe N+  pred (inn m) = m+  ```++* `Set` and `Prop` are no longer keywords but are now primitives+  defined in the module `Agda.Primitive`. They can be renamed when+  importing this module, for example:++  ```agda+  open import Agda.Primitive renaming (Set to Type)++  test : Type₁+  test = Type+  ```++  To preserve backwards compatibility, each top-level Agda module now+  starts with an implicit statement:++  ```agda+  open import Agda.Primitive using (Set; Prop)+  ```++  This implicit import can be disabled with the+  `--no-import-sorts` flag.++* Agda now has support for sorts `Setωᵢ` (alternative syntax: `Setωi`)+  for natural numbers `i`, where `Setω₀ = Setω`. These sorts form a+  second hierarchy `Setωᵢ : Setωᵢ₊₁` similar to the standard hierarchy+  of `Setᵢ`, but do not support universe polymorphism. It should not+  be necessary to refer to these sorts during normal usage of Agda,+  but they might be useful for defining reflection-based macros (see+  [#2119](https://github.com/agda/agda/issues/2119) and+  [#4585](https://github.com/agda/agda/issues/4585)).++* Changed the internal representation of literal strings: instead of using a+  linked list of characters (`String`), we are now using `Data.Text`. This+  should be a transparent change from the user's point of view: the backend+  was already packing these strings as text.++  Used this opportunity to introduce a `primStringUncons` primitive in+  `Agda.Builtin.String` (and to correspondingly add the+  `Agda.Builtin.Maybe` it needs).++* The option `--confluence-check` for rewrite rules has been given a+  new implementation that checks global confluence instead of local+  confluence. Concretely, it does so by enforcing two properties:++  1. For any two left-hand sides of the rewrite rules that overlap+     (either at the root position or at a subterm), the most general+     unifier of the two left-hand sides is again a left-hand side of a+     rewrite rule. For example, if there are two rules `suc m + n =+     suc (m + n)` and `m + suc n = suc (m + n)`, then there should+     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 `u =>+     v`, we should have another single-step parallel unfolding `v =>+     w`.++  The previous behaviour of the confluence checker that only ensures+  local confluence can be restored by using the+  `--local-confluence-check` flag.++* Binary integer literals with prefix `0b` (for instance,+  `0b11001001`) are now supported.++* Overloaded literals now require the conversion function (`fromNat`,+  `fromNeg`, or `fromString`) to be in scope *unqualified* to take+  effect.++  Previously, it was enough for the function to be in scope at all,+  which meant you couldn't import the corresponding builtin module+  without having overloaded literals turned on.++* Added `interleaved mutual` blocks where users can forward-declare+  function, record, and data types and interleave their+  definitions. These blocks are elaborated to more traditional mutual+  blocks by:++    - leaving the signatures where they are+    - grouping the clauses for a function together with the first of them+    - grouping the constructors for a datatype together with the first of them++  Example: two interleaved function definitions++  ```agda++  interleaved mutual++    -- Declarations:+    even : Nat → Bool+    odd  : Nat → Bool++    -- zero is even, not odd+    even zero = true+    odd  zero = false++    -- suc case: switch evenness on the predecessor+    even (suc n) = odd n+    odd  (suc n) = even n+  ```++  Other example: the definition of universe of types closed under the+  natural numbers and pairing:++  ```agda++  interleaved mutual++    -- Declaration of a product record, a universe of codes, and a decoding function+    record _×_ (A B : Set) : Set+    data U : Set+    El : U → Set++    -- We have a code for the type of natural numbers in our universe+    constructor `Nat : U+    El `Nat = Nat++    -- Btw we know how to pair values in a record+    record _×_ A B where+      constructor _,_+      inductive+      field fst : A; snd : B++    -- And we have a code for pairs in our universe+    constructor _`×_ : (A B : U) → U+    El (A `× B) = El A × El B+  ```++* Erased constructors (see+  [#4638](https://github.com/agda/agda/issues/4638)).++  Constructors can be marked as erased. Example:+  ```agda+    {-# OPTIONS --cubical --safe #-}++    open import Agda.Builtin.Cubical.Path+    open import Agda.Primitive++    private+      variable+        a   : Level+        A B : Set a++    Is-proposition : Set a → Set a+    Is-proposition A = (x y : A) → x ≡ y++    data ∥_∥ (A : Set a) : Set a where+      ∣_∣        : A → ∥ A ∥+      @0 trivial : Is-proposition ∥ A ∥++    rec : @0 Is-proposition B → (A → B) → ∥ A ∥ → B+    rec p f ∣ x ∣           = f x+    rec p f (trivial x y i) = p (rec p f x) (rec p f y) i+  ```+  In the code above the constructor `trivial` is only available at+  compile-time, whereas `∣_∣` is also available at run-time. Erased+  names can be used in bodies of clauses that match on `trivial`, if+  the match is done in a non-erased position, like in the final clause+  of `rec`. (Note that Cubical Agda programs still cannot be+  compiled.)++* Erased pattern-matching lambdas (see+  [#4525](https://github.com/agda/agda/issues/4525)).++  Regular pattern-matching lambdas are treated as non-erased+  function definitions. One can make a pattern-matching lambda erased+  by writing `@0` or `@erased` after the lambda:+  ```agda+  @0 _ : @0 Set → Set+  _ = λ @0 { A → A }++  @0 _ : @0 Set → Set+  _ = λ @erased where+    A → A+  ```++  The reflection machinery currently does not support erased+  pattern-matching lambdas (they are quoted as regular+  pattern-matching lambdas).++* New (?) rule for modalities of generalised variables+  (see [#5058](https://github.com/agda/agda/issues/5058)).++  The new rule is that generalisable variables get the modality that+  they are declared with, whereas other variables always get the+  default modality. (It is unclear what the old rule was, perhaps+  nothing was changed.)++* Private abstract type signatures can no longer see through abstract+  (see [#418](https://github.com/agda/agda/issues/418)).++  This means that abstract definitions no longer evaluate in *any*+  type signatures in the same module. Previously they evaluated in+  type signatures of definitions that were both private and abstract.++  It also means that metavariables in type signatures have to be+  solved locally, and cannot make use of information in the definition+  body, and that constructors of abstract datatypes are not in scope+  in type signatures.++* Type inference is disabled for abstract definitions (see+  [#418](https://github.com/agda/agda/issues/418)).++  This means that abstract definitions (inluding functions defined in+  `where` blocks of abstract definitions) need complete type+  signatures.++* One can now declare syntax with two name parts without any hole in+  between, and syntax without any holes.++  Examples:+  ```agda+  syntax Σ A (λ x → B) = [ x ∶ A ] × B+  syntax []            = [ ]+  ```++* Internalised the *inspect idiom* that allows users to abstract over+  an expression in a ``with`` clause while, at the same time,+  remembering the origin of the abstracted pattern via an equation.++  In the following example, abstracting over and then matching on the+  result of ``p x`` allows the first call to ``filter p (x ∷ xs)`` to+  reduce.++  In case the element ``x`` is kept, the second call to ``filter`` on+  the LHS then performs the same ``p x`` test. Because we have+  retained the proof that ``p x ≡ true`` in ``eq``, we are able to+  rewrite by this equality and get it to reduce too.++  This leads to just enough computation that we can finish the proof+  with an appeal to congruence and the induction hypothesis.++  ```agda+  filter-filter : ∀ p xs → filter p (filter p xs) ≡ filter p xs+  filter-filter p []       = refl+  filter-filter p (x ∷ xs) with p x in eq+  ... | false = filter-filter p xs -- easy+  ... | true -- second filter stuck on `p x`: rewrite by `eq`!+    rewrite eq = cong (x ∷_) (filter-filter p xs)+  ```++* As a consequence of the above extensions to `with`, lambdas and lets+  now need parentheses when appearing in a `with`. For instance,++  ```agda+  with-on-fun : Nat → Nat+  with-on-fun n with (λ m → m + n)  -- parentheses required!+  ... | f = f n+  ```++* It is now possible to add hiding and relevance annotations to `with`+  expressions. For example:++  ```agda+  module _ (A B : Set) (recompute : .B → .{{A}} → B) where++    _$_ : .(A → B) → .A → B+    f $ x with .{f} | .(f x) | .{{x}}+    ... | y = recompute y+  ```++Builtins+--------++- Primitive operations for floating-point numbers changed. The equalities now+  follow IEEE 754 equality, after unifying all NaNs. Primitive inequality was+  added:+  ```agda+  primFloatEquality   : Float -> Float -> Bool -- from primFloatNumericEquality+  primFloatLess       : Float -> Float -> Bool -- from primFloatNumericLess+  primFloatInequality : Float -> Float -> Bool -- new+  ```+  The “numeric” relations are now deprecated.++  There are several new predicates on floating-point numbers:+  ```agda+  primFloatIsInfinite     : Float -> Bool -- new+  primFloatIsNaN          : Float -> Bool -- new+  primFloatIsSafeInteger  : Float -> Bool -- new+  ```+  The `primFloatIsSafeInteger` function determines whether the value is a number+  that is a safe integer, i.e., is within the range where the arithmetic+  operations do not lose precision.++  The operations for conversion to integers (`primRound`, `primFloor`,+  and `primCeiling`) were renamed for consistency, and return a value+  of type `Maybe Int`, returning `nothing` for NaN and the infinities:+  ```agda+  primFloatRound   : Float → Maybe Int -- from primRound+  primFloatFloor   : Float → Maybe Int -- from primFloor+  primFloatCeiling : Float → Maybe Int -- from primCeiling+  ```++  There are several new conversions:+  ```agda+  primIntToFloat    : Int -> Float               -- new+  primFloatToRatio  : Float -> (Int × Nat)       -- new+  primRatioToFloat  : Int -> Nat -> Float        -- new+  primFloatDecode   : Float -> Maybe (Int × Int) -- new+  primFloatEncode   : Int -> Int -> Maybe Float  -- new+  ```+  The `primFloatDecode` function decodes a floating-point number f to a mantissa+  and exponent, such that `f = mantissa * 2 ^ exponent`, normalised such that+  the mantissa is the smallest possible number. The `primFloatEncode` function+  encodes a pair of a mantissa and exponent to a floating-point number.++  There are several new operations:+  ```agda+  primFloatPow        : Float -> Float -> Float -- new+  primFloatATan2      : Float -> Float -> Float -- from primATan2+  primFloatSinh       : Float -> Float          -- new+  primFloatCosh       : Float -> Float          -- new+  primFloatTanh       : Float -> Float          -- new+  primFloatASinh      : Float -> Float          -- new+  primFloatACosh      : Float -> Float          -- new+  primFloatATanh      : Float -> Float          -- new+  ```+  Furthermore, the following operations were renamed for consistency:+  ```agda+  primFloatExp        : Float -> Float          -- from primExp+  primFloatSin        : Float -> Float          -- from primSin+  primFloatLog        : Float -> Float          -- from primLog+  primFloatCos        : Float -> Float          -- from primCos+  primFloatTan        : Float -> Float          -- from primTan+  primFloatASin       : Float -> Float          -- from primASin+  primFloatACos       : Float -> Float          -- from primACos+  primFloatATan       : Float -> Float          -- from primATan+  ```++  All of these operations are implemented on the JavaScript backend.++- `primNatToChar` maps surrogate code points to the replacement character+  `'U+FFFD` and surrogate code points are disallowed in character literals++  [Surrogate code points](https://www.unicode.org/glossary/#surrogate_code_point)+  are characters in the range `U+D800` to `U+DFFF` and are reserved for use by+  UTF-16.++  The reason for this change is that strings are represented (at type-checking+  time and in the GHC backend) by Data.Text byte strings, which cannot+  represent surrogate code points and replaces them by `U+FFFD`. By doing the+  same for characters we can have `primStringFromList` be injective (witnessed+  by `Agda.Builtin.String.Properties.primStringFromListInjective`).+++Reflection+----------++- New operation in `TC` monad, similar to `quoteTC` but operating on+  types in `Setω`+  ```agda+  quoteωTC : ∀ {A : Setω} → A → TC Term+  ```+- `typeError` and `debugPrint` no longer inserts spaces around `termErr` and+  `nameErr` parts. They also do a better job of respecting line breaks in+  `strErr` parts.++- The reflection machinery now supports quantities in `Arg` (see+  [#5317](https://github.com/agda/agda/issues/5317)). The `ArgInfo`+  type has changed, and there are new types `Modality` and `Quantity`:+  ```agda+  data Quantity : Set where+    quantity-0 quantity-ω : Quantity++  {-# BUILTIN QUANTITY   Quantity   #-}+  {-# BUILTIN QUANTITY-0 quantity-0 #-}+  {-# BUILTIN QUANTITY-ω quantity-ω #-}++  data Modality : Set where+    modality : (r : Relevance) (q : Quantity) → Modality++  {-# BUILTIN MODALITY             Modality #-}+  {-# BUILTIN MODALITY-CONSTRUCTOR modality #-}++  data ArgInfo : Set where+    arg-info : (v : Visibility) (m : Modality) → ArgInfo+  ```++- The representation of reflected patterns and clauses has+  changed. Each clause now includes a telescope with the names and+  types of the pattern variables.++  ```agda+  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+  ```++  These telescopes provide additional information on the types of+  pattern variables that was previously hard to reconstruct (see+  [#2151](https://github.com/agda/agda/issues/2151)). When unquoting a+  clause, the types in the clause telescope are currently ignored (but+  this is subject to change in the future).++  Three constructors of the `Pattern` datatype were also changed:++  * pattern variables now refer to a de Bruijn index (relative to the+    clause telescope) rather than a string,+  * absurd patterns take a de Bruijn index and are expected to be bound by the+    clause telescope,+  * dot patterns now include the actual dotted term.++  ```agda+  data Pattern where+    con    : (c : Name) (ps : List (Arg Pattern)) → Pattern+    dot    : (t : Term)    → Pattern   -- previously:   dot : Pattern+    var    : (x : Nat)     → Pattern   -- previously:   var : (x : String) → Pattern+    lit    : (l : Literal) → Pattern+    proj   : (f : Name)    → Pattern+    absurd : (x : Nat)     → Pattern+  ```++  It is likely that this change to the reflected syntax requires you+  to update reflection code written for previous versions of+  Agda. Here are some tips for updating your code:++  * When quoting a clause, you can recover the name of a pattern+    variable by looking up the given index in the clause+    telescope. The contents of dot patterns can safely be ignored+    (unless you have a use for them).++  * When creating a new clause for unquoting, you need to create a+    telescope for the types of the pattern variables. To get back the+    old behaviour of Agda, it is sufficient to set all the types of+    the pattern variables to `unknown`. So you can construct the+    telescope by listing the names of all pattern variables and absurd+    patterns together with their `ArgInfo`. Meanwhile, the pattern+    variables should be numbered in order to update them to the new+    representation. As for the telescope types, the contents of a+    `dot` pattern can safely be set to `unknown`.++- New operation in `TC` monad, `execTC`, which calls an external executable+  ```agda+  execTC : (exe : String) (args : List String) (stdIn : String)+         → TC (Σ Nat (λ _ → Σ String (λ _ → String)))+  ```+  The `execTC` builtin takes three arguments: the basename of the+  executable (e.g., `"echo"`), a list of arguments, and the contents+  of the standard input. It returns a triple, consisting of the exit+  code (as a natural number), the contents of the standard output, and+  the contents of the standard error.++  The builtin is only available when `--allow-exec` is passed. (Note+  that `--allow-exec` is incompatible with ``--safe``.) To make an+  executable available to Agda, add the absolute path on a new line in+  `~/.agda/executables`.++- Two new operations in the `TC` monad, `onlyReduceDefs` and+  `dontReduceDefs`:+  ```agda+  onlyReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+  dontReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+  ```+  These functions allow picking a specific set of functions that+  should (resp. should not) be reduced while executing the given `TC`+  computation.++  For example, the following macro unifies the current hole with the+  term `3 - 3`:+  ```agda+  macro₁ : Term -> TC ⊤+  macro₁ goal = do+    u   ← quoteTC ((1 + 2) - 3)+    u'  ← onlyReduceDefs (quote _+_ ∷ []) (normalise u)+    unify u' goal+  ```+- New operation in the `TC` monad, `withReconstructed`:+  ```agda+  withReconstructed : ∀ {a} {A : Set a} → TC A → TC A+  ```++  This function ensures reconstruction of hidden parameters+  after performing the `TC` computation.  For example, consider the+  following type and function:+  ```agda+  record RVec {a} (X : Set a) (n : Nat) : Set a where+    constructor vec+    field sel : Fin n → X++  test-rvec : Nat → RVec Nat 5+  test-rvec x = vec λ _ → x+  ```++  In the reflected syntax the body of the `test-rvec` would be represented+  as `con vec (unknown ∷ unknown ∷ unknown ∷ (lam _ x)`.  The use of+  `withReconstructed` replaces `unknown`s with the actual values:+  ```agda+  macro₂ : Name → Term → TC ⊤+  macro₂ n hole = do+    (function (clause tel ps t ∷ [])) ←+      withReconstructed (getDefinition n)+      where _ → quoteTC "ERROR" >>= unify hole+    quoteTC t >>= unify hole+  ```++- Three new constructors in the `Sort` datatype, `prop : Level →+  Sort`, `propLit : Nat → Sort`, and `inf : Nat → Sort`, representing+  the sorts `Prop ℓ`, `Propᵢ`, and `Setωᵢ`.++- Terms that belong to a type in `Prop` are no longer unquoted to+  `unknown` but to a proper `Term`. (See+  [#3553](https://github.com/agda/agda/issues/3553).)++Library management+------------------++- `.agda-lib` files can now contain an extra field `flags:` with+  default flags for the library. Flags can be any flags that are+  accepted as part of an `{-# OPTIONS ... #-}` pragma. For example,+  file `my-library.agda-lib` with++  ```+  flags: --without-K+  ```++  will apply the `--without-K` flag to all Agda files in the current+  directory and (recursive) subdirectories that do not themselves+  contain an `.agda-lib` file.+++Emacs mode+----------++* New command prefix `C-u C-u C-u` for weak-head normalization. For instance,+  given++  ```agda+  downFrom : Nat → List Nat+  downFrom 0 = []+  downFrom (suc n) = n ∷ downFrom n+  ```++  `C-u C-u C-u C-c C-n downFrom 5` returns `4 ∷ downFrom 4`.++* New keyboard shortcut `C-c C-x C-i` for toggling display of+  irrelevant arguments.++* One can no longer use commands like `M-;` (`comment-dwim`) to+  uncomment block comments. In return one can use `M-;` to comment out+  pragmas. (See [#3329](https://github.com/agda/agda/issues/3329).)++JSON Interaction mode+---------------------++Changes have been made to the structure of error and warning+messages. The changes are summarized below. See+[#5052](https://github.com/agda/agda/issues/5052) for additional+details.++* The format of an error or warning was previously a bare string. Now, errors+  and warnings are represented by an object with a `"message"` key.++  This means that responses _previously_ structured like:++  ```json+  {"…": "…", "error": "Foo bar baz"}+  ```++  will now be structured:++  ```json+  {"…": "…", "error": {"message": "Foo bar baz"}}+  ```++  This applies directly to the `PostPonedCheckFunDef` response kind+  and `Error` info kind of the `DisplayInfo` response kind.++* The format of collections of errors or warnings, which previously were each+  represented by a single newline-joined string, has been updated to represent+  each warning or error individually in a list.++  That means that responses _previously_ structured like:++  ```json+  { "…": "…"+  , "errors": "Postulates overcooked\nAxioms too wiggly"+  , "warnings": "Something wrong\nSomething else\nwrong"+  }+  ```++  will now be structured:++  ```json+  { "…": "…"+  , "errors":+    [ { "message": "Postulates overcooked" }+    , { "message": "Axioms too wiggly" }+    ]+  , "warnings":+    [ { "message": "Something wrong" }+    , { "message": "Something else\nwrong" }+    ]+  }+  ```++  This applies to `CompilationOk`, `AllGoalsWarning`, and `Error` info+  kinds of the `DisplayInfo` response kind.++* The `Error` info kind of the `DisplayInfo` response kind has+  additionally been updated to distinguish warnings and errors.++  An example of the _previous_ format of a `DisplayInfo` response with+  an `Error` info kind was:+  ```json+  {+    "kind": "DisplayInfo",+    "info": {+      "kind": "Error",+      "message": "———— Error —————————————————————————————————————————————————\n/data/code/agda-test/Test.agda:2,1-9\nFailed to find source of module M in any of the following\nlocations:\n  /data/code/agda-test/M.agda\n  /data/code/agda-test/M.lagda\nwhen scope checking the declaration\n  import M\n\n———— Warning(s) ————————————————————————————————————————————\n/data/code/agda-test/Test.agda:3,1-10\nEmpty postulate block."+    }+  }+  ```++  The updated format is:+  ```json+  {+    "kind": "DisplayInfo",+    "info": {+      "kind": "Error",+      "error": {+        "message": "/data/code/agda-test/Test.agda:2,1-9\nFailed to find source of module M in any of the following\nlocations:\n  /data/code/agda-test/M.agda\n  /data/code/agda-test/M.lagda\nwhen scope checking the declaration\n  import M"+      },+      "warnings": [+        {+          "message": "/data/code/agda-test/Test.agda:3,1-10\nEmpty postulate block."+        }+      ]+    }+  }+  ```++Compiler backends -----------------++- With option `--allow-unsolved-metas`, code with holes can be compiled.+  If a hole is reached at runtime, the compiled program crashes.+  See issue [#5103](https://github.com/agda/agda/issues/5103)++- Previously the GHC backend compiled at least one instance of Hinze's+  memoisation technique from ["Memo functions,+  polytypically!"](http://www.cs.ox.ac.uk/ralf.hinze/publications/index.html#P11)+  to reasonably efficient code. That is no longer the case (at least+  for that particular instance, see+  [#5153](https://github.com/agda/agda/issues/5153)).++LaTeX backend+-------------++- The spacing in comments is now preserved when generating LaTex files+  from literate Agda.  See+  [#5320](https://github.com/agda/agda/pull/5320) for more details.++HTML backend+------------++- The named `id` attributes for local modules inside local modules are+  now different (see [#5335](https://github.com/agda/agda/pull/5320)).++  For instance, consider the following Agda file:+  ```agda+  module Top-level where++    module Inner where++      module Inside-inner where+  ```+  Previously one could link to the module `Inside-inner` using a URL+  that ended with `#Inside-inner`. Now one can use+  `#Inner.Inside-inner` instead.++JS backend+----------++- Smaller local variable names in the generated JS code.++  Previously: `x0`, `x1`, `x2`, ...++  Now: `a`, `b`, `c`, ..., `z`, `a0`, `b0`, ..., `z0`, `a1`, `b1`, ...++- Improved indentation of generated JS code.++- More compact rendering of generated JS functions.++  Previously:+  ```js+  exports["N"]["suc"] = function (x0) {+      return function (x1) {+        return x1["suc"](x0);+      };+    };+  ```++  Now:+  ```js+  exports["N"]["suc"] = a => b => b["suc"](a);+  ```++- Irrelevant arguments are now erased in the generated JS code.++  Example Agda code:+  ```agda+  flip : {A B C : Set} -> (B -> A -> C) -> A -> B -> C+  flip f a b = f b a+  ```++  Previously generated JS code:+  ```js+  exports["flip"] = function (x0) {+      return function (x1) {+        return function (x2) {+          return function (x3) {+            return function (x4) {+              return function (x5) {+                return x3(x5)(x4);+              };+            };+          };+        };+      };+    };+  ```++  JS code generated now:+  ```js+  exports["flip"] = a => b => c => a(c)(b);+  ```++- Record fields are not stored separately (the fields are stored only+  in the constructor) in the generated JS code.++  Example Agda code:+  ```agda+  record Sigma (A : Set) (B : A -> Set) : Set where+    field+      fst : A+      snd : B fst+  ```++  Previously generated JS code (look at the `"fst"` and `"snd"` fields in the+  return value of `exports["Sigma"]["record"]`:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = function (x0) {+      return x0["record"]({+        "record": function (x1, x2) {+          return x1;+        }+      });+    };+  exports["Sigma"]["snd"] = function (x0) {+      return x0["record"]({+        "record": function (x1, x2) {+          return x2;+        }+      });+    };+  exports["Sigma"]["record"] = function (x0) {+      return function (x1) {+        return {+          "fst": x0,+          "record": function (x2) {+            return x2["record"](x0, x1);+          },+          "snd": x1+        };+      };+    };+  ```++  JS code generated now:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a["record"]({"record": (b,c) => b});+  exports["Sigma"]["snd"] = a => a["record"]({"record": (b,c) => c});+  exports["Sigma"]["record"] = a => b => ({"record": c => c["record"](a,b)});+  ```++- `--js-optimize` flag has been added to the `agda` compiler.++  With `--js-optimize`, `agda` does not wrap records in JS objects.++  Example Agda code:+  ```agda+  record Sigma (A : Set) (B : A -> Set) : Set where+    field+      fst : A+      snd : B fst+  ```++  JS code generated without the `--js-optimize` flag:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a["record"]({"record": (b,c) => b});+  exports["Sigma"]["snd"] = a => a["record"]({"record": (b,c) => c});+  exports["Sigma"]["record"] = a => b => ({"record": c => c["record"](a,b)});+  ```++  JS code generated with the `--js-optimize` flag:+  ```js+  exports["Sigma"] = {};+  exports["Sigma"]["fst"] = a => a((b,c) => b);+  exports["Sigma"]["snd"] = a => a((b,c) => c);+  exports["Sigma"]["record"] = a => b => c => c(a,b);+  ```++  With `--js-optimize`, `agda` uses JS arrays instead of JS objects.+  This is possible because constructor names are not relevant during the evaluation.++  Example Agda code:+  ```agda+  data Bool : Set where+    false : Bool+    true  : Bool++  not : Bool -> Bool+  not false = true+  not true  = false+  ```++  JS code generated without the `--js-optimize` flag:+  ```js+  exports["Bool"] = {};+  exports["Bool"]["false"] = a => a["false"]();+  exports["Bool"]["true"] = a => a["true"]();+  exports["not"] = a => a({+      "false": () => exports["Bool"]["true"],+      "true": () => exports["Bool"]["false"]+    });+  ```++  JS code generated with the `--js-optimize` flag:+  ```js+  exports["Bool"] = {};+  exports["Bool"]["false"] = a => a[0/* false */]();+  exports["Bool"]["true"] = a => a[1/* true */]();+  exports["not"] = a => a([+      /* false */() => exports["Bool"]["true"],+      /* true */() => exports["Bool"]["false"]+    ]);+  ```++  Note that comments are added to generated JS code to help human readers.++  Erased branches are replaced by `null` in the generated array.  If+  more than the half of branches are erased, the array is compressed+  to be a object like `{3: ..., 13: ...}`.++- `--js-minify` flag has been added to the `agda` compiler.++  With `--js-minify`, `agda` discards comments and whitespace in the+  generated JS code.+++Agda as a library (API)+-----------------------++* The `SourceInfo` record has been renamed to `Source`, and the+  `sourceInfo` function to `parseSource`.++Other issues+------------++For 2.6.2, the following issues were also closed (see [bug+tracker](https://github.com/agda/agda/issues)):++  -  [#418](https://github.com/agda/agda/issues/418): Unifier ignores presence of abstract keyword+  -  [#958](https://github.com/agda/agda/issues/958): Module application display forms in parameterised modules+  -  [#1145](https://github.com/agda/agda/issues/1145): Allow multiple layout keywords on the same line+  -  [#2151](https://github.com/agda/agda/issues/2151): Add TC primitive to check left-hand side+  -  [#2461](https://github.com/agda/agda/issues/2461): Support with in the presence of IApply patterns+  -  [#2858](https://github.com/agda/agda/issues/2858): Feature request: Interleaving mutually-defined functions & datatypes+  -  [#3000](https://github.com/agda/agda/issues/3000): Interaction: iterated give encounters internal error+  -  [#3118](https://github.com/agda/agda/issues/3118): Feature request: default flags in .agda-lib file+  -  [#3289](https://github.com/agda/agda/issues/3289): Postfix projections should not have hiding information+  -  [#3360](https://github.com/agda/agda/issues/3360): Make Emacs mode available as a normal package via MELPA+  -  [#3365](https://github.com/agda/agda/issues/3365): Update GitHub linguist syntax highlight file+  -  [#3398](https://github.com/agda/agda/issues/3398): With the option --allow-unsolved-metas, the unsolved metas are not shown, only yellow+  -  [#3422](https://github.com/agda/agda/issues/3422): Show names of instance candidates in error message+  -  [#3486](https://github.com/agda/agda/issues/3486): Elaborate-and-give shouldn't reduce solution+  -  [#3532](https://github.com/agda/agda/issues/3532): Refine does not work for functions with 10 arguments or more+  -  [#3538](https://github.com/agda/agda/issues/3538): Regression: Rewrite rule involving constructors rejected in parametrized module+  -  [#3588](https://github.com/agda/agda/issues/3588): Refine suggests overloaded constructor which is not in scope+  -  [#3627](https://github.com/agda/agda/issues/3627): Where-blocks of clauses with irrelevant projections can use irrelevant variables+  -  [#3644](https://github.com/agda/agda/issues/3644): Error message without position+  -  [#3672](https://github.com/agda/agda/issues/3672): Better error messages for generalize easter eggs+  -  [#3684](https://github.com/agda/agda/issues/3684): Make error about non-existent record field a warning?+  -  [#3734](https://github.com/agda/agda/issues/3734): WARNING_ON_USAGE is not raised for constructors+  -  [#3744](https://github.com/agda/agda/issues/3744): Internal error related to abstract+  -  [#3870](https://github.com/agda/agda/issues/3870): Internal error during instance search+  -  [#3926](https://github.com/agda/agda/issues/3926): Document the effect of `mutual` to the order of type checking+  -  [#3933](https://github.com/agda/agda/issues/3933): `import` can remove definitions from scope+  -  [#3961](https://github.com/agda/agda/issues/3961): Missing documentation for coverage checking+  -  [#4071](https://github.com/agda/agda/issues/4071): Ill-scoped code in error message+  -  [#4088](https://github.com/agda/agda/issues/4088): Strange scoping rules for irrefutable with, part 2+  -  [#4093](https://github.com/agda/agda/issues/4093): Make it possible to rename Set?+  -  [#4109](https://github.com/agda/agda/issues/4109): cannot declare data types in Setω+  -  [#4131](https://github.com/agda/agda/issues/4131): Record definition doesn't compile without a specific `let` binding+  -  [#4132](https://github.com/agda/agda/issues/4132): The regular expression for floats in the lexer is too liberal+  -  [#4135](https://github.com/agda/agda/issues/4135): Constructor disambiguation picks non-unique solution+  -  [#4157](https://github.com/agda/agda/issues/4157): Agda gets confused by multiple anonymous definitions in a single mutual block+  -  [#4160](https://github.com/agda/agda/issues/4160): Printing implicit lambdas with --show-implicit+  -  [#4161](https://github.com/agda/agda/issues/4161): An alternative solution for hGetContent error on Windows when non-English+  -  [#4166](https://github.com/agda/agda/issues/4166): Instances that are not in scope are candidates for instance resolution+  -  [#4208](https://github.com/agda/agda/issues/4208): Field named `_` in `genTel` record+  -  [#4252](https://github.com/agda/agda/issues/4252): Interaction ids get conflated after iterated give+  -  [#4265](https://github.com/agda/agda/issues/4265): Unsolved constraints when --no-syntactic-equality is used+  -  [#4280](https://github.com/agda/agda/issues/4280): Test case for #4169 fails in JS backend+  -  [#4291](https://github.com/agda/agda/issues/4291): Incorrect names can be generated for generalised variables+  -  [#4341](https://github.com/agda/agda/issues/4341): The documentation of inContext seems wrong.+  -  [#4350](https://github.com/agda/agda/issues/4350): Scoping bug with let open in telescope+  -  [#4365](https://github.com/agda/agda/issues/4365): Module fails to type check after parametrising it by postulates+  -  [#4400](https://github.com/agda/agda/issues/4400): TERMINATING pragma in where clause+  -  [#4425](https://github.com/agda/agda/issues/4425): [doc] What are .agdai files?+  -  [#4456](https://github.com/agda/agda/issues/4456): No error highlighting for error warnings?+  -  [#4458](https://github.com/agda/agda/issues/4458): The command agda2-measure-load-time is broken+  -  [#4481](https://github.com/agda/agda/issues/4481): Named implicit arguments do not behave the same in anonymous lambdas & definitions+  -  [#4482](https://github.com/agda/agda/issues/4482): "Unexpected implicit argument" should pinpoint exactly where the error starts+  -  [#4486](https://github.com/agda/agda/issues/4486): "did you mean" hint also for failing imports+  -  [#4491](https://github.com/agda/agda/issues/4491): Add a primitive for Data.Text's uncons+  -  [#4516](https://github.com/agda/agda/issues/4516): Internal error if files cannot be written to the directory for temporary files+  -  [#4518](https://github.com/agda/agda/issues/4518): Confusing error message if missing import+  -  [#4520](https://github.com/agda/agda/issues/4520): Better error for ambiguous BUILTIN [FROMNAT no longer working]+  -  [#4521](https://github.com/agda/agda/issues/4521): Massive increase in memory required to install Agda 2.6.1+  -  [#4526](https://github.com/agda/agda/issues/4526): Agda 2.6.1 bad performance: findProjectConfig slow in big directories+  -  [#4528](https://github.com/agda/agda/issues/4528): Internal error due to new forcing translation+  -  [#4530](https://github.com/agda/agda/issues/4530): Less normalization of goal types for instance search+  -  [#4534](https://github.com/agda/agda/issues/4534): [reflection] quote is not a defined name+  -  [#4536](https://github.com/agda/agda/issues/4536): co-pattern matching on empty record type removes body+  -  [#4538](https://github.com/agda/agda/issues/4538): changing the predefined precedence of an operator+  -  [#4543](https://github.com/agda/agda/issues/4543): Access violation on Windows on GHC 8.8.3, 8.8.4, 8.10.1 and 8.10.2+  -  [#4550](https://github.com/agda/agda/issues/4550): Documentation build: malformed code-block+  -  [#4556](https://github.com/agda/agda/issues/4556): [documentation] update hello world+  -  [#4557](https://github.com/agda/agda/issues/4557): activate github's discussions beta+  -  [#4560](https://github.com/agda/agda/issues/4560): Loss of canonicity with no-eta record and copatterns.+  -  [#4572](https://github.com/agda/agda/issues/4572): add PiSort and UnivSort to the documentation+  -  [#4576](https://github.com/agda/agda/issues/4576): quoteTC for Setω+  -  [#4580](https://github.com/agda/agda/issues/4580): No highlighting for pragmas FROMNAT, FROMNEG, FROMSTRING+  -  [#4583](https://github.com/agda/agda/issues/4583): QuickLaTeX backend does not highlight coinductive constructors as such+  -  [#4586](https://github.com/agda/agda/issues/4586): Better error message  for "Not a valid let declaration"+  -  [#4593](https://github.com/agda/agda/issues/4593): The blocking machinery seems to be broken+  -  [#4595](https://github.com/agda/agda/issues/4595): Should Setω be a type?+  -  [#4596](https://github.com/agda/agda/issues/4596): Improve pattern matching on records in telescopes+  -  [#4606](https://github.com/agda/agda/issues/4606): The combination of Cubical Agda with inductive families is logically inconsistent+  -  [#4610](https://github.com/agda/agda/issues/4610): Support Emacs 27.1+  -  [#4615](https://github.com/agda/agda/issues/4615): Enable --no-sort-comparison by default?+  -  [#4621](https://github.com/agda/agda/issues/4621): Make --rewriting infective+  -  [#4623](https://github.com/agda/agda/issues/4623): Empty where blocks should get dead code warnings+  -  [#4631](https://github.com/agda/agda/issues/4631): Non-linear patterns handled in a buggy way+  -  [#4637](https://github.com/agda/agda/issues/4637): recCon-NOT-PRINTED in termination error in connection to with+  -  [#4638](https://github.com/agda/agda/issues/4638): Erased constructors+  -  [#4649](https://github.com/agda/agda/issues/4649): Repair Agda's REPL (agda -I) to work with --safe flag+  -  [#4656](https://github.com/agda/agda/issues/4656): Function name not wrapped in `\AgdaFunction` in generated LaTeX+  -  [#4662](https://github.com/agda/agda/issues/4662): Current module contents+  -  [#4665](https://github.com/agda/agda/issues/4665): Documentation: add install instructions for stack+  -  [#4671](https://github.com/agda/agda/issues/4671): Weird error message on case-insensitive file systems+  -  [#4679](https://github.com/agda/agda/issues/4679): Cubical: giving seems to skip the boundary condition check for extended lambdas+  -  [#4681](https://github.com/agda/agda/issues/4681): Get rid of auto-inlining?+  -  [#4684](https://github.com/agda/agda/issues/4684): Type error due to --no-syntactic-equality+  -  [#4687](https://github.com/agda/agda/issues/4687): Instance search fails with two equal candidates+  -  [#4704](https://github.com/agda/agda/issues/4704): Case-split generates invalid code+  -  [#4707](https://github.com/agda/agda/issues/4707): Just warn when `using` directive has repetitions+  -  [#4721](https://github.com/agda/agda/issues/4721): de Bruijn index out of scope when using rewriting+  -  [#4727](https://github.com/agda/agda/issues/4727): Meta-variable solutions contain subterms with the wrong modality+  -  [#4735](https://github.com/agda/agda/issues/4735): primShowQName creates not-in-scope names+  -  [#4737](https://github.com/agda/agda/issues/4737): Turn error `Hiding ... has no effect` into a warning+  -  [#4750](https://github.com/agda/agda/issues/4750): Unification failure in 2.6.1 and the master branch+  -  [#4752](https://github.com/agda/agda/issues/4752): Panic on unbound variable with pattern synonym+  -  [#4768](https://github.com/agda/agda/issues/4768): De Bruijn index @0 in error "Not a finite domain"+  -  [#4769](https://github.com/agda/agda/issues/4769): mergeEqualPs ignores Name and ArgInfo of merged-in patterns+  -  [#4772](https://github.com/agda/agda/issues/4772): C-u C-u C-c C-? should show all goals normalized (Cmd_metas)+  -  [#4773](https://github.com/agda/agda/issues/4773): Missing does-not-export warning for `open` directive for parametrised module+  -  [#4775](https://github.com/agda/agda/issues/4775): Internal error when trying to use incorrect lambda syntax to pattern match+  -  [#4784](https://github.com/agda/agda/issues/4784): Make erasure compatible with univalence+  -  [#4795](https://github.com/agda/agda/issues/4795): Build "agda-tests" fails using dynamic linking+  -  [#4815](https://github.com/agda/agda/issues/4815): Current master fails compilation: binding for 'error' shadows the existing binding+  -  [#4828](https://github.com/agda/agda/issues/4828): Symlinks are incorrectly followed during compilation+  -  [#4833](https://github.com/agda/agda/issues/4833): Internal error: cannot type-check file+  -  [#4851](https://github.com/agda/agda/issues/4851): BUILTIN SIGMA and --type-in-type+  -  [#4852](https://github.com/agda/agda/issues/4852): First load the file+  -  [#4857](https://github.com/agda/agda/issues/4857): Instance argument is printed as explicit argument+  -  [#4869](https://github.com/agda/agda/issues/4869): Internal error at src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs:147+  -  [#4880](https://github.com/agda/agda/issues/4880): Non-dependent, irrelevant, nameless arguments aren't accepted in arrows+  -  [#4882](https://github.com/agda/agda/issues/4882): Missing `reduce` in `literalStrategy`+  -  [#4888](https://github.com/agda/agda/issues/4888): "Illegal declaration(s) before top-level module" in Agda 2.6.1+  -  [#4909](https://github.com/agda/agda/issues/4909): Rewrite rule not accepted with --no-fast-reduce+  -  [#4924](https://github.com/agda/agda/issues/4924): Instance resolution loops infinitely even when an instance is available+  -  [#4925](https://github.com/agda/agda/issues/4925): Too aggressive literal overloading+  -  [#4928](https://github.com/agda/agda/issues/4928): Internal error checking cubical library+  -  [#4929](https://github.com/agda/agda/issues/4929): Regression in 2.6.1 connected to forcing translation (internal error)+  -  [#4944](https://github.com/agda/agda/issues/4944): Generalize: stuck on constraint ↑ i =< ↑ (↑ i) : Size+  -  [#4946](https://github.com/agda/agda/issues/4946): Size polarity brittle with generalization+  -  [#4949](https://github.com/agda/agda/issues/4949): Cubical: internal error in eta-expansion under constraints+  -  [#4950](https://github.com/agda/agda/issues/4950): Range too large in complaint about missing definitions+  -  [#4951](https://github.com/agda/agda/issues/4951): Data types in Setω are treated as non-fibrant+  -  [#4952](https://github.com/agda/agda/issues/4952): Incorrect HTML generated for renaming clause+  -  [#4962](https://github.com/agda/agda/issues/4962): JS backend: bugs involving "null"+  -  [#4967](https://github.com/agda/agda/issues/4967): Crazy bug when defining Ord instances for Int+  -  [#4970](https://github.com/agda/agda/issues/4970): `variable` use adds explicit argument+  -  [#4975](https://github.com/agda/agda/issues/4975): "no such meta variable" when calling `C-u C-c C-;`+  -  [#4982](https://github.com/agda/agda/issues/4982): Internal error related to Cubical Agda+  -  [#4986](https://github.com/agda/agda/issues/4986): Pattern matching allows you to turn `(x y : A) -> A` into `(@0 x y : A) -> A`+  -  [#4995](https://github.com/agda/agda/issues/4995): No Cycle should not look under lambdas.+  -  [#4998](https://github.com/agda/agda/issues/4998): Make case in clause with instance projection does not work+  -  [#4999](https://github.com/agda/agda/issues/4999): `primStringFromList` is not injective because of surrogate code points+  -  [#5002](https://github.com/agda/agda/issues/5002): Bad JavaScript generated+  -  [#5005](https://github.com/agda/agda/issues/5005): Add flag to print AGDA_DIR and exit+  -  [#5029](https://github.com/agda/agda/issues/5029): One can override --safe+  -  [#5033](https://github.com/agda/agda/issues/5033): Internal error related to @tick+  -  [#5048](https://github.com/agda/agda/issues/5048): Disturbing names in normalised reflected type+  -  [#5064](https://github.com/agda/agda/issues/5064): Give more information in error "Pattern matching on no-eta record types is by default not allowed"+  -  [#5065](https://github.com/agda/agda/issues/5065): The termination checker is too liberal+  -  [#5079](https://github.com/agda/agda/issues/5079): Deep pattern-matching is sometimes allowed for erased arguments+  -  [#5093](https://github.com/agda/agda/issues/5093): Weird instance propagation between parameterised modules+  -  [#5112](https://github.com/agda/agda/issues/5112): `make install-fix-whitespace` shouldn't use the `stack-X.Y.Z.yaml` files used for Agda+  -  [#5128](https://github.com/agda/agda/issues/5128): getDefinition sometimes loses patterns+  -  [#5133](https://github.com/agda/agda/issues/5133): Current master fails LaTeX-related tests+  -  [#5140](https://github.com/agda/agda/issues/5140): test/LaTeXAndHTML/succeed contains failing tests+  -  [#5146](https://github.com/agda/agda/issues/5146): v2.6.1.2 does not contain MAlonzo/RTE/Float.hs+  -  [#5161](https://github.com/agda/agda/issues/5161): No error location for error in imported module when .agdai file exists+  -  [#5167](https://github.com/agda/agda/issues/5167): Fix broken compatibility with agda-bench+  -  [#5168](https://github.com/agda/agda/issues/5168): User manual: Missing instructions for installing Agda from Hackage using stack+  -  [#5176](https://github.com/agda/agda/issues/5176): `mutual` is deprecated in doc+  -  [#5204](https://github.com/agda/agda/issues/5204): Investigate highlighting failures+  -  [#5205](https://github.com/agda/agda/issues/5205): acmart examples in (user-manual) fail to build with latest TeXLive+  -  [#5207](https://github.com/agda/agda/issues/5207): Agda generated code does not type-check with GHC 9.0+  -  [#5210](https://github.com/agda/agda/issues/5210): Internal error+  -  [#5230](https://github.com/agda/agda/issues/5230): When `stack.yaml` exists, `make` calls `stack`, even on `make debug`+  -  [#5231](https://github.com/agda/agda/issues/5231): Problems compiling hello-world.agda+  -  [#5237](https://github.com/agda/agda/issues/5237): `__IMPOSSIBLE__` from Agda.TypeChecking.Substitute+  -  [#5238](https://github.com/agda/agda/issues/5238): Rewrites are conjuring elements out of thin air+  -  [#5245](https://github.com/agda/agda/issues/5245): An infinite loop?+  -  [#5250](https://github.com/agda/agda/issues/5250): Change of warning options ignored+  -  [#5251](https://github.com/agda/agda/issues/5251): @0 annotation on lambda ignored+  -  [#5252](https://github.com/agda/agda/issues/5252): Internal error when case splitting pattern-lambda with higher rank type+  -  [#5286](https://github.com/agda/agda/issues/5286): Wrong error location with do notation and parse error in lhs+  -  [#5288](https://github.com/agda/agda/issues/5288): Very weird behaviour with compiled Data.Nat.Show.readMaybe+  -  [#5313](https://github.com/agda/agda/issues/5313): Documentation for internal level properties+  -  [#5314](https://github.com/agda/agda/issues/5314): Warn about abstract definitions without type signatures+  -  [#5317](https://github.com/agda/agda/issues/5317): The reflection machinery should support quantities+  -  [#5326](https://github.com/agda/agda/issues/5326): The highlighting code should be optimised+  -  [#5334](https://github.com/agda/agda/issues/5334): Meta-variable in constructor type busts interleaved mutual+  -  [#5335](https://github.com/agda/agda/issues/5335): Incorrect id attributes for local modules inside local modules+  -  [#5336](https://github.com/agda/agda/issues/5336): `data Foo constructor {cs : ts}` notation in `interleaved mutual`+  -  [#5339](https://github.com/agda/agda/issues/5339): `constructor` blocks do not tolerate overloading in same block+  -  [#5341](https://github.com/agda/agda/issues/5341): Do not make context variables non-erased+  -  [#5356](https://github.com/agda/agda/issues/5356): `interleaved mutual`: `data _ where` instead of `constructor`+  -  [#5358](https://github.com/agda/agda/issues/5358): tactic annotation on record field of function type drops domain in copattern definition+  -  [#5367](https://github.com/agda/agda/issues/5367): Parser regression involving `with` and `let`+  -  [#5370](https://github.com/agda/agda/issues/5370): Inconsistency in agda --help+  -  [#5375](https://github.com/agda/agda/issues/5375): Efficient conversion between interaction points and meta-variables+  -  [#5410](https://github.com/agda/agda/issues/5410): Module applications in where clauses of erased definitions yield non-erased code+  -  [#5419](https://github.com/agda/agda/issues/5419): Missing licences?+  -  [#5424](https://github.com/agda/agda/issues/5424): Internal error in v2.6.2 release candidate 1+  -  [#5434](https://github.com/agda/agda/issues/5434): The user manual's explanation of how erasure is checked for constructors does not match the implementation
+ 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,60 +1,79 @@+{-# 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.Applicative-import Control.Exception-import Control.Monad-import Data.Char-import Data.List-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.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."   , ""@@ -66,184 +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 $ \h ->-      evaluate . (identifier files `isInfixOf`) =<< hGetContents h-      -- 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 <- rawSystem "emacs"-                      [ "--no-desktop", "--no-window-system", "--no-splash"-                          -- Andreas, 2014-01-11: ^ try a leaner startup of emacs-                      , "--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---- | 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 <- rawSystem "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/Agda.css 
@@ -1,33 +0,0 @@-/* Aspects. */-.Comment       { color: #B22222 }-.Keyword       { color: #CD6600 }-.String        { color: #B22222 }-.Number        { color: #A020F0 }-.Symbol        { color: #404040 }-.PrimitiveType { color: #0000CD }-.Operator      {}--/* NameKinds. */-.Bound                  { color: black   }-.InductiveConstructor   { color: #008B00 }-.CoinductiveConstructor { color: #8B7500 }-.Datatype               { color: #0000CD }-.Field                  { color: #EE1289 }-.Function               { color: #0000CD }-.Module                 { color: #A020F0 }-.Postulate              { color: #0000CD }-.Primitive              { color: #0000CD }-.Record                 { color: #0000CD }--/* OtherAspects. */-.DottedPattern      {}-.UnsolvedMeta       { color: black; background: yellow         }-.UnsolvedConstraint { color: black; background: yellow         }-.TerminationProblem { color: black; background: #FFA07A        }-.IncompletePattern  { color: black; background: #F5DEB3        }-.Error              { color: red;   text-decoration: underline }-.TypeChecks         { color: black; background: #ADD8E6        }--/* Standard attributes. */-a { text-decoration: none }-a[href]:hover { background-color: #B4EEB4 }
+ 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
@@ -1,172 +1,386 @@-// NOTE:-// Some of the primitives here are curried, some are not. All uncurried primitives are prefixed by 'u'.--var biginteger = require("biginteger")+// 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 -exports.primIntegerFromString = function(x) {-  return biginteger.BigInteger(x);-};-exports.primShowInteger = function(x) {-  return x.toString();-};+// primIntegerFromString : String -> Int+exports.primIntegerFromString = BigInt; -exports.uprimIntegerPlus = function(x,y) {-  return x.add(y);+// 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; };-exports.uprimIntegerMinus = function(x,y) {-  return x.subtract(y);++// 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.uprimIntegerMultiply = function(x,y) {-  return x.multiply(y);+exports._primFloatRound = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.round(x));+    } };-exports.uprimIntegerEqual = function(x,y) {-  return x.compare(y) == 0;+exports._primFloatFloor = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.floor(x));+    } };-exports.uprimIntegerGreaterOrEqualThan = function(x,y) {-  return x.compare(y) >= 0;+exports._primFloatCeiling = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.ceil(x));+    } };-exports.uprimIntegerLessThan = function(x,y) {-  return x.compare(y) == -1;+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.primNatMinus = function(x) {-  return function(y) {-    var z = x.subtract(y);-    if (z.isNegative()) {-      return biginteger.ZERO;-    } else {-      return z;+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);+}; -// Floats -exports.primShowFloat = function(x) {-  // See Issue #2192.-  if (Number.isInteger(x)) {-    if (Object.is(x,-0.0)) {-      return ("-0.0");-    } else {-        var a = x.toString();-        return (a + ".0");+// 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 {-    return x.toString();-  }+    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));+    } }; -exports.primFloatEquality = function(x) {-  return function(y) {-    return Object.is(x,y);-  };-};+// primNatToFloat : Nat -> Float+exports.primNatToFloat = Number; -exports.primFloatNumericalEquality = function(x) {-  return function(y) {-    return x==y;-  };-};+// primIntToFloat : Int -> Float+exports.primIntToFloat = Number; -exports.uprimFloatEquality = function(x, y) {-  return Object.is(x,y);+// 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.primFloatNumericalLess = function(x) {-  return function(y) {-    if(x == Number.NEGATIVE_INFINITY) {-      return y != Number.NEGATIVE_INFINITY;-    } else if(y == Number.NEGATIVE_INFINITY) {-      return false;-    } else if(isNaN(x)) {-      return !isNaN(y);-    } else if(isNaN(y)) {-      return false;+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<y;+        return x.toString();     }-  }; };- exports.primFloatPlus = function(x) {-  return function(y) {-    return x+y;-  };+    return function(y) {+        return x + y;+    }; }; exports.primFloatMinus = function(x) {-  return function(y) {-    return x-y;-  };+    return function(y) {+        return x - y;+    }; }; exports.primFloatTimes = function(x) {-  return function(y) {-    return x*y;-  };+    return function(y) {+        return x * y;+    }; };- exports.primFloatNegate = function(x) {-  return -x;+    return -x; };- exports.primFloatDiv = function(x) {   return function(y) {-    return x/y;+    return x / y;   }; };+exports.primFloatPow = function(x) {+    return function(y) {+        return x ** y;+    };+}; exports.primFloatSqrt = function(x) {-  return Math.sqrt(x);+    return Math.sqrt(x); };--exports.primSin = function(x) {-  return Math.sin(x);+exports.primFloatExp = function(x) {+    return Math.exp(x); };--exports.primCos = function(x) {-  return Math.cos(x);+exports.primFloatLog = function(x) {+    return Math.log(x); };--exports.primTan = function(x) {-  return Math.tan(x);+exports.primFloatSin = function(x) {+    return Math.sin(x); };--exports.primASin = function(x) {-  return Math.asin(x);+exports.primFloatCos = function(x) {+    return Math.cos(x); };--exports.primACos = function(x) {-  return Math.acos(x);+exports.primFloatTan = function(x) {+    return Math.tan(x); };--exports.primATan = function(x) {-  return Math.atan(x);+exports.primFloatASin = function(x) {+    return Math.asin(x); };--exports.primATan2 = function(y) {-  return function(x){-    return Math.atan2(y,x);-  }+exports.primFloatACos = function(x) {+    return Math.acos(x); };--exports.primExp = function(x) {-  return Math.exp(x);+exports.primFloatATan = function(x) {+    return Math.atan(x); };--// As Javascript is strict, this should be fine in general. Not sure-// what PSeq (Axiom ...) (...) should do?-exports.primSeq = function(x, y) {-  return y;+exports.primFloatATan2 = function(x) {+    return function(y){+        return Math.atan2(x, y);+    }; };--exports.primShowQName = function(x) {-  return x["name"];+exports.primFloatSinh = function(x) {+    return Math.sinh(x); };-exports.uprimQNameEquality = function(x,y) {-  return x["id"].compare(y["id"]) == 0 && x["moduleId"].compare(y["moduleId"]) == 0;+exports.primFloatCosh = function(x) {+    return Math.cosh(x); };-exports.primQNameEquality = function(x) {-  return function(y) {-    return exports.uprimQNameEquality(x, y);-  };+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'];
+ 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/JS/biginteger.js 
@@ -1,1620 +0,0 @@-/*-	JavaScript BigInteger library version 0.9.1-	http://silentmatt.com/biginteger/--	Copyright (c) 2009 Matthew Crumley <email@matthewcrumley.com>-	Copyright (c) 2010,2011 by John Tobey <John.Tobey@gmail.com>-	Licensed under the MIT license.--	Support for arbitrary internal representation base was added by-	Vitaly Magerya.-*/--/*-	File: biginteger.js--	Exports:--		<BigInteger>-*/-(function(exports) {-"use strict";-/*-	Class: BigInteger-	An arbitrarily-large integer.--	<BigInteger> objects should be considered immutable. None of the "built-in"-	methods modify *this* or their arguments. All properties should be-	considered private.--	All the methods of <BigInteger> instances can be called "statically". The-	static versions are convenient if you don't already have a <BigInteger>-	object.--	As an example, these calls are equivalent.--	> BigInteger(4).multiply(5); // returns BigInteger(20);-	> BigInteger.multiply(4, 5); // returns BigInteger(20);--	> var a = 42;-	> var a = BigInteger.toJSValue("0b101010"); // Not completely useless...-*/--var CONSTRUCT = {}; // Unique token to call "private" version of constructor--/*-	Constructor: BigInteger()-	Convert a value to a <BigInteger>.--	Although <BigInteger()> is the constructor for <BigInteger> objects, it is-	best not to call it as a constructor. If *n* is a <BigInteger> object, it is-	simply returned as-is. Otherwise, <BigInteger()> is equivalent to <parse>-	without a radix argument.--	> var n0 = BigInteger();      // Same as <BigInteger.ZERO>-	> var n1 = BigInteger("123"); // Create a new <BigInteger> with value 123-	> var n2 = BigInteger(123);   // Create a new <BigInteger> with value 123-	> var n3 = BigInteger(n2);    // Return n2, unchanged--	The constructor form only takes an array and a sign. *n* must be an-	array of numbers in little-endian order, where each digit is between 0-	and BigInteger.base.  The second parameter sets the sign: -1 for-	negative, +1 for positive, or 0 for zero. The array is *not copied and-	may be modified*. If the array contains only zeros, the sign parameter-	is ignored and is forced to zero.--	> new BigInteger([5], -1): create a new BigInteger with value -5--	Parameters:--		n - Value to convert to a <BigInteger>.--	Returns:--		A <BigInteger> value.--	See Also:--		<parse>, <BigInteger>-*/-function BigInteger(n, s, token) {-	if (token !== CONSTRUCT) {-		if (n instanceof BigInteger) {-			return n;-		}-		else if (typeof n === "undefined") {-			return ZERO;-		}-		return BigInteger.parse(n);-	}--	n = n || [];  // Provide the nullary constructor for subclasses.-	while (n.length && !n[n.length - 1]) {-		--n.length;-	}-	this._d = n;-	this._s = n.length ? (s || 1) : 0;-}--BigInteger._construct = function(n, s) {-	return new BigInteger(n, s, CONSTRUCT);-};--// Base-10 speedup hacks in parse, toString, exp10 and log functions-// require base to be a power of 10. 10^7 is the largest such power-// that won't cause a precision loss when digits are multiplied.-var BigInteger_base = 10000000;-var BigInteger_base_log10 = 7;--BigInteger.base = BigInteger_base;-BigInteger.base_log10 = BigInteger_base_log10;--var ZERO = new BigInteger([], 0, CONSTRUCT);-// Constant: ZERO-// <BigInteger> 0.-BigInteger.ZERO = ZERO;--var ONE = new BigInteger([1], 1, CONSTRUCT);-// Constant: ONE-// <BigInteger> 1.-BigInteger.ONE = ONE;--var M_ONE = new BigInteger(ONE._d, -1, CONSTRUCT);-// Constant: M_ONE-// <BigInteger> -1.-BigInteger.M_ONE = M_ONE;--// Constant: _0-// Shortcut for <ZERO>.-BigInteger._0 = ZERO;--// Constant: _1-// Shortcut for <ONE>.-BigInteger._1 = ONE;--/*-	Constant: small-	Array of <BigIntegers> from 0 to 36.--	These are used internally for parsing, but useful when you need a "small"-	<BigInteger>.--	See Also:--		<ZERO>, <ONE>, <_0>, <_1>-*/-BigInteger.small = [-	ZERO,-	ONE,-	/* Assuming BigInteger_base > 36 */-	new BigInteger( [2], 1, CONSTRUCT),-	new BigInteger( [3], 1, CONSTRUCT),-	new BigInteger( [4], 1, CONSTRUCT),-	new BigInteger( [5], 1, CONSTRUCT),-	new BigInteger( [6], 1, CONSTRUCT),-	new BigInteger( [7], 1, CONSTRUCT),-	new BigInteger( [8], 1, CONSTRUCT),-	new BigInteger( [9], 1, CONSTRUCT),-	new BigInteger([10], 1, CONSTRUCT),-	new BigInteger([11], 1, CONSTRUCT),-	new BigInteger([12], 1, CONSTRUCT),-	new BigInteger([13], 1, CONSTRUCT),-	new BigInteger([14], 1, CONSTRUCT),-	new BigInteger([15], 1, CONSTRUCT),-	new BigInteger([16], 1, CONSTRUCT),-	new BigInteger([17], 1, CONSTRUCT),-	new BigInteger([18], 1, CONSTRUCT),-	new BigInteger([19], 1, CONSTRUCT),-	new BigInteger([20], 1, CONSTRUCT),-	new BigInteger([21], 1, CONSTRUCT),-	new BigInteger([22], 1, CONSTRUCT),-	new BigInteger([23], 1, CONSTRUCT),-	new BigInteger([24], 1, CONSTRUCT),-	new BigInteger([25], 1, CONSTRUCT),-	new BigInteger([26], 1, CONSTRUCT),-	new BigInteger([27], 1, CONSTRUCT),-	new BigInteger([28], 1, CONSTRUCT),-	new BigInteger([29], 1, CONSTRUCT),-	new BigInteger([30], 1, CONSTRUCT),-	new BigInteger([31], 1, CONSTRUCT),-	new BigInteger([32], 1, CONSTRUCT),-	new BigInteger([33], 1, CONSTRUCT),-	new BigInteger([34], 1, CONSTRUCT),-	new BigInteger([35], 1, CONSTRUCT),-	new BigInteger([36], 1, CONSTRUCT)-];--// Used for parsing/radix conversion-BigInteger.digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ".split("");--/*-	Method: toString-	Convert a <BigInteger> to a string.--	When *base* is greater than 10, letters are upper case.--	Parameters:--		base - Optional base to represent the number in (default is base 10).-		       Must be between 2 and 36 inclusive, or an Error will be thrown.--	Returns:--		The string representation of the <BigInteger>.-*/-BigInteger.prototype.toString = function(base) {-	base = +base || 10;-	if (base < 2 || base > 36) {-		throw new Error("illegal radix " + base + ".");-	}-	if (this._s === 0) {-		return "0";-	}-	if (base === 10) {-		var str = this._s < 0 ? "-" : "";-		str += this._d[this._d.length - 1].toString();-		for (var i = this._d.length - 2; i >= 0; i--) {-			var group = this._d[i].toString();-			while (group.length < BigInteger_base_log10) group = '0' + group;-			str += group;-		}-		return str;-	}-	else {-		var numerals = BigInteger.digits;-		base = BigInteger.small[base];-		var sign = this._s;--		var n = this.abs();-		var digits = [];-		var digit;--		while (n._s !== 0) {-			var divmod = n.divRem(base);-			n = divmod[0];-			digit = divmod[1];-			// TODO: This could be changed to unshift instead of reversing at the end.-			// Benchmark both to compare speeds.-			digits.push(numerals[digit.valueOf()]);-		}-		return (sign < 0 ? "-" : "") + digits.reverse().join("");-	}-};--// Verify strings for parsing-BigInteger.radixRegex = [-	/^$/,-	/^$/,-	/^[01]*$/,-	/^[012]*$/,-	/^[0-3]*$/,-	/^[0-4]*$/,-	/^[0-5]*$/,-	/^[0-6]*$/,-	/^[0-7]*$/,-	/^[0-8]*$/,-	/^[0-9]*$/,-	/^[0-9aA]*$/,-	/^[0-9abAB]*$/,-	/^[0-9abcABC]*$/,-	/^[0-9a-dA-D]*$/,-	/^[0-9a-eA-E]*$/,-	/^[0-9a-fA-F]*$/,-	/^[0-9a-gA-G]*$/,-	/^[0-9a-hA-H]*$/,-	/^[0-9a-iA-I]*$/,-	/^[0-9a-jA-J]*$/,-	/^[0-9a-kA-K]*$/,-	/^[0-9a-lA-L]*$/,-	/^[0-9a-mA-M]*$/,-	/^[0-9a-nA-N]*$/,-	/^[0-9a-oA-O]*$/,-	/^[0-9a-pA-P]*$/,-	/^[0-9a-qA-Q]*$/,-	/^[0-9a-rA-R]*$/,-	/^[0-9a-sA-S]*$/,-	/^[0-9a-tA-T]*$/,-	/^[0-9a-uA-U]*$/,-	/^[0-9a-vA-V]*$/,-	/^[0-9a-wA-W]*$/,-	/^[0-9a-xA-X]*$/,-	/^[0-9a-yA-Y]*$/,-	/^[0-9a-zA-Z]*$/-];--/*-	Function: parse-	Parse a string into a <BigInteger>.--	*base* is optional but, if provided, must be from 2 to 36 inclusive. If-	*base* is not provided, it will be guessed based on the leading characters-	of *s* as follows:--	- "0x" or "0X": *base* = 16-	- "0c" or "0C": *base* = 8-	- "0b" or "0B": *base* = 2-	- else: *base* = 10--	If no base is provided, or *base* is 10, the number can be in exponential-	form. For example, these are all valid:--	> BigInteger.parse("1e9");              // Same as "1000000000"-	> BigInteger.parse("1.234*10^3");       // Same as 1234-	> BigInteger.parse("56789 * 10 ** -2"); // Same as 567--	If any characters fall outside the range defined by the radix, an exception-	will be thrown.--	Parameters:--		s - The string to parse.-		base - Optional radix (default is to guess based on *s*).--	Returns:--		a <BigInteger> instance.-*/-BigInteger.parse = function(s, base) {-	// Expands a number in exponential form to decimal form.-	// expandExponential("-13.441*10^5") === "1344100";-	// expandExponential("1.12300e-1") === "0.112300";-	// expandExponential(1000000000000000000000000000000) === "1000000000000000000000000000000";-	function expandExponential(str) {-		str = str.replace(/\s*[*xX]\s*10\s*(\^|\*\*)\s*/, "e");--		return str.replace(/^([+\-])?(\d+)\.?(\d*)[eE]([+\-]?\d+)$/, function(x, s, n, f, c) {-			c = +c;-			var l = c < 0;-			var i = n.length + c;-			x = (l ? n : f).length;-			c = ((c = Math.abs(c)) >= x ? c - x + l : 0);-			var z = (new Array(c + 1)).join("0");-			var r = n + f;-			return (s || "") + (l ? r = z + r : r += z).substr(0, i += l ? z.length : 0) + (i < r.length ? "." + r.substr(i) : "");-		});-	}--	s = s.toString();-	if (typeof base === "undefined" || +base === 10) {-		s = expandExponential(s);-	}--	var prefixRE;-	if (typeof base === "undefined") {-		prefixRE = '0[xcb]';-	}-	else if (base == 16) {-		prefixRE = '0x';-	}-	else if (base == 8) {-		prefixRE = '0c';-	}-	else if (base == 2) {-		prefixRE = '0b';-	}-	else {-		prefixRE = '';-	}-	var parts = new RegExp('^([+\\-]?)(' + prefixRE + ')?([0-9a-z]*)(?:\\.\\d*)?$', 'i').exec(s);-	if (parts) {-		var sign = parts[1] || "+";-		var baseSection = parts[2] || "";-		var digits = parts[3] || "";--		if (typeof base === "undefined") {-			// Guess base-			if (baseSection === "0x" || baseSection === "0X") { // Hex-				base = 16;-			}-			else if (baseSection === "0c" || baseSection === "0C") { // Octal-				base = 8;-			}-			else if (baseSection === "0b" || baseSection === "0B") { // Binary-				base = 2;-			}-			else {-				base = 10;-			}-		}-		else if (base < 2 || base > 36) {-			throw new Error("Illegal radix " + base + ".");-		}--		base = +base;--		// Check for digits outside the range-		if (!(BigInteger.radixRegex[base].test(digits))) {-			throw new Error("Bad digit for radix " + base);-		}--		// Strip leading zeros, and convert to array-		digits = digits.replace(/^0+/, "").split("");-		if (digits.length === 0) {-			return ZERO;-		}--		// Get the sign (we know it's not zero)-		sign = (sign === "-") ? -1 : 1;--		// Optimize 10-		if (base == 10) {-			var d = [];-			while (digits.length >= BigInteger_base_log10) {-				d.push(parseInt(digits.splice(digits.length-BigInteger.base_log10, BigInteger.base_log10).join(''), 10));-			}-			d.push(parseInt(digits.join(''), 10));-			return new BigInteger(d, sign, CONSTRUCT);-		}--		// Do the conversion-		var d = ZERO;-		base = BigInteger.small[base];-		var small = BigInteger.small;-		for (var i = 0; i < digits.length; i++) {-			d = d.multiply(base).add(small[parseInt(digits[i], 36)]);-		}-		return new BigInteger(d._d, sign, CONSTRUCT);-	}-	else {-		throw new Error("Invalid BigInteger format: " + s);-	}-};--/*-	Function: add-	Add two <BigIntegers>.--	Parameters:--		n - The number to add to *this*. Will be converted to a <BigInteger>.--	Returns:--		The numbers added together.--	See Also:--		<subtract>, <multiply>, <quotient>, <next>-*/-BigInteger.prototype.add = function(n) {-	if (this._s === 0) {-		return BigInteger(n);-	}--	n = BigInteger(n);-	if (n._s === 0) {-		return this;-	}-	if (this._s !== n._s) {-		n = n.negate();-		return this.subtract(n);-	}--	var a = this._d;-	var b = n._d;-	var al = a.length;-	var bl = b.length;-	var sum = new Array(Math.max(al, bl) + 1);-	var size = Math.min(al, bl);-	var carry = 0;-	var digit;--	for (var i = 0; i < size; i++) {-		digit = a[i] + b[i] + carry;-		sum[i] = digit % BigInteger_base;-		carry = (digit / BigInteger_base) | 0;-	}-	if (bl > al) {-		a = b;-		al = bl;-	}-	for (i = size; carry && i < al; i++) {-		digit = a[i] + carry;-		sum[i] = digit % BigInteger_base;-		carry = (digit / BigInteger_base) | 0;-	}-	if (carry) {-		sum[i] = carry;-	}--	for ( ; i < al; i++) {-		sum[i] = a[i];-	}--	return new BigInteger(sum, this._s, CONSTRUCT);-};--/*-	Function: negate-	Get the additive inverse of a <BigInteger>.--	Returns:--		A <BigInteger> with the same magnatude, but with the opposite sign.--	See Also:--		<abs>-*/-BigInteger.prototype.negate = function() {-	return new BigInteger(this._d, (-this._s) | 0, CONSTRUCT);-};--/*-	Function: abs-	Get the absolute value of a <BigInteger>.--	Returns:--		A <BigInteger> with the same magnatude, but always positive (or zero).--	See Also:--		<negate>-*/-BigInteger.prototype.abs = function() {-	return (this._s < 0) ? this.negate() : this;-};--/*-	Function: subtract-	Subtract two <BigIntegers>.--	Parameters:--		n - The number to subtract from *this*. Will be converted to a <BigInteger>.--	Returns:--		The *n* subtracted from *this*.--	See Also:--		<add>, <multiply>, <quotient>, <prev>-*/-BigInteger.prototype.subtract = function(n) {-	if (this._s === 0) {-		return BigInteger(n).negate();-	}--	n = BigInteger(n);-	if (n._s === 0) {-		return this;-	}-	if (this._s !== n._s) {-		n = n.negate();-		return this.add(n);-	}--	var m = this;-	// negative - negative => -|a| - -|b| => -|a| + |b| => |b| - |a|-	if (this._s < 0) {-		m = new BigInteger(n._d, 1, CONSTRUCT);-		n = new BigInteger(this._d, 1, CONSTRUCT);-	}--	// Both are positive => a - b-	var sign = m.compareAbs(n);-	if (sign === 0) {-		return ZERO;-	}-	else if (sign < 0) {-		// swap m and n-		var t = n;-		n = m;-		m = t;-	}--	// a > b-	var a = m._d;-	var b = n._d;-	var al = a.length;-	var bl = b.length;-	var diff = new Array(al); // al >= bl since a > b-	var borrow = 0;-	var i;-	var digit;--	for (i = 0; i < bl; i++) {-		digit = a[i] - borrow - b[i];-		if (digit < 0) {-			digit += BigInteger_base;-			borrow = 1;-		}-		else {-			borrow = 0;-		}-		diff[i] = digit;-	}-	for (i = bl; i < al; i++) {-		digit = a[i] - borrow;-		if (digit < 0) {-			digit += BigInteger_base;-		}-		else {-			diff[i++] = digit;-			break;-		}-		diff[i] = digit;-	}-	for ( ; i < al; i++) {-		diff[i] = a[i];-	}--	return new BigInteger(diff, sign, CONSTRUCT);-};--(function() {-	function addOne(n, sign) {-		var a = n._d;-		var sum = a.slice();-		var carry = true;-		var i = 0;--		while (true) {-			var digit = (a[i] || 0) + 1;-			sum[i] = digit % BigInteger_base;-			if (digit <= BigInteger_base - 1) {-				break;-			}-			++i;-		}--		return new BigInteger(sum, sign, CONSTRUCT);-	}--	function subtractOne(n, sign) {-		var a = n._d;-		var sum = a.slice();-		var borrow = true;-		var i = 0;--		while (true) {-			var digit = (a[i] || 0) - 1;-			if (digit < 0) {-				sum[i] = digit + BigInteger_base;-			}-			else {-				sum[i] = digit;-				break;-			}-			++i;-		}--		return new BigInteger(sum, sign, CONSTRUCT);-	}--	/*-		Function: next-		Get the next <BigInteger> (add one).--		Returns:--			*this* + 1.--		See Also:--			<add>, <prev>-	*/-	BigInteger.prototype.next = function() {-		switch (this._s) {-		case 0:-			return ONE;-		case -1:-			return subtractOne(this, -1);-		// case 1:-		default:-			return addOne(this, 1);-		}-	};--	/*-		Function: prev-		Get the previous <BigInteger> (subtract one).--		Returns:--			*this* - 1.--		See Also:--			<next>, <subtract>-	*/-	BigInteger.prototype.prev = function() {-		switch (this._s) {-		case 0:-			return M_ONE;-		case -1:-			return addOne(this, -1);-		// case 1:-		default:-			return subtractOne(this, 1);-		}-	};-})();--/*-	Function: compareAbs-	Compare the absolute value of two <BigIntegers>.--	Calling <compareAbs> is faster than calling <abs> twice, then <compare>.--	Parameters:--		n - The number to compare to *this*. Will be converted to a <BigInteger>.--	Returns:--		-1, 0, or +1 if *|this|* is less than, equal to, or greater than *|n|*.--	See Also:--		<compare>, <abs>-*/-BigInteger.prototype.compareAbs = function(n) {-	if (this === n) {-		return 0;-	}--	if (!(n instanceof BigInteger)) {-		if (!isFinite(n)) {-			return(isNaN(n) ? n : -1);-		}-		n = BigInteger(n);-	}--	if (this._s === 0) {-		return (n._s !== 0) ? -1 : 0;-	}-	if (n._s === 0) {-		return 1;-	}--	var l = this._d.length;-	var nl = n._d.length;-	if (l < nl) {-		return -1;-	}-	else if (l > nl) {-		return 1;-	}--	var a = this._d;-	var b = n._d;-	for (var i = l-1; i >= 0; i--) {-		if (a[i] !== b[i]) {-			return a[i] < b[i] ? -1 : 1;-		}-	}--	return 0;-};--/*-	Function: compare-	Compare two <BigIntegers>.--	Parameters:--		n - The number to compare to *this*. Will be converted to a <BigInteger>.--	Returns:--		-1, 0, or +1 if *this* is less than, equal to, or greater than *n*.--	See Also:--		<compareAbs>, <isPositive>, <isNegative>, <isUnit>-*/-BigInteger.prototype.compare = function(n) {-	if (this === n) {-		return 0;-	}--	n = BigInteger(n);--	if (this._s === 0) {-		return -n._s;-	}--	if (this._s === n._s) { // both positive or both negative-		var cmp = this.compareAbs(n);-		return cmp * this._s;-	}-	else {-		return this._s;-	}-};--/*-	Function: isUnit-	Return true iff *this* is either 1 or -1.--	Returns:--		true if *this* compares equal to <BigInteger.ONE> or <BigInteger.M_ONE>.--	See Also:--		<isZero>, <isNegative>, <isPositive>, <compareAbs>, <compare>,-		<BigInteger.ONE>, <BigInteger.M_ONE>-*/-BigInteger.prototype.isUnit = function() {-	return this === ONE ||-		this === M_ONE ||-		(this._d.length === 1 && this._d[0] === 1);-};--/*-	Function: multiply-	Multiply two <BigIntegers>.--	Parameters:--		n - The number to multiply *this* by. Will be converted to a-		<BigInteger>.--	Returns:--		The numbers multiplied together.--	See Also:--		<add>, <subtract>, <quotient>, <square>-*/-BigInteger.prototype.multiply = function(n) {-	// TODO: Consider adding Karatsuba multiplication for large numbers-	if (this._s === 0) {-		return ZERO;-	}--	n = BigInteger(n);-	if (n._s === 0) {-		return ZERO;-	}-	if (this.isUnit()) {-		if (this._s < 0) {-			return n.negate();-		}-		return n;-	}-	if (n.isUnit()) {-		if (n._s < 0) {-			return this.negate();-		}-		return this;-	}-	if (this === n) {-		return this.square();-	}--	var r = (this._d.length >= n._d.length);-	var a = (r ? this : n)._d; // a will be longer than b-	var b = (r ? n : this)._d;-	var al = a.length;-	var bl = b.length;--	var pl = al + bl;-	var partial = new Array(pl);-	var i;-	for (i = 0; i < pl; i++) {-		partial[i] = 0;-	}--	for (i = 0; i < bl; i++) {-		var carry = 0;-		var bi = b[i];-		var jlimit = al + i;-		var digit;-		for (var j = i; j < jlimit; j++) {-			digit = partial[j] + bi * a[j - i] + carry;-			carry = (digit / BigInteger_base) | 0;-			partial[j] = (digit % BigInteger_base) | 0;-		}-		if (carry) {-			digit = partial[j] + carry;-			carry = (digit / BigInteger_base) | 0;-			partial[j] = digit % BigInteger_base;-		}-	}-	return new BigInteger(partial, this._s * n._s, CONSTRUCT);-};--// Multiply a BigInteger by a single-digit native number-// Assumes that this and n are >= 0-// This is not really intended to be used outside the library itself-BigInteger.prototype.multiplySingleDigit = function(n) {-	if (n === 0 || this._s === 0) {-		return ZERO;-	}-	if (n === 1) {-		return this;-	}--	var digit;-	if (this._d.length === 1) {-		digit = this._d[0] * n;-		if (digit >= BigInteger_base) {-			return new BigInteger([(digit % BigInteger_base)|0,-					(digit / BigInteger_base)|0], 1, CONSTRUCT);-		}-		return new BigInteger([digit], 1, CONSTRUCT);-	}--	if (n === 2) {-		return this.add(this);-	}-	if (this.isUnit()) {-		return new BigInteger([n], 1, CONSTRUCT);-	}--	var a = this._d;-	var al = a.length;--	var pl = al + 1;-	var partial = new Array(pl);-	for (var i = 0; i < pl; i++) {-		partial[i] = 0;-	}--	var carry = 0;-	for (var j = 0; j < al; j++) {-		digit = n * a[j] + carry;-		carry = (digit / BigInteger_base) | 0;-		partial[j] = (digit % BigInteger_base) | 0;-	}-	if (carry) {-		partial[j] = carry;-	}--	return new BigInteger(partial, 1, CONSTRUCT);-};--/*-	Function: square-	Multiply a <BigInteger> by itself.--	This is slightly faster than regular multiplication, since it removes the-	duplicated multiplcations.--	Returns:--		> this.multiply(this)--	See Also:-		<multiply>-*/-BigInteger.prototype.square = function() {-	// Normally, squaring a 10-digit number would take 100 multiplications.-	// Of these 10 are unique diagonals, of the remaining 90 (100-10), 45 are repeated.-	// This procedure saves (N*(N-1))/2 multiplications, (e.g., 45 of 100 multiplies).-	// Based on code by Gary Darby, Intellitech Systems Inc., www.DelphiForFun.org--	if (this._s === 0) {-		return ZERO;-	}-	if (this.isUnit()) {-		return ONE;-	}--	var digits = this._d;-	var length = digits.length;-	var imult1 = new Array(length + length + 1);-	var product, carry, k;-	var i;--	// Calculate diagonal-	for (i = 0; i < length; i++) {-		k = i * 2;-		product = digits[i] * digits[i];-		carry = (product / BigInteger_base) | 0;-		imult1[k] = product % BigInteger_base;-		imult1[k + 1] = carry;-	}--	// Calculate repeating part-	for (i = 0; i < length; i++) {-		carry = 0;-		k = i * 2 + 1;-		for (var j = i + 1; j < length; j++, k++) {-			product = digits[j] * digits[i] * 2 + imult1[k] + carry;-			carry = (product / BigInteger_base) | 0;-			imult1[k] = product % BigInteger_base;-		}-		k = length + i;-		var digit = carry + imult1[k];-		carry = (digit / BigInteger_base) | 0;-		imult1[k] = digit % BigInteger_base;-		imult1[k + 1] += carry;-	}--	return new BigInteger(imult1, 1, CONSTRUCT);-};--/*-	Function: quotient-	Divide two <BigIntegers> and truncate towards zero.--	<quotient> throws an exception if *n* is zero.--	Parameters:--		n - The number to divide *this* by. Will be converted to a <BigInteger>.--	Returns:--		The *this* / *n*, truncated to an integer.--	See Also:--		<add>, <subtract>, <multiply>, <divRem>, <remainder>-*/-BigInteger.prototype.quotient = function(n) {-	return this.divRem(n)[0];-};--/*-	Function: divide-	Deprecated synonym for <quotient>.-*/-BigInteger.prototype.divide = BigInteger.prototype.quotient;--/*-	Function: remainder-	Calculate the remainder of two <BigIntegers>.--	<remainder> throws an exception if *n* is zero.--	Parameters:--		n - The remainder after *this* is divided *this* by *n*. Will be-		    converted to a <BigInteger>.--	Returns:--		*this* % *n*.--	See Also:--		<divRem>, <quotient>-*/-BigInteger.prototype.remainder = function(n) {-	return this.divRem(n)[1];-};--/*-	Function: divRem-	Calculate the integer quotient and remainder of two <BigIntegers>.--	<divRem> throws an exception if *n* is zero.--	Parameters:--		n - The number to divide *this* by. Will be converted to a <BigInteger>.--	Returns:--		A two-element array containing the quotient and the remainder.--		> a.divRem(b)--		is exactly equivalent to--		> [a.quotient(b), a.remainder(b)]--		except it is faster, because they are calculated at the same time.--	See Also:--		<quotient>, <remainder>-*/-BigInteger.prototype.divRem = function(n) {-	n = BigInteger(n);-	if (n._s === 0) {-		throw new Error("Divide by zero");-	}-	if (this._s === 0) {-		return [ZERO, ZERO];-	}-	if (n._d.length === 1) {-		return this.divRemSmall(n._s * n._d[0]);-	}--	// Test for easy cases -- |n1| <= |n2|-	switch (this.compareAbs(n)) {-	case 0: // n1 == n2-		return [this._s === n._s ? ONE : M_ONE, ZERO];-	case -1: // |n1| < |n2|-		return [ZERO, this];-	}--	var sign = this._s * n._s;-	var a = n.abs();-	var b_digits = this._d;-	var b_index = b_digits.length;-	var digits = n._d.length;-	var quot = [];-	var guess;--	var part = new BigInteger([], 0, CONSTRUCT);--	while (b_index) {-		part._d.unshift(b_digits[--b_index]);-		part = new BigInteger(part._d, 1, CONSTRUCT);--		if (part.compareAbs(n) < 0) {-			quot.push(0);-			continue;-		}-		if (part._s === 0) {-			guess = 0;-		}-		else {-			var xlen = part._d.length, ylen = a._d.length;-			var highx = part._d[xlen-1]*BigInteger_base + part._d[xlen-2];-			var highy = a._d[ylen-1]*BigInteger_base + a._d[ylen-2];-			if (part._d.length > a._d.length) {-				// The length of part._d can either match a._d length,-				// or exceed it by one.-				highx = (highx+1)*BigInteger_base;-			}-			guess = Math.ceil(highx/highy);-		}-		do {-			var check = a.multiplySingleDigit(guess);-			if (check.compareAbs(part) <= 0) {-				break;-			}-			guess--;-		} while (guess);--		quot.push(guess);-		if (!guess) {-			continue;-		}-		var diff = part.subtract(check);-		part._d = diff._d.slice();-	}--	return [new BigInteger(quot.reverse(), sign, CONSTRUCT),-		   new BigInteger(part._d, this._s, CONSTRUCT)];-};--// Throws an exception if n is outside of (-BigInteger.base, -1] or-// [1, BigInteger.base).  It's not necessary to call this, since the-// other division functions will call it if they are able to.-BigInteger.prototype.divRemSmall = function(n) {-	var r;-	n = +n;-	if (n === 0) {-		throw new Error("Divide by zero");-	}--	var n_s = n < 0 ? -1 : 1;-	var sign = this._s * n_s;-	n = Math.abs(n);--	if (n < 1 || n >= BigInteger_base) {-		throw new Error("Argument out of range");-	}--	if (this._s === 0) {-		return [ZERO, ZERO];-	}--	if (n === 1 || n === -1) {-		return [(sign === 1) ? this.abs() : new BigInteger(this._d, sign, CONSTRUCT), ZERO];-	}--	// 2 <= n < BigInteger_base--	// divide a single digit by a single digit-	if (this._d.length === 1) {-		var q = new BigInteger([(this._d[0] / n) | 0], 1, CONSTRUCT);-		r = new BigInteger([(this._d[0] % n) | 0], 1, CONSTRUCT);-		if (sign < 0) {-			q = q.negate();-		}-		if (this._s < 0) {-			r = r.negate();-		}-		return [q, r];-	}--	var digits = this._d.slice();-	var quot = new Array(digits.length);-	var part = 0;-	var diff = 0;-	var i = 0;-	var guess;--	while (digits.length) {-		part = part * BigInteger_base + digits[digits.length - 1];-		if (part < n) {-			quot[i++] = 0;-			digits.pop();-			diff = BigInteger_base * diff + part;-			continue;-		}-		if (part === 0) {-			guess = 0;-		}-		else {-			guess = (part / n) | 0;-		}--		var check = n * guess;-		diff = part - check;-		quot[i++] = guess;-		if (!guess) {-			digits.pop();-			continue;-		}--		digits.pop();-		part = diff;-	}--	r = new BigInteger([diff], 1, CONSTRUCT);-	if (this._s < 0) {-		r = r.negate();-	}-	return [new BigInteger(quot.reverse(), sign, CONSTRUCT), r];-};--/*-	Function: isEven-	Return true iff *this* is divisible by two.--	Note that <BigInteger.ZERO> is even.--	Returns:--		true if *this* is even, false otherwise.--	See Also:--		<isOdd>-*/-BigInteger.prototype.isEven = function() {-	var digits = this._d;-	return this._s === 0 || digits.length === 0 || (digits[0] % 2) === 0;-};--/*-	Function: isOdd-	Return true iff *this* is not divisible by two.--	Returns:--		true if *this* is odd, false otherwise.--	See Also:--		<isEven>-*/-BigInteger.prototype.isOdd = function() {-	return !this.isEven();-};--/*-	Function: sign-	Get the sign of a <BigInteger>.--	Returns:--		* -1 if *this* < 0-		* 0 if *this* == 0-		* +1 if *this* > 0--	See Also:--		<isZero>, <isPositive>, <isNegative>, <compare>, <BigInteger.ZERO>-*/-BigInteger.prototype.sign = function() {-	return this._s;-};--/*-	Function: isPositive-	Return true iff *this* > 0.--	Returns:--		true if *this*.compare(<BigInteger.ZERO>) == 1.--	See Also:--		<sign>, <isZero>, <isNegative>, <isUnit>, <compare>, <BigInteger.ZERO>-*/-BigInteger.prototype.isPositive = function() {-	return this._s > 0;-};--/*-	Function: isNegative-	Return true iff *this* < 0.--	Returns:--		true if *this*.compare(<BigInteger.ZERO>) == -1.--	See Also:--		<sign>, <isPositive>, <isZero>, <isUnit>, <compare>, <BigInteger.ZERO>-*/-BigInteger.prototype.isNegative = function() {-	return this._s < 0;-};--/*-	Function: isZero-	Return true iff *this* == 0.--	Returns:--		true if *this*.compare(<BigInteger.ZERO>) == 0.--	See Also:--		<sign>, <isPositive>, <isNegative>, <isUnit>, <BigInteger.ZERO>-*/-BigInteger.prototype.isZero = function() {-	return this._s === 0;-};--/*-	Function: exp10-	Multiply a <BigInteger> by a power of 10.--	This is equivalent to, but faster than--	> if (n >= 0) {-	>     return this.multiply(BigInteger("1e" + n));-	> }-	> else { // n <= 0-	>     return this.quotient(BigInteger("1e" + -n));-	> }--	Parameters:--		n - The power of 10 to multiply *this* by. *n* is converted to a-		javascipt number and must be no greater than <BigInteger.MAX_EXP>-		(0x7FFFFFFF), or an exception will be thrown.--	Returns:--		*this* * (10 ** *n*), truncated to an integer if necessary.--	See Also:--		<pow>, <multiply>-*/-BigInteger.prototype.exp10 = function(n) {-	n = +n;-	if (n === 0) {-		return this;-	}-	if (Math.abs(n) > Number(MAX_EXP)) {-		throw new Error("exponent too large in BigInteger.exp10");-	}-	// Optimization for this == 0. This also keeps us from having to trim zeros in the positive n case-	if (this._s === 0) {-		return ZERO;-	}-	if (n > 0) {-		var k = new BigInteger(this._d.slice(), this._s, CONSTRUCT);--		for (; n >= BigInteger_base_log10; n -= BigInteger_base_log10) {-			k._d.unshift(0);-		}-		if (n == 0)-			return k;-		k._s = 1;-		k = k.multiplySingleDigit(Math.pow(10, n));-		return (this._s < 0 ? k.negate() : k);-	} else if (-n >= this._d.length*BigInteger_base_log10) {-		return ZERO;-	} else {-		var k = new BigInteger(this._d.slice(), this._s, CONSTRUCT);--		for (n = -n; n >= BigInteger_base_log10; n -= BigInteger_base_log10) {-			k._d.shift();-		}-		return (n == 0) ? k : k.divRemSmall(Math.pow(10, n))[0];-	}-};--/*-	Function: pow-	Raise a <BigInteger> to a power.--	In this implementation, 0**0 is 1.--	Parameters:--		n - The exponent to raise *this* by. *n* must be no greater than-		<BigInteger.MAX_EXP> (0x7FFFFFFF), or an exception will be thrown.--	Returns:--		*this* raised to the *nth* power.--	See Also:--		<modPow>-*/-BigInteger.prototype.pow = function(n) {-	if (this.isUnit()) {-		if (this._s > 0) {-			return this;-		}-		else {-			return BigInteger(n).isOdd() ? this : this.negate();-		}-	}--	n = BigInteger(n);-	if (n._s === 0) {-		return ONE;-	}-	else if (n._s < 0) {-		if (this._s === 0) {-			throw new Error("Divide by zero");-		}-		else {-			return ZERO;-		}-	}-	if (this._s === 0) {-		return ZERO;-	}-	if (n.isUnit()) {-		return this;-	}--	if (n.compareAbs(MAX_EXP) > 0) {-		throw new Error("exponent too large in BigInteger.pow");-	}-	var x = this;-	var aux = ONE;-	var two = BigInteger.small[2];--	while (n.isPositive()) {-		if (n.isOdd()) {-			aux = aux.multiply(x);-			if (n.isUnit()) {-				return aux;-			}-		}-		x = x.square();-		n = n.quotient(two);-	}--	return aux;-};--/*-	Function: modPow-	Raise a <BigInteger> to a power (mod m).--	Because it is reduced by a modulus, <modPow> is not limited by-	<BigInteger.MAX_EXP> like <pow>.--	Parameters:--		exponent - The exponent to raise *this* by. Must be positive.-		modulus - The modulus.--	Returns:--		*this* ^ *exponent* (mod *modulus*).--	See Also:--		<pow>, <mod>-*/-BigInteger.prototype.modPow = function(exponent, modulus) {-	var result = ONE;-	var base = this;--	while (exponent.isPositive()) {-		if (exponent.isOdd()) {-			result = result.multiply(base).remainder(modulus);-		}--		exponent = exponent.quotient(BigInteger.small[2]);-		if (exponent.isPositive()) {-			base = base.square().remainder(modulus);-		}-	}--	return result;-};--/*-	Function: log-	Get the natural logarithm of a <BigInteger> as a native JavaScript number.--	This is equivalent to--	> Math.log(this.toJSValue())--	but handles values outside of the native number range.--	Returns:--		log( *this* )--	See Also:--		<toJSValue>-*/-BigInteger.prototype.log = function() {-	switch (this._s) {-	case 0:	 return -Infinity;-	case -1: return NaN;-	default: // Fall through.-	}--	var l = this._d.length;--	if (l*BigInteger_base_log10 < 30) {-		return Math.log(this.valueOf());-	}--	var N = Math.ceil(30/BigInteger_base_log10);-	var firstNdigits = this._d.slice(l - N);-	return Math.log((new BigInteger(firstNdigits, 1, CONSTRUCT)).valueOf()) + (l - N) * Math.log(BigInteger_base);-};--/*-	Function: valueOf-	Convert a <BigInteger> to a native JavaScript integer.--	This is called automatically by JavaScipt to convert a <BigInteger> to a-	native value.--	Returns:--		> parseInt(this.toString(), 10)--	See Also:--		<toString>, <toJSValue>-*/-BigInteger.prototype.valueOf = function() {-	return parseInt(this.toString(), 10);-};--/*-	Function: toJSValue-	Convert a <BigInteger> to a native JavaScript integer.--	This is the same as valueOf, but more explicitly named.--	Returns:--		> parseInt(this.toString(), 10)--	See Also:--		<toString>, <valueOf>-*/-BigInteger.prototype.toJSValue = function() {-	return parseInt(this.toString(), 10);-};--var MAX_EXP = BigInteger(0x7FFFFFFF);-// Constant: MAX_EXP-// The largest exponent allowed in <pow> and <exp10> (0x7FFFFFFF or 2147483647).-BigInteger.MAX_EXP = MAX_EXP;--(function() {-	function makeUnary(fn) {-		return function(a) {-			return fn.call(BigInteger(a));-		};-	}--	function makeBinary(fn) {-		return function(a, b) {-			return fn.call(BigInteger(a), BigInteger(b));-		};-	}--	function makeTrinary(fn) {-		return function(a, b, c) {-			return fn.call(BigInteger(a), BigInteger(b), BigInteger(c));-		};-	}--	(function() {-		var i, fn;-		var unary = "toJSValue,isEven,isOdd,sign,isZero,isNegative,abs,isUnit,square,negate,isPositive,toString,next,prev,log".split(",");-		var binary = "compare,remainder,divRem,subtract,add,quotient,divide,multiply,pow,compareAbs".split(",");-		var trinary = ["modPow"];--		for (i = 0; i < unary.length; i++) {-			fn = unary[i];-			BigInteger[fn] = makeUnary(BigInteger.prototype[fn]);-		}--		for (i = 0; i < binary.length; i++) {-			fn = binary[i];-			BigInteger[fn] = makeBinary(BigInteger.prototype[fn]);-		}--		for (i = 0; i < trinary.length; i++) {-			fn = trinary[i];-			BigInteger[fn] = makeTrinary(BigInteger.prototype[fn]);-		}--		BigInteger.exp10 = function(x, n) {-			return BigInteger(x).exp10(n);-		};-	})();-})();--exports.BigInteger = BigInteger;-})(typeof exports !== 'undefined' ? exports : this);
src/data/MAlonzo/src/MAlonzo/RTE.hs view
@@ -1,11 +1,25 @@+{-# LANGUAGE PolyKinds #-}+ module MAlonzo.RTE where -import Unsafe.Coerce-import GHC.Prim-import Numeric.IEEE ( IEEE(identicalIEEE) )+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+ -- Special version of coerce that plays well with rules. {-# INLINE [1] coe #-}+coe :: a -> b coe = unsafeCoerce {-# RULES "coerce-id" forall (x :: a) . coe x = x #-} @@ -13,8 +27,9 @@ data QName = QName { nameId, moduleId :: Integer, qnameString :: String, qnameFixity :: Fixity }  data Assoc      = NonAssoc | LeftAssoc | RightAssoc-data Precedence = Unrelated | Related Integer+data Precedence = Unrelated | Related PrecedenceLevel data Fixity     = Fixity Assoc Precedence+type PrecedenceLevel = Double  instance Eq QName where   QName a b _ _ == QName c d _ _ = (a, b) == (c, d)@@ -25,12 +40,12 @@ erased :: a erased = coe (\ _ -> erased) -mazIncompleteMatch :: String -> a-mazIncompleteMatch s = error ("Agda: incomplete pattern matching: " ++ s)- mazUnreachableError :: a mazUnreachableError = error ("Agda: unreachable code reached.") +mazHole :: String -> a+mazHole s = error ("Agda: reached hole: " ++ s)+ addInt :: Integer -> Integer -> Integer addInt = (+) @@ -55,41 +70,52 @@ remInt :: Integer -> Integer -> Integer remInt = rem -eqFloat :: Double -> Double -> Bool-eqFloat x y = identicalIEEE x y || (isNaN x && isNaN y)+-- #4999: Data.Text maps surrogate code points (\xD800 - \xDFFF) to the replacement character+-- \xFFFD, so to keep strings isomorphic to list of characters we do the same for characters.+natToChar :: Integer -> Char+natToChar n | generalCategory c == Surrogate = '\xFFFD'+            | otherwise                      = c+  where c = toEnum $ fromIntegral $ mod n 0x110000 -eqNumFloat :: Double -> Double -> Bool-eqNumFloat = (==)+-- Words -- -negativeZero :: Double-negativeZero = -0.0+type Word64 = Data.Word.Word64 -positiveInfinity :: Double-positiveInfinity = 1.0 / 0.0+word64ToNat :: Word64 -> Integer+word64ToNat = fromIntegral -negativeInfinity :: Double-negativeInfinity = -positiveInfinity+word64FromNat :: Integer -> Word64+word64FromNat = fromIntegral -positiveNaN :: Double-positiveNaN = 0.0 / 0.0+{-# INLINE add64 #-}+add64 :: Word64 -> Word64 -> Word64+add64 = (+) -negativeNaN :: Double-negativeNaN = -positiveNaN+{-# INLINE sub64 #-}+sub64 :: Word64 -> Word64 -> Word64+sub64 = (-) --- Adapted from the same function on Agda.Syntax.Literal.-compareFloat :: Double -> Double -> Ordering-compareFloat x y-  | identicalIEEE x y          = EQ-  | isNegInf x                 = LT-  | isNegInf y                 = GT-  | isNaN x && isNaN y         = EQ-  | isNaN x                    = LT-  | isNaN y                    = GT-  | otherwise                  = compare x y-  where-    isNegInf z = z < 0 && isInfinite z+{-# INLINE mul64 #-}+mul64 :: Word64 -> Word64 -> Word64+mul64 = (*) -ltNumFloat :: Double -> Double -> Bool-ltNumFloat x y = case compareFloat x y of-                LT -> True-                _  -> False+{-# INLINE quot64 #-}+quot64 :: Word64 -> Word64 -> Word64+quot64 = quot++{-# INLINE rem64 #-}+rem64 :: Word64 -> Word64 -> Word64+rem64 = rem++{-# INLINE eq64 #-}+eq64 :: Word64 -> Word64 -> Bool+eq64 = (==)++{-# INLINE lt64 #-}+lt64 :: Word64 -> Word64 -> Bool+lt64 = (<)++-- Support for musical coinduction.++data Inf                      a = Sharp { flat :: a }+type Infinity (level :: Type) a = Inf a
+ src/data/MAlonzo/src/MAlonzo/RTE/Float.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}++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 )+import Data.Ratio       ( (%), numerator, denominator )+import Data.Word        ( Word64 )++#if __GLASGOW_HASKELL__ >= 804+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+#else+import System.IO.Unsafe (unsafePerformIO)+import qualified Foreign          as F+import qualified Foreign.Storable as F+#endif++#if __GLASGOW_HASKELL__ < 804+castDoubleToWord64 :: Double -> Word64+castDoubleToWord64 float = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) float+  F.peek buf++castWord64ToDouble :: Word64 -> Double+castWord64ToDouble word = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) word+  F.peek buf+#endif++{-# INLINE doubleEq #-}+doubleEq :: Double -> Double -> Bool+doubleEq = (==)++{-# INLINE doubleLe #-}+doubleLe :: Double -> Double -> Bool+doubleLe = (<=)++{-# INLINE doubleLt #-}+doubleLt :: Double -> Double -> Bool+doubleLt = (<)++truncateDouble :: Double -> Double+truncateDouble = castWord64ToDouble . castDoubleToWord64++{-# INLINE intToDouble #-}+intToDouble :: Integral a => a -> Double+intToDouble = truncateDouble . fromIntegral++{-# INLINE doublePlus #-}+doublePlus :: Double -> Double -> Double+doublePlus x y = truncateDouble (x + y)++{-# INLINE doubleMinus #-}+doubleMinus :: Double -> Double -> Double+doubleMinus x y = truncateDouble (x - y)++{-# INLINE doubleTimes #-}+doubleTimes :: Double -> Double -> Double+doubleTimes x y = truncateDouble (x * y)++{-# INLINE doubleNegate #-}+doubleNegate :: Double -> Double+doubleNegate = negate -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleDiv #-}+doubleDiv :: Double -> Double -> Double+doubleDiv = (/) -- NOTE: doesn't cause underflow/overflow++{-# INLINE doublePow #-}+doublePow :: Double -> Double -> Double+doublePow x y = truncateDouble (x ** y)++{-# INLINE doubleSqrt #-}+doubleSqrt :: Double -> Double+doubleSqrt = sqrt -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleExp #-}+doubleExp :: Double -> Double+doubleExp x = truncateDouble (exp x)++{-# INLINE doubleLog #-}+doubleLog :: Double -> Double+doubleLog = log -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSin #-}+doubleSin :: Double -> Double+doubleSin = sin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCos #-}+doubleCos :: Double -> Double+doubleCos = cos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTan #-}+doubleTan :: Double -> Double+doubleTan = tan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASin #-}+doubleASin :: Double -> Double+doubleASin = asin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACos #-}+doubleACos :: Double -> Double+doubleACos = acos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan #-}+doubleATan :: Double -> Double+doubleATan = atan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan2 #-}+doubleATan2 :: Double -> Double -> Double+doubleATan2 = atan2 -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSinh #-}+doubleSinh :: Double -> Double+doubleSinh = sinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCosh #-}+doubleCosh :: Double -> Double+doubleCosh = cosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTanh #-}+doubleTanh :: Double -> Double+doubleTanh = tanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASinh #-}+doubleASinh :: Double -> Double+doubleASinh = asinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACosh #-}+doubleACosh :: Double -> Double+doubleACosh = acosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATanh #-}+doubleATanh :: Double -> Double+doubleATanh = atanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE negativeZero #-}+negativeZero :: Double+negativeZero = -0.0++positiveInfinity :: Double+positiveInfinity = 1.0 / 0.0++negativeInfinity :: Double+negativeInfinity = -positiveInfinity++nan :: Double+nan = 0.0 / 0.0++isPosInf :: Double -> Bool+isPosInf x = x > 0.0 && isInfinite x++isNegInf :: Double -> Bool+isNegInf x = x < 0.0 && isInfinite x++isPosZero :: Double -> Bool+isPosZero x = doubleDenotEq x 0.0++isNegZero :: Double -> Bool+isNegZero x = doubleDenotEq x (-0.0)++doubleRound :: Double -> Maybe Integer+doubleRound = fmap round . asFinite++doubleFloor :: Double -> Maybe Integer+doubleFloor = fmap floor . asFinite++doubleCeiling :: Double -> Maybe Integer+doubleCeiling = fmap ceiling . asFinite++normaliseNaN :: Double -> Double+normaliseNaN x+  | isNaN x   = nan+  | otherwise = x++doubleToWord64 :: Double -> Maybe Word64+doubleToWord64 x+  | isNaN x   = Nothing+  | otherwise = Just (castDoubleToWord64 x)++-- |Denotational equality for floating point numbers, checks bitwise equality.+--+--  NOTE: Denotational equality distinguishes NaNs, so its results may vary+--        depending on the architecture and compilation flags. Unfortunately,+--        this is a problem with floating-point numbers in general.+--+doubleDenotEq :: Double -> Double -> Bool+doubleDenotEq = (==) `on` doubleToWord64++-- |I guess "denotational orderings" are now a thing? The point is that we need+--  an Ord instance which provides a total ordering, and is consistent with the+--  denotational equality.+--+--  NOTE: The ordering induced via `doubleToWord64` is total, and is consistent+--        with `doubleDenotEq`. However, it is *deeply* unintuitive. For one, it+--        considers all negative numbers to be larger than positive numbers.+--+doubleDenotOrd :: Double -> Double -> Ordering+doubleDenotOrd = compare `on` doubleToWord64++-- |Return Just x if it's a finite number, otherwise return Nothing.+asFinite :: Double -> Maybe Double+asFinite x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just x++-- |Decode a Double to an integer ratio.+doubleToRatio :: Double -> (Integer, Integer)+doubleToRatio x+  | isNaN      x = (0, 0)+  | isInfinite x = (signum (floor x), 0)+  | otherwise    = let r = toRational x in (numerator r, denominator r)++-- |Encode an integer ratio as a double.+ratioToDouble :: Integer -> Integer -> Double+ratioToDouble n d+  | d == 0 = case compare n 0 of+      LT -> negativeInfinity+      EQ -> nan+      GT -> positiveInfinity+  | otherwise = fromRational (n % d)++-- |Decode a Double to its mantissa and its exponent, normalised such that the+--  mantissa is the smallest possible number without loss of accuracy.+doubleDecode :: Double -> Maybe (Integer, Integer)+doubleDecode x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just (uncurry normalise (second toInteger (decodeFloat x)))+  where+    normalise :: Integer -> Integer -> (Integer, Integer)+    normalise mantissa exponent+      | even mantissa = normalise (mantissa `div` 2) (exponent + 1)+      | otherwise = (mantissa, exponent)++-- |Checks whether or not the Double is within a safe range of operation.+isSafeInteger :: Double -> Bool+isSafeInteger x = case properFraction x of+  (n, f) -> f == 0.0 && minMantissa <= n && n <= maxMantissa++doubleRadix :: Integer+doubleRadix = floatRadix (undefined :: Double)++doubleDigits :: Int+doubleDigits = floatDigits (undefined :: Double)++doubleRange :: (Int, Int)+doubleRange = floatRange (undefined :: Double)++-- |The smallest representable mantissa. Simultaneously, the smallest integer which can be+--  represented as a Double without loss of precision.+minMantissa :: Integer+minMantissa = - maxMantissa++-- |The largest representable mantissa. Simultaneously, the largest integer which can be+--  represented as a Double without loss of precision.+maxMantissa :: Integer+maxMantissa = (doubleRadix ^ toInteger doubleDigits) - 1++-- |The largest representable exponent.+minExponent :: Integer+minExponent = toInteger $ (fst doubleRange - doubleDigits) - 1++-- |The smallest representable exponent.+maxExponent :: Integer+maxExponent = toInteger $ snd doubleRange - doubleDigits++-- |Encode a mantissa and an exponent as a Double.+doubleEncode :: Integer -> Integer -> Maybe Double+doubleEncode mantissa exponent+  = if minMantissa <= mantissa && mantissa <= maxMantissa &&+       minExponent <= exponent && exponent <= maxExponent+    then Just (encodeFloat mantissa (fromInteger exponent))+    else Nothing
− src/data/agda.sty 
@@ -1,532 +0,0 @@-% -----------------------------------------------------------------------% Some useful commands when doing highlighting of Agda code in LaTeX.-% ------------------------------------------------------------------------\ProvidesPackage{agda}--\RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox}--% https://tex.stackexchange.com/questions/47576/combining-ifxetex-and-ifluatex-with-the-logical-or-operation-\newif\ifxetexorluatex-\ifxetex-  \xetexorluatextrue-\else-  \ifluatex-    \xetexorluatextrue-  \else-    \xetexorluatexfalse-  \fi-\fi--% XeLaTeX or LuaLaTeX-\ifxetexorluatex--    % Hack to get the amsthm package working.-    % https://tex.stackexchange.com/questions/130491/xelatex-error-paragraph-ended-before-tempa-was-complete-    \let\AgdaOpenBracket\[\let\AgdaCloseBracket\]-    \RequirePackage{fontspec}-    \let\[\AgdaOpenBracket\let\]\AgdaCloseBracket-    \RequirePackage{unicode-math}--    \tracinglostchars=2 % If the font is missing some symbol, then say-                        % so in the compilation output.-    \setmainfont-      [ Ligatures      = TeX-      , BoldItalicFont = xits-bolditalic.otf-      , BoldFont       = xits-bold.otf-      , ItalicFont     = xits-italic.otf-      ]-      {xits-regular.otf}--    \setmathfont{xits-math.otf}-    \setmonofont[Mapping=tex-text]{FreeMono.otf}--    % Make mathcal and mathscr appear as different.-    % https://tex.stackexchange.com/questions/120065/xetex-what-happened-to-mathcal-and-mathscr-    \setmathfont[range={\mathcal,\mathbfcal},StylisticSet=1]{xits-math.otf}-    \setmathfont[range=\mathscr]{xits-math.otf}--    \providecommand{\DeclareUnicodeCharacter}[2]{\relax}--% pdfLaTeX-\else-    \RequirePackage{ucs, amsfonts, amssymb}-    \RequirePackage[safe]{tipa} % See page 12 of the tipa manual for what-                                % safe does.--    % https://tex.stackexchange.com/questions/1774/how-to-insert-pipe-symbol-in-latex-    \RequirePackage[T1]{fontenc}-    \RequirePackage[utf8x]{inputenc}-\fi--% -----------------------------------------------------------------------% Options--\DeclareOption{bw}   {\newcommand{\AgdaColourScheme}{bw}}-\DeclareOption{conor}{\newcommand{\AgdaColourScheme}{conor}}--\newif\if@AgdaEnableReferences\@AgdaEnableReferencesfalse-\DeclareOption{references}{-  \@AgdaEnableReferencestrue-}--\newif\if@AgdaEnableLinks\@AgdaEnableLinksfalse-\DeclareOption{links}{-  \@AgdaEnableLinkstrue-}--\ProcessOptions\relax--% -----------------------------------------------------------------------% Colour schemes.--\providecommand{\AgdaColourScheme}{standard}--% -----------------------------------------------------------------------% References to code (needs additional post-processing of tex files to-% work, see wiki for details).--\if@AgdaEnableReferences-  \RequirePackage{catchfilebetweentags, xstring}-  \newcommand{\AgdaRef}[2][]{%-    \StrSubstitute{#2}{\_}{AgdaUnderscore}[\tmp]%-    \ifthenelse{\isempty{#1}}%-               {\ExecuteMetaData{AgdaTag-\tmp}}%-               {\ExecuteMetaData{#1}{AgdaTag-\tmp}}-  }-\fi--\providecommand{\AgdaRef}[2][]{#2}--% -----------------------------------------------------------------------% Links (only done if the option is passed and the user has loaded the-% hyperref package).--\if@AgdaEnableLinks-  \@ifpackageloaded{hyperref}{--    % List that holds added targets.-    \newcommand{\AgdaList}[0]{}--    \newtoggle{AgdaIsElem}-    \newcounter{AgdaIndex}-    \newcommand{\AgdaLookup}[3]{%-      \togglefalse{AgdaIsElem}%-      \setcounter{AgdaIndex}{0}%-      \renewcommand*{\do}[1]{%-      \ifstrequal{#1}{##1}%-        {\toggletrue{AgdaIsElem}\listbreak}%-        {\stepcounter{AgdaIndex}}}%-      \dolistloop{\AgdaList}%-      \iftoggle{AgdaIsElem}{#2}{#3}%-    }--    \newcommand*{\AgdaTargetHelper}[1]{%-      \AgdaLookup{#1}%-        {\PackageError{agda}{``#1'' used as target more than once}%-                            {Overloaded identifiers and links do not%-                             work well, consider using unique%-                             \MessageBreak identifiers instead.}%-        }%-        {\listadd{\AgdaList}{#1}%-         \hypertarget{Agda\theAgdaIndex}{}%-        }%-    }--    \newcommand{\AgdaTarget}[1]{\forcsvlist{\AgdaTargetHelper}{#1}}--    \newcommand{\AgdaLink}[1]{%-      \AgdaLookup{#1}%-        {\hyperlink{Agda\theAgdaIndex}{#1}}%-        {#1}%-    }-  }{\PackageError{agda}{Load the hyperref package before the agda package}{}}-\fi--\providecommand{\AgdaTarget}[1]{}-\providecommand{\AgdaLink}[1]{#1}--% -----------------------------------------------------------------------% Font styles.--\ifxetexorluatex-  \newcommand{\AgdaFontStyle}[1]{\ensuremath{\mathsf{#1}}}-  \ifthenelse{\equal{\AgdaColourScheme}{bw}}{-      \newcommand{\AgdaKeywordFontStyle}[1]{\underline{#1}}-  }{-      \newcommand{\AgdaKeywordFontStyle}[1]{\ensuremath{\mathsf{#1}}}-  }-  \newcommand{\AgdaStringFontStyle}[1]{\ensuremath{\texttt{#1}}}-  \newcommand{\AgdaCommentFontStyle}[1]{\ensuremath{\texttt{#1}}}-  \newcommand{\AgdaBoundFontStyle}[1]{\ensuremath{\mathit{#1}}}--\else-  \newcommand{\AgdaFontStyle}[1]{\textsf{#1}}-  \ifthenelse{\equal{\AgdaColourScheme}{bw}}{-      \newcommand{\AgdaKeywordFontStyle}[1]{\underline{#1}}-  }{-      \newcommand{\AgdaKeywordFontStyle}[1]{\textsf{#1}}-  }-  \newcommand{\AgdaStringFontStyle}[1]{\texttt{#1}}-  \newcommand{\AgdaCommentFontStyle}[1]{\texttt{#1}}-  \newcommand{\AgdaBoundFontStyle}[1]{\textit{#1}}-\fi--% -----------------------------------------------------------------------% Colours.--% -----------------------------------% The black and white colour scheme.-\ifthenelse{\equal{\AgdaColourScheme}{bw}}{--    % Aspect colours.-    \definecolor{AgdaComment}      {HTML}{000000}-    \definecolor{AgdaKeyword}      {HTML}{000000}-    \definecolor{AgdaString}       {HTML}{000000}-    \definecolor{AgdaNumber}       {HTML}{000000}-    \definecolor{AgdaSymbol}       {HTML}{000000}-    \definecolor{AgdaPrimitiveType}{HTML}{000000}-    \definecolor{AgdaOperator}     {HTML}{000000}--    % NameKind colours.-    \definecolor{AgdaBound}                 {HTML}{000000}-    \definecolor{AgdaInductiveConstructor}  {HTML}{000000}-    \definecolor{AgdaCoinductiveConstructor}{HTML}{000000}-    \definecolor{AgdaDatatype}              {HTML}{000000}-    \definecolor{AgdaField}                 {HTML}{000000}-    \definecolor{AgdaFunction}              {HTML}{000000}-    \definecolor{AgdaMacro}                 {HTML}{000000}-    \definecolor{AgdaModule}                {HTML}{000000}-    \definecolor{AgdaPostulate}             {HTML}{000000}-    \definecolor{AgdaPrimitive}             {HTML}{000000}-    \definecolor{AgdaRecord}                {HTML}{000000}-    \definecolor{AgdaArgument}              {HTML}{000000}--    % Other aspect colours.-    \definecolor{AgdaDottedPattern}     {HTML}{000000}-    \definecolor{AgdaUnsolvedMeta}      {HTML}{D3D3D3}-    \definecolor{AgdaTerminationProblem}{HTML}{BEBEBE}-    \definecolor{AgdaIncompletePattern} {HTML}{D3D3D3}-    \definecolor{AgdaError}             {HTML}{696969}--    % Misc.-    \definecolor{AgdaHole}              {HTML}{BEBEBE}--% -----------------------------------% Conor McBride's colour scheme.-}{ \ifthenelse{\equal{\AgdaColourScheme}{conor}}{--    % Aspect colours.-    \definecolor{AgdaComment}      {HTML}{B22222}-    \definecolor{AgdaKeyword}      {HTML}{000000}-    \definecolor{AgdaString}       {HTML}{000000}-    \definecolor{AgdaNumber}       {HTML}{000000}-    \definecolor{AgdaSymbol}       {HTML}{000000}-    \definecolor{AgdaPrimitiveType}{HTML}{0000CD}-    \definecolor{AgdaOperator}     {HTML}{000000}--    % NameKind colours.-    \definecolor{AgdaBound}                 {HTML}{A020F0}-    \definecolor{AgdaInductiveConstructor}  {HTML}{8B0000}-    \definecolor{AgdaCoinductiveConstructor}{HTML}{8B0000}-    \definecolor{AgdaDatatype}              {HTML}{0000CD}-    \definecolor{AgdaField}                 {HTML}{8B0000}-    \definecolor{AgdaFunction}              {HTML}{006400}-    \definecolor{AgdaMacro}                 {HTML}{006400}-    \definecolor{AgdaModule}                {HTML}{006400}-    \definecolor{AgdaPostulate}             {HTML}{006400}-    \definecolor{AgdaPrimitive}             {HTML}{006400}-    \definecolor{AgdaRecord}                {HTML}{0000CD}-    \definecolor{AgdaArgument}              {HTML}{404040}--    % Other aspect colours.-    \definecolor{AgdaDottedPattern}     {HTML}{000000}-    \definecolor{AgdaUnsolvedMeta}      {HTML}{FFD700}-    \definecolor{AgdaTerminationProblem}{HTML}{FF0000}-    \definecolor{AgdaIncompletePattern} {HTML}{A020F0}-    \definecolor{AgdaError}             {HTML}{F4A460}--    % Misc.-    \definecolor{AgdaHole}              {HTML}{9DFF9D}--% -----------------------------------% The standard colour scheme.-}{-    % Aspect colours.-    \definecolor{AgdaComment}      {HTML}{B22222}-    \definecolor{AgdaKeyword}      {HTML}{CD6600}-    \definecolor{AgdaString}       {HTML}{B22222}-    \definecolor{AgdaNumber}       {HTML}{A020F0}-    \definecolor{AgdaSymbol}       {HTML}{404040}-    \definecolor{AgdaPrimitiveType}{HTML}{0000CD}-    \definecolor{AgdaOperator}     {HTML}{000000}--    % NameKind colours.-    \definecolor{AgdaBound}                 {HTML}{000000}-    \definecolor{AgdaInductiveConstructor}  {HTML}{008B00}-    \definecolor{AgdaCoinductiveConstructor}{HTML}{8B7500}-    \definecolor{AgdaDatatype}              {HTML}{0000CD}-    \definecolor{AgdaField}                 {HTML}{EE1289}-    \definecolor{AgdaFunction}              {HTML}{0000CD}-    \definecolor{AgdaMacro}                 {HTML}{458B74}-    \definecolor{AgdaModule}                {HTML}{A020F0}-    \definecolor{AgdaPostulate}             {HTML}{0000CD}-    \definecolor{AgdaPrimitive}             {HTML}{0000CD}-    \definecolor{AgdaRecord}                {HTML}{0000CD}-    \definecolor{AgdaArgument}              {HTML}{404040}--    % Other aspect colours.-    \definecolor{AgdaDottedPattern}     {HTML}{000000}-    \definecolor{AgdaUnsolvedMeta}      {HTML}{FFFF00}-    \definecolor{AgdaTerminationProblem}{HTML}{FFA07A}-    \definecolor{AgdaIncompletePattern} {HTML}{F5DEB3}-    \definecolor{AgdaError}             {HTML}{FF0000}--    % Misc.-    \definecolor{AgdaHole}              {HTML}{9DFF9D}-}}--% -----------------------------------------------------------------------% Commands.--% Aspect commands.-\newcommand{\AgdaComment}     [1]-    {\AgdaCommentFontStyle{\textcolor{AgdaComment}{#1}}}-\newcommand{\AgdaKeyword}     [1]-    {\AgdaKeywordFontStyle{\textcolor{AgdaKeyword}{#1}}}-\newcommand{\AgdaString}      [1]{\AgdaStringFontStyle{\textcolor{AgdaString}{#1}}}-\newcommand{\AgdaNumber}      [1]{\AgdaFontStyle{\textcolor{AgdaNumber}{#1}}}-\newcommand{\AgdaSymbol}      [1]{\AgdaFontStyle{\textcolor{AgdaSymbol}{#1}}}-\newcommand{\AgdaPrimitiveType}[1]-    {\AgdaFontStyle{\textcolor{AgdaPrimitiveType}{#1}}}-\newcommand{\AgdaOperator}    [1]{\AgdaFontStyle{\textcolor{AgdaOperator}{#1}}}--% NameKind commands.-\newcommand{\AgdaNoSpaceMath}[1]-    {\begingroup\thickmuskip=0mu\medmuskip=0mu#1\endgroup}--\newcommand{\AgdaBound}[1]-    {\AgdaNoSpaceMath{\AgdaBoundFontStyle{\textcolor{AgdaBound}{#1}}}}-\newcommand{\AgdaInductiveConstructor}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaInductiveConstructor}{\AgdaLink{#1}}}}}-\newcommand{\AgdaCoinductiveConstructor}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaCoinductiveConstructor}{\AgdaLink{#1}}}}}-\newcommand{\AgdaDatatype}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaDatatype}{\AgdaLink{#1}}}}}-\newcommand{\AgdaField}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaField}{\AgdaLink{#1}}}}}-\newcommand{\AgdaFunction}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaFunction}{\AgdaLink{#1}}}}}-\newcommand{\AgdaMacro}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaMacro}{\AgdaLink{#1}}}}}-\newcommand{\AgdaModule}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaModule}{\AgdaLink{#1}}}}}-\newcommand{\AgdaPostulate}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaPostulate}{\AgdaLink{#1}}}}}-\newcommand{\AgdaPrimitive}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaPrimitive}{#1}}}}-\newcommand{\AgdaRecord}[1]-    {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaRecord}{\AgdaLink{#1}}}}}-\newcommand{\AgdaArgument}[1]-    {\AgdaNoSpaceMath{\AgdaBoundFontStyle{\textcolor{AgdaArgument}{#1}}}}--% Other aspect commands.-\newcommand{\AgdaFixityOp}          [1]{\AgdaNoSpaceMath{$#1$}}-\newcommand{\AgdaDottedPattern}     [1]{\textcolor{AgdaDottedPattern}{#1}}-\newcommand{\AgdaUnsolvedMeta}      [1]-    {\AgdaFontStyle{\colorbox{AgdaUnsolvedMeta}{#1}}}-\newcommand{\AgdaTerminationProblem}[1]-    {\AgdaFontStyle{\colorbox{AgdaTerminationProblem}{#1}}}-\newcommand{\AgdaIncompletePattern} [1]{\colorbox{AgdaIncompletePattern}{#1}}-\newcommand{\AgdaError}             [1]-    {\AgdaFontStyle{\textcolor{AgdaError}{\underline{#1}}}}--% Misc.-\newcommand{\AgdaHole}[1]{\colorbox{AgdaHole}{#1}}-\long\def\AgdaHide#1{\ignorespaces} % Used to hide code from LaTeX.--\newcommand{\AgdaIndent}[1]{$\;\;$}--% -----------------------------------------------------------------------% The code environment.--\newcommand{\AgdaCodeStyle}{}-% \newcommand{\AgdaCodeStyle}{\tiny}--\ifdefined\mathindent-  {}-\else-  \newdimen\mathindent\mathindent\leftmargini-\fi--% Adds the given amount of vertical space and starts a new line.-%-% The implementation comes from lhs2TeX's polycode.fmt, written by-% Andres Löh.-\newcommand{\AgdaNewlineWithVerticalSpace}[1]{%-  {\parskip=0pt\parindent=0pt\par\vskip #1\noindent}}--% 0: No space around code. 1: Space around code.-\newcounter{Agda@SpaceAroundCode}--% Use this command to avoid extra space around code blocks.-\newcommand{\AgdaNoSpaceAroundCode}{%-  \setcounter{Agda@SpaceAroundCode}{0}}--% Use this command to include extra space around code blocks.-\newcommand{\AgdaSpaceAroundCode}{%-  \setcounter{Agda@SpaceAroundCode}{1}}--% By default space is inserted around code blocks.-\AgdaSpaceAroundCode{}--% Sometimes one might want to break up a code block into multiple-% pieces, but keep code in different blocks aligned with respect to-% each other. Then one can use the AgdaAlign environment. Example-% usage:-%-%   \begin{AgdaAlign}-%   \begin{code}-%     code-%       code  (more code)-%   \end{code}-%   Explanation...-%   \begin{code}-%     aligned with "code"-%       code  (aligned with (more code))-%   \end{code}-%   \end{AgdaAlign}-%-% Note that AgdaAlign environments should not be nested.-%-% Sometimes one might also want to hide code in the middle of a code-% block. This can be accomplished in the following way:-%-%   \begin{AgdaAlign}-%   \begin{code}-%     visible-%   \end{code}-%   \AgdaHide{-%   \begin{code}-%     hidden-%   \end{code}}-%   \begin{code}-%     visible-%   \end{code}-%   \end{AgdaAlign}-%-% However, the result may be ugly: extra space is perhaps inserted-% around the code blocks.-%-% The AgdaSuppressSpace environment ensures that extra space is only-% inserted before the first code block, and after the last one (but-% not if \AgdaNoSpaceAroundCode{} is used).-%-% The environment takes one argument, the number of wrapped code-% blocks (excluding hidden ones). Example usage:-%-%   \begin{AgdaAlign}-%   \begin{code}-%     code-%       more code-%   \end{code}-%   Explanation...-%   \begin{AgdaSuppressSpace}{2}-%   \begin{code}-%     aligned with "code"-%       aligned with "more code"-%   \end{code}-%   \AgdaHide{-%   \begin{code}-%     hidden code-%   \end{code}}-%   \begin{code}-%       also aligned with "more code"-%   \end{code}-%   \end{AgdaSuppressSpace}-%   \end{AgdaAlign}-%-% Note that AgdaSuppressSpace environments should not be nested.-%-% There is also a combined environment, AgdaMultiCode, that combines-% the effects of AgdaAlign and AgdaSuppressSpace.--% 0: AgdaAlign is not active. 1: AgdaAlign is active.-\newcounter{Agda@Align}-\setcounter{Agda@Align}{0}--% The current code block.-\newcounter{Agda@AlignCurrent}--\newcommand{\Agda@AlignStart}{%-  \setcounter{Agda@Align}{1}%-  \setcounter{Agda@AlignCurrent}{1}}--\newcommand{\Agda@AlignEnd}{\setcounter{Agda@Align}{0}}--\newenvironment{AgdaAlign}{%-  \Agda@AlignStart{}}{%-  \Agda@AlignEnd{}%-  \ignorespacesafterend}--% 0: AgdaSuppressSpace is not active. 1: AgdaSuppressSpace is active.-\newcounter{Agda@Suppress}-\setcounter{Agda@Suppress}{0}--% The current code block.-\newcounter{Agda@SuppressCurrent}--% The expected number of code blocks.-\newcounter{Agda@SuppressLast}--\newcommand{\Agda@SuppressStart}[1]{%-  \setcounter{Agda@Suppress}{1}%-  \setcounter{Agda@SuppressLast}{#1}%-  \setcounter{Agda@SuppressCurrent}{1}}--\newcommand{\Agda@SuppressEnd}{\setcounter{Agda@Suppress}{0}}--\newenvironment{AgdaSuppressSpace}[1]{%-  \Agda@SuppressStart{#1}}{%-  \Agda@SuppressEnd{}%-  \ignorespacesafterend}--\newenvironment{AgdaMultiCode}[1]{%-  \Agda@AlignStart{}%-  \Agda@SuppressStart{#1}}{%-  \Agda@SuppressEnd{}%-  \Agda@AlignEnd{}%-  \ignorespacesafterend}--% The code environment.-%-% The implementation is based on plainhscode in lhs2TeX's-% polycode.fmt, written by Andres Löh.-\newenvironment{code}{%-  \ifthenelse{\value{Agda@SpaceAroundCode} = 0 \or%-              \not \(\value{Agda@Suppress} = 0 \or%-                     \value{Agda@SuppressCurrent} = 1\)}{%-    \AgdaNewlineWithVerticalSpace{0pt}}{%-    \AgdaNewlineWithVerticalSpace{\abovedisplayskip}}%-  \advance\leftskip\mathindent%-  \AgdaCodeStyle%-  \pboxed%-  \ifthenelse{\value{Agda@Align} = 0}{}{%-    \ifthenelse{\value{Agda@AlignCurrent} = 1}{%-      \savecolumns}{%-      \restorecolumns}}}{%-  \endpboxed%-  \ifthenelse{\value{Agda@SpaceAroundCode} = 0 \or%-              \not \(\value{Agda@Suppress} = 0 \or%-                     \value{Agda@SuppressCurrent} =%-                     \value{Agda@SuppressLast}\)}{%-    \AgdaNewlineWithVerticalSpace{0pt}}{%-    \AgdaNewlineWithVerticalSpace{\belowdisplayskip}}%-  \stepcounter{Agda@AlignCurrent}%-  \stepcounter{Agda@SuppressCurrent}%-  \ignorespacesafterend}--% Default column for polytable.-\defaultcolumn{@{~}l@{~}}--\endinput
src/data/emacs-mode/agda-input.el view
@@ -1,5 +1,7 @@+;;; -*- lexical-binding: t; -*- ;;; agda-input.el --- The Agda input method +;; SPDX-License-Identifier: MIT License ;;; Commentary:  ;; A highly customisable input method which can inherit from other@@ -19,7 +21,7 @@ ;;; Code:  (require 'quail)-(require 'cl)+(require 'cl-lib) ;; Quail is quite stateful, so be careful when editing this code.  Note ;; that with-temp-buffer is used below whenever buffer-local state is ;; modified.@@ -50,17 +52,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions used to tweak translation pairs -;; lexical-let is used since Elisp lacks lexical scoping.- (defun agda-input-compose (f g)-  "\x -> concatMap F (G x)"-  (lexical-let ((f1 f) (g1 g))-    (lambda (x) (agda-input-concat-map f1 (funcall g1 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"-  (lexical-let ((f1 f) (g1 g))-    (lambda (x) (append (funcall f1 x) (funcall g1 x)))))+  "λ x -> F x ++ G x"+    (lambda (x) (append (funcall f x) (funcall g x))))  (defun agda-input-nonempty ()   "Only keep pairs with a non-empty first component."@@ -68,42 +66,36 @@  (defun agda-input-prepend (prefix)   "Prepend PREFIX to all key sequences."-  (lexical-let ((prefix1 prefix))-    (lambda (x) `((,(concat prefix1 (car x)) . ,(cdr x))))))+    (lambda (x) `((,(concat prefix (car x)) . ,(cdr x)))))  (defun agda-input-prefix (prefix)   "Only keep pairs whose key sequence starts with PREFIX."-  (lexical-let ((prefix1 prefix))     (lambda (x)-      (if (equal (substring (car x) 0 (length prefix1)) prefix1)-          (list x)))))+      (if (equal (substring (car x) 0 (length prefix)) prefix)+          (list x))))  (defun agda-input-suffix (suffix)   "Only keep pairs whose key sequence ends with SUFFIX."-  (lexical-let ((suffix1 suffix))     (lambda (x)       (if (equal (substring (car x)-                            (- (length (car x)) (length suffix1)))-                 suffix1)-          (list x)))))+                            (- (length (car x)) (length suffix)))+                 suffix)+          (list x))))  (defun agda-input-drop (ss)   "Drop pairs matching one of the given key sequences. SS should be a list of strings."-  (lexical-let ((ss1 ss))-    (lambda (x) (unless (member (car x) ss1) (list x)))))+    (lambda (x) (unless (member (car x) ss) (list x))))  (defun agda-input-drop-beginning (n)   "Drop N characters from the beginning of each key sequence."-  (lexical-let ((n1 n))-    (lambda (x) `((,(substring (car x) n1) . ,(cdr x))))))+    (lambda (x) `((,(substring (car x) n) . ,(cdr x)))))  (defun agda-input-drop-end (n)   "Drop N characters from the end of each key sequence."-  (lexical-let ((n1 n))     (lambda (x)-      `((,(substring (car x) 0 (- (length (car x)) n1)) .-         ,(cdr x))))))+      `((,(substring (car x) 0 (- (length (car x)) n)) .+         ,(cdr x)))))  (defun agda-input-drop-prefix (prefix)   "Only keep pairs whose key sequence starts with PREFIX.@@ -115,10 +107,9 @@ (defun agda-input-drop-suffix (suffix)   "Only keep pairs whose key sequence ends with SUFFIX. This suffix is dropped."-  (lexical-let ((suffix1 suffix))     (agda-input-compose-     (agda-input-drop-end (length suffix1))-     (agda-input-suffix suffix1))))+     (agda-input-drop-end (length suffix))+     (agda-input-suffix suffix)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization@@ -193,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" . ("≉"))   ("~~~"  . ("≋"))   (":~"   . ("∻"))@@ -207,6 +199,7 @@   ("~~-"  . ("≊"))   ("=="   . ("≡"))  ("==n" . ("≢"))   ("==="  . ("≣"))+  ("="    . ("＝"))   (".="   . ("≐"))  (".=." . ("≑"))   (":="   . ("≔"))  ("=:"  . ("≕"))   ("=o"   . ("≗"))@@ -220,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 "≯  ≱≩≵⋧≹⊁ ⋩⊅⊉⊋  ⋣⋥ ⋫⋭   ⋡"))    ("<="   . ("≤"))  (">="   . ("≥"))@@ -237,6 +230,8 @@   ("subn"  . ("⊄"))  ("supn"  . ("⊅"))   ("sub="  . ("⊆"))  ("sup="  . ("⊇"))   ("sub=n" . ("⊈"))  ("sup=n" . ("⊉"))+  ("sub~"  . ("⫇"))  ("sup~"  . ("⫈"))+  ("sub~~"  . ("⫉"))  ("sup~~"  . ("⫊"))    ("squb"   . ("⊏"))  ("squp"   . ("⊐"))   ("squb="  . ("⊑"))  ("squp="  . ("⊒"))@@ -261,7 +256,7 @@   ("glb" . ("⊓"))  ("lub" . ("⊔"))   ("Glb" . ("⨅"))  ("Lub" . ("⨆")) -  ;; Entailment etc.+  ;; Entailment, tacks, etc.    ("entails" . ,(agda-input-to-string-list "⊢⊣⊤⊥⊦⊧⊨⊩⊪⊫⊬⊭⊮⊯")) @@ -272,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"  . ("∤"))@@ -284,6 +289,8 @@   ("exn" . ("∄"))   ("0"   . ("∅"))   ("C"   . ("∁"))+  ("uin"    . ("⟒"))+  ("din"    . ("⫙"))    ;; Corners, ceilings and floors. @@ -302,20 +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 "⨾⨟⁏፤꛶；︔﹔⍮⸵;"))+  ("++"        . ("⧺"))   ("::"        . ("∷"))   ("::-"       . ("∺"))   ("-:"        . ("∹"))   ("+ "        . ("⊹"))+  ("+"         . ("＋"))+  ("sqrt"      . ("√"))+  ("surd"      . ("√"))   ("surd3"     . ("∛"))   ("surd4"     . ("∜"))   ("increment" . ("∆"))   ("inf"       . ("∞"))-  ("&"         . ("⅋"))+  ("&"         . ,(agda-input-to-string-list "⅋﹠＆"))+  ("z;"        . ,(agda-input-to-string-list "⨟⨾"))+  ("z:"        . ("⦂"))+  ("at"        . ,(agda-input-to-string-list "@﹫＠"))    ;; Circled operators. @@ -327,7 +343,7 @@   ("oo"  . ("⊚"))   ("o*"  . ("⊛"))   ("o="  . ("⊜"))-  ("o-"  . ("⊝"))+  ("o-"  . ,(agda-input-to-string-list "⊝⟜"))    ("O+"  . ("⨁"))   ("Ox"  . ("⨂"))@@ -336,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 "↖⇖                        ⇱↸                                               "))@@ -360,7 +414,7 @@   ("dr" . ,(agda-input-to-string-list "↘⇘                        ⇲                ➴➷➘                             "))   ("dl" . ,(agda-input-to-string-list "↙⇙                                                                         ")) -  ("l-"  . ("←"))  ("<-"  . ("←"))  ("l="  . ("⇐"))+  ("l-"  . ("←"))  ("<-"  . ("←"))  ("l="  . ("⇐"))  ("<="  . ("⇐"))   ("r-"  . ("→"))  ("->"  . ("→"))  ("r="  . ("⇒"))  ("=>"  . ("⇒"))   ("u-"  . ("↑"))                   ("u="  . ("⇑"))   ("d-"  . ("↓"))                   ("d="  . ("⇓"))@@ -394,6 +448,7 @@   ("r->" . ("↣"))    ("r-o" . ("⊸"))  ("-o"  . ("⊸"))+  ("l-o" . ("⟜"))    ("dz" . ("↯")) @@ -541,15 +596,238 @@   ("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"   . ("𝟎"))+  ("B1"   . ("𝟏"))+  ("B2"   . ("𝟐"))+  ("B3"   . ("𝟑"))+  ("B4"   . ("𝟒"))+  ("B5"   . ("𝟓"))+  ("B6"   . ("𝟔"))+  ("B7"   . ("𝟕"))+  ("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 "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢"))-  (")" . ,(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 "⟩>≫⋙≻⊃⋑⊐⊱⊳⋗＞"))   ("<<" . ("⟪"))   (">>" . ("⟫"))   ("{{" . ("⦃"))@@ -561,13 +839,19 @@   ("lbag" . ("⟅"))   ("rbag" . ("⟆")) -  ("(|" . ("⦇"))+  ("<|" . ("⦉"))  ;; Angle bar brackets+  ("|>" . ("⦊"))++  ("(|" . ("⦇"))  ;; Idiom 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. @@ -582,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"   . ("‿"))@@ -604,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"̲̳"))@@ -636,7 +933,7 @@   ("Gd"  . ("δ"))  ("GD"  . ("Δ"))   ("Ge"  . ("ε"))  ("GE"  . ("Ε"))   ("Gz"  . ("ζ"))  ("GZ"  . ("Ζ"))-  ;; \eta \Eta+  ("Gh"  . ("η"))  ("GH"  . ("Η"))   ("Gth" . ("θ"))  ("GTH" . ("Θ"))   ("Gi"  . ("ι"))  ("GI"  . ("Ι"))   ("Gk"  . ("κ"))  ("GK"  . ("Κ"))@@ -655,7 +952,7 @@   ("Gp"  . ("ψ"))  ("GP"  . ("Ψ"))   ("Go"  . ("ω"))  ("GO"  . ("Ω")) -  ;; Mathematical characters+  ;; Mathematical characters.    ("MiA" . ("𝐴"))   ("MiB" . ("𝐵"))@@ -690,6 +987,7 @@   ("Mie" . ("𝑒"))   ("Mif" . ("𝑓"))   ("Mig" . ("𝑔"))+  ("Mih" . ("ℎ"))   ("Mii" . ("𝑖"))   ("Mij" . ("𝑗"))   ("Mik" . ("𝑘"))@@ -708,6 +1006,7 @@   ("Mix" . ("𝑥"))   ("Miy" . ("𝑦"))   ("Miz" . ("𝑧"))+   ("MIA" . ("𝑨"))   ("MIB" . ("𝑩"))   ("MIC" . ("𝑪"))@@ -734,6 +1033,7 @@   ("MIX" . ("𝑿"))   ("MIY" . ("𝒀"))   ("MIZ" . ("𝒁"))+   ("MIa" . ("𝒂"))   ("MIb" . ("𝒃"))   ("MIc" . ("𝒄"))@@ -760,16 +1060,25 @@   ("MIx" . ("𝒙"))   ("MIy" . ("𝒚"))   ("MIz" . ("𝒛"))+   ("McA" . ("𝒜"))+  ("McB" . ("ℬ"))   ("McC" . ("𝒞"))   ("McD" . ("𝒟"))+  ("McE" . ("ℰ"))+  ("McF" . ("ℱ"))   ("McG" . ("𝒢"))+  ("McH" . ("ℋ"))+  ("McI" . ("ℐ"))   ("McJ" . ("𝒥"))   ("McK" . ("𝒦"))+  ("McL" . ("ℒ"))+  ("McM" . ("ℳ"))   ("McN" . ("𝒩"))   ("McO" . ("𝒪"))   ("McP" . ("𝒫"))   ("McQ" . ("𝒬"))+  ("McR" . ("ℛ"))   ("McS" . ("𝒮"))   ("McT" . ("𝒯"))   ("McU" . ("𝒰"))@@ -782,7 +1091,9 @@   ("Mcb" . ("𝒷"))   ("Mcc" . ("𝒸"))   ("Mcd" . ("𝒹"))+  ("Mce" . ("ℯ"))   ("Mcf" . ("𝒻"))+  ("Mcg" . ("ℊ"))   ("Mch" . ("𝒽"))   ("Mci" . ("𝒾"))   ("Mcj" . ("𝒿"))@@ -790,6 +1101,7 @@   ("Mcl" . ("𝓁"))   ("Mcm" . ("𝓂"))   ("Mcn" . ("𝓃"))+  ("Mco" . ("ℴ"))   ("Mcp" . ("𝓅"))   ("Mcq" . ("𝓆"))   ("Mcr" . ("𝓇"))@@ -801,6 +1113,7 @@   ("Mcx" . ("𝓍"))   ("Mcy" . ("𝓎"))   ("Mcz" . ("𝓏"))+   ("MCA" . ("𝓐"))   ("MCB" . ("𝓑"))   ("MCC" . ("𝓒"))@@ -853,12 +1166,16 @@   ("MCx" . ("𝔁"))   ("MCy" . ("𝔂"))   ("MCz" . ("𝔃"))+   ("MfA" . ("𝔄"))   ("MfB" . ("𝔅"))+  ("MfC" . ("ℭ"))   ("MfD" . ("𝔇"))   ("MfE" . ("𝔈"))   ("MfF" . ("𝔉"))   ("MfG" . ("𝔊"))+  ("MfH" . ("ℌ"))+  ("MfI" . ("ℑ"))   ("MfJ" . ("𝔍"))   ("MfK" . ("𝔎"))   ("MfL" . ("𝔏"))@@ -867,6 +1184,7 @@   ("MfO" . ("𝔒"))   ("MfP" . ("𝔓"))   ("MfQ" . ("𝔔"))+  ("MfR" . ("ℜ"))   ("MfS" . ("𝔖"))   ("MfT" . ("𝔗"))   ("MfU" . ("𝔘"))@@ -874,6 +1192,7 @@   ("MfW" . ("𝔚"))   ("MfX" . ("𝔛"))   ("MfY" . ("𝔜"))+  ("MfZ" . ("ℨ"))   ("Mfa" . ("𝔞"))   ("Mfb" . ("𝔟"))   ("Mfc" . ("𝔠"))@@ -901,10 +1220,22 @@   ("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+  ;;+  ;; Perhaps they will be added in future versions, however there are no+  ;; proposals for it currently in the pipeline:+  ;; https://www.unicode.org/alloc/Pipeline.html    ("_a" . ("ₐ"))+  ;; ("_b" . ("b"))+  ;; ("_c" . ("c"))+  ;; ("_d" . ("d"))   ("_e" . ("ₑ"))+  ;; ("_f" . ("f"))+  ;; ("_g" . ("g"))   ("_h" . ("ₕ"))   ("_i" . ("ᵢ"))   ("_j" . ("ⱼ"))@@ -914,13 +1245,23 @@   ("_n" . ("ₙ"))   ("_o" . ("ₒ"))   ("_p" . ("ₚ"))+  ;; ("_q" . ("q"))   ("_r" . ("ᵣ"))   ("_s" . ("ₛ"))   ("_t" . ("ₜ"))   ("_u" . ("ᵤ"))   ("_v" . ("ᵥ"))+  ;; ("_w" . ("w"))   ("_x" . ("ₓ"))+  ;; ("_y" . ("y"))+  ;; ("_z" . ("z")) +  ("_Gb" . ("ᵦ"))+  ("_Gg" . ("ᵧ"))+  ("_Gr" . ("ᵨ"))+  ("_Gf" . ("ᵩ"))+  ("_Gc" . ("ᵪ"))+   ("^a" . ("ᵃ"))   ("^b" . ("ᵇ"))   ("^c" . ("ᶜ"))@@ -937,6 +1278,7 @@   ("^n" . ("ⁿ"))   ("^o" . ("ᵒ"))   ("^p" . ("ᵖ"))+  ;; ("^q" . ("q"))   ("^r" . ("ʳ"))   ("^s" . ("ˢ"))   ("^t" . ("ᵗ"))@@ -949,8 +1291,10 @@    ("^A" . ("ᴬ"))   ("^B" . ("ᴮ"))+  ;; ("^C" . ("C"))   ("^D" . ("ᴰ"))   ("^E" . ("ᴱ"))+  ;; ("^F" . ("F"))   ("^G" . ("ᴳ"))   ("^H" . ("ᴴ"))   ("^I" . ("ᴵ"))@@ -961,12 +1305,29 @@   ("^N" . ("ᴺ"))   ("^O" . ("ᴼ"))   ("^P" . ("ᴾ"))+  ;; ("^Q" . ("Q"))   ("^R" . ("ᴿ"))+  ;; ("^S" . ("S"))   ("^T" . ("ᵀ"))   ("^U" . ("ᵁ"))   ("^V" . ("ⱽ"))   ("^W" . ("ᵂ"))+  ;; ("^X" . ("X"))+  ;; ("^Y" . ("Y"))+  ;; ("^Z" . ("Z")) +  ("^Ga" . ("ᵅ"))+  ("^Gb" . ("ᵝ"))+  ("^Gg" . ("ᵞ"))+  ("^Gd" . ("ᵟ"))+  ("^Ge" . ("ᵋ"))+  ("^Gth" . ("ᶿ"))+  ("^Gi" . ("ᶥ"))+  ("^Gf" . ("ᵠ"))+  ("^Gc" . ("ᵡ"))++  ("^GF" . ("ᶲ"))+   ;; Some ISO8859-1 characters.    (" "         . (" "))@@ -980,7 +1341,7 @@    ;; Circled, parenthesised etc. numbers and letters. -  ( "(0)" . ,(agda-input-to-string-list " ⓪"))+  ( "(0)" . ,(agda-input-to-string-list " ⓪🄀⓿🄋🄌"))   ( "(1)" . ,(agda-input-to-string-list "⑴①⒈❶➀➊"))   ( "(2)" . ,(agda-input-to-string-list "⑵②⒉❷➁➋"))   ( "(3)" . ,(agda-input-to-string-list "⑶③⒊❸➂➌"))@@ -991,43 +1352,43 @@   ( "(8)" . ,(agda-input-to-string-list "⑻⑧⒏❽➇➑"))   ( "(9)" . ,(agda-input-to-string-list "⑼⑨⒐❾➈➒"))   ("(10)" . ,(agda-input-to-string-list "⑽⑩⒑❿➉➓"))-  ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒"))-  ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓"))-  ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔"))-  ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕"))-  ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖"))-  ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗"))-  ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘"))-  ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙"))-  ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚"))-  ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛"))+  ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒⓫"))+  ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓⓬"))+  ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔⓭"))+  ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕⓮"))+  ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖⓯"))+  ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗⓰"))+  ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘⓱"))+  ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙⓲"))+  ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚⓳"))+  ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛⓴")) -  ("(a)"  . ,(agda-input-to-string-list "⒜Ⓐⓐ"))-  ("(b)"  . ,(agda-input-to-string-list "⒝Ⓑⓑ"))-  ("(c)"  . ,(agda-input-to-string-list "⒞Ⓒⓒ"))-  ("(d)"  . ,(agda-input-to-string-list "⒟Ⓓⓓ"))-  ("(e)"  . ,(agda-input-to-string-list "⒠Ⓔⓔ"))-  ("(f)"  . ,(agda-input-to-string-list "⒡Ⓕⓕ"))-  ("(g)"  . ,(agda-input-to-string-list "⒢Ⓖⓖ"))-  ("(h)"  . ,(agda-input-to-string-list "⒣Ⓗⓗ"))-  ("(i)"  . ,(agda-input-to-string-list "⒤Ⓘⓘ"))-  ("(j)"  . ,(agda-input-to-string-list "⒥Ⓙⓙ"))-  ("(k)"  . ,(agda-input-to-string-list "⒦Ⓚⓚ"))-  ("(l)"  . ,(agda-input-to-string-list "⒧Ⓛⓛ"))-  ("(m)"  . ,(agda-input-to-string-list "⒨Ⓜⓜ"))-  ("(n)"  . ,(agda-input-to-string-list "⒩Ⓝⓝ"))-  ("(o)"  . ,(agda-input-to-string-list "⒪Ⓞⓞ"))-  ("(p)"  . ,(agda-input-to-string-list "⒫Ⓟⓟ"))-  ("(q)"  . ,(agda-input-to-string-list "⒬Ⓠⓠ"))-  ("(r)"  . ,(agda-input-to-string-list "⒭Ⓡⓡ"))-  ("(s)"  . ,(agda-input-to-string-list "⒮Ⓢⓢ"))-  ("(t)"  . ,(agda-input-to-string-list "⒯Ⓣⓣ"))-  ("(u)"  . ,(agda-input-to-string-list "⒰Ⓤⓤ"))-  ("(v)"  . ,(agda-input-to-string-list "⒱Ⓥⓥ"))-  ("(w)"  . ,(agda-input-to-string-list "⒲Ⓦⓦ"))-  ("(x)"  . ,(agda-input-to-string-list "⒳Ⓧⓧ"))-  ("(y)"  . ,(agda-input-to-string-list "⒴Ⓨⓨ"))-  ("(z)"  . ,(agda-input-to-string-list "⒵Ⓩⓩ"))+  ("(a)"  . ,(agda-input-to-string-list "⒜Ⓐⓐ🅐🄰🅰"))+  ("(b)"  . ,(agda-input-to-string-list "⒝Ⓑⓑ🅑🄱🅱"))+  ("(c)"  . ,(agda-input-to-string-list "⒞Ⓒⓒ🅒🄲🅲"))+  ("(d)"  . ,(agda-input-to-string-list "⒟Ⓓⓓ🅓🄳🅳"))+  ("(e)"  . ,(agda-input-to-string-list "⒠Ⓔⓔ🅔🄴🅴"))+  ("(f)"  . ,(agda-input-to-string-list "⒡Ⓕⓕ🅕🄵🅵"))+  ("(g)"  . ,(agda-input-to-string-list "⒢Ⓖⓖ🅖🄶🅶"))+  ("(h)"  . ,(agda-input-to-string-list "⒣Ⓗⓗ🅗🄷🅷"))+  ("(i)"  . ,(agda-input-to-string-list "⒤Ⓘⓘ🅘🄸🅸"))+  ("(j)"  . ,(agda-input-to-string-list "⒥Ⓙⓙ🅙🄹🅹"))+  ("(k)"  . ,(agda-input-to-string-list "⒦Ⓚⓚ🅚🄺🅺"))+  ("(l)"  . ,(agda-input-to-string-list "⒧Ⓛⓛ🅛🄻🅻"))+  ("(m)"  . ,(agda-input-to-string-list "⒨Ⓜⓜ🅜🄼🅼"))+  ("(n)"  . ,(agda-input-to-string-list "⒩Ⓝⓝ🅝🄽🅽"))+  ("(o)"  . ,(agda-input-to-string-list "⒪Ⓞⓞ🅞🄾🅾"))+  ("(p)"  . ,(agda-input-to-string-list "⒫Ⓟⓟ🅟🄿🅿"))+  ("(q)"  . ,(agda-input-to-string-list "⒬Ⓠⓠ🅠🅀🆀"))+  ("(r)"  . ,(agda-input-to-string-list "⒭Ⓡⓡ🅡🅁🆁"))+  ("(s)"  . ,(agda-input-to-string-list "⒮Ⓢⓢ🅢🅂🆂"))+  ("(t)"  . ,(agda-input-to-string-list "⒯Ⓣⓣ🅣🅃🆃"))+  ("(u)"  . ,(agda-input-to-string-list "⒰Ⓤⓤ🅤🅄🆄"))+  ("(v)"  . ,(agda-input-to-string-list "⒱Ⓥⓥ🅥🅅🆅"))+  ("(w)"  . ,(agda-input-to-string-list "⒲Ⓦⓦ🅦🅆🆆"))+  ("(x)"  . ,(agda-input-to-string-list "⒳Ⓧⓧ🅧🅇🆇"))+  ("(y)"  . ,(agda-input-to-string-list "⒴Ⓨⓨ🅨🅈🆈"))+  ("(z)"  . ,(agda-input-to-string-list "⒵Ⓩⓩ🅩🅉🆉"))    ))   "A list of translations specific to the Agda input method.
src/data/emacs-mode/agda2-abbrevs.el view
@@ -1,4 +1,6 @@+;; -*- lexical-binding: t -*- ;; agda2-abbrevs.el --- Default Agda abbrevs+;; SPDX-License-Identifier: MIT License  ;;; Commentary:
src/data/emacs-mode/agda2-highlight.el view
@@ -1,4 +1,6 @@+;; -*- lexical-binding: t -*- ;;; agda2-highlight.el --- Syntax highlighting for Agda (version ≥ 2)+;; SPDX-License-Identifier: MIT License  ;;; Commentary: @@ -55,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.@@ -96,6 +80,8 @@              :foreground "medium blue")             (agda2-highlight-bound-variable-face              :foreground "purple")+            (agda2-highlight-generalizable-variable-face+             :foreground "purple")             (agda2-highlight-inductive-constructor-face              :foreground "firebrick3")             (agda2-highlight-coinductive-constructor-face@@ -120,6 +106,9 @@             (agda2-highlight-error-face              :foreground "red"              :underline t)+            (agda2-highlight-error-warning-face+             :background "light coral"+             :underline t)             (agda2-highlight-unsolved-meta-face              :foreground "black"              :background "yellow")@@ -140,68 +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+                      (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@@ -228,17 +198,26 @@   :group 'agda2-highlight)  (defface agda2-highlight-keyword-face-  '((t (:foreground "DarkOrange3")))+  '((((background light))+     (:foreground "DarkOrange3"))+    (((background dark))+     (:foreground "#FF9932")))   "The face used for keywords."   :group 'agda2-highlight-faces)  (defface agda2-highlight-string-face-  '((t (:foreground "firebrick")))+  '((((background light))+     (:foreground "firebrick"))+    (((background dark))+     (:foreground "#DD4D4D")))   "The face used for strings."   :group 'agda2-highlight-faces)  (defface agda2-highlight-number-face-  '((t (:foreground "purple")))+  '((((background light))+     (:foreground "purple"))+    (((background dark))+     (:foreground "#9010E0")))   "The face used for numbers."   :group 'agda2-highlight-faces) @@ -251,7 +230,10 @@   :group 'agda2-highlight-faces)  (defface agda2-highlight-primitive-type-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for primitive types (like Set and Prop)."   :group 'agda2-highlight-faces) @@ -260,53 +242,93 @@   "The face used for bound variables."   :group 'agda2-highlight-faces) +(defface agda2-highlight-generalizable-variable-face+  '((t nil))+  "The face used for generalizable variables."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-inductive-constructor-face-  '((t (:foreground "green4")))+  '((((background light))+     :foreground "green4")+    (((background dark))+     :foreground "#29CC29"))   "The face used for inductive constructors."   :group 'agda2-highlight-faces)  (defface agda2-highlight-coinductive-constructor-face-  '((t (:foreground "gold4")))+  '((((background light))+     :foreground "gold4")+    (((background dark))+     :foreground "#FFEA75"))   "The face used for coinductive constructors."   :group 'agda2-highlight-faces)  (defface agda2-highlight-datatype-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for datatypes."   :group 'agda2-highlight-faces)  (defface agda2-highlight-field-face-  '((t (:foreground "DeepPink2")))+  '((((background light))+     (:foreground "DeepPink2"))+    (((background dark))+     (:foreground "#F570B7")))   "The face used for record fields."   :group 'agda2-highlight-faces)  (defface agda2-highlight-function-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for functions."   :group 'agda2-highlight-faces)  (defface agda2-highlight-module-face-  '((t (:foreground "purple")))+  '((((background light))+     (:foreground "purple"))+    (((background dark))+     (:foreground "#CD80FF")))   "The face used for module names."   :group 'agda2-highlight-faces)  (defface agda2-highlight-postulate-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for postulates."   :group 'agda2-highlight-faces) +(defface agda2-highlight-pragma-face+  '((t nil))+  "The face used for (some text in) pragmas."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-primitive-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for primitive functions."   :group 'agda2-highlight-faces)  (defface agda2-highlight-macro-face-  '((t (:foreground "aquamarine4")))+  '((((background light))+     (:foreground "aquamarine4"))+    (((background dark))+     (:foreground "#73BAA2")))   "The face used for macros."   :group 'agda2-highlight-faces)  (defface agda2-highlight-record-face-  '((t (:foreground "medium blue")))+  '((((background light))+     (:foreground "medium blue"))+    (((background dark))+     (:foreground "#8080FF")))   "The face used for record types."   :group 'agda2-highlight-faces) @@ -321,54 +343,136 @@   :group 'agda2-highlight-faces)  (defface agda2-highlight-error-face-  '((t (:foreground "red" :underline t)))+  '((((background light))+     (:foreground "red" :underline t))+    (((background dark))+     (:foreground "#FF0000" :underline t)))   "The face used for errors."   :group 'agda2-highlight-faces) +(defface agda2-highlight-error-warning-face+  '((((background light))+     (:background "light coral" :underline t))+    (((background dark))+     (:background "#802400" :underline t)))+  "The face used for fatal warnings."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-unsolved-meta-face-  '((t (:background "yellow"-        :foreground "black")))+  '((((background light))+     (:background "yellow"))+    (((background dark))+     (:background "#806B00")))   "The face used for unsolved meta variables."   :group 'agda2-highlight-faces)  (defface agda2-highlight-unsolved-constraint-face-  '((t (:background "yellow"-        :foreground "black")))+  '((((background light))+     (:background "yellow"))+    (((background dark))+     (:background "#806B00")))   "The face used for unsolved constraints which are not connected to metas."   :group 'agda2-highlight-faces)  (defface agda2-highlight-termination-problem-face-  '((t (:background "light salmon"-        :foreground "black")))+  '((((background light))+     (:background "light salmon"))+    (((background dark))+     (:background "#802400")))   "The face used for termination problems."   :group 'agda2-highlight-faces)  (defface agda2-highlight-positivity-problem-face-  '((t (:background "peru"-        :foreground "black")))+  '((((background light))+     (:background "peru"))+    (((background dark))+     (:background "#803F00")))   "The face used for positivity problems."   :group 'agda2-highlight-faces) -(defface agda2-highlight-incomplete-pattern-face-  '((t (:background "wheat"-        :foreground "black")))-  "The face used for incomplete patterns. (Currently unused.)"+(defface agda2-highlight-deadcode-face+  '((((background light))+     (:background "dark gray"))+    (((background dark))+     (:background "#808080")))+  "The face used for dead code (unreachable clauses, etc.)."   :group 'agda2-highlight-faces) +(defface agda2-highlight-shadowing-in-telescope-face+  '((((background light))+     (:background "dark gray"))+    (((background dark))+     (:background "#808080")))+  "The face used for shadowed repeated variable names in telescopes."+  :group 'agda2-highlight-faces)++(defface agda2-highlight-coverage-problem-face+  '((((background light))+     (:background "wheat"))+    (((background dark))+     (:background "#805300")))+  "The face used for coverage problems."+  :group 'agda2-highlight-faces)++(defface agda2-highlight-catchall-clause-face+  '((((background light))+     (:background "white smoke"))+    (((background dark))+     (:background "#404040")))+  "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"))+    (((background dark))+     (:background "#800080")))+  "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"))+    (((background dark))+     (:background "#804040")))+  "The face used for type declarations with missing definitions."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-typechecks-face-  '((t (:background "light blue"-        :foreground "black")))+  '((((background light))+     (:background "light blue" :foreground "black"))+    (((background dark))+     (:background "#006080" :foreground "white")))   "The face used for code which is being type-checked."   :group 'agda2-highlight-faces)  (defvar agda2-highlight-faces   '((keyword                . agda2-highlight-keyword-face)     (comment                . font-lock-comment-face)+    (background             . default)+    (markup                 . font-lock-comment-delimiter-face)     (string                 . agda2-highlight-string-face)     (number                 . agda2-highlight-number-face)     (symbol                 . agda2-highlight-symbol-face)     (primitivetype          . agda2-highlight-primitive-type-face)     (bound                  . agda2-highlight-bound-variable-face)+    (generalizable          . agda2-highlight-generalizable-variable-face)     (inductiveconstructor   . agda2-highlight-inductive-constructor-face)     (coinductiveconstructor . agda2-highlight-coinductive-constructor-face)     (datatype               . agda2-highlight-datatype-face)@@ -376,49 +480,72 @@     (function               . agda2-highlight-function-face)     (module                 . agda2-highlight-module-face)     (postulate              . agda2-highlight-postulate-face)+    (pragma                 . agda2-highlight-pragma-face)     (primitive              . agda2-highlight-primitive-face)     (macro                  . agda2-highlight-macro-face)     (record                 . agda2-highlight-record-face)     (dotted                 . agda2-highlight-dotted-face)     (operator               . agda2-highlight-operator-face)     (error                  . agda2-highlight-error-face)+    (errorwarning           . agda2-highlight-error-warning-face)     (unsolvedmeta           . agda2-highlight-unsolved-meta-face)     (unsolvedconstraint     . agda2-highlight-unsolved-constraint-face)     (terminationproblem     . agda2-highlight-termination-problem-face)+    (deadcode               . agda2-highlight-deadcode-face)+    (shadowingintelescope   . agda2-highlight-shadowing-in-telescope-face)+    (coverageproblem        . agda2-highlight-coverage-problem-face)     (positivityproblem      . agda2-highlight-positivity-problem-face)     (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.  The aspects currently recognised are the following: +`background'             Non-Agda code contents in literate mode. `bound'                  Bound variables.+`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). `dotted'                 Dotted patterns. `error'                  Errors.+`errorwarning'           Fatal warnings. `field'                  Record fields. `function'               Functions.+`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+                           from other contents. `module'                 Module names. `number'                 Numbers. `operator'               Operators.+`positivityproblem'      Positivity problems. `postulate'              Postulates.+`pragma'                 Text occurring in pragmas that does not have+                           a more specific (syntactic) aspect. `primitive'              Primitive functions. `primitivetype'          Primitive types (like Set and Prop).-`macro'                  Macros. `record'                 Record types.+`shadowingintelescope'   Shadowed repeated variable names in telescopes. `string'                 Strings. `symbol'                 Symbols like forall, =, ->, etc. `terminationproblem'     Termination problems.-`positivityproblem'      Positivity problems. `typechecks'             Code which is being type-checked. `unsolvedconstraint'     Unsolved constraints, not connected to meta                            variables.-`unsolvedmeta'           Unsolved meta variables.-`comment'                Comments.")+`unsolvedmeta'           Unsolved meta variables.")  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables@@ -432,23 +559,26 @@  (defun agda2-highlight-setup nil   "Set up the `annotation' library for use with `agda2-mode'."+  (agda2-highlight-set-faces 'agda2-highlight-face-groups agda2-highlight-face-groups)   (setq annotation-bindings agda2-highlight-faces)) -(defun agda2-highlight-apply (&rest cmds)+(defun agda2-highlight-apply (remove &rest cmds)   "Adds the syntax highlighting information in the annotation list CMDS. -Old syntax highlighting information is not removed."+If REMOVE is nil, then old syntax highlighting information is not+removed. Otherwise all token-based syntax highlighting is removed."   (let (;; Ignore read-only status, otherwise this function may fail.         (inhibit-read-only t))     (apply 'annotation-load            "Click mouse-2 to jump to definition"+           remove            cmds))) -(defun agda2-highlight-add-annotations (&rest cmds)+(defun agda2-highlight-add-annotations (remove &rest cmds)   "Like `agda2-highlight-apply'. But only if `agda2-highlight-in-progress' is non-nil."   (if agda2-highlight-in-progress-      (apply 'agda2-highlight-apply cmds)))+      (apply 'agda2-highlight-apply remove cmds)))  (defun agda2-highlight-load (file)   "Load syntax highlighting information from FILE.@@ -470,12 +600,15 @@           (agda2-highlight-load file))     (delete-file file))) -(defun agda2-highlight-clear nil-  "Remove all syntax highlighting added by `agda2-highlight-reload'."+(defun agda2-highlight-clear (&optional token-based)+  "Remove all syntax highlighting.++If TOKEN-BASED is non-nil, then only token-based highlighting is+removed."   (interactive)   (let ((inhibit-read-only t))        ; Ignore read-only status, otherwise this function may fail.-    (annotation-remove-annotations)))+    (annotation-remove-annotations token-based)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Administrative details
src/data/emacs-mode/agda2-mode-pkg.el view
@@ -1,2 +1,3 @@-(define-package "agda2-mode" "2.5.1"-  "interactive development for Agda, a dependently typed functional programming language")+(define-package "agda2-mode" "2.8.0"+  "interactive development for Agda, a dependently typed functional programming language"+  '((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,2010 +1,2122 @@-;;; agda2-mode.el --- Major mode for Agda--;;; Commentary:--;;--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; Dependency---;;; Code:--(defvar agda2-version "2.5.2"-  "The version of the Agda mode.-Note that the same version of the Agda executable must be used.")--(require 'cl)-(require 'compile)-(require 'pp)-(require 'time-date)-(require 'eri)-(require 'annotation)-(require 'fontset)-(require 'agda-input)-(require 'agda2)-(require 'agda2-highlight)-(require 'agda2-abbrevs)-(require 'agda2-queue)-(eval-and-compile-  ;; Load filladapt, if it is installed.-  (condition-case nil-      (require 'filladapt)-    (error nil))-  (unless (fboundp 'overlays-in) (load "overlay")) ; for Xemacs-  (unless (fboundp 'propertize)                    ; for Xemacs 21.4-    ;; FIXME: XEmacs-21.4 (patch 22) does have `propertize' and so does Emacs-22-    ;; (and agda2-mode doesn't work in Emacs-21, AFAICT).-    (defun propertize (string &rest properties)-      "Return a copy of STRING with text properties added.-First argument is the string to copy.-Remaining arguments form a sequence of PROPERTY VALUE pairs for text-properties to add to the result."-      (let ((str (copy-sequence string)))-        (add-text-properties 0 (length str) properties str)-        str)))-  (unless (fboundp 'prog-mode)          ;For Emacs<24.-    (defalias 'prog-mode 'fundamental-mode)))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; Utilities--(defmacro agda2-let (varbind funcbind &rest body)-  "Expands to (let* VARBIND (cl-labels FUNCBIND BODY...)).-Or possibly (let* VARBIND (labels FUNCBIND BODY...))."-  (declare (debug ((&rest [&or symbolp (symbolp form)])-                   (&rest (cl-defun))-                   body))-           (indent 2))-  ;; Use cl-labels if available to avoid obsolescence warnings.-  `(let* ,varbind (,(if (fboundp 'cl-labels) 'cl-labels 'labels) ,funcbind ,@body)))--(defun agda2-chunkify (n xs)-  "Returns a list containing chunks of XS of length at most N.-All the elements of XS are included, in their original order."-  (let ((i 0)-        (len (length xs))-        out)-    (while (< i len)-      (let ((new-i (+ i (min n (- len i)))))-        (setq out (cons (subseq xs i new-i) out))-        (setq i new-i)))-    (nreverse out)))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; User options--(defgroup agda2 nil-  "Major mode for interactively developing Agda programs."-  :group 'languages)--(defcustom agda2-program-name "agda"-  "The name of the Agda executable."-  :type 'string-  :group 'agda2)--(defcustom agda2-program-args nil-  "Command-line arguments given to the Agda executable (one per string).--Note: Do not give several arguments in the same string.--The flag \"--interaction\" is always included as the first-argument, and does not need to be listed here."-  :type '(repeat string)-  :group 'agda2)--(defvar agda2-backends '("GHC" "GHCNoMain" "JS" "LaTeX")-  "Compilation backends.")--(defcustom agda2-backend-  'ask-  "The backend used to compile Agda programs."-  :type `(choice (const :tag "Ask every time" ask)-                 ,@(mapcar (lambda (x) `(const ,x)) agda2-backends))-  :group 'agda2)--(defcustom agda2-toplevel-module "Agda.Interaction.GhciTop"-  "The name of the Agda toplevel module."-  :type 'string :group 'agda2)--(defcustom agda2-warning-window-max-height-  0.35-  "The maximum height of the warning window.-A multiple of the frame height."-  :type 'number-  :group 'agda2)--(defcustom agda2-information-window-max-height-  0.35-  "The maximum height of the information window.-A multiple of the frame height."-  :type 'number-  :group 'agda2)--(defcustom agda2-fontset-name-  (unless (or (eq window-system 'mac)-              ;; Emacs-23 uses a revamped font engine which should-              ;; make agda2-fontset-name unnecessary in most cases.-              ;; And if it turns out to be necessary, we should-              ;; probably use face-remapping-alist rather than-              ;; set-frame-font so the special font only applies to-              ;; Agda buffers, and so it applies in all frames where-              ;; Agda buffers are displayed.-              (boundp 'face-remapping-alist))-    "fontset-agda2")-  "Default font to use in the selected frame when activating the Agda mode.-This is only used if it's non-nil and Emacs is not running in a-terminal.--Note that this setting (if non-nil) affects non-Agda buffers as-well, and that you have to restart Emacs if you want settings to-this variable to take effect."-  :type '(choice (string :tag "Fontset name")-                 (const :tag "Do not change the font" nil))-  :group 'agda2)--(defcustom agda2-fontset-spec-of-fontset-agda2-    "-*-fixed-Medium-r-Normal-*-18-*-*-*-c-*-fontset-agda2,-    ascii:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO8859-1,-    latin-iso8859-2:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-2,-    latin-iso8859-3:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-3,-    latin-iso8859-4:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-4,-    cyrillic-iso8859-5:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-5,-    greek-iso8859-7:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-7,-    latin-iso8859-9:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-9,-    mule-unicode-0100-24ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,-    mule-unicode-2500-33ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,-    mule-unicode-e000-ffff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,-    japanese-jisx0208:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0208.1990-0,-    japanese-jisx0212:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0212.1990-0,-    thai-tis620:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-TIS620.2529-1,-    lao:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-MuleLao-1,-    tibetan:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-160-MuleTibetan-0,-    tibetan-1-column:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-80-MuleTibetan-1,-    korean-ksc5601:-Daewoo-Mincho-Medium-R-Normal--16-120-100-100-C-160-KSC5601.1987-0,-    chinese-gb2312:-ISAS-Fangsong ti-Medium-R-Normal--16-160-72-72-c-160-GB2312.1980-0,-    chinese-cns11643-1:-HKU-Fixed-Medium-R-Normal--16-160-72-72-C-160-CNS11643.1992.1-0,-    chinese-big5-1:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0,-    chinese-big5-2:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0"-  "Specification of the \"fontset-agda2\" fontset.-This fontset is only created if `agda2-fontset-name' is-\"fontset-agda2\" and Emacs is not run in a terminal.--Note that the text \"fontset-agda2\" has to be part of the-string (in a certain way; see the default setting) in order for the-agda2 fontset to be created properly.--Note also that the default setting may not work unless suitable-fonts are installed on your system. Refer to the README file-accompanying the Agda distribution for more details.--Note finally that you have to restart Emacs if you want settings-to this variable to take effect."-  :group 'agda2-  :type 'string)--(if (and (equal agda2-fontset-name "fontset-agda2") window-system)-    (create-fontset-from-fontset-spec agda2-fontset-spec-of-fontset-agda2 t t))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; Global and buffer-local vars, initialization--(defvar agda2-mode-syntax-table-  (let ((tbl (make-syntax-table)))-    ;; Set the syntax of every char to "w" except for those whose default-    ;; syntax in `standard-syntax-table' is `paren' or `whitespace'.-    (map-char-table (lambda (keys val)-                      ;; `keys' here can be a normal char, a generic char-                      ;; (Emacs<23), or a char range (Emacs>=23).-                      (unless (memq (car val)-                                    (eval-when-compile-                                      (mapcar 'car-                                              (list (string-to-syntax "(")-                                                    (string-to-syntax ")")-                                                    (string-to-syntax " ")))))-                        (modify-syntax-entry keys "w" tbl)))-                    (standard-syntax-table))-    ;; Then override the remaining special cases.-    (dolist (cs '((?{ . "(}1n") (?} . "){4n") (?- . "w 123b") (?\n . "> b")-                  (?. . ".") (?\; . ".") (?_ . ".") (?! . ".")))-      (modify-syntax-entry (car cs) (cdr cs) tbl))-    tbl)-  "Syntax table used by the Agda mode:--{}   | Comment characters, matching parentheses.--    | Comment character, word constituent.-\n   | Comment ender.-.;_! | Punctuation.--Remaining characters inherit their syntax classes from the-standard syntax table if that table treats them as matching-parentheses or whitespace.  Otherwise they are treated as word-constituents.")--(defconst agda2-command-table-  `(-    (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-quit                              "\C-c\C-x\C-q"       (global)       "Quit")-    (agda2-restart                           "\C-c\C-x\C-r"       (global)       "Kill and restart Agda")-    (agda2-remove-annotations                "\C-c\C-x\C-d"       (global)       "Remove goals and highlighting (\"deactivate\")")-    (agda2-display-implicit-arguments        "\C-c\C-x\C-h"       (global)       "Toggle display of hidden arguments")-    (agda2-show-constraints                  ,(kbd "C-c C-=")     (global)       "Show constraints")-    (agda2-solve-maybe-all                   ,(kbd "C-c C-s")     (local global) "Solve constraints")-    (agda2-show-goals                        ,(kbd "C-c C-?")     (global)       "Show goals")-    (agda2-next-goal                         "\C-c\C-f"           (global)       "Next goal") ; Forward.-    (agda2-previous-goal                     "\C-c\C-b"           (global)       "Previous goal") ; Back.-    (agda2-give                              ,(kbd "C-c C-SPC")   (local)        "Give")-    (agda2-refine                            "\C-c\C-r"           (local)        "Refine")-    (agda2-auto                              "\C-c\C-a"           (local)        "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)")-    (agda2-helper-function-type              "\C-c\C-h"           (local)        "Helper function type")-    (agda2-infer-type-maybe-toplevel         "\C-c\C-d"           (local global) "Infer (deduce) type")-    (agda2-why-in-scope-maybe-toplevel       "\C-c\C-w"           (local global) "Explain why a particular name is in scope")-    (agda2-goal-and-context                  ,(kbd "C-c C-,")     (local)        "Goal type and context")-    (agda2-goal-and-context-and-inferred     ,(kbd "C-c C-.")     (local)        "Goal type, context and inferred type")-    (agda2-search-about-toplevel             ,(kbd "C-c C-z")     (local global) "Search About")-    (agda2-module-contents-maybe-toplevel    ,(kbd "C-c C-o")     (local global) "Module contents")-    (agda2-compute-normalised-maybe-toplevel "\C-c\C-n"           (local global) "Evaluate term to normal form")-    (describe-char                           nil                  (global)       "Information about the character at point")-    (agda2-comment-dwim-rest-of-buffer       ,(kbd "C-c C-x M-;") (global)       "Comment/uncomment the rest of the buffer")-    (agda2-display-program-version           nil                  (global)       "Version")-    (agda2-set-program-version               "\C-c\C-x\C-s"       (global)       "Switch to another version of Agda")-    (eri-indent                  ,(kbd "TAB"))-    (eri-indent-reverse          [S-iso-lefttab])-    (eri-indent-reverse          [S-lefttab])-    (eri-indent-reverse          [S-tab])-    (agda2-goto-definition-mouse [mouse-2])-    (agda2-goto-definition-keyboard "\M-.")-    (agda2-go-back                  ,(if (version< emacs-version "25.1") "\M-*" "\M-,"))-    )-  "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-menu; and DESC is the description of the command used in the-menus.")--(defvar agda2-mode-map-  (let ((map (make-sparse-keymap "Agda mode")))-    (define-key map [menu-bar Agda]-      (cons "Agda" (make-sparse-keymap "Agda")))-    (define-key map [down-mouse-3]  'agda2-popup-menu-3)-    (dolist (d (reverse agda2-command-table))-      (destructuring-bind (f &optional keys kinds desc) d-        (if keys (define-key map keys f))-        (if (member 'global kinds)-            (define-key map-              (vector 'menu-bar 'Agda (intern desc)) (cons desc f)))))-    map)-  "Keymap for `agda2-mode'.")--(defvar agda2-goal-map-  (let ((map (make-sparse-keymap "Agda goal")))-    (dolist (d (reverse agda2-command-table))-      (destructuring-bind (f &optional keys kinds desc) d-        (if (member 'local kinds)-            (define-key map-              (vector (intern desc)) (cons desc f)))))-    map)-  "Keymap for agda2 goal menu.")--(defvar agda2-info-buffer nil-  "Agda information buffer.")--(defvar agda2-warning-buffer nil-  "Agda warnings buffer.")--(defvar agda2-process-buffer nil-  "Agda subprocess buffer.-Set in `agda2-restart'.")--(defvar agda2-process nil-  "Agda subprocess.-Set in `agda2-restart'.")--(defvar agda2-in-progress nil-  "Is the Agda process currently busy?")--;; Some buffer locals-(defvar agda2-buffer-external-status ""-  "External status of an `agda2-mode' buffer (dictated by the Haskell side).")-(make-variable-buffer-local 'agda2-buffer-external-status)--(defvar agda2-output-prompt "Agda2> "-  "The Agda2 buffer's prompt.")--(defconst agda2-help-address-  ""-  "Address accepting submissions of bug reports and questions.")--;; Annotation for a goal-;; {! .... !}-;; ----------  overlay:    agda2-gn num, face highlight, after-string num,-;;                         modification-hooks (agda2-protect-goal-markers)-;; -           text-props: category agda2-delim1-;;  -          text-props: category agda2-delim2-;;         -   text-props: category agda2-delim3-;;          -  text-props: category agda2-delim4-;;-;; Char categories for {! ... !}-(defvar agda2-open-brace  "{")-(defvar agda2-close-brace " }")-(setplist 'agda2-delim1 `(display ,agda2-open-brace))-(setplist 'agda2-delim2 `(display ,agda2-open-brace rear-nonsticky t-                                  agda2-delim2 t))-(setplist 'agda2-delim3 `(display ,agda2-close-brace agda2-delim3 t))-(setplist 'agda2-delim4 `(display ,agda2-close-brace rear-nonsticky t))--;; Note that strings used with the display property are compared by-;; reference. If the agda2-*-brace definitions were inlined, then-;; goals would be displayed as "{{ }}n" instead of "{ }n".--(defvar agda2-measure-data nil-  "Used by `agda2-measure-load-time'.-This value is either nil or a pair containing a continuation (or-nil) and the time at which the measurement was started.")-(make-variable-buffer-local 'agda2-measure-data)--;; The following variables are used by the filter process,-;; `agda2-output-filter'. Their values are only modified by the filter-;; process, `agda2-go', `agda2-restart', and-;; `agda2-abort-highlighting'.--(defvar agda2-responses-expected nil-  "Is the Agda process expected to produce at least one response?")-(make-variable-buffer-local 'agda2-responses-expected)--(defvar agda2-responses 0-  "The number of encountered response commands.")-(make-variable-buffer-local 'agda2-responses)--(defvar agda2-output-chunk-incomplete (agda2-queue-empty)-  "Buffer for incomplete lines.-\(See `agda2-output-filter'.)")-(make-variable-buffer-local 'agda2-output-chunk-incomplete)--(defvar agda2-last-responses nil-  "Response commands which should be run after other commands.-The command which arrived last is stored first in the list.")-(make-variable-buffer-local 'agda2-last-responses)--(defvar agda2-file-buffer nil-  "The Agda buffer.-Note that this variable is not buffer-local.")--(defvar agda2-in-agda2-file-buffer nil-  "Was `agda2-file-buffer' active when `agda2-output-filter' started?-Note that this variable is not buffer-local.")--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; agda2-mode--;;;###autoload-(add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode))-;;;###autoload-(modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8)-;;;###autoload-(define-derived-mode agda2-mode prog-mode "Agda"-  "Major mode for Agda files.--The following paragraph does not apply to Emacs 23 or newer.--  Note that when this mode is activated the default font of the-  current frame is changed to the fontset `agda2-fontset-name'.-  The reason is that Agda programs often use mathematical symbols-  and other Unicode characters, so we try to provide a suitable-  default font setting, which can display many of the characters-  encountered. If you prefer to use your own settings, set-  `agda2-fontset-name' to nil.--Special commands:-\\{agda2-mode-map}"-- (if (boundp 'agda2-include-dirs)-     (display-warning 'agda2 "Note that the variable agda2-include-dirs is-no longer used. You may want to update your configuration. You-have at least two choices:-* Use the library management system.-* Set the include path using agda2-program-args.--One way to avoid seeing this warning is to make sure that-agda2-include-dirs is not bound." :warning))-- (setq local-abbrev-table agda2-mode-abbrev-table-       indent-tabs-mode   nil-       mode-line-process-         '((:eval (unless (eq 0 (length agda2-buffer-external-status))-                    (concat ":" agda2-buffer-external-status)))))- (let ((l '(max-specpdl-size    2600-            max-lisp-eval-depth 2800)))-   (while l (set (make-local-variable (pop l)) (pop l))))- (if (and window-system agda2-fontset-name)-     (condition-case nil-         (set-frame-font agda2-fontset-name)-       (error (error "Unable to change the font; change agda2-fontset-name or tweak agda2-fontset-spec-of-fontset-agda2"))))- ;; Deactivate highlighting if the buffer is edited before- ;; typechecking is complete.- (add-hook 'first-change-hook 'agda2-abort-highlighting nil 'local)- ;; If Agda is not running syntax highlighting does not work properly.- (unless (eq 'run (agda2-process-status))-   (agda2-restart))- (agda2-highlight-setup)- (condition-case err-     (agda2-highlight-reload)-   (error (message "Highlighting not loaded: %s"-                   (error-message-string err))))- (agda2-comments-and-paragraphs-setup)- (force-mode-line-update)- ;; Protect global value of default-input-method from set-input-method.- (make-local-variable 'default-input-method)- ;; Don't take script into account when determining word boundaries- (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))- (set-input-method "Agda")- ;; Highlighting etc. is removed when we switch from the Agda mode.- ;; Use case: When a file M.lagda with a local variables list- ;; including "mode: latex" is loaded chances are that the Agda mode- ;; is activated before the LaTeX mode, and the LaTeX mode does not- ;; seem to remove the text properties set by the Agda mode.- (add-hook 'change-major-mode-hook 'agda2-quit nil 'local))--(defun agda2-restart ()-  "Tries to start or restart the Agda process."-  (interactive)--  ;; Kill any running instance of the Agda process.-  (condition-case nil-      (agda2-term)-    (error nil))--  ;; Check that the right version of Agda is used.-  (let* ((coding-system-for-read 'utf-8)-         (output (with-output-to-string-                   (call-process agda2-program-name-                                 nil standard-output nil "--version")))-         (version (and (string-match "^Agda version \\([0-9.]+\\)" output)-                       (match-string 1 output))))-    (unless (equal version agda2-version)-      (error "The Agda mode's version (%s) does not match that of %s (%s)."-             agda2-version-             agda2-program-name (or version "unknown"))))--  (let ((all-program-args (cons "--interaction" agda2-program-args)))--    ;; Check that the arguments are not malformed.-    (let* ((coding-system-for-read 'utf-8)-           (status)-           (output-            (with-output-to-string-              (setq status-                    (apply 'call-process agda2-program-name-                           nil standard-output nil all-program-args)))))-      (unless (equal status 0)-        (error "Failed to start the Agda process:\n%s" output)))--    ;; Start the Agda process.-    (let ((agda2-bufname "*agda2*"))--      (let ((process-connection-type nil)) ; Pipes are faster than PTYs.-        (setq agda2-process-              (apply 'start-process "Agda2" agda2-bufname-                     agda2-program-name all-program-args)))--      (set-process-coding-system agda2-process 'utf-8 'utf-8)-      (set-process-query-on-exit-flag agda2-process nil)-      (set-process-filter agda2-process 'agda2-output-filter)-      (setq agda2-in-progress nil-            agda2-file-buffer (current-buffer))--      (with-current-buffer agda2-bufname-        (setq agda2-process-buffer (current-buffer)-              mode-name            "Agda executable"-              agda2-last-responses nil)-        (set-buffer-file-coding-system 'utf-8))--      (agda2-remove-annotations))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; Communicating with Agda--(defun agda2-raise-error ()-  "Raises an error.-The error message directs the user to the *agda2* buffer."-  (error "Problem encountered. The *agda2* buffer can perhaps explain why."))--(defun agda2-running-p nil-  "Does the *agda2* buffer exist, and is the Agda2 process running?"-  (and (buffer-live-p agda2-process-buffer)-       (eq (agda2-process-status) 'run)))--(defun agda2-send-command (restart &rest args)-  "Send a command to the Agda2 asyncronous process.  Saves the buffer-and sends the list of strings ARGS to Agda2.  If RESTART is non-nil-and the Agda2 process is not running, or the *agda2* buffer does not-exist, then an attempt is made to restart the process."-  (save-buffer)-  (when (and restart (not (agda2-running-p)))-    ;; Try restarting automatically, but only once, in case there is-    ;; some major problem.-    (agda2-restart)-    (unless (agda2-running-p)-      (agda2-raise-error)))-  (let ((command (apply 'concat (agda2-intersperse " " args))))-    (with-current-buffer agda2-process-buffer-      (goto-char (point-max))-      (insert command)-      (insert "\n")-      (process-send-string agda2-process (concat command "\n")))))--(defun agda2-abort-if-in-progress ()-  "Raise an error if the Agda process is (thought to be) busy."-  (when agda2-in-progress-    (error "Another command is currently in progress-\(if a command has been aborted you may want to restart Agda)")))--(defun agda2-go (responses-expected highlight do-abort &rest args)-  "Executes commands in the Agda2 interpreter.-Sends the list of strings ARGS to the Agda2 interpreter, waits for-output and executes the responses, if any. If no responses are-received, and RESPONSES-EXPECTED is non-nil, then an error is-raised. If HIGHLIGHT is non-nil, then the buffer's syntax-highlighting may be updated."--  (if do-abort (agda2-abort-if-in-progress))--  (setq agda2-in-progress             t-        agda2-highlight-in-progress   highlight-        agda2-responses-expected      responses-expected-        agda2-responses               0-        agda2-output-chunk-incomplete (agda2-queue-empty)-        agda2-file-buffer             (current-buffer))--  (apply 'agda2-send-command-         'restart-         "IOTCM"-         (agda2-string-quote (buffer-file-name))-         (if highlight (agda2-highlight-level) "None")-         "Indirect"-         "("-         (append args '(")"))))---(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-exactly one command. Incomplete lines are stored in a-buffer (`agda2-output-chunk-incomplete').--Every command is run by this function, unless it has the form-\"(('last . priority) . cmd)\", in which case it is run by-`agda2-run-last-commands' at the end, after the Agda2 prompt-has reappeared, after all non-last commands, and after all-interactive highlighting is complete. The last commands can have-different integer priorities; those with the lowest priority are-executed first.--Non-last commands should not call the Agda process.--All commands are echoed to the *agda2* buffer, with the exception-of commands of the form \"(agda2-highlight-... ...)\".--The non-last commands are run in the order in which they appear.--When the prompt has been reached an error is raised if-`agda2-responses-expected' is non-nil and no commands have-arrived. Otherwise highlighting annotations are-reloaded from `agda2-highlighting-file', unless-`agda2-highlighting-in-progress' is nil."--  ;; Beware: the buffer may have been killed in the mean time.  E.g. when-  ;; viewing an attachment containing Agda code in Gnus, Gnus will-  ;; create a temp buffer, set it in agda2-mode, call font-lock-ensure on it-  ;; (which won't know that it needs to wait for some process to reply), then-  ;; extract the fontified text and kill the temp buffer; so when Agda-  ;; finally answers, the temp buffer is long gone.-  (when (buffer-live-p agda2-file-buffer)-  (setq agda2-in-agda2-file-buffer-        (and agda2-file-buffer-             (equal (current-buffer) agda2-file-buffer)))-  (let (;; The input lines in the current chunk.-        (lines (split-string chunk "\n"))--        ;; Non-last commands found in the current chunk (reversed).-        (non-last-commands ())--        ;; Last incomplete line, if any.-        (output-chunk-incomplete ""))-    (with-current-buffer agda2-file-buffer-      (when (consp lines)-        (agda2-queue-enqueue agda2-output-chunk-incomplete (pop lines))-        (when (consp lines)-          ;; The previous uncomplete chunk is now complete.-          (push (agda2-queue-to-string agda2-output-chunk-incomplete)-                lines)--          ;; Stash away the last incomplete line, if any. (Note that-          ;; (split-string "...\n" "\n") evaluates to (... "").)-          (setq output-chunk-incomplete (car (last lines))-                agda2-output-chunk-incomplete-                (agda2-queue-from-string output-chunk-incomplete))--          ;; Handle every complete line.-          (dolist (line (butlast lines))-            (let* (;; The command. Lines which cannot be parsed as a single-                   ;; list, without any junk, are ignored.-                   (cmd (condition-case nil-                            (let ((result (read-from-string line)))-                              (if (and (listp (car result))-                                       (= (cdr result) (length line)))-                                  (car result)))-                          (error nil)))-                   (is-highlighting-command-                    (and cmd-                         (symbolp (car cmd))-                         (let ((case-fold-search nil))-                           (string-match "^agda2-highlight-"-                                         (symbol-name (car cmd)))))))--              ;; Do not echo highlighting commands.-              (unless is-highlighting-command-                (with-current-buffer agda2-process-buffer-                  (save-excursion-                    (goto-char (point-max))-                    (insert line)-                    (insert "\n"))))-              (when cmd-                (unless is-highlighting-command-                  (incf agda2-responses))-                (if (equal 'last (car-safe (car cmd)))-                    (push (cons (cdr (car cmd)) (cdr cmd))-                          agda2-last-responses)-                  (push cmd non-last-commands)))))--          ;; Run non-last commands.-          (mapc 'agda2-exec-response (nreverse non-last-commands)))--        ;; Check if the prompt has been reached. This function assumes-        ;; that the prompt does not include any newline characters.-        (when (agda2-queue-is-prefix-of agda2-output-prompt-                                        agda2-output-chunk-incomplete)-          (with-current-buffer agda2-process-buffer-            (insert output-chunk-incomplete))-          (setq agda2-output-chunk-incomplete (agda2-queue-empty)-                agda2-in-progress nil-                agda2-last-responses (nreverse agda2-last-responses))--          (when (and agda2-responses-expected-                     (equal agda2-responses 0))-            (agda2-raise-error))--          (agda2-run-last-commands)--          (when agda2-measure-data-            (let ((elapsed-                   (format "%.2fs"-                           (float-time (time-since-                                        (cdr agda2-measure-data)))))-                  (continuation (car agda2-measure-data)))-              (setq agda2-measure-data nil)-              (message "Load time: %s." elapsed)-              (when continuation-                (funcall continuation elapsed))))))))))--(defun agda2-run-last-commands nil-  "Execute the last commands in the right order.-\(After the prompt has reappeared.) See `agda2-output-filter'."--  ;; with-current-buffer is used repeatedly below, because some last-  ;; commands may switch the focus to another buffer.--  (while (with-current-buffer agda2-file-buffer-           (and (not agda2-in-progress) (consp agda2-last-responses)))-    (with-current-buffer agda2-file-buffer-      ;; The list is sorted repeatedly because this function may be-      ;; called recursively (via `agda2-exec-response').-      (setq agda2-last-responses (sort agda2-last-responses-                                       (lambda (x y) (<= (car x) (car y)))))-      (let ((r (pop agda2-last-responses)))-        (agda2-exec-response (cdr r)))))--  ;; Unset agda2-highlight-in-progress when all the asynchronous-  ;; commands have terminated.-  (unless agda2-in-progress-      (setq agda2-highlight-in-progress nil)))--(defun agda2-abort-highlighting nil-  "Abort any interactive highlighting.-This function should be used in `first-change-hook'."-  (when agda2-highlight-in-progress-    (setq agda2-highlight-in-progress nil)-    (message "\"%s\" has been modified. Interrupting highlighting."-             (buffer-name (current-buffer)))))--(defun agda2-goal-cmd (cmd &optional want ask &rest args)-  "Reads input from goal or minibuffer and sends command to Agda.--An error is raised if point is not in a goal.--The command sent to Agda is--  CMD <goal number> <goal range> <user input> ARGS.--The user input is computed as follows:--* If WANT is nil, then the user input is the empty string.--* If WANT is a string, and either ASK is non-nil or the goal only-  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-  used.--If the user input is not taken from the goal, then an empty goal-range is given.--An error is raised if no responses are received."-  (multiple-value-bind (o g) (agda2-goal-at (point))-    (unless g (error "For this command, please place the cursor in a goal"))-    (let ((txt (buffer-substring-no-properties (+ (overlay-start o) 2)-                                               (- (overlay-end   o) 2)))-          (input-from-goal nil))-      (cond ((null want) (setq txt ""))-            ((and (stringp want)-                  (or ask (string-match "\\`\\s *\\'" txt)))-             (setq txt (read-string (concat want ": ") nil nil txt t)))-            (t (setq input-from-goal t)))-      (apply 'agda2-go t input-from-goal t cmd-             (format "%d" g)-             (if input-from-goal (agda2-goal-Range o) (agda2-mkRange nil))-             (agda2-string-quote txt) args))))--;; Note that the following function is a security risk, since it-;; evaluates code without first inspecting it. The code (supposedly)-;; comes from the Agda backend, but there could be bugs in the backend-;; which can be exploited by an attacker which manages to trick-;; someone into type-checking compromised Agda code.--(defun agda2-exec-response (response)-  "Interprets response."-  (let ((inhibit-read-only t))-    (eval response)))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; User commands and response processing--(defun agda2-load ()-  "Load current buffer."-  (interactive)-  (agda2-go t t t "Cmd_load"-            (agda2-string-quote (buffer-file-name))-            (agda2-list-quote agda2-program-args)-            ))--(defun agda2-measure-load-time-  (&optional highlighting-level continuation)-  "Load the current buffer and print how much time it takes.-\(Wall-clock time.)--The given HIGHLIGHTING-LEVEL is used (if non-nil).--If CONTINUATION is non-nil, then CONTINUATION is applied to the-resulting time (represented as a string)."-  (interactive)-  (agda2-abort-if-in-progress)-  (let* ((agda2-highlight-level-          (or highlighting-level agda2-highlight-level)))-    (setq agda2-measure-data (cons continuation (current-time)))-    (agda2-load)))--(defun agda2-compile ()-  "Compile the current module.--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 'ask)-                        (completing-read "Backend: " agda2-backends-                                         nil t nil nil nil-                                         'inherit-input-method))-                       (t agda2-backend))))-    (unless (member backend agda2-backends)-      (if (equal backend "")-          (error "No backend chosen")-        (error "Invalid backend: %s" backend)))-    (agda2-go t t t "Cmd_compile"-              backend-              (agda2-string-quote (buffer-file-name))-              (agda2-list-quote agda2-program-args)-              )))--(defun agda2-give()-  "Give to the goal at point the expression in it" (interactive)-  (agda2-goal-cmd "Cmd_give" "expression to give"))--(defun agda2-give-action (old-g paren)-  "Update the goal OLD-G with the expression in it."-  (let-     ;; Don't run modification hooks: we don't want this to-      ;; trigger agda2-abort-highlighting.-      ((inhibit-modification-hooks t))-  (agda2-update old-g paren)))--(defun agda2-refine (pmlambda)-  "Refine the goal at point.-If the goal contains an expression e, and some \"suffix\" of the-type of e unifies with the goal type, then the goal is replaced-by e applied to a suitable number of new goals.--PMLAMBDA is only used if the goal has a functional type.-When the prefix argument is given a pattern maching lambda will-be inserted, otherwise a standard lambda will be used.--If the goal is empty, the goal type is a data type, and there is-exactly one constructor which unifies with this type, then the-goal is replaced by the constructor applied to a suitable number-of new goals."-  (interactive "P")-  (if pmlambda-      (agda2-goal-cmd "Cmd_refine_or_intro True" 'goal)-    (agda2-goal-cmd "Cmd_refine_or_intro False" 'goal)))--(defun agda2-auto ()- "Simple proof search" (interactive)- (agda2-goal-cmd "Cmd_auto" 'goal))--(defun agda2-make-case ()-  "Refine the pattern variables given in the goal.-Assumes that <clause> = {!<variables>!} is on one line."-  (interactive)-  (agda2-goal-cmd "Cmd_make_case" "pattern variables to case (empty for split on result)"))--(defun agda2-make-case-action (newcls)-  "Replace the line at point with new clauses NEWCLS and reload."-  (agda2-forget-all-goals);; we reload later anyway.-  (let* ((p0 (point))-         ;; (p1 (goto-char (agda2-decl-beginning)))-         (p1 (goto-char (+ (current-indentation) (line-beginning-position))))-         (indent (current-column))-         cl)-    (goto-char p0)-    (re-search-forward "!}" (line-end-position) 'noerr)-    (delete-region p1 (point))-    (while (setq cl (pop newcls))-      (insert cl)-      (if newcls (insert "\n" (make-string indent ?  ))))-    (goto-char p1))-  (agda2-load))--(defun agda2-make-case-action-extendlam (newcls)-  "Replace definition of extended lambda with new clauses NEWCLS and reload."-  (agda2-forget-all-goals);; we reload later anyway.-  (let* ((p0 (point))-         (pmax (re-search-forward "!}"))-         (bracketCount 0)-         (p1 (goto-char (+ (current-indentation) (line-beginning-position))))-         (indent (current-column))-         cl)-    (goto-char p0)-    (re-search-backward "{!")-    (while (and (not (equal (preceding-char) ?\;)) (>= bracketCount 0) (> (point) p1))-      (backward-char)-      (if (equal (preceding-char) ?}) (incf bracketCount))-      (if (equal (preceding-char) ?{) (decf bracketCount)))-    (let* ((is-lambda-where (= (point) p1))-           (p (point)))-      (delete-region (point) pmax)-      (if (not is-lambda-where) (insert " "))-      (while (setq cl (pop newcls))-        (insert cl)-        (if newcls (if is-lambda-where (insert "\n" (make-string indent ? )) (insert " ; "))))-      (goto-char p)))-  (agda2-load))--(defun agda2-status-action (status)-  "Display the string STATUS in the current buffer's mode line.-\(precondition: the current buffer has to use the Agda mode as the-major mode)."-  (setq agda2-buffer-external-status status))--(defun agda2-warning-buffer nil-  "Creates the Agda warning buffer, if it does not already exist.-The buffer is returned."-  (unless (buffer-live-p agda2-warning-buffer)-    (setq agda2-warning-buffer-          (generate-new-buffer "*Agda warnings*"))--    (with-current-buffer agda2-warning-buffer-      (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))))-      ;; No support for recompilation. The key binding is removed, and-      ;; attempts to run `recompile' will (hopefully) result in an-      ;; error.-      (let ((map (copy-keymap (current-local-map))))-        (define-key map (kbd "g") 'undefined)-        (use-local-map map))-      (set (make-local-variable 'compile-command)-           'agda2-does-not-support-compilation-via-the-compilation-mode)--      (set-syntax-table agda2-mode-syntax-table)-      (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))-      (set-input-method "Agda")))--  agda2-warning-buffer)--(defun agda2-font-syntactic-face (state)-  (cond ((nth 4 state)-         ( save-excursion-           (goto-char (nth 8 state))-           (cond ((looking-at "--[[:space:]\n]") 'font-lock-comment-face)-                 ((looking-at "{-[^#]") 'font-lock-comment-face)-          )))))--(defun agda2-info-buffer nil-  "Creates the Agda info buffer, if it does not already exist.-The buffer is returned."-  (unless (buffer-live-p agda2-info-buffer)-    (setq agda2-info-buffer-          (generate-new-buffer "*Agda information*"))--    (with-current-buffer agda2-info-buffer-      (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))))-      ;; No support for recompilation. The key binding is removed, and-      ;; attempts to run `recompile' will (hopefully) result in an-      ;; error.-      (let ((map (copy-keymap (current-local-map))))-        (define-key map (kbd "g") 'undefined)-        (use-local-map map))-      (set (make-local-variable 'compile-command)-           'agda2-does-not-support-compilation-via-the-compilation-mode)--      (set-syntax-table agda2-mode-syntax-table)-      (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))-      (set-input-method "Agda")))--  agda2-info-buffer)--(defun agda2-info-action (name text &optional append)-  "Insert TEXT into the Agda info buffer and display it.-NAME is displayed in the buffer's mode line.--If APPEND is non-nil, then TEXT is appended at the end of the-buffer, and point placed after this text.--If APPEND is nil, then any previous text is removed before TEXT-is inserted, and point is placed before this text."-  (interactive)-  (let ((buf (agda2-info-buffer)))-    (with-current-buffer buf-      ;; In some cases the jump-to-position-mentioned-in-text-      ;; functionality (see compilation-error-regexp-alist above)-      ;; didn't work: Emacs jumped to the wrong position. However, it-      ;; seems to work if compilation-forget-errors is used. This-      ;; problem may be related to Emacs bug #9679-      ;; (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9679). The idea-      ;; to use compilation-forget-errors comes from a comment due to-      ;; Oleksandr Manzyuk-      ;; (https://github.com/haskell/haskell-mode/issues/67).-      (compilation-forget-errors)-      (unless append (erase-buffer))-      (save-excursion-        (goto-char (point-max))-        (insert text))-      (put-text-property 0 (length name) 'face '(:weight bold) name)-      (setq mode-line-buffer-identification name)-      (force-mode-line-update))-    ;; If the current window displays the information buffer, then the-    ;; window configuration is left untouched.-    (unless (equal (window-buffer) buf)-      (let ((agda-window-              (and agda2-file-buffer-                   (car-safe-                     ;; All windows, including minibuffers, on any-                     ;; frame on the current terminal, displaying the-                     ;; present Agda file buffer.-                     (get-buffer-window-list agda2-file-buffer t 0)))))-        (save-selected-window-          ;; Select a window displaying the Agda file buffer (if such-          ;; a window exists). With certain configurations of-          ;; display-buffer this should increase the likelihood that-          ;; the info buffer will be displayed on the same frame.-          (when agda-window-            (select-window agda-window 'no-record))-          (let* (;; If there is only one window, then the info window-                 ;; should be created above or below the code window,-                 ;; not to the left or right.-                 (split-width-threshold nil)-                 (window-                   (display-buffer-                     buf-                     ;; Under Emacs 23 the effect of the following-                     ;; argument is only that the current window-                     ;; should not be used.-                     '(nil-                       .-                       (;; Do not use the same window.-                        (inhibit-same-window . t)-                        ;; Do not raise or select another frame.-                        (inhibit-switch-frame . t))))))-            (if window-                (fit-window-to-buffer window-                  (truncate-                    (* (frame-height)-                       agda2-information-window-max-height))))))))-    ;; Move point in every window displaying the information buffer.-    ;; Exception: If we are appending, don't move point in selected-    ;; windows.-    (dolist (window (get-buffer-window-list buf 'no-minibuffer t))-      (unless (and append-                   (equal window (selected-window)))-        (with-selected-window window-          (if append-              (goto-char (point-max))-            (goto-char (point-min))))))))--(defun agda2-close-warning nil-  (interactive)-  (when (buffer-live-p agda2-warning-buffer)-        (delete-windows-on agda2-warning-buffer))-)--(defun agda2-warning-action (name text &optional append)-  "Insert TEXT into the Agda warning buffer and display it.-NAME is displayed in the buffer's mode line.--If APPEND is non-nil, then TEXT is appended at the end of the-buffer, and point placed after this text.--If APPEND is nil, then any previous text is removed before TEXT-is inserted, and point is placed before this text."-  (interactive)-  (let ((buf (agda2-warning-buffer)))-    (with-current-buffer buf-      ;; In some cases the jump-to-position-mentioned-in-text-      ;; functionality (see compilation-error-regexp-alist above)-      ;; didn't work: Emacs jumped to the wrong position. However, it-      ;; seems to work if compilation-forget-errors is used. This-      ;; problem may be related to Emacs bug #9679-      ;; (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9679). The idea-      ;; to use compilation-forget-errors comes from a comment due to-      ;; Oleksandr Manzyuk-      ;; (https://github.com/haskell/haskell-mode/issues/67).-      (compilation-forget-errors)-      (unless append (erase-buffer))-      (save-excursion-        (goto-char (point-max))-        (insert text))-      (put-text-property 0 (length name) 'face '(:weight bold) name)-      (setq mode-line-buffer-identification name)-      (force-mode-line-update))-    ;; If the current window displays the information buffer, then the-    ;; window configuration is left untouched.-    (unless (equal (window-buffer) buf)-      (let ((agda-info-              (and agda2-info-buffer-                   (car-safe-                     ;; All windows, including minibuffers, on any-                     ;; frame on the current terminal, displaying the-                     ;; present Agda file buffer.-                    (get-buffer-window-list agda2-info-buffer t 0)))))-        (save-selected-window-          ;; Select a window displaying the Agda file buffer (if such-          ;; a window exists). With certain configurations of-          ;; display-buffer this should increase the likelihood that-          ;; the info buffer will be displayed on the same frame.-          (when agda-info-            (select-window agda-info 'no-record))-          (let* (;; The warnings window should be displayed below the-                 ;; Agda info one-                 (split-width-threshold nil)-                 (split-height-threshold 1)-                 (window-                   (display-buffer-                     buf-                     ;; Under Emacs 23 the effect of the following-                     ;; argument is only that the current window-                     ;; should not be used.-                     '((display-buffer-below-selected)-                       .-                       (;; Do not use the same window-                        (inhibit-same-window . t)-                        ;; Do not raise or select another frame.-                        (inhibit-switch-frame . t))))))-            (if window-                (fit-window-to-buffer window-                  (truncate-                    (* (frame-height)-                       agda2-warning-window-max-height))))))))-    ;; Move point in every window displaying the information buffer.-    ;; Exception: If we are appending, don't move point in selected-    ;; windows.-    (dolist (window (get-buffer-window-list buf 'no-minibuffer t))-      (unless (and append-                   (equal window (selected-window)))-        (with-selected-window window-          (if append-              (goto-char (point-max))-            (goto-char (point-min))))))))--(defun agda2-info-action-and-copy (name text &optional append)-  "Same as agda2-info-action but also puts TEXT in the kill ring."-  (kill-new text)-  (agda2-info-action name text append))--(defun agda2-show-goals()-  "Show all goals." (interactive)-  (agda2-go t t t "Cmd_metas"))--(defun agda2-show-constraints()-  "Show constraints." (interactive)-  (agda2-go t t t "Cmd_constraints"))--(defun agda2-remove-annotations ()-  "Removes buffer annotations (overlays and text properties)."-  (interactive)-  (dolist (o (overlays-in (point-min) (point-max)))-    (delete-overlay o))-  (let ((inhibit-read-only t))-    (annotation-preserve-mod-p-and-undo-     (set-text-properties (point-min) (point-max) '()))-    (force-mode-line-update)))--(defun agda2-next-goal ()     "Go to the next goal, if any."     (interactive)-  (agda2-mv-goal 'next-single-property-change     'agda2-delim2 1 (point-min)))-(defun agda2-previous-goal () "Go to the previous goal, if any." (interactive)-  (agda2-mv-goal 'previous-single-property-change 'agda2-delim3 0 (point-max)))-(defun agda2-mv-goal (change delim adjust wrapped)-  (agda2-let ()-      ((go (p) (while (and (setq p (funcall change p 'category))-                           (not (eq (get-text-property p 'category) delim))))-           (if p (goto-char (+ adjust p)))))-    (or (go (point)) (go wrapped) (message "No goals in the buffer"))))--(defun agda2-quit ()-  "Quit and clean up after agda2."-  (interactive)-  (remove-hook 'first-change-hook 'agda2-abort-highlighting 'local)-  (agda2-remove-annotations)-  (agda2-term))--(defun agda2-term ()-  "Send a SIGTERM signal to the Agda2 process, then kill its buffer."-  (interactive)-  (when (buffer-live-p agda2-process-buffer)-    (with-current-buffer agda2-process-buffer-      (condition-case nil-          (signal-process agda2-process 'SIGTERM)-        (error nil))-      (kill-buffer))))--(defmacro agda2-maybe-normalised (name comment cmd want)-  "This macro constructs a function NAME which runs CMD.-COMMENT is used to build the function's comment. The function-NAME takes a prefix argument which tells whether it should-normalise types or not when running CMD (through-`agda2-goal-cmd'; WANT is used as `agda2-goal-cmd's WANT-argument)."-  (let ((eval (make-symbol "eval")))-  `(defun ,name (&optional prefix)-     ,(concat comment ".--The form of the result depends on the prefix argument:--* If the prefix argument is `nil' (i.e., if no prefix argument is-  given), then the result is simplified.--* If the prefix argument is `(4)' (for instance if C-u is typed-  exactly once right before the command is invoked), then the-  result is neither explicitly normalised nor simplified.--* If any other prefix argument is used (for instance if C-u is-  typed twice right before the command is invoked), then the-  result is normalised.")-     (interactive "P")-     (let ((,eval (cond ((equal prefix nil) "Simplified")-                        ((equal prefix '(4)) "Instantiated")-                        ("Normalised"))))-       (agda2-goal-cmd (concat ,cmd " " ,eval)-                       ,want)))))--(defmacro agda2-maybe-normalised-toplevel (name comment cmd prompt)-  "This macro constructs a function NAME which runs CMD.-COMMENT is used to build the function's comments. The function-NAME takes a prefix argument which tells whether it should-normalise types or not when running CMD (through-`agda2-go' t nil t; the string PROMPT is used as the goal command-prompt)."-  (let ((eval (make-symbol "eval")))-    `(defun ,name (prefix expr)-       ,(concat comment ".--The form of the result depends on the prefix argument:--* If the prefix argument is `nil' (i.e., if no prefix argument is-  given), then the result is simplified.--* If the prefix argument is `(4)' (for instance if C-u is typed-  exactly once right before the command is invoked), then the-  result is neither explicitly normalised nor simplified.--* If any other prefix argument is used (for instance if C-u is-  typed twice right before the command is invoked), then the-  result is normalised.")-       (interactive ,(concat "P\nM" prompt ": "))-       (let ((,eval (cond ((equal prefix nil) "Simplified")-                          ((equal prefix '(4)) "Instantiated")-                          ("Normalised"))))-         (agda2-go t nil t-                   (concat ,cmd " " ,eval " "-                           (agda2-string-quote expr)))))))--(defmacro agda2-maybe-normalised-global (name comment cmd)-  "This macro constructs a function NAME which runs CMD.-COMMENT is used to build the function's comments. The function-NAME takes a prefix argument which tells whether it should-normalise types or not when running CMD (through-`agda2-go' t nil t;)."-  (let ((eval (make-symbol "eval")))-    `(defun ,name (prefix)-       ,(concat comment ".--The form of the result depends on the prefix argument:--* If the prefix argument is `nil' (i.e., if no prefix argument is-  given), then the result is simplified.--* If the prefix argument is `(4)' (for instance if C-u is typed-  exactly once right before the command is invoked), then the-  result is neither explicitly normalised nor simplified.--* If any other prefix argument is used (for instance if C-u is-  typed twice right before the command is invoked), then the-  result is normalised.")-       (interactive "P")-       (let ((,eval (cond ((equal prefix nil) "AsIs")-                          ((equal prefix '(4)) "Simplified")-                          ("Normalised"))))-         (agda2-go t nil t-                   (concat ,cmd " " ,eval " "-                           ))))))--(agda2-maybe-normalised- agda2-goal-type- "Show the type of the goal at point"- "Cmd_goal_type"- nil)--(agda2-maybe-normalised- agda2-infer-type- "Infer the type of the goal at point"- "Cmd_infer"- "expression to type")--(agda2-maybe-normalised-toplevel-   agda2-infer-type-toplevel-   "Infers the type of the given expression. The scope used for-the expression is that of the last point inside the current-top-level module"-   "Cmd_infer_toplevel"-   "Expression")--(defun agda2-infer-type-maybe-toplevel ()-  "Infers the type of the given expression.-Either uses the scope of the current goal or, if point is not in a goal, the-top-level scope."-  (interactive)-  (call-interactively (if (agda2-goal-at (point))-                          'agda2-infer-type-                        'agda2-infer-type-toplevel)))--(defun agda2-why-in-scope ()-  "Explain why something is in scope in a goal."-  (interactive)-  (agda2-goal-cmd "Cmd_why_in_scope" "Name"))--(defun agda2-why-in-scope-toplevel (name)-  "Explain why something is in scope at the top level."-  (interactive "MName: ")-  (agda2-go t nil t-            "Cmd_why_in_scope_toplevel"-            (agda2-string-quote name)))--(defun agda2-why-in-scope-maybe-toplevel ()-  "Explains why a given name is in scope."-  (interactive)-  (call-interactively (if (agda2-goal-at (point))-                          'agda2-why-in-scope-                          'agda2-why-in-scope-toplevel)))--(agda2-maybe-normalised- agda2-goal-and-context- "Shows the type of the goal at point and the currect context"- "Cmd_goal_type_context"- nil)--(agda2-maybe-normalised- agda2-goal-and-context-and-inferred- "Shows the context, the goal and the given expression's inferred type"- "Cmd_goal_type_context_infer"- "expression to type")--(agda2-maybe-normalised- agda2-show-context- "Show the context of the goal at point"- "Cmd_context"- nil)--(agda2-maybe-normalised- agda2-helper-function-type-  "Compute the type of a hypothetical helper function."-  "Cmd_helper_function"-  "Expression")--(agda2-maybe-normalised-  agda2-module-contents-  "Shows all the top-level names in the given module.-Along with their types."-  "Cmd_show_module_contents"-  "Module name")--(agda2-maybe-normalised-toplevel-  agda2-module-contents-toplevel-  "Shows all the top-level names in the given module.-Along with their types."-  "Cmd_show_module_contents_toplevel"-  "Module name"-)--(agda2-maybe-normalised-toplevel-  agda2-search-about-toplevel-  "Search About an identifier"-  "Cmd_search_about_toplevel"-  "Name"-)--(defun agda2-module-contents-maybe-toplevel ()-  "Shows all the top-level names in the given module.-Along with their types.--Uses either the scope of the current goal or, if point is not in-a goal, the top-level scope."-  (interactive)-  (call-interactively (if (agda2-goal-at (point))-                          'agda2-module-contents-                        'agda2-module-contents-toplevel)))--(defun agda2-solve-maybe-all ()-  "Solves goals that are already instantiated internally.-Either only one if point is a goal, or all of them."-  (interactive)-  (call-interactively (if (agda2-goal-at (point))-                          'agda2-solveOne-                          'agda2-solveAll))-)--(agda2-maybe-normalised-global-  agda2-solveAll-  "Solves all goals that are already instantiated internally."-  "Cmd_solveAll"-)--(agda2-maybe-normalised-  agda2-solveOne-  "Solves the goal at point if it is already instantiated internally"-  "Cmd_solveOne"-  nil-)--(defun agda2-solveAll-action (iss)-  (while iss-    (let* ((g (pop iss)) (txt (pop iss))-           (cmd (cons 'agda2-solve-action (cons g (cons txt nil)))))-      (if (null agda2-last-responses)-          (push (cons 1 cmd) agda2-last-responses)-        (nconc agda2-last-responses (cons (cons 3 cmd) nil))))))--(defun agda2-solve-action (g txt)-  (save-excursion-    (agda2-replace-goal g txt)-    (agda2-goto-goal g)-    (agda2-give)))--(defun agda2-compute-normalised (&optional arg)-  "Compute the normal form of the expression in the goal at point.--With a prefix argument distinct from `(4)' the normal form of-\"show <expression>\" is computed, and then the resulting string-is printed.--With any prefix argument \"abstract\" is ignored during the-computation."-  (interactive "P")-  (let ((cmd (concat "Cmd_compute"-                      (cond ((equal arg nil) " DefaultCompute")-                            ((equal arg '(4)) " IgnoreAbstract")-                            (" UseShowInstance")))))-    (agda2-goal-cmd cmd "expression to normalise")))--(defun agda2-compute-normalised-toplevel (expr &optional arg)-  "Compute the normal form of the given expression.-The scope used for the expression is that of the last point-inside the current top-level module.--With a prefix argument distinct from `(4)' the normal form of-\"show <expression>\" is computed, and then the resulting string-is printed.--With any prefix argument \"abstract\" is ignored during the-computation."-  (interactive "MExpression: \nP")-  (let ((cmd (concat "Cmd_compute_toplevel"-                     (cond ((equal arg nil) " DefaultCompute")-                            ((equal arg '(4)) " IgnoreAbstract")-                            (" UseShowInstance")) " ")))-    (agda2-go t nil t (concat cmd (agda2-string-quote expr)))))--(defun agda2-compute-normalised-maybe-toplevel ()-  "Compute the normal form of the given expression.-The scope used for the expression is that of the last point-inside the current top-level module.--With a prefix argument distinct from `(4)' the normal form of-\"show <expression>\" is computed, and then the resulting string-is printed.--With any prefix argument \"abstract\" is ignored during the-computation."-  (interactive)-  (if (agda2-goal-at (point))-      (call-interactively 'agda2-compute-normalised)-    (call-interactively 'agda2-compute-normalised-toplevel)))--(defun agda2-display-program-version ()-  "Display version of Agda"-  (interactive)-  (agda2-go nil nil t "Cmd_show_version"))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;;--(defun agda2-highlight-reload nil-  "Loads precomputed syntax highlighting info for the current buffer.-If there is any to load."-  (agda2-go nil t t-            "Cmd_load_highlighting_info"-            (agda2-string-quote (buffer-file-name))))--(defun agda2-literate-p ()-  "Is the current buffer a literate Agda buffer?"-  (equal (file-name-extension (buffer-name)) "lagda"))--(defmacro agda2--case (exp &rest branches) ;FIXME: Use `pcase' instead!-  (declare (debug t) (indent 1))-  (let ((s (make-symbol "v")))-    `(let ((,s ,exp))-       (cond-         ,@(mapcar (lambda (branch)-                     `((equal ,s ,(car branch)) ,@(cdr branch)))-                   branches)))))--(defun agda2-goals-action (goals)-  "Annotates the goals in the current buffer with text properties.-GOALS is a list of the buffer's goal numbers, in the order in-which they appear in the buffer. Note that this function should-be run /after/ syntax highlighting information has been loaded,-because the two highlighting mechanisms interact in unfortunate-ways."-  (agda2-forget-all-goals)-  (agda2-let-      ((literate (agda2-literate-p))-       stk-       top-       ;; 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}" 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. "--")-       (is-proper (s comment-starter)-          (save-excursion-            (save-match-data-              (backward-char (length s))-              (unless (bolp) (backward-char 1))  ;; bolp = pointer at beginning of line-              ;; Andreas, 2014-05-17 Issue 1132-              ;; A questionmark can also follow immediately after a .-              ;; for instance to be a place holder for a dot pattern.-              (looking-at (concat "\\([.{}();]\\|^\\|\\s \\)"  ;; \\s = whitespace-                                  (regexp-quote s)-                                  (unless comment-starter-                                    "\\([{}();]\\|$\\|\\s \\)"))))))-       (make(p)  (agda2-make-goal p (point) (pop goals)))-       (inside-comment() (and stk (null     (car stk))))-       (inside-goal()    (and stk (integerp (car stk))))-       (outside-code()   (and stk (eq (car stk) 'outside)))-       (inside-code()    (not (outside-code)))-       ;; inside a multi-line comment ignore everything but the multi-line comment markers-       (safe-delims()-          (if (inside-comment)-               (re-search-forward "{-\\|-}" nil t)-            (delims))))-    (save-excursion-      ;; In literate mode we should start out in the "outside of code"-      ;; state.-      (if literate (push 'outside stk))-      (goto-char (point-min))-      (while (and goals (safe-delims))-        (agda2--case (match-string 0)-          ("\\begin{code}" (when (outside-code)               (pop stk)))-          ("\\end{code}"   (when (not stk)                    (push 'outside stk)))-          ("--"            (when (and (not stk)-                                      (is-proper "--" t))     (end-of-line)))-          ("{-"            (when (and (inside-code)-                                      (not (inside-goal)))    (push nil           stk)))-          ("-}"            (when (inside-comment)             (pop stk)))-          ("{!"            (when (and (inside-code)-                                      (not (inside-comment))) (push (- (point) 2) stk)))-          ("!}"            (when (inside-goal)-                             (setq top (pop stk))-                             (unless stk (make top))))-          ("?"             (progn-                             (when (and (not stk) (is-proper "?" nil))-                               (delete-char -1)-                               (insert "{!!}")-                               (make (- (point) 4))))))))))--(defun agda2-make-goal (p q n)-  "Make a goal with number N at <P>{!...!}<Q>.  Assume the region is clean."-  (annotation-preserve-mod-p-and-undo-   (let ((atp (lambda (x ps) (add-text-properties x (1+ x) ps))))-     (funcall atp p       '(category agda2-delim1))-     (funcall atp (1+ p)  '(category agda2-delim2))-     (funcall atp (- q 2) '(category agda2-delim3))-     (funcall atp (1- q)  '(category agda2-delim4)))-   (let ((o (make-overlay p q nil t nil)))-     (overlay-put o 'modification-hooks '(agda2-protect-goal-markers))-     (overlay-put o 'agda2-gn           n)-     (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)-  "Ensures that the goal markers cannot be tampered with.-Except if `inhibit-read-only' is non-nil or /all/ of the goal is-modified."-  (if action-      ;; This is the after-change hook.-      nil-    ;; This is the before-change hook.-    (cond-     ((and (<= beg (overlay-start ol)) (>= end (overlay-end ol)))-      ;; The user is trying to remove the whole goal:-      ;; manually evaporate the overlay and add an undo-log entry so-      ;; it gets re-added if needed.-      (when (listp buffer-undo-list)-        (push (list 'apply 0 (overlay-start ol) (overlay-end ol)-                    'move-overlay ol (overlay-start ol) (overlay-end ol))-              buffer-undo-list))-      (delete-overlay ol))-     ((or (< beg (+ (overlay-start ol) 2))-          (> end (- (overlay-end ol) 2)))-      (unless inhibit-read-only-        (signal 'text-read-only nil))))))--(defun agda2-update (old-g new-txt)-  "Update the goal OLD-G.-If NEW-TXT is a string, then the goal is replaced by the string,-and otherwise the text inside the goal is retained (parenthesised-if NEW-TXT is `'paren').--Removes the goal braces, but does not remove the goal overlay or-text properties."-  (multiple-value-bind (p q) (agda2-range-of-goal old-g)-    (save-excursion-      (cond ((stringp new-txt)-             (agda2-replace-goal old-g new-txt))-            ((equal new-txt 'paren)-             (goto-char (- q 2)) (insert ")")-             (goto-char (+ p 2)) (insert "(")))-      (multiple-value-bind (p q) (agda2-range-of-goal old-g)-        (delete-region (- q 2) q)-        (delete-region p (+ p 2)))-        ;; Update highlighting-        (if (and (not (equal new-txt 'paren)) (not (equal new-txt 'no-paren)))-            (apply 'agda2-go t t nil "Cmd_highlight"-              (format "%d" old-g)-              (agda2-mkRange `(,p ,(- q 2)))-              (agda2-string-quote new-txt) nil))-    )))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;; Misc--(defun agda2-process-status ()-  "Status of `agda2-process-buffer', or \"no process\"."-  (condition-case nil-      (process-status agda2-process)-    (error "no process")))--(defun agda2-intersperse (sep xs)-  (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."-  (agda2-mkRange `(,(+ (overlay-start o) 2)-                   ,(- (overlay-end   o) 2))))--(defun agda2-mkRange (points)-  "A string representing a range corresponding to POINTS.-POINTS must be a list of integers, and its length must be 0 or 2."-  (if points-      (format "(intervalsToRange (Just (mkAbsolute %s)) %s)"-              (agda2-string-quote (file-truename (buffer-file-name)))-              (format "[Interval %s %s]"-                      (agda2-mkPos (car points))-                      (agda2-mkPos (cadr points))))-    "noRange"))--(defun agda2-mkPos (&optional p)-  "The Haskell PositionWithoutFile corresponding to P or `point'."-  (save-excursion-    (save-restriction-      (widen)-      (if p (goto-char p))-      (format "(Pn () %d %d %d)"-              (point)-              (count-lines (point-min) (point))-              (1+ (current-column))))))--(defun agda2-char-quote (c)-  "Convert character C to the notation used in Haskell strings.-The non-ASCII characters are actually rendered as-\"\\xNNNN\\&\", i.e. followed by a \"null character\", to avoid-problems if they are followed by digits.  ASCII characters (code-points < 128) are converted to singleton strings."-  (if (< c 128)-      (list c)-    ;; FIXME: Why return a list rather than a string?  --Stef-    (append (format "\\x%x\\&" (encode-char c 'ucs)) nil)))--(defun agda2-string-quote (s)-  "Format S as a Haskell string literal.-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)-        (s2 (copy-sequence s)))-    (set-text-properties 0 (length s2) nil s2)-    (mapconcat 'agda2-char-quote (pp-to-string s2) "")))--(defun agda2-list-quote (strings)-  "Convert a list of STRINGS into a string representing it in Haskell syntax."-  (concat "[" (mapconcat 'agda2-string-quote strings ", ") "]"))--(defun agda2-goal-at(pos)-  "Return (goal overlay, goal number) at POS, or nil."-  (let ((os (and pos (overlays-at pos))) o g)-    (while (and os (not(setq g (overlay-get (setq o (pop os)) 'agda2-gn)))))-    (if g (list o g))))--(defun agda2-goal-overlay (g)-  "Returns the overlay of goal number G, if any."-  (car-   (remove nil-           (mapcar (lambda (o) (if (equal (overlay-get o 'agda2-gn) g) o))-                   (overlays-in (point-min) (point-max))))))--(defun agda2-range-of-goal (g)-  "The range of goal G."-  (let ((o (agda2-goal-overlay g)))-    (if o (list (overlay-start o) (overlay-end o)))))--(defun agda2-goto-goal (g)-  (let ((p (+ 2 (car (agda2-range-of-goal g)))))-    (if p (goto-char p))))--(defun agda2-replace-goal (g newtxt)-  "Replace the content of goal G with NEWTXT." (interactive)-  (save-excursion-    (multiple-value-bind (p q) (agda2-range-of-goal g)-      (setq p (+ p 2) q (- q 2))-      (let ((indent (and (goto-char p) (current-column))))-        (delete-region p q) (insert newtxt)-        (while (re-search-backward "^" p t)-          (insert-char ?  indent) (backward-char (1+ indent)))))))--(defun agda2-forget-all-goals ()-  "Remove all goal annotations.-\(Including some text properties which might be used by other-\(minor) modes.)"-  (annotation-preserve-mod-p-and-undo-   (remove-text-properties (point-min) (point-max)-                           '(category nil agda2-delim2 nil agda2-delim3 nil-                             display nil rear-nonsticky nil)))-  (let ((p (point-min)))-    (while (< (setq p (next-single-char-property-change p 'agda2-gn))-              (point-max))-      (delete-overlay (car (agda2-goal-at p))))))--(defun agda2-decl-beginning ()-  "Find the beginning point of the declaration containing the point.-To do: dealing with semicolon separated decls."-  (interactive)-  (save-excursion-    (let* ((pEnd (point))-           (pDef (progn (goto-char (point-min))-                        (re-search-forward "\\s *" pEnd t)))-           (cDef (current-column)))-      (while (re-search-forward-              "where\\(\\s +\\)\\S \\|^\\(\\s *\\)\\S " pEnd t)-        (if (match-end 1)-            (setq pDef (goto-char (match-end 1))-                  cDef (current-column))-          (goto-char (match-end 2))-          (if (>= cDef (current-column))-              (setq pDef (point)-                    cDef (current-column))))-        (forward-char))-      (goto-char pDef)-      (if (equal (current-word) "mutual")-          (or (match-end 2) (match-end 1))-        pDef))))--(defun agda2-beginning-of-decl ()-  (interactive)-  (goto-char (agda2-decl-beginning)))--(defvar agda2-debug-buffer-name "*Agda debug*"-  "The name of the buffer used for Agda debug messages.")--(defun agda2-verbose (msg)-  "Appends the string MSG to the `agda2-debug-buffer-name' buffer.-Note that this buffer's contents is not erased automatically when-a file is loaded."-  (with-current-buffer (get-buffer-create agda2-debug-buffer-name)-    (save-excursion-      (goto-char (point-max))-      (insert msg))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Comments and paragraphs--(defun agda2-comments-and-paragraphs-setup nil-  "Set up comment and paragraph handling for Agda mode."--  ;; Syntax table setup for comments is done elsewhere.--  ;; Enable highlighting of comments via Font Lock mode (which uses-  ;; the syntax table).-  (set (make-local-variable 'font-lock-defaults)-       '(nil nil nil nil nil (font-lock-syntactic-face-function . agda2-font-syntactic-face)))-  ;; If the following s-expression is removed, then highlighting of-  ;; comments stops working.-  (when font-lock-mode-    (font-lock-mode t))--  ;; Empty lines (all white space according to Emacs) delimit-  ;; paragraphs.-  (set (make-local-variable 'paragraph-start) "\\s-*$")-  (set (make-local-variable 'paragraph-separate) paragraph-start)--  ;; Support for adding/removing comments.-  (set (make-local-variable 'comment-start) "-- ")--  ;; Support for proper filling of text in comments (requires that-  ;; Filladapt is activated).-  (when (featurep 'filladapt)-    (add-to-list (make-local-variable-                  'filladapt-token-table)-                 '("--" agda2-comment))-    (add-to-list (make-local-variable 'filladapt-token-match-table)-                 '(agda2-comment agda2-comment) t)-    (add-to-list (make-local-variable 'filladapt-token-conversion-table)-                 '(agda2-comment . exact))))--(defun agda2-comment-dwim-rest-of-buffer ()-  "Comment or uncomment the rest of the buffer.-From the beginning of the current line to the end of the buffer."-  (interactive)-  (save-excursion-    (forward-line 0)-    (push-mark (point) 'no-message 'activate-mark)-    (unwind-protect-        (progn-          (goto-char (point-max))-          (comment-dwim nil))-      (pop-mark))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Go to definition site--(defun agda2-goto-definition-keyboard (&optional other-window)-  "Go to the definition site of the name under point (if any).-If this function is invoked with a prefix argument then another window is used-to display the given position."-  (interactive "P")-  (annotation-goto-indirect (point) other-window))--(defun agda2-goto-definition-mouse (ev)-  "Go to the definition site of the name clicked on, if any.-Otherwise, yank (see `mouse-yank-primary')."-  (interactive "e")-  (unless (annotation-goto-indirect ev)-    ;; FIXME: Shouldn't we use something like-    ;; (call-interactively (key-binding ev))?  --Stef-    (mouse-yank-primary ev)))--(defun agda2-go-back nil-  "Go back to the previous position in which-`agda2-goto-definition-keyboard' or `agda2-goto-definition-mouse' was-invoked."-  (interactive)-  (annotation-go-back))--(defun agda2-maybe-goto (filepos)-  "Might move point to the given error.-FILEPOS should have the form (FILE . POSITION).--If `agda2-highlight-in-progress' is nil, then nothing happens.-Otherwise, if the current buffer is the one that is connected to-the Agda process, then point is moved to POSITION in-FILE (assuming that the FILE is readable). Otherwise point is-moved to the given position in the buffer visiting the file, if-any, and in every window displaying the buffer, but the window-configuration and the selected window are not changed."-  (when (and agda2-highlight-in-progress-             (consp filepos)-             (stringp (car filepos))-             (integerp (cdr filepos)))-    (if agda2-in-agda2-file-buffer-        (annotation-goto-and-push (current-buffer) (point) filepos)-      (save-excursion-        (let ((buffer (find-buffer-visiting (car filepos))))-          (when buffer-            (let ((windows (get-buffer-window-list buffer-                                                   'no-minibuffer t)))-              (if windows-                  (dolist (window windows)-                    (with-selected-window window-                      (annotation-goto-position (cdr filepos))))-                (with-current-buffer buffer-                  (annotation-goto-position (cdr filepos)))))))))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Implicit arguments--(defun agda2-display-implicit-arguments (&optional arg)-  "Toggle display of implicit arguments.-With prefix argument, turn on display of implicit arguments if-the argument is a positive number, otherwise turn it off."-  (interactive "P")-  (cond ((eq arg nil)       (agda2-go t t t "ToggleImplicitArgs"))-        ((and (numberp arg)-              (> arg 0))    (agda2-go t t t "ShowImplicitArgs" "True"))-        (t                  (agda2-go t t t "ShowImplicitArgs" "False"))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;;;;--(defun agda2-popup-menu-3 (ev)-  "If in a goal, popup the goal menu and call chosen command."-  (interactive "e")-  (let (choice)-    (save-excursion-      (and (agda2-goal-at (goto-char (posn-point (event-end ev))))-           (setq choice (x-popup-menu ev agda2-goal-map))-           (call-interactively-            (lookup-key agda2-goal-map (apply 'vector choice)))))))--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;-;; Switching to a different version of Agda--(defun get-agda-program-versions ()-  "Get \"version strings\" of executables starting with-'agda-mode' in current path."-  (delete-dups-   (mapcar (lambda (path)-             ;; strip 'agda-mode' prefix-             (replace-regexp-in-string "^agda-mode-?" ""-                                       (file-name-nondirectory path)))-           (remove-if-not 'file-executable-p-             ;; concatenate result-             (reduce 'append-                     ;; for each directory in exec-path, get list of-                     ;; files whose name starts with 'agda-mode'-                     (mapcar (lambda (path)-                               (when (file-accessible-directory-p path)-                                 (directory-files path 't "^agda-mode")))-                             exec-path))))))--;; Note that other versions of Agda may use different protocols, so-;; this function unloads the Emacs mode.--(defun agda2-set-program-version (version)-  "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.)"-  (interactive-   (list (completing-read "Version: " (get-agda-program-versions))))--  (let*-      ((agda-buffers-        (mapcan (lambda (buf)-                  (with-current-buffer buf-                    (when (equal major-mode 'agda2-mode)-                      (list buf))))-                (buffer-list)))--       (version-suffix (if (or (equal version "")-                               (equal version nil))-                           ""-                         (concat "-" version)))--       ;; 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))-       (agda-mode-path-        (condition-case nil-            (with-temp-buffer-              (unless-                  (equal 0 (call-process agda-mode-prog-                                         nil (current-buffer) nil-                                         "locate"))-                (error "%s" (concat "Error when running "-                                    agda-mode-prog)))-              (buffer-string))-          (file-error-           (error "%s" (concat "Could not find " agda-mode-prog))))))--    ;; Make sure that agda-mode<version-suffix> returns a valid file.-    (unless (file-readable-p agda-mode-path)-      (error "%s" (concat "Could not read " agda-mode-path)))--    ;; Kill some processes/buffers related to Agda.-    (when (and agda2-process-               (process-status agda2-process))-      (kill-process agda2-process))-    (when (buffer-live-p agda2-process-buffer)-      (kill-buffer agda2-process-buffer))-    (when (buffer-live-p agda2-info-buffer)-      (kill-buffer agda2-info-buffer))-    (when (and agda2-debug-buffer-name-               (get-buffer agda2-debug-buffer-name))-      (kill-buffer agda2-debug-buffer-name))--    ;; Remove the Agda mode directory from the load path.-    (setq load-path (delete agda2-directory load-path))--    ;; Unload the Agda mode and its dependencies.-    (unload-feature 'agda2-mode      'force)-    (unload-feature 'agda2           'force)-    (unload-feature 'eri             'force)-    (unload-feature 'annotation      'force)-    (unload-feature 'agda-input      'force)-    (unload-feature 'agda2-highlight 'force)-    (unload-feature 'agda2-abbrevs   'force)-    (unload-feature 'agda2-queue     'force)--    ;; Load the new version of Agda.-    (load-file agda-mode-path)-    (require 'agda2-mode)-    (setq agda2-program-name (concat "agda" version-suffix))+;; -*- lexical-binding: t -*-+;;; agda2-mode.el --- Major mode for Agda+;; SPDX-License-Identifier: MIT License++;;; Commentary:++;; A major mode for editing Agda (the dependently typed programming+;; language / interactive theorem prover).+;;+;; Major features include:+;;+;; - syntax highlighting.+;;+;; - on the fly Agda interpretation.+;;+;; - goal-driven development+;;+;; - interactive case-splitting+;;+;; - proof search+;;+;; - input support (for utf8 characters)+;;+;; see https://agda.readthedocs.io/ for more information++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; Dependency+++;;; Code:++(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 'time-date)+(require 'eri)+(require 'annotation)+(require 'fontset)+(require 'agda-input)+(require 'agda2)+(require 'agda2-highlight)+(require 'agda2-abbrevs)+(require 'agda2-queue)+(eval-and-compile+  ;; Load filladapt, if it is installed.+  (condition-case nil+      (require 'filladapt)+    (error nil))+  (unless (fboundp 'overlays-in) (load "overlay")) ; for Xemacs+  (unless (fboundp 'propertize)                    ; for Xemacs 21.4+    ;; FIXME: XEmacs-21.4 (patch 22) does have `propertize' and so does Emacs-22+    ;; (and agda2-mode doesn't work in Emacs-21, AFAICT).+    (defun propertize (string &rest properties)+      "Return a copy of STRING with text properties added.+First argument is the string to copy.+Remaining arguments form a sequence of PROPERTY VALUE pairs for text+properties to add to the result."+      (let ((str (copy-sequence string)))+        (add-text-properties 0 (length str) properties str)+        str)))+  (unless (fboundp 'prog-mode)          ;For Emacs<24.+    (defalias 'prog-mode 'fundamental-mode)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; Utilities++(defmacro agda2-let (varbind funcbind &rest body)+  "Expands to (let* VARBIND (cl-labels FUNCBIND BODY...)).+Or possibly (let* VARBIND (labels FUNCBIND BODY...))."+  (declare (debug ((&rest [&or symbolp (symbolp form)])+                   (&rest (cl-defun))+                   body))+           (indent 2))+  ;; Use cl-labels if available to avoid obsolescence warnings.+  `(let* ,varbind (,(if (fboundp 'cl-labels) 'cl-labels 'labels) ,funcbind ,@body)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; User options++(defgroup agda2 nil+  "Major mode for interactively developing Agda programs."+  :group 'languages)++(defcustom agda2-program-name "agda"+  "The name of the Agda executable."+  :type 'string+  :group 'agda2)++(defcustom agda2-program-args nil+  "Command-line arguments given to the Agda executable (one per string).++Note: Do not give several arguments in the same string.++The flag \"--interaction\" is always included as the first+argument, and does not need to be listed here."+  :type '(repeat string)+  :group 'agda2)++(defvar agda2-backends '("GHC" "GHCNoMain" "JS" "LaTeX" "QuickLaTeX" "HTML")+  "Compilation backends.")++(defcustom agda2-backend+  nil+  "The backend used to compile Agda programs (nil to ask every time)."+  :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+  "The maximum height of the information window.+A multiple of the frame height."+  :type 'number+  :group 'agda2)++(defcustom agda2-fontset-name+  (unless (or (eq window-system 'mac)+              ;; Emacs-23 uses a revamped font engine which should+              ;; make agda2-fontset-name unnecessary in most cases.+              ;; And if it turns out to be necessary, we should+              ;; probably use face-remapping-alist rather than+              ;; set-frame-font so the special font only applies to+              ;; Agda buffers, and so it applies in all frames where+              ;; Agda buffers are displayed.+              (boundp 'face-remapping-alist))+    "fontset-agda2")+  "Default font to use in the selected frame when activating the Agda mode.+This is only used if it's non-nil and Emacs is not running in a+terminal.++Note that this setting (if non-nil) affects non-Agda buffers as+well, and that you have to restart Emacs if you want settings to+this variable to take effect."+  :type '(choice (string :tag "Fontset name")+                 (const :tag "Do not change the font" nil))+  :group 'agda2)++(defcustom agda2-fontset-spec-of-fontset-agda2+    "-*-fixed-Medium-r-Normal-*-18-*-*-*-c-*-fontset-agda2,+    ascii:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO8859-1,+    latin-iso8859-2:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-2,+    latin-iso8859-3:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-3,+    latin-iso8859-4:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-4,+    cyrillic-iso8859-5:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-5,+    greek-iso8859-7:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-7,+    latin-iso8859-9:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-9,+    mule-unicode-0100-24ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,+    mule-unicode-2500-33ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,+    mule-unicode-e000-ffff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1,+    japanese-jisx0208:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0208.1990-0,+    japanese-jisx0212:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0212.1990-0,+    thai-tis620:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-TIS620.2529-1,+    lao:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-MuleLao-1,+    tibetan:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-160-MuleTibetan-0,+    tibetan-1-column:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-80-MuleTibetan-1,+    korean-ksc5601:-Daewoo-Mincho-Medium-R-Normal--16-120-100-100-C-160-KSC5601.1987-0,+    chinese-gb2312:-ISAS-Fangsong ti-Medium-R-Normal--16-160-72-72-c-160-GB2312.1980-0,+    chinese-cns11643-1:-HKU-Fixed-Medium-R-Normal--16-160-72-72-C-160-CNS11643.1992.1-0,+    chinese-big5-1:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0,+    chinese-big5-2:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0"+  "Specification of the \"fontset-agda2\" fontset.+This fontset is only created if `agda2-fontset-name' is+\"fontset-agda2\" and Emacs is not run in a terminal.++Note that the text \"fontset-agda2\" has to be part of the+string (in a certain way; see the default setting) in order for the+agda2 fontset to be created properly.++Note also that the default setting may not work unless suitable+fonts are installed on your system. Refer to the README file+accompanying the Agda distribution for more details.++Note finally that you have to restart Emacs if you want settings+to this variable to take effect."+  :group 'agda2+  :type 'string)++(if (and (equal agda2-fontset-name "fontset-agda2") window-system)+    (create-fontset-from-fontset-spec agda2-fontset-spec-of-fontset-agda2 t t))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; Global and buffer-local vars, initialization++(defvar agda2-mode-syntax-table+  (let ((tbl (make-syntax-table)))+    ;; Set the syntax of every char to "w" except for those whose default+    ;; syntax in `standard-syntax-table' is `paren' or `whitespace'.+    (map-char-table (lambda (keys val)+                      ;; `keys' here can be a normal char, a generic char+                      ;; (Emacs<23), or a char range (Emacs>=23).+                      (unless (memq (car val)+                                    (eval-when-compile+                                      (mapcar 'car+                                              (list (string-to-syntax "(")+                                                    (string-to-syntax ")")+                                                    (string-to-syntax " ")))))+                        (modify-syntax-entry keys "w" tbl)))+                    (standard-syntax-table))+    ;; Then override the remaining special cases.+    (dolist (cs '((?- . "w 12") (?\n . ">")+                  (?. . ".") (?\; . ".") (?! . ".")))+      (modify-syntax-entry (car cs) (cdr cs) tbl))+    tbl)+  "Syntax table used by the Agda mode:++-   | Comment character, word constituent.+\n  | Comment ender.+.;! | Punctuation.++Remaining characters inherit their syntax classes from the+standard syntax table if that table treats them as matching+parentheses or whitespace.  Otherwise they are treated as word+constituents.")++(defconst agda2-command-table+  `(+    (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")+    (agda2-remove-annotations                "\C-c\C-x\C-d"       (global)       "Remove goals and highlighting (\"deactivate\")")+    (agda2-display-implicit-arguments        "\C-c\C-x\C-h"       (global)       "Toggle display of hidden arguments")+    (agda2-display-irrelevant-arguments      "\C-c\C-x\C-i"       (global)       "Toggle display of irrelevant arguments")+    (agda2-show-constraints                  ,(kbd "C-c C-=")     (global)       "Show constraints")+    (agda2-solve-maybe-all                   ,(kbd "C-c C-s")     (local global) "Solve constraints")+    (agda2-show-goals                        ,(kbd "C-c C-?")     (global)       "Show goals")+    (agda2-next-goal                         "\C-c\C-f"           (global)       "Next goal") ; Forward.+    (agda2-previous-goal                     "\C-c\C-b"           (global)       "Previous goal") ; Back.+    (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-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)")+    (agda2-helper-function-type              "\C-c\C-h"           (local)        "Helper function type")+    (agda2-infer-type-maybe-toplevel         "\C-c\C-d"           (local global) "Infer (deduce) type")+    (agda2-why-in-scope-maybe-toplevel       "\C-c\C-w"           (local global) "Explain why a particular name is in scope")+    (agda2-goal-and-context                  ,(kbd "C-c C-,")     (local)        "Goal type and context")+    (agda2-goal-and-context-and-inferred     ,(kbd "C-c C-.")     (local)        "Goal type, context and inferred type")+    (agda2-goal-and-context-and-checked      ,(kbd "C-c C-;")     (local)        "Goal type, context and checked type")+    (agda2-search-about-toplevel             ,(kbd "C-c C-z")     (local global) "Search About")+    (agda2-module-contents-maybe-toplevel    ,(kbd "C-c C-o")     (local global) "Module contents")+    (agda2-compute-normalised-maybe-toplevel "\C-c\C-n"           (local global) "Evaluate term to normal form")+    (describe-char                           nil                  (global)       "Information about the character at point")+    (agda2-comment-dwim-rest-of-buffer       ,(kbd "C-c C-x M-;") (global)       "Comment/uncomment the rest of the buffer")+    (agda2-display-program-version           nil                  (global)       "Version")+    (agda2-set-program-version               "\C-c\C-x\C-s"       (global)       "Switch to another version of Agda")+    (eri-indent                  ,(kbd "TAB"))+    (eri-indent-reverse          [S-iso-lefttab])+    (eri-indent-reverse          [S-lefttab])+    (eri-indent-reverse          [S-tab])+    (agda2-goto-definition-mouse [mouse-2])+    (agda2-goto-definition-keyboard "\M-.")+    (agda2-go-back                  ,(if (version< emacs-version "25.1") "\M-*" "\M-,"))+    )+  "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+menu; and DESC is the description of the command used in the+menus.")++(defvar agda2-mode-map+  (let ((map (make-sparse-keymap "Agda mode")))+    (define-key map [menu-bar Agda]+      (cons "Agda" (make-sparse-keymap "Agda")))+    (define-key map [down-mouse-3]  'agda2-popup-menu-3)+    (dolist (d (reverse agda2-command-table))+      (cl-destructuring-bind (f &optional keys kinds desc) d+        (if keys (define-key map keys f))+        (if (member 'global kinds)+            (define-key map+              (vector 'menu-bar 'Agda (intern desc)) (cons desc f)))))+    map)+  "Keymap for `agda2-mode'.")++(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+        (if (member 'local kinds)+            (define-key map+              (vector (intern desc)) (cons desc f)))))+    map)+  "Keymap for agda2 goal menu.")++(defvar agda2-info-buffer nil+  "Agda information buffer.")++(defvar agda2-process-buffer nil+  "Agda subprocess buffer.+Set in `agda2-restart'.")++(defvar agda2-process nil+  "Agda subprocess.+Set in `agda2-restart'.")++(defvar agda2-in-progress nil+  "Is the Agda process currently busy?+Valid values: `nil' (not busy), `busy' (busy),+`not-so-busy' (busy with something that should typically+terminate fairly quickly).")++;; Some buffer locals+(defvar agda2-buffer-external-status ""+  "External status of an `agda2-mode' buffer (dictated by the Haskell side).")+(make-variable-buffer-local 'agda2-buffer-external-status)++(defvar agda2-output-prompt "Agda2> "+  "The Agda2 buffer's prompt.")++(defconst agda2-help-address+  ""+  "Address accepting submissions of bug reports and questions.")++;; Annotation for a goal+;; {! .... !}+;; ----------  overlay:    agda2-gn num, face highlight, after-string num,+;;                         modification-hooks (agda2-protect-goal-markers)+;; -           text-props: category agda2-delim1+;;  -          text-props: category agda2-delim2+;;         -   text-props: category agda2-delim3+;;          -  text-props: category agda2-delim4+;;+;; Char categories for {! ... !}+(defvar agda2-open-brace  "{")+(defvar agda2-close-brace " }")+(setplist 'agda2-delim1 `(display ,agda2-open-brace))+(setplist 'agda2-delim2 `(display ,agda2-open-brace rear-nonsticky t+                                  agda2-delim2 t))+(setplist 'agda2-delim3 `(display ,agda2-close-brace agda2-delim3 t))+(setplist 'agda2-delim4 `(display ,agda2-close-brace rear-nonsticky t))++;; Note that strings used with the display property are compared by+;; reference. If the agda2-*-brace definitions were inlined, then+;; goals would be displayed as "{{ }}n" instead of "{ }n".++;; The following variables are used by the filter process,+;; `agda2-output-filter'. Their values are only modified by the filter+;; process, `agda2-go', `agda2-restart', `agda2-abort-highlighting',+;; and `agda2-abort-done'.++(defvar agda2-output-chunk-incomplete (agda2-queue-empty)+  "Buffer for incomplete lines.+\(See `agda2-output-filter'.)")+(make-variable-buffer-local 'agda2-output-chunk-incomplete)++(defvar agda2-last-responses nil+  "Response commands which should be run after other commands.+The command which arrived last is stored first in the list.")+(make-variable-buffer-local 'agda2-last-responses)++(defvar agda2-file-buffer nil+  "The Agda buffer.+Note that this variable is not buffer-local.")++(defvar agda2-in-agda2-file-buffer nil+  "Was `agda2-file-buffer' active when `agda2-output-filter' started?+Note that this variable is not buffer-local.")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; agda2-mode++;;;###autoload+(add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode))+;;;###autoload+(modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8)+;;;###autoload+(define-derived-mode agda2-mode prog-mode "Agda"+  "Major mode for Agda files.++The following paragraph does not apply to Emacs 23 or newer.++  Note that when this mode is activated the default font of the+  current frame is changed to the fontset `agda2-fontset-name'.+  The reason is that Agda programs often use mathematical symbols+  and other Unicode characters, so we try to provide a suitable+  default font setting, which can display many of the characters+  encountered. If you prefer to use your own settings, set+  `agda2-fontset-name' to nil.++Special commands:+\\{agda2-mode-map}"++ (if (boundp 'agda2-include-dirs)+     (display-warning 'agda2 "Note that the variable agda2-include-dirs is+no longer used. You may want to update your configuration. You+have at least two choices:+* Use the library management system.+* Set the include path using agda2-program-args.++One way to avoid seeing this warning is to make sure that+agda2-include-dirs is not bound." :warning))++ (setq local-abbrev-table agda2-mode-abbrev-table+       indent-tabs-mode   nil+       mode-line-process+         '((:eval (unless (eq 0 (length agda2-buffer-external-status))+                    (concat ":" agda2-buffer-external-status)))))+ (let ((l '(max-specpdl-size    2600+            max-lisp-eval-depth 2800)))+   (while l (set (make-local-variable (pop l)) (pop l))))+ (if (and window-system agda2-fontset-name)+     (condition-case nil+         (set-frame-font agda2-fontset-name)+       (error (error "Unable to change the font; change agda2-fontset-name or tweak agda2-fontset-spec-of-fontset-agda2"))))+ ;; Deactivate highlighting if the buffer is edited before+ ;; typechecking is complete.+ (add-hook 'first-change-hook 'agda2-abort-highlighting nil 'local)+ ;; If Agda is not running syntax highlighting does not work properly.+ (unless (eq 'run (agda2-process-status))+   (agda2-restart))+ ;; Make sure that Font Lock mode is not used.+ (font-lock-mode 0)+ (agda2-highlight-setup)+ (condition-case err+     (agda2-highlight-reload)+   (error (message "Highlighting not loaded: %s"+                   (error-message-string err))))+ (agda2-comments-and-paragraphs-setup)+ (force-mode-line-update)+ ;; Protect global value of default-input-method from set-input-method.+ (make-local-variable 'default-input-method)+ ;; Don't take script into account when determining word boundaries+ (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))+ (set-input-method "Agda")+ ;; Highlighting etc. is removed when we switch from the Agda mode.+ ;; Use case: When a file M.lagda with a local variables list+ ;; including "mode: latex" is loaded chances are that the Agda mode+ ;; is activated before the LaTeX mode, and the LaTeX mode does not+ ;; seem to remove the text properties set by the Agda mode.+ (add-hook 'change-major-mode-hook 'agda2-quit nil 'local))++(defun agda2-restart ()+  "Tries to start or restart the Agda process."+  (interactive)++  ;; Kill any running instance of the Agda process.+  (condition-case nil+      (agda2-term)+    (error nil))++  ;; Check that the right version of Agda is used.+  (let* ((coding-system-for-read 'utf-8)+         (output (with-output-to-string+                   (call-process agda2-program-name+                                 nil standard-output nil "--version")))+         (version (and (string-match "^Agda version \\([0-9.]+\\)" output)+                       (match-string 1 output))))+    (unless (equal version agda2-version)+      (error "The Agda mode's version (%s) does not match that of %s (%s)."+             agda2-version+             agda2-program-name (or version "unknown"))))++  (let ((all-program-args (cons "--interaction" agda2-program-args)))++    ;; Check that the arguments are not malformed.+    (let* ((coding-system-for-read 'utf-8)+           (status)+           (output+            (with-output-to-string+              (setq status+                    (apply 'call-process agda2-program-name+                           nil standard-output nil all-program-args)))))+      (unless (equal status 0)+        (error "Failed to start the Agda process:\n%s" output)))++    ;; Start the Agda process.+    (let ((agda2-bufname "*agda2*"))++      (let ((process-connection-type nil)) ; Pipes are faster than PTYs.+        (setq agda2-process+              (apply 'start-process "Agda2" agda2-bufname+                     agda2-program-name all-program-args)))++      (set-process-coding-system agda2-process 'utf-8 'utf-8)+      (set-process-query-on-exit-flag agda2-process nil)+      (set-process-filter agda2-process 'agda2-output-filter)+      (setq agda2-in-progress nil+            agda2-file-buffer (current-buffer))++      (with-current-buffer agda2-bufname+        (setq agda2-process-buffer (current-buffer)+              mode-name            "Agda executable"+              agda2-last-responses nil)+        (set-buffer-file-coding-system 'utf-8))++      (agda2-remove-annotations))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; Communicating with Agda++(defun agda2-raise-error ()+  "Raises an error.+The error message directs the user to the *agda2* buffer."+  (error "Problem encountered. The *agda2* buffer can perhaps explain why."))++(defun agda2-running-p nil+  "Does the *agda2* buffer exist, and is the Agda2 process running?"+  (and (buffer-live-p agda2-process-buffer)+       (eq (agda2-process-status) 'run)))++(defun agda2-send-command (restart &rest args)+  "Send a command to the Agda process.+Sends the list of strings ARGS to the process. If RESTART is+non-nil and the process is not running, or the *agda2*+buffer does not exist, then an attempt is made to restart the+process."+  (when (and restart (not (agda2-running-p)))+    ;; Try restarting automatically, but only once, in case there is+    ;; some major problem.+    (agda2-restart)+    (unless (agda2-running-p)+      (agda2-raise-error)))+  (let ((command (apply 'concat (agda2-intersperse " " args))))+    (with-current-buffer agda2-process-buffer+      (goto-char (point-max))+      (insert command)+      (insert "\n")+      (process-send-string agda2-process (concat command "\n")))))++(defun agda2-go (save highlight how-busy do-abort &rest args)+  "Executes commands in the Agda2 interpreter.+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 HIGHLIGHT is non-nil, then the buffer's syntax highlighting+may be updated. This is also the case if the Agda process is+busy (or `not-so-busy') and `agda2-highlight-in-process' is+non-nil.++The value HOW-BUSY should be `busy' if it should not be possible+to invoke other commands while this command is running (with the+exception of commands for which DO-ABORT is nil). Otherwise it+should be `not-so-busy' (which should only be used for commands+that typically terminate fairly quickly).++If the Agda process is busy (or `not-so-busy'), and the current+buffer does not match `agda2-file-buffer', then the command is+not executed and an error is raised. The same applies if DO-ABORT+is non-nil and the Agda process is `busy'."++  ; Check that how-busy is well-formed.+  (cl-assert (or (equal how-busy 'busy)+              (equal how-busy 'not-so-busy)))++  (when (and agda2-in-progress+             (not (equal agda2-file-buffer+                         (current-buffer))))+    (error "Agda is busy with something in the buffer %s"+           agda2-file-buffer))++  (when (and do-abort+             (equal agda2-in-progress 'busy))+    (error "Agda is busy with something+\(you have the option to abort or restart Agda)"))++  (setq agda2-file-buffer (current-buffer))++  (setq agda2-highlight-in-progress+        (or highlight+            (and agda2-in-progress+                 agda2-highlight-in-progress)))++  (unless agda2-in-progress+    (setq agda2-output-chunk-incomplete (agda2-queue-empty)))++  (setq agda2-in-progress+        (if (or (equal how-busy 'busy)+                (equal agda2-in-progress 'busy))+            'busy+          'not-so-busy))++  (when (equal save 'save) (save-buffer))++  (apply 'agda2-send-command+         'restart+         "IOTCM"+         (agda2-string-quote (buffer-file-name))+         (if highlight (agda2-highlight-level) "None")+         "Indirect"+         "("+         (append args '(")"))))++(defun agda2-abort ()+  "Tries to abort the current computation, if any.+May be more efficient than restarting Agda."+  (interactive)+  (agda2-send-command nil+                      "IOTCM"+                      (agda2-string-quote (buffer-file-name))+                      "None"+                      "Indirect"+                      "Cmd_abort"))++(defun agda2-abort-done ()+  "Resets certain variables.+Intended to be used by the backend if an abort command was+successful."+  (agda2-info-action "*Aborted*" "Aborted." t)+  (setq agda2-highlight-in-progress nil+        agda2-last-responses        nil))++(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+exactly one command. Incomplete lines are stored in a+buffer (`agda2-output-chunk-incomplete').++Every command is run by this function, unless it has the form+\"(('last . priority) . cmd)\", in which case it is run by+`agda2-run-last-commands' at the end, after the Agda2 prompt+has reappeared, after all non-last commands, and after all+interactive highlighting is complete. The last commands can have+different integer priorities; those with the lowest priority are+executed first.++Non-last commands should not call the Agda process.++All commands are echoed to the *agda2* buffer, with the exception+of commands of the form \"(agda2-highlight-... ...)\".++The non-last commands are run in the order in which they appear.++When the prompt has been reached highlighting annotations are+reloaded from `agda2-highlighting-file', unless+`agda2-highlighting-in-progress' is nil."++  ;; Beware: the buffer may have been killed in the mean time.  E.g. when+  ;; viewing an attachment containing Agda code in Gnus, Gnus will+  ;; create a temp buffer, set it in agda2-mode, call font-lock-ensure on it+  ;; (which won't know that it needs to wait for some process to reply), then+  ;; extract the fontified text and kill the temp buffer; so when Agda+  ;; finally answers, the temp buffer is long gone.+  (when (buffer-live-p agda2-file-buffer)+  (setq agda2-in-agda2-file-buffer+        (and agda2-file-buffer+             (equal (current-buffer) agda2-file-buffer)))+  (let (;; The input lines in the current chunk.+        (lines (split-string chunk "\n"))++        ;; Non-last commands found in the current chunk (reversed).+        (non-last-commands ())++        ;; Last incomplete line, if any.+        (output-chunk-incomplete ""))+    (with-current-buffer agda2-file-buffer+      (when (consp lines)+        (agda2-queue-enqueue agda2-output-chunk-incomplete (pop lines))+        (when (consp lines)+          ;; The previous uncomplete chunk is now complete.+          (push (agda2-queue-to-string agda2-output-chunk-incomplete)+                lines)++          ;; Stash away the last incomplete line, if any. (Note that+          ;; (split-string "...\n" "\n") evaluates to (... "").)+          (setq output-chunk-incomplete (car (last lines))+                agda2-output-chunk-incomplete+                (agda2-queue-from-string output-chunk-incomplete))++          ;; Handle every complete line.+          (dolist (line (butlast lines))+            (let* (;; The command. Lines which cannot be parsed as a single+                   ;; list, without any junk, are ignored.+                   (cmd (condition-case nil+                            (let ((result (read-from-string line)))+                              (if (and (listp (car result))+                                       (= (cdr result) (length line)))+                                  (car result)))+                          (error nil)))+                   (is-highlighting-command+                    (and cmd+                         (symbolp (car cmd))+                         (let ((case-fold-search nil))+                           (string-match "^agda2-highlight-"+                                         (symbol-name (car cmd)))))))++              ;; Do not echo highlighting commands.+              (unless is-highlighting-command+                (with-current-buffer agda2-process-buffer+                  (save-excursion+                    (goto-char (point-max))+                    (insert line)+                    (insert "\n"))))+              (when cmd+                (if (equal 'last (car-safe (car cmd)))+                    (push (cons (cdr (car cmd)) (cdr cmd))+                          agda2-last-responses)+                  (push cmd non-last-commands)))))++          ;; Run non-last commands.+          (mapc 'agda2-exec-response (nreverse non-last-commands)))++        ;; Check if the prompt has been reached. This function assumes+        ;; that the prompt does not include any newline characters.+        (when (agda2-queue-is-prefix-of agda2-output-prompt+                                        agda2-output-chunk-incomplete)+          (with-current-buffer agda2-process-buffer+            (insert output-chunk-incomplete))+          (setq agda2-output-chunk-incomplete (agda2-queue-empty)+                agda2-in-progress nil+                agda2-last-responses (nreverse agda2-last-responses))++          (agda2-run-last-commands)))))))++(defun agda2-run-last-commands nil+  "Execute the last commands in the right order.+\(After the prompt has reappeared.) See `agda2-output-filter'."++  ;; with-current-buffer is used repeatedly below, because some last+  ;; commands may switch the focus to another buffer.++  (while (with-current-buffer agda2-file-buffer+           (and (not agda2-in-progress) (consp agda2-last-responses)))+    (with-current-buffer agda2-file-buffer+      ;; The list is sorted repeatedly because this function may be+      ;; called recursively (via `agda2-exec-response').+      (setq agda2-last-responses (sort agda2-last-responses+                                       (lambda (x y) (<= (car x) (car y)))))+      (let ((r (pop agda2-last-responses)))+        (agda2-exec-response (cdr r)))))++  ;; Unset agda2-highlight-in-progress when all the asynchronous+  ;; commands have terminated.+  (unless agda2-in-progress+      (setq agda2-highlight-in-progress nil)))++(defun agda2-abort-highlighting nil+  "Abort any interactive highlighting.+This function should be used in `first-change-hook'."+  (when agda2-highlight-in-progress+    (setq agda2-highlight-in-progress nil)+    (message "\"%s\" has been modified. Interrupting highlighting."+             (buffer-name (current-buffer)))))++(defun agda2-goal-cmd (cmd save &optional want ask &rest args)+  "Reads input from goal or minibuffer and sends command to Agda.++An error is raised if point is not in a goal.++The command sent to Agda is++  CMD <goal number> <goal range> <user input> ARGS.++The user input is computed as follows:++* If WANT is nil, then the user input is the empty string.++* If WANT is a string, and either ASK is non-nil or the goal only+  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+  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+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"))+    (let ((txt (buffer-substring-no-properties (+ (overlay-start o) 2)+                                               (- (overlay-end   o) 2)))+          (input-from-goal nil))+      (cond ((null want) (setq txt ""))+            ((and (stringp want)+                  (or ask (string-match "\\`\\s *\\'" txt)))+             (setq txt (read-string (concat want ": ") nil nil txt t)))+            (t (setq input-from-goal t)))+      (apply 'agda2-go save input-from-goal 'busy t cmd+             (format "%d" g)+             (if input-from-goal (agda2-goal-Range o) (agda2-mkRange nil))+             (agda2-string-quote txt) args))))++;; Note that the following function is a security risk, since it+;; evaluates code without first inspecting it. The code (supposedly)+;; comes from the Agda backend, but there could be bugs in the backend+;; which can be exploited by an attacker which manages to trick+;; someone into type-checking compromised Agda code.++(defun agda2-exec-response (response)+  "Interprets response."+  (let ((inhibit-read-only t))+    (eval response)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; User commands and response processing++(defun agda2-load ()+  "Load current buffer."+  (interactive)+  (agda2-go 'save t 'busy t "Cmd_load"+            (agda2-string-quote (buffer-file-name))+            (agda2-list-quote agda2-program-args)+            ))++(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 (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+NAME takes a prefix argument which tells whether it should+apply force or not when running CMD (through+`agda2-goal-cmd';+SAVE is used as `agda2-goal-cmd's SAVE argument and+WANT is used as `agda2-goal-cmd's WANT argument)."+  (let ((eval (make-symbol "eval")))+  `(defun ,name (&optional prefix)+     ,(concat comment ".++The action depends on the prefix argument:++* If the prefix argument is `nil' (i.e., if no prefix argument is+  given), then no force is applied.++* If any other prefix argument is used (for instance, if C-u is+  typed once or twice right before the command is invoked), then+  force is applied.")+     (interactive "P")+     (let ((,eval (cond ((equal prefix nil) "WithoutForce")+                        ("WithForce"))))+       (agda2-goal-cmd (concat ,cmd " " ,eval)+                       ,save ,want)))))++(agda2-maybe-forced+  agda2-give+  "Give to the goal at point the expression in it"+  "Cmd_give"+  'save+  "expression to give")++;; (defun agda2-give()+;;   "Give to the goal at point the expression in it" (interactive)+;;   (agda2-goal-cmd "Cmd_give" 'save "expression to give"))++(defun agda2-give-action (old-g paren)+  "Update the goal OLD-G with the expression in it."+  (let+     ;; Don't run modification hooks: we don't want this to+      ;; trigger agda2-abort-highlighting.+      ((inhibit-modification-hooks t))+  (agda2-update old-g paren)))++(defun agda2-refine (pmlambda)+  "Refine the goal at point.+If the goal contains an expression e, and some \"suffix\" of the+type of e unifies with the goal type, then the goal is replaced+by e applied to a suitable number of new goals.++PMLAMBDA is only used if the goal has a functional type.+When the prefix argument is given a pattern maching lambda will+be inserted, otherwise a standard lambda will be used.++If the goal is empty, the goal type is a data type, and there is+exactly one constructor which unifies with this type, then the+goal is replaced by the constructor applied to a suitable number+of new goals."+  (interactive "P")+  (if pmlambda+      (agda2-goal-cmd "Cmd_refine_or_intro True" 'save 'goal)+    (agda2-goal-cmd "Cmd_refine_or_intro False" 'save 'goal)))++(defun agda2-make-case ()+  "Refine the pattern variables given in the goal.+Assumes that <clause> = {!<variables>!} is on one line."+  (interactive)+  (agda2-goal-cmd "Cmd_make_case" 'save "pattern variables to case (empty for split on result)"))++(defun agda2-make-case-action (newcls)+  "Replace the line at point with new clauses NEWCLS and reload."+  (agda2-forget-all-goals);; we reload later anyway.+  (let* ((p0 (point))+         (p1 (goto-char (+ (current-indentation) (line-beginning-position))))+         (indent (current-column))+         cl)+    (delete-region p1 (line-end-position))+    (while (setq cl (pop newcls))+      (insert cl)+      (if newcls (insert "\n" (make-string indent ?  ))))+    (goto-char p0))+  (agda2-load))++(defun agda2-make-case-action-extendlam (newcls)+  "Replace definition of extended lambda with new clauses NEWCLS and reload."+  (agda2-forget-all-goals);; we reload later anyway.+  (let* ((p0 (point))+         (pmax (re-search-forward "!}"))+         (bracketCount 0)+         (p1 (goto-char (+ (current-indentation) (line-beginning-position))))+         (indent (current-column))+         cl)+    (goto-char p0)+    (re-search-backward "{!")+    (while (and (not (equal (preceding-char) ?\;)) (>= bracketCount 0) (> (point) p1))+      (backward-char)+      (if (equal (preceding-char) ?}) (cl-incf bracketCount))+      (if (equal (preceding-char) ?{) (cl-decf bracketCount)))+    (let* ((is-lambda-where (= (point) p1))+           (p (point)))+      (delete-region (point) pmax)+      (if (not is-lambda-where) (insert " "))+      (while (setq cl (pop newcls))+        (insert cl)+        (if newcls (if is-lambda-where (insert "\n" (make-string indent ? )) (insert " ; "))))+      (goto-char p)))+  (agda2-load))++(defun agda2-status-action (status)+  "Display the string STATUS in the current buffer's mode line.+\(precondition: the current buffer has to use the Agda mode as the+major mode)."+  (setq agda2-buffer-external-status status)+  (force-mode-line-update))++(defmacro agda2-information-buffer (buffer kind title)+  "Used to define functions like `agda2-info-buffer'."+  `(defun ,buffer nil+     ,(concat "Creates the Agda " kind+              " buffer, if it does not already exist.+The buffer is returned.")+  (unless (buffer-live-p ,buffer)+    (setq ,buffer+          (generate-new-buffer ,title))++    (with-current-buffer ,buffer+      (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 . 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)+      ;; No support for recompilation. The key binding is removed, and+      ;; attempts to run `recompile' will (hopefully) result in an+      ;; error.+      (let ((map (copy-keymap (current-local-map))))+        (define-key map (kbd "g") 'undefined)+        (use-local-map map))+      (set (make-local-variable 'compile-command)+           'agda2-does-not-support-compilation-via-the-compilation-mode)++      (set-syntax-table agda2-mode-syntax-table)+      (set (make-local-variable 'word-combining-categories) (cons '(nil . nil) word-combining-categories))+      (set-input-method "Agda")))++  ,buffer))++(agda2-information-buffer agda2-info-buffer "info" "*Agda information*")++(defun agda2-info-action (name text &optional append)+  "Insert TEXT into the Agda info buffer and display it.+NAME is displayed in the buffer's mode line.++If APPEND is non-nil, then TEXT is appended at the end of the+buffer, and point placed after this text.++If APPEND is nil, then any previous text is removed before TEXT+is inserted, and point is placed before this text."+  (interactive)+  (let ((buf (agda2-info-buffer)))+    (with-current-buffer buf+      ;; In some cases the jump-to-position-mentioned-in-text+      ;; functionality (see compilation-error-regexp-alist above)+      ;; didn't work: Emacs jumped to the wrong position. However, it+      ;; seems to work if compilation-forget-errors is used. This+      ;; problem may be related to Emacs bug #9679+      ;; (http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9679). The idea+      ;; to use compilation-forget-errors comes from a comment due to+      ;; Oleksandr Manzyuk+      ;; (https://github.com/haskell/haskell-mode/issues/67).+      (compilation-forget-errors)+      (unless append (erase-buffer))+      (save-excursion+        (goto-char (point-max))+        (insert text))+      (put-text-property 0 (length name) 'face '(:weight bold) name)+      (setq mode-line-buffer-identification name)+      (force-mode-line-update))+    ;; If the current window displays the information buffer, then the+    ;; window configuration is left untouched.+    (unless (equal (window-buffer) buf)+      (let ((agda-window+              (and agda2-file-buffer+                   (car-safe+                     ;; All windows, including minibuffers, on any+                     ;; frame on the current terminal, displaying the+                     ;; present Agda file buffer.+                     (get-buffer-window-list agda2-file-buffer t 0)))))+        (save-selected-window+          ;; Select a window displaying the Agda file buffer (if such+          ;; a window exists). With certain configurations of+          ;; display-buffer this should increase the likelihood that+          ;; the info buffer will be displayed on the same frame.+          (when agda-window+            (select-window agda-window 'no-record))+          (let* (;; If there is only one window, then the info window+                 ;; should be created above or below the code window,+                 ;; not to the left or right.+                 (split-width-threshold nil)+                 (window+                   (display-buffer+                     buf+                     ;; Under Emacs 23 the effect of the following+                     ;; argument is only that the current window+                     ;; should not be used.+                     '(nil+                       .+                       (;; Do not use the same window.+                        (inhibit-same-window . t)+                        ;; Do not raise or select another frame.+                        (inhibit-switch-frame . t))))))+            (if window+                (fit-window-to-buffer window+                  (truncate+                    (* (frame-height)+                       agda2-information-window-max-height))))))))+    ;; Move point in every window displaying the information buffer.+    ;; Exception: If we are appending, don't move point in selected+    ;; windows.+    (dolist (window (get-buffer-window-list buf 'no-minibuffer t))+      (unless (and append+                   (equal window (selected-window)))+        (with-selected-window window+          (if append+              (goto-char (point-max))+            (goto-char (point-min))))))))++(defun agda2-info-action-and-copy (name text &optional append)+  "Same as agda2-info-action but also puts TEXT in the kill ring."+  (kill-new text)+  (agda2-info-action name text append))++(defun agda2-show-constraints()+  "Show constraints." (interactive)+  (agda2-go nil t 'busy t "Cmd_constraints"))++(defun agda2-remove-annotations ()+  "Removes buffer annotations (overlays and text properties)."+  (interactive)+  (dolist (o (overlays-in (point-min) (point-max)))+    (delete-overlay o))+  (let ((inhibit-read-only t))+    (annotation-preserve-mod-p-and-undo+     (set-text-properties (point-min) (point-max) '()))+    (force-mode-line-update)))++(defun agda2-next-goal ()     "Go to the next goal, if any."     (interactive)+  (agda2-mv-goal 'next-single-property-change     'agda2-delim2 1 (point-min)))+(defun agda2-previous-goal () "Go to the previous goal, if any." (interactive)+  (agda2-mv-goal 'previous-single-property-change 'agda2-delim3 0 (point-max)))+(defun agda2-mv-goal (change delim adjust wrapped)+  (agda2-let ()+      ((go (p) (while (and (setq p (funcall change p 'category))+                           (not (eq (get-text-property p 'category) delim))))+           (if p (goto-char (+ adjust p)))))+    (or (go (point)) (go wrapped) (message "No goals in the buffer"))))++(defun agda2-quit ()+  "Quit and clean up after agda2."+  (interactive)+  (remove-hook 'first-change-hook 'agda2-abort-highlighting 'local)+  (remove-hook 'after-save-hook 'agda2-highlight-tokens 'local)+  (agda2-remove-annotations)+  (agda2-term))++(defun agda2-term (&optional nicely)+  "Interrupt the Agda process and kill its buffer.+If this function is invoked with a prefix argument, then Agda is+asked nicely to terminate itself after any previously invoked+commands have completed."+  (interactive "P")+  (if nicely+      (progn+        ;; Set up things so that if the Agda process terminates, then+        ;; its buffer is killed.+        (when (and agda2-process+                   (process-status agda2-process))+          (set-process-sentinel agda2-process 'agda2-kill-process-buffer))+        ;; Kill the process buffer if the Agda process has already+        ;; been killed.+        (agda2-kill-process-buffer)+        ;; Try to kill the Agda process.+        (agda2-send-command nil+                            "IOTCM"+                            (agda2-string-quote (buffer-file-name))+                            "None"+                            "Indirect"+                            "Cmd_exit"))+    ;; Try to kill the Agda process and the process buffer.+    (when (and agda2-process+               (process-status agda2-process))+      (interrupt-process agda2-process))+    (when (buffer-live-p agda2-process-buffer)+      (kill-buffer agda2-process-buffer))))++(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.++This function can be used as a process sentinel."+  (when (and (or (null agda2-process)+                 (member (process-status agda2-process)+                         '(exit signal failed nil)))+             (buffer-live-p agda2-process-buffer))+    (kill-buffer agda2-process-buffer)))++(cl-defmacro agda2--with-gensyms ((&rest names) &body body)+  "Bind NAMES to fresh symbols in BODY"+  (declare (indent 1))+  `(let ,(cl-loop for x in names collecting `(,x (make-symbol (symbol-name',x))))+     ,@body))++;; This macro is meant to be used to generate other macros which define+;; functions which can be used either directly from a goal or at a global+;; level and are modifiable using one of three levels of normalisation.++(defmacro agda2-proto-maybe-normalised (name comment cmd norm0 norm1 norm2 norm3 spec)+  "This macro constructs a function NAME which runs CMD.+COMMENT is used to build the function's comment.+The function NAME takes a prefix argument which tells whether it+should normalise types according to either NORM0, NORM1, NORM2, or NORM3+when running CMD through `agda2-goal-cmd`.+SPEC can be either (fromgoal want) or (global prompt).+"++  ;; Names bound in a macro should be ``uninterned'' to avoid name capture+  ;; We use the macro `agda2--with-gensyms' to bind these.+  (agda2--with-gensyms (eval prefix args)+    `(defun ,name (,prefix &rest ,args)+       ,(format "%s.++The form of the result depends on the prefix argument:++* If the prefix argument is `nil' (i.e., if no prefix argument is+  given), then the result is %s.++* If the prefix argument is `(4)' (for instance if C-u is typed+  exactly once right before the command is invoked), then the+  result is %s.++* If the prefix argument is `(16)' (for instance if C-u is typed+  exactly twice right before the command is invoked), then the+  result is %s.++* If any other prefix argument is used (for instance if C-u is+  typed thrice right before the command is invoked), then the+  result is %s." comment (nth 1 norm0) (nth 1 norm1) (nth 1 norm2) (nth 1 norm3))++       ;; All the commands generated by the macro are interactive.+       ;; 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)+                        "P")+                       (`(global ,prompt)+                        (if prompt+                            (concat "P\nM" prompt ": ")+                          "P"))))+       ;; Depending on the prefix's value we pick one of the three+       ;; normalisation levels+       (let ((,eval (cond ((null ,prefix)+                           ,(car norm0))+                          ((equal ,prefix '(4))+                           ,(car norm1))+                          ((equal ,prefix '(16))+                           ,(car norm2))+                          (t ,(car norm3)))))+       ;; Finally, if the command is called from a goal, we use `agda2-goal-cmd'+       ;; Otherwise we resort to `agda2-go'+         ,(pcase spec+            (`(fromgoal ,want)+             `(agda2-goal-cmd (concat ,cmd " " ,eval) nil ,want))+            (`(global ,prompt)+             `(agda2-go nil t 'busy t+                        (concat ,cmd " "+                                ,eval " "+                                (if ,prompt+                                    (agda2-string-quote (car ,args))+                                    "")))))))))++(defmacro agda2-maybe-normalised (name comment cmd want)+  `(agda2-proto-maybe-normalised+    ,name ,comment ,cmd+    ("Simplified"   "simplified")+    ("Instantiated" "neither explicitly normalised nor simplified")+    ("Normalised"   "normalised")+    ("HeadNormal"   "head normalised")+    (fromgoal ,want)))++(defmacro agda2-maybe-normalised-asis (name comment cmd want)+  `(agda2-proto-maybe-normalised+    ,name ,comment ,cmd+    ("AsIs"       "returned as is")+    ("Simplified" "simplified")+    ("Normalised" "normalised")+    ("HeadNormal" "head normalised")+    (fromgoal ,want)))++(defmacro agda2-maybe-normalised-toplevel (name comment cmd prompt)+  `(agda2-proto-maybe-normalised+    ,name ,comment ,cmd+    ("Simplified"   "simplified")+    ("Instantiated" "neither explicitly normalised nor simplified")+    ("Normalised"   "normalised")+    ("HeadNormal"   "head normalised")+    (global ,prompt)))++(defmacro agda2-maybe-normalised-toplevel-asis-noprompt (name comment cmd)+  `(agda2-proto-maybe-normalised+    ,name ,comment ,cmd+    ("AsIs"       "returned as is")+    ("Simplified" "simplified")+    ("Normalised" "normalised")+    ("HeadNormal" "head normalised")+    (global nil)))++(agda2-maybe-normalised+ agda2-goal-type+ "Show the type of the goal at point"+ "Cmd_goal_type"+ nil)++(agda2-maybe-normalised+ agda2-infer-type+ "Infer the type of the goal at point"+ "Cmd_infer"+ "expression to type")++(agda2-maybe-normalised-toplevel+   agda2-infer-type-toplevel+   "Infers the type of the given expression. The scope used for+the expression is that of the last point inside the current+top-level module"+   "Cmd_infer_toplevel"+   "Expression")++(defun agda2-infer-type-maybe-toplevel ()+  "Infers the type of the given expression.+Either uses the scope of the current goal or, if point is not in a goal, the+top-level scope."+  (interactive)+  (call-interactively (if (agda2-goal-at (point))+                          'agda2-infer-type+                        'agda2-infer-type-toplevel)))++(defun agda2-why-in-scope ()+  "Explain why something is in scope in a goal."+  (interactive)+  (agda2-goal-cmd "Cmd_why_in_scope" nil "Name"))++(defun agda2-why-in-scope-toplevel (name)+  "Explain why something is in scope at the top level."+  (interactive "MName: ")+  (agda2-go nil t 'busy t+            "Cmd_why_in_scope_toplevel"+            (agda2-string-quote name)))++(defun agda2-why-in-scope-maybe-toplevel ()+  "Explains why a given name is in scope."+  (interactive)+  (call-interactively (if (agda2-goal-at (point))+                          'agda2-why-in-scope+                          'agda2-why-in-scope-toplevel)))++(agda2-maybe-normalised+ agda2-elaborate-give+ "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")++(agda2-maybe-normalised+ agda2-goal-and-context+ "Shows the type of the goal at point and the currect context"+ "Cmd_goal_type_context"+ nil)++(agda2-maybe-normalised+ agda2-goal-and-context-and-inferred+ "Shows the context, the goal and the given expression's inferred type"+ "Cmd_goal_type_context_infer"+ "expression to type")++(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"+ "Cmd_goal_type_context_check"+ "expression to type")++(agda2-maybe-normalised+ agda2-show-context+ "Show the context of the goal at point"+ "Cmd_context"+ nil)++(agda2-maybe-normalised-asis+ agda2-helper-function-type+  "Compute the type of a hypothetical helper function."+  "Cmd_helper_function"+  "Expression")++(agda2-maybe-normalised+  agda2-module-contents+  "Shows all the top-level names in the given module.+Along with their types."+  "Cmd_show_module_contents"+  "Module name (empty for current module)")++(agda2-maybe-normalised-toplevel+  agda2-module-contents-toplevel+  "Shows all the top-level names in the given module.+Along with their types."+  "Cmd_show_module_contents_toplevel"+  "Module name (empty for top-level module)"+)++(agda2-maybe-normalised-toplevel+  agda2-search-about-toplevel+  "Search About an identifier"+  "Cmd_search_about_toplevel"+  "Name"+)++(defun agda2-module-contents-maybe-toplevel ()+  "Shows all the top-level names in the given module.+Along with their types.++Uses either the scope of the current goal or, if point is not in+a goal, the top-level scope."+  (interactive)+  (call-interactively (if (agda2-goal-at (point))+                          'agda2-module-contents+                        'agda2-module-contents-toplevel)))++(defun agda2-solve-maybe-all ()+  "Solves goals that are already instantiated internally.+Either only one if point is a goal, or all of them."+  (interactive)+  (call-interactively (if (agda2-goal-at (point))+                          'agda2-solveOne+                          'agda2-solveAll))+)++(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-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"+ )++(agda2-maybe-normalised-toplevel-asis-noprompt+ agda2-solveAll+ "Solves all goals that are already instantiated internally."+ "Cmd_solveAll"+ )++(agda2-maybe-normalised+  agda2-solveOne+  "Solves the goal at point if it is already instantiated internally"+  "Cmd_solveOne"+  nil+)++(defun agda2-solveAll-action (iss)+  (while iss+    (let* ((g (pop iss)) (txt (pop iss))+           (cmd (cons 'agda2-solve-action (cons g (cons txt nil)))))+      (if (null agda2-last-responses)+          (push (cons 1 cmd) agda2-last-responses)+        (nconc agda2-last-responses (cons (cons 3 cmd) nil))))))++(defun agda2-solve-action (g txt)+  (save-excursion+    (agda2-replace-goal g txt)+    (agda2-goto-goal g)+    (agda2-give)))++(defun agda2-compute-normalised (&optional arg)+  "Compute the normal form of the expression in the goal at point.++With the prefix argument `(4)' \"abstract\" is ignored during the+computation.++With a prefix argument `(16)' the normal form of+\"show <expression>\" is computed, and then the resulting string+is printed.++With any other prefix the head normal form is computed."+  (interactive "P")+  (let ((cmd (concat "Cmd_compute"+                      (cond ((equal arg nil) " DefaultCompute")+                            ((equal arg '(4)) " IgnoreAbstract")+                            ((equal arg '(16)) " UseShowInstance")+                            (" HeadCompute")))))+    (agda2-goal-cmd cmd nil "expression to normalise")))++(defun agda2-compute-normalised-toplevel (expr &optional arg)+  "Compute the normal form of the given expression.+The scope used for the expression is that of the last point+inside the current top-level module.++With a prefix argument distinct from `(4)' the normal form of+\"show <expression>\" is computed, and then the resulting string+is printed.++With the prefix argument `(4)' \"abstract\" is ignored during the+computation."+  (interactive "MExpression: \nP")+  (let ((cmd (concat "Cmd_compute_toplevel"+                     (cond ((equal arg nil) " DefaultCompute")+                            ((equal arg '(4)) " IgnoreAbstract")+                            ((equal arg '(16)) " UseShowInstance")+                            (" HeadCompute")) " ")))+    (agda2-go nil t 'busy t+              (concat cmd (agda2-string-quote expr)))))++(defun agda2-compute-normalised-maybe-toplevel ()+  "Compute the normal form of the given expression.+The scope used for the expression is that of the last point+inside the current top-level module.++With a prefix argument distinct from `(4)' the normal form of+\"show <expression>\" is computed, and then the resulting string+is printed.++With the prefix argument `(4)' \"abstract\" is ignored during the+computation."+  (interactive)+  (if (agda2-goal-at (point))+      (call-interactively 'agda2-compute-normalised)+    (call-interactively 'agda2-compute-normalised-toplevel)))++(defun agda2-display-program-version ()+  "Display version of Agda"+  (interactive)+  (agda2-go nil nil 'busy t "Cmd_show_version"))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;;++(defun agda2-highlight-reload nil+  "Loads precomputed syntax highlighting info for the current buffer.+Only if the buffer is unmodified, and only if there is anything to load."+ (unless (buffer-modified-p)+   (agda2-go nil t 'not-so-busy t+             "Cmd_load_highlighting_info"+             (agda2-string-quote (buffer-file-name)))))++(defun agda2-literate-p ()+  "Is the current buffer a literate Agda buffer?"+  (not (equal (file-name-extension (buffer-file-name)) "agda")))++(defmacro agda2--case (exp &rest branches) ;FIXME: Use `pcase' instead!+  (declare (debug t) (indent 1))+  (let ((s (make-symbol "v")))+    `(let ((,s ,exp))+       (cond+         ,@(mapcar (lambda (branch)+                     `((equal ,s ,(car branch)) ,@(cdr branch)))+                   branches)))))++(defun agda2-goals-action (goals)+  "Annotates the goals in the current buffer with text properties.+GOALS is a list of the buffer's goal numbers, in the order in+which they appear in the buffer. Note that this function should+be run /after/ syntax highlighting information has been loaded,+because the two highlighting mechanisms interact in unfortunate+ways."+  (agda2-forget-all-goals)+  (agda2-let+      ((literate (agda2-literate-p))+       stk+       top+       ;; 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" 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. "--")+       (is-proper (s comment-starter)+          (save-excursion+            (save-match-data+              (backward-char (length s))+              (unless (bolp) (backward-char 1))  ;; bolp = pointer at beginning of line+              ;; Andreas, 2014-05-17 Issue 1132+              ;; A questionmark can also follow immediately after a .+              ;; for instance to be a place holder for a dot pattern.+              (looking-at (concat "\\([.{}();]\\|^\\|\\s \\)"  ;; \\s = whitespace+                                  (regexp-quote s)+                                  (unless comment-starter+                                    "\\([{}();]\\|$\\|\\s \\)"))))))+       (make(p)  (agda2-make-goal p (point) (pop goals)))+       (inside-comment() (and stk (null     (car stk))))+       (inside-goal()    (and stk (integerp (car stk))))+       (outside-code()   (and stk (eq (car stk) 'outside)))+       (inside-code()    (not (outside-code)))+       ;; inside a multi-line comment ignore everything but the multi-line comment markers+       (safe-delims()+          (if (inside-comment)+               (re-search-forward "{-\\|-}" nil t)+            (delims))))+    (save-excursion+      ;; In literate mode we should start out in the "outside of code"+      ;; state.+      (if literate (push 'outside stk))+      (goto-char (point-min))+      (while (and goals (safe-delims))+        (agda2--case (match-string 0)+          ("\\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"         (when (not stk)                    (push 'outside stk)))+          ("```"               (if   (outside-code)               (pop stk)+                               (when (not stk)                    (push 'outside stk))))+          ("--"                (when (and (not stk)+                                          (is-proper "--" t))     (end-of-line)))+          ("{-"                (when (and (inside-code)+                                          (not (inside-goal)))    (push nil           stk)))+          ("-}"                (when (inside-comment)             (pop stk)))+          ("{!"                (when (and (inside-code)+                                          (not (inside-comment))) (push (- (point) 2) stk)))+          ("!}"                (when (inside-goal)+                                 (setq top (pop stk))+                                 (unless stk (make top))))+          ("?"                 (progn+                                 (when (and (not stk) (is-proper "?" nil))+                                   (delete-char -1)+                                   (insert "{!!}")+                                   (make (- (point) 4))))))))))++(defun agda2-make-goal (p q n)+  "Make a goal with number N at <P>{!...!}<Q>.  Assume the region is clean."+  (annotation-preserve-mod-p-and-undo+   (let ((atp (lambda (x ps) (add-text-properties x (1+ x) ps))))+     (funcall atp p       '(category agda2-delim1))+     (funcall atp (1+ p)  '(category agda2-delim2))+     (funcall atp (- q 2) '(category agda2-delim3))+     (funcall atp (1- q)  '(category agda2-delim4)))+   (let ((o (make-overlay p q nil t nil)))+     (overlay-put o 'modification-hooks '(agda2-protect-goal-markers))+     (overlay-put o 'agda2-gn           n)+     (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)+  "Ensures that the goal markers cannot be tampered with.+Except if `inhibit-read-only' is non-nil or /all/ of the goal is+modified."+  (if action+      ;; This is the after-change hook.+      nil+    ;; This is the before-change hook.+    (cond+     ((and (<= beg (overlay-start ol)) (>= end (overlay-end ol)))+      ;; The user is trying to remove the whole goal:+      ;; manually evaporate the overlay and add an undo-log entry so+      ;; it gets re-added if needed.+      (when (listp buffer-undo-list)+        (push (list 'apply 0 (overlay-start ol) (overlay-end ol)+                    'move-overlay ol (overlay-start ol) (overlay-end ol))+              buffer-undo-list))+      (delete-overlay ol))+     ((or (< beg (+ (overlay-start ol) 2))+          (> end (- (overlay-end ol) 2)))+      (unless inhibit-read-only+        (signal 'text-read-only nil))))))++(defun agda2-update (old-g new-txt)+  "Update the goal OLD-G.+If NEW-TXT is a string, then the goal is replaced by the string,+and otherwise the text inside the goal is retained (parenthesised+if NEW-TXT is `'paren').++Removes the goal braces, but does not remove the goal overlay or+text properties."+  (cl-multiple-value-bind (p q) (agda2-range-of-goal old-g)+    (save-excursion+      (cond ((stringp new-txt)+             (agda2-replace-goal old-g new-txt))+            ((equal new-txt 'paren)+             (goto-char (- q 2)) (insert ")")+             (goto-char (+ p 2)) (insert "(")))+      (cl-multiple-value-bind (p q) (agda2-range-of-goal old-g)+        (delete-region (- q 2) q)+        (delete-region p (+ p 2)))+        ;; Update highlighting+        (if (and (not (equal new-txt 'paren)) (not (equal new-txt 'no-paren)))+            (apply 'agda2-go 'save t 'busy nil "Cmd_highlight"+              (format "%d" old-g)+              (agda2-mkRange `(,p ,(- q 2)))+              (agda2-string-quote new-txt) nil))+    )))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;; Misc++(defun agda2-process-status ()+  "Status of `agda2-process-buffer', or \"no process\"."+  (condition-case nil+      (process-status agda2-process)+    (error "no process")))++(defun agda2-intersperse (sep xs)+  (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."+  (agda2-mkRange `(,(+ (overlay-start o) 2)+                   ,(- (overlay-end   o) 2))))++(defun agda2-mkRange (points)+  "A string representing a range corresponding to POINTS.+POINTS must be a list of integers, and its length must be 0 or 2."+  (if points+      (format "(intervalsToRange (Just (mkAbsolute %s)) %s)"+              (agda2-string-quote (file-truename (buffer-file-name)))+              (format "[Interval () %s %s]"+                      (agda2-mkPos (car points))+                      (agda2-mkPos (cadr points))))+    "noRange"))++(defun agda2-mkPos (&optional p)+  "The Haskell PositionWithoutFile corresponding to P or `point'."+  (save-excursion+    (save-restriction+      (widen)+      (if p (goto-char p))+      (format "(Pn () %d %d %d)"+              (point)+              (count-lines (point-min) (point))+              (1+ (current-column))))))++(defun agda2-char-quote (c)+  "Convert character C to the notation used in Haskell strings.+The non-ASCII characters are actually rendered as+\"\\xNNNN\\&\", i.e. followed by a \"null character\", to avoid+problems if they are followed by digits.  ASCII characters (code+points < 128) are converted to singleton strings."+  (if (< c 128)+      (list c)+    ;; FIXME: Why return a list rather than a string?  --Stef+    (append (format "\\x%x\\&" (encode-char c 'ucs)) nil)))++(defun agda2-string-quote (s)+  "Format S as a Haskell string literal.+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 ((print-escape-newlines t)+        (s2 (copy-sequence s)))+    (set-text-properties 0 (length s2) nil 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."+  (concat "[" (mapconcat 'agda2-string-quote strings ", ") "]"))++(defun agda2-goal-at(pos)+  "Return (goal overlay, goal number) at POS, or nil."+  (let ((os (and pos (overlays-at pos))) o g)+    (while (and os (not(setq g (overlay-get (setq o (pop os)) 'agda2-gn)))))+    (if g (list o g))))++(defun agda2-goal-overlay (g)+  "Returns the overlay of goal number G, if any."+  (car+   (remove nil+           (mapcar (lambda (o) (if (equal (overlay-get o 'agda2-gn) g) o))+                   (overlays-in (point-min) (point-max))))))++(defun agda2-range-of-goal (g)+  "The range of goal G."+  (let ((o (agda2-goal-overlay g)))+    (if o (list (overlay-start o) (overlay-end o)))))++(defun agda2-goto-goal (g)+  (let ((p (+ 2 (car (agda2-range-of-goal g)))))+    (if p (goto-char p))))++(defun agda2-replace-goal (g newtxt)+  "Replace the content of goal G with NEWTXT." (interactive)+  (save-excursion+    (cl-multiple-value-bind (p q) (agda2-range-of-goal g)+      (setq p (+ p 2) q (- q 2))+      (let ((indent (and (goto-char p) (current-column))))+        (delete-region p q) (insert newtxt)+        (while (re-search-backward "^" p t)+          (insert-char ?  indent) (backward-char (1+ indent)))))))++(defun agda2-forget-all-goals ()+  "Remove all goal annotations.+\(Including some text properties which might be used by other+\(minor) modes.)"+  (annotation-preserve-mod-p-and-undo+   (remove-text-properties (point-min) (point-max)+                           '(category nil agda2-delim2 nil agda2-delim3 nil+                             display nil rear-nonsticky nil)))+  (let ((p (point-min)))+    (while (< (setq p (next-single-char-property-change p 'agda2-gn))+              (point-max))+      (delete-overlay (car (agda2-goal-at p))))))++(defun agda2-decl-beginning ()+  "Find the beginning point of the declaration containing the point.+To do: dealing with semicolon separated decls."+  (interactive)+  (save-excursion+    (let* ((pEnd (point))+           (pDef (progn (goto-char (point-min))+                        (re-search-forward "\\s *" pEnd t)))+           (cDef (current-column)))+      (while (re-search-forward+              "where\\(\\s +\\)\\S \\|^\\(\\s *\\)\\S " pEnd t)+        (if (match-end 1)+            (setq pDef (goto-char (match-end 1))+                  cDef (current-column))+          (goto-char (match-end 2))+          (if (>= cDef (current-column))+              (setq pDef (point)+                    cDef (current-column))))+        (forward-char))+      (goto-char pDef)+      (if (equal (current-word) "mutual")+          (or (match-end 2) (match-end 1))+        pDef))))++(defun agda2-beginning-of-decl ()+  (interactive)+  (goto-char (agda2-decl-beginning)))++(defvar agda2-debug-buffer-name "*Agda debug*"+  "The name of the buffer used for Agda debug messages.")++(defun agda2-verbose (msg)+  "Appends the string MSG to the `agda2-debug-buffer-name' buffer.+Note that this buffer's contents is not erased automatically when+a file is loaded."+  (with-current-buffer (get-buffer-create agda2-debug-buffer-name)+    (save-excursion+      (goto-char (point-max))+      (insert msg))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Comments and paragraphs++(defun agda2-comments-and-paragraphs-setup nil+  "Set up comment and paragraph handling for the Agda mode."++  ;; Empty lines (all white space according to Emacs) delimit+  ;; paragraphs.+  (set (make-local-variable 'paragraph-start) "\\s-*$")+  (set (make-local-variable 'paragraph-separate) paragraph-start)++  ;; Support for adding/removing comments.+  (set (make-local-variable 'comment-start) "-- ")++  ;; Use the syntax table to locate comments (and possibly other+  ;; things). Syntax table setup for comments is done elsewhere.+  (set (make-local-variable 'comment-use-syntax) t)++  ;; Update token-based highlighting after the buffer has been saved.+  (add-hook 'after-save-hook 'agda2-highlight-tokens nil 'local)++  ;; Support for proper filling of text in comments (requires that+  ;; Filladapt is activated).+  (when (featurep 'filladapt)+    (add-to-list (make-local-variable+                  'filladapt-token-table)+                 '("--" agda2-comment))+    (add-to-list (make-local-variable 'filladapt-token-match-table)+                 '(agda2-comment agda2-comment) t)+    (add-to-list (make-local-variable 'filladapt-token-conversion-table)+                 '(agda2-comment . exact))))++(defun agda2-comment-dwim-rest-of-buffer ()+  "Comment or uncomment the rest of the buffer.+From the beginning of the current line to the end of the buffer."+  (interactive)+  (save-excursion+    (forward-line 0)+    (push-mark (point) 'no-message 'activate-mark)+    (unwind-protect+        (progn+          (goto-char (point-max))+          (comment-dwim nil))+      (pop-mark))))++(defun agda2-highlight-tokens nil+  "Compute token-based highlighting information.++Unless `agda2-highlight-level' is `none' or the Agda process is+busy (or `not-so-busy') with something. This command might save+the buffer."+  (unless (or agda2-in-progress+              (equal agda2-highlight-level 'none))+    (agda2-go 'save t 'not-so-busy t+              "Cmd_tokenHighlighting"+              (agda2-string-quote (buffer-file-name))+              "Keep")))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Go to definition site++(defun agda2-goto-definition-keyboard (&optional other-window)+  "Go to the definition site of the name under point (if any).+If this function is invoked with a prefix argument then another window is used+to display the given position."+  (interactive "P")+  (annotation-goto-indirect (point) other-window))++(defun agda2-goto-definition-mouse (ev)+  "Go to the definition site of the name clicked on, if any.+Otherwise, yank (see `mouse-yank-primary')."+  (interactive "e")+  (unless (annotation-goto-indirect ev)+    ;; FIXME: Shouldn't we use something like+    ;; (call-interactively (key-binding ev))?  --Stef+    (mouse-yank-primary ev)))++(defun agda2-go-back nil+  "Go back to the previous position in which+`agda2-goto-definition-keyboard' or `agda2-goto-definition-mouse' was+invoked."+  (interactive)+  (annotation-go-back))++(defun agda2-maybe-goto (filepos)+  "Might move point to the given error.+FILEPOS should have the form (FILE . POSITION).++If `agda2-highlight-in-progress' is nil, then nothing happens.+Otherwise, if the current buffer is the one that is connected to+the Agda process, then point is moved to POSITION in+FILE (assuming that the FILE is readable). Otherwise point is+moved to the given position in the buffer visiting the file, if+any, and in every window displaying the buffer, but the window+configuration and the selected window are not changed."+  (when (and agda2-highlight-in-progress+             (consp filepos)+             (stringp (car filepos))+             (integerp (cdr filepos)))+    (if agda2-in-agda2-file-buffer+        (annotation-goto-and-push (current-buffer) (point) filepos)+      (save-excursion+        (let ((buffer (find-buffer-visiting (car filepos))))+          (when buffer+            (let ((windows (get-buffer-window-list buffer+                                                   'no-minibuffer t)))+              (if windows+                  (dolist (window windows)+                    (with-selected-window window+                      (goto-char (cdr filepos))))+                (with-current-buffer buffer+                  (goto-char (cdr filepos)))))))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Implicit arguments++(defun agda2-display-implicit-arguments (&optional arg)+  "Toggle display of implicit arguments.+With prefix argument, turn on display of implicit arguments if+the argument is a positive number, otherwise turn it off."+  (interactive "P")+  (cond+   ((eq arg nil)+      (agda2-go nil t 'not-so-busy t "ToggleImplicitArgs"))+   ((and (numberp arg) (> arg 0))+      (agda2-go nil t 'not-so-busy t "ShowImplicitArgs" "True"))+   (t (agda2-go nil t 'not-so-busy t "ShowImplicitArgs" "False"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Irrelevant arguments++(defun agda2-display-irrelevant-arguments (&optional arg)+  "Toggle display of irrelevant arguments.+With prefix argument, turn on display of irrelevant arguments if+the argument is a positive number, otherwise turn it off."+  (interactive "P")+  (cond+   ((eq arg nil)+      (agda2-go nil t 'not-so-busy t "ToggleIrrelevantArgs"))+   ((and (numberp arg) (> arg 0))+      (agda2-go nil t 'not-so-busy t "ShowIrrelevantArgs" "True"))+   (t (agda2-go nil t 'not-so-busy t "ShowIrrelevantArgs" "False"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;;++(defun agda2-popup-menu-3 (ev)+  "If in a goal, popup the goal menu and call chosen command."+  (interactive "e")+  (let (choice)+    (save-excursion+      (and (agda2-goal-at (goto-char (posn-point (event-end ev))))+           (setq choice (x-popup-menu ev agda2-goal-map))+           (call-interactively+            (lookup-key agda2-goal-map (apply 'vector choice)))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Switching to a different version of Agda++(defun agda2-get-agda-program-versions ()+  "Get suffixes (\"version strings\") of executables starting with+\\='agda-\\=' in exec-path."+  (interactive) ;; for debugging purposes+  (delete-dups+   (mapcar (lambda (path)+             ;; 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-'+                     (mapcar (lambda (path)+                               (when (file-accessible-directory-p path)+                                 (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.++(defun agda2-set-program-version (version)+  "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.+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))))++  (let*+      ((agda-buffers+        (cl-mapcan (lambda (buf)+                  (with-current-buffer buf+                    (when (equal major-mode 'agda2-mode)+                      (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))+                           ""+                         (concat "-" version)))++       ;; Run agda-mode<version-suffix> and make sure that it returns+       ;; successfully.+       (coding-system-for-read 'utf-8)+       (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+                    (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))+          (file-error+           (error "%s" (concat "Could not find " agda-mode-prog))))))++    ;; Make sure that agda-mode<version-suffix> returns a valid file.+    (unless (file-readable-p agda-mode-path)+      (error "%s" (concat "Could not read " agda-mode-path)))++    ;; Turn off the Agda mode.+    (agda2-quit)++    ;; Kill some buffers related to Agda.+    (when (buffer-live-p agda2-info-buffer)+      (kill-buffer agda2-info-buffer))+    (when (and agda2-debug-buffer-name+               (get-buffer agda2-debug-buffer-name))+      (kill-buffer agda2-debug-buffer-name))++    ;; Remove the Agda mode directory from the load path.+    (setq load-path (delete agda2-directory load-path))++    ;; Unload the Agda mode and its dependencies.+    (unload-feature 'agda2-mode      'force)+    (unload-feature 'agda2           'force)+    (unload-feature 'eri             'force)+    (unload-feature 'annotation      'force)+    (unload-feature 'agda-input      'force)+    (unload-feature 'agda2-highlight 'force)+    (unload-feature 'agda2-abbrevs   'force)+    (unload-feature 'agda2-queue     'force)++    ;; Load the new version of Agda.+    (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,4 +1,6 @@+;; -*- lexical-binding: t -*- ;;; agda2-queue.el --- Simple FIFO character queues.+;; SPDX-License-Identifier: MIT License  (defun agda2-queue-empty ()   "Creates a new empty FIFO character queue.
src/data/emacs-mode/agda2.el view
@@ -1,6 +1,8 @@+;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Agda mode code which should run before the first Agda file is ;; loaded+;; SPDX-License-Identifier: MIT License  (defvar agda2-directory (file-name-directory load-file-name)   "Path to the directory that contains agda2.el(c).")
src/data/emacs-mode/annotation.el view
@@ -1,15 +1,18 @@+;; -*- lexical-binding: t -*- ;;; annotation.el --- Functions for annotating text with faces and help bubbles +;; Version: 1.0++;; SPDX-License-Identifier: MIT License+;; URL: https://github.com/agda/agda+;; Version: 1.0+ ;;; Commentary:-;; -;;; Code:-(require 'cl)+;; Note that this library enumerates buffer positions starting from 1,+;; just like Emacs. -(defconst annotations-offset (- (save-restriction (widen) (point-min)) 1)-  "Offset between buffer positions and annotations's positions.-Annotations's positions are based on 1, so this adjusts it to the base-position used by your Emacs.")+(require 'cl-lib)  (defvar annotation-bindings nil   "An association list mapping symbols to faces.")@@ -33,7 +36,6 @@   (let (source-pos         source-window         source-buffer-        source-file-name         target)     (cond ((eventp link)            (let ((pn (event-end link)))@@ -90,15 +92,33 @@             (if other-window                 (find-file-other-window file)               (find-file file))-            (annotation-goto-position (cdr filepos))+            (goto-char (cdr filepos))             t)         (error "File does not exist or is unreadable: %s." file))))) -(defun annotation-goto-position (position)-  "Move point to POSITION."-  (goto-char (+ position annotations-offset)))+(defun annotation-merge-faces (start end faces)+  "Helper procedure used by `annotation-annotate'.+For each position in the range the FACES are merged+with the current value of the annotation-faces text property, and+both the face and the annotation-faces text properties are set to+the resulting list of faces. -(defun annotation-annotate (start end anns &optional info goto)+Precondition: START and END must be numbers, and START must be+less than END."+  (cl-assert (condition-case nil (< start end) (error nil)))+  (let ((pos start)+        mid)+    (while (< pos end)+      (setq mid (next-single-property-change pos 'annotation-faces+                                             nil end))+      (let* ((old-faces (get-text-property pos 'annotation-faces))+             (all-faces (cl-union old-faces faces)))+        (mapc (lambda (prop) (put-text-property pos mid prop all-faces))+              '(annotation-faces face))+        (setq pos mid)))))++(defun annotation-annotate+    (start end anns &optional token-based info goto)   "Annotate text between START and END in the current buffer.  Nothing happens if either START or END are out of bounds for the@@ -109,9 +129,18 @@ following happens.  All the symbols in ANNS are looked up in `annotation-bindings',-and the font-lock-face text property for the given character-range is set to the resulting list of faces.+and the resulting list of faces is used to set the face text+property. For each position in the range the faces are merged+with the current value of the annotation-faces text property, and+both the face and the annotation-faces text properties are set to+the resulting list of faces. +If TOKEN-BASED is non-nil, then the annotation-token-based+property is set to t. This means that all text properties set by+`annotation-annotate' in this range are interpreted as being+token-based, including those set by previous calls to this+procedure.+ If the string INFO is non-nil, the mouse-face property is set to highlight, and INFO is used as the help-echo string. If GOTO has the form (FILENAME . POSITION), then the@@ -128,40 +157,44 @@ that have been set; this ensures that the text properties can later be removed (if the annotation-* properties are not tampered with)."-  (incf start annotations-offset)-  (incf end annotations-offset)   (when (and (<= (point-min) start)              (< start end)              (<= end (point-max)))     (if (null anns)-        (annotation-remove-annotations start end)+        (annotation-remove-annotations nil start end)       (let ((faces (delq nil                          (mapcar (lambda (ann)                                    (cdr (assoc ann annotation-bindings)))                                  anns)))             (props nil))         (when faces-          (put-text-property start end 'font-lock-face faces)-          (add-to-list 'props 'font-lock-face))+          (annotation-merge-faces start end faces)+          (cl-pushnew 'face props)+          (cl-pushnew 'annotation-faces props))+        (when token-based+          (add-text-properties start end+                               `(annotation-token-based t))+          (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+          (cl-pushnew 'annotation-annotated props)           (let ((pos start)                 mid)             (while (< pos end)               (setq mid (next-single-property-change pos                            'annotation-annotations nil end))               (let* ((old-props (get-text-property pos 'annotation-annotations))-                     (all-props (union old-props props)))+                     (all-props (cl-union old-props props)))                 (add-text-properties pos mid                    `(annotation-annotated t annotation-annotations ,all-props))                 (setq pos mid)))))))))@@ -169,6 +202,7 @@ (defmacro annotation-preserve-mod-p-and-undo (&rest code)   "Run CODE preserving both the undo data and the modification bit. Modification hooks are also disabled."+  (declare (debug (&rest form)))   (let ((modp (make-symbol "modp")))   `(let ((,modp (buffer-modified-p))          ;; Don't check if the file is being modified by some other process.@@ -181,11 +215,13 @@          (progn ,@code)        (restore-buffer-modified-p ,modp))))) -(defun annotation-remove-annotations (&optional start end)-  "Remove all text properties set by `annotation-annotate'.+(defun annotation-remove-annotations (&optional token-based start end)+  "Remove text properties set by `annotation-annotate'.  In the current buffer. If START and END are given, then-properties are only removed between these positions.+properties are only removed between these positions. If+TOKEN-BASED is non-nil, then only token-based properties are+removed.  This function preserves the file modification stamp of the current buffer, does not modify the undo list, and temporarily@@ -197,20 +233,24 @@   ;; remove-text-properties fails for read-only text.    (annotation-preserve-mod-p-and-undo-   (let ((pos (or start (point-min)))+   (let ((tag (if token-based+                  'annotation-token-based+                'annotation-annotated))+         (pos (or start (point-min)))+         (end (or end (point-max)))          pos2)      (while pos-       (setq pos2 (next-single-property-change pos 'annotation-annotated-                                               nil end))        (let ((props (get-text-property pos 'annotation-annotations)))-         (when props+         (setq pos2 (next-single-property-change pos tag nil end))+         (when (and props+                    (or (not token-based)+                        (member 'annotation-token-based props)))            (remove-text-properties pos (or pos2 (point-max))-              (mapcan (lambda (prop) (list prop nil))-                      (append '(annotation-annotated annotation-annotations)-                              props)))))-       (setq pos (unless (equal pos2 end) pos2))))))+              (cl-mapcan (lambda (prop) (list prop nil))+                      (cons 'annotation-annotations props)))))+       (setq pos (unless (or (not pos2) (>= pos2 end)) pos2)))))) -(defun annotation-load (goto-help &rest cmds)+(defun annotation-load (goto-help remove &rest cmds)   "Apply highlighting annotations in CMDS in the current buffer.  The argument CMDS should be a list of lists (start end anns@@ -224,6 +264,14 @@ GOTO-HELP. The intention is that the default help text should inform the user about the \"goto\" facility. +If REMOVE is nil, then old syntax highlighting information is not+removed. Otherwise all token-based syntax highlighting is+removed. In order to reduce the risk of flicker this highlighting+is removed step by step, in conjunction with the addition of new+highlighting. (This process assumes that CMDS is ordered by the+positions of the annotations. If it isn't, then the highlighting+is still applied correctly, but perhaps with more flicker.)+ This function preserves the file modification stamp of the current buffer, does not modify the undo list, and temporarily disables all modification hooks.@@ -232,12 +280,22 @@ buffer."   (annotation-preserve-mod-p-and-undo     (when (listp cmds)-      (dolist (cmd cmds)-        (destructuring-bind (start end anns &optional info goto) cmd-          (let ((info (if (and (not info) (consp goto))-                          goto-help-                        info)))-            (annotation-annotate start end anns info goto)))))))+      (let ((pos (point-min)))+        (dolist (cmd cmds)+          (cl-destructuring-bind+              (start end anns &optional token-based info goto) cmd+            (let ((info (if (and (not info) (consp goto))+                            goto-help+                          info)))+              (when remove+                (annotation-remove-annotations+                 'token-based pos end)+                (setq pos end))+              (annotation-annotate+               start end anns token-based info goto))))+        (when remove+          (annotation-remove-annotations+           'token-based pos (point-max)))))))  (provide 'annotation) ;;; annotation.el ends here
src/data/emacs-mode/eri.el view
@@ -1,10 +1,17 @@+;; -*- lexical-binding: t -*- ;;; eri.el --- Enhanced relative indentation (eri) +;; SPDX-License-Identifier: MIT License+;; URL: https://github.com/agda/agda+;; Version: 1.0+ ;;; Commentary: +;; Cycle between indentation points with enhanced relative indentation.+ ;;; Code: -(require 'cl)+(require 'cl-lib)  (defun eri-current-line-length nil   "Calculate length of current line."@@ -28,7 +35,7 @@   "Return a pair of lists (XS1 . XS2). If XS is sorted, then XS = (append XS1 XS2), and all elements in XS1 are <= X, whereas all elements in XS2 are > X."-  (let* ((pos (or (position-if (lambda (y) (> y x)) xs) (length xs)))+  (let* ((pos (or (cl-position-if (lambda (y) (> y x)) xs) (length xs)))          (xs1 (eri-take pos xs))          (xs2 (nthcdr pos xs)))     (cons xs1 xs2)))@@ -45,7 +52,7 @@   ^ ^ ^ ^ ^ ^ ^     ^  |                        |                        MAX"-  (let ((result))+  (let ((result nil))     (save-excursion       (save-restriction         (beginning-of-line)@@ -59,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
@@ -0,0 +1,42 @@+/* Aspects. */+.Agda .Comment       { color: #B22222 }+.Agda .Background    {}+.Agda .Markup        { color: #000000 }+.Agda .Keyword       { color: #CD6600 }+.Agda .String        { color: #B22222 }+.Agda .Number        { color: #A020F0 }+.Agda .Symbol        { color: #404040 }+.Agda .PrimitiveType { color: #0000CD }+.Agda .Pragma        { color: black   }+.Agda .Operator      {}+.Agda .Hole          { background: #B4EEB4 }++/* NameKinds. */+.Agda .Bound                  { color: black   }+.Agda .Generalizable          { color: black   }+.Agda .InductiveConstructor   { color: #008B00 }+.Agda .CoinductiveConstructor { color: #8B7500 }+.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 }+.Agda .Record                 { color: #0000CD }++/* OtherAspects. */+.Agda .DottedPattern        {}+.Agda .UnsolvedMeta         { color: black; background: yellow         }+.Agda .UnsolvedConstraint   { color: black; background: yellow         }+.Agda .TerminationProblem   { color: black; background: #FFA07A        }+.Agda .IncompletePattern    { color: black; background: #F5DEB3        }+.Agda .Error                { color: red;   text-decoration: underline }+.Agda .TypeChecks           { color: black; background: #ADD8E6        }+.Agda .Deadcode             { color: black; background: #808080        }+.Agda .ShadowingInTelescope { color: black; background: #808080        }++/* Standard attributes. */+.Agda a { text-decoration: none }+.Agda a[href]:hover { background-color: #B4EEB4 }+.Agda [href].hover-highlight { background-color: #B4EEB4; }
+ src/data/html/highlight-hover.js view
@@ -0,0 +1,35 @@+// Copyright 2023, Andreas Abel.+// Falls under the Agda license at https://github.com/agda/agda/blob/master/LICENSE++// 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.++// A dictionary from hrefs to 'a'-elements that have this href.+const dict = new Map();++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);+  }++  // 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
@@ -0,0 +1,722 @@+% ----------------------------------------------------------------------+% Some useful commands when doing highlighting of Agda code in LaTeX.+% ----------------------------------------------------------------------++% !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+% !!! NOTE: when you make changes to this file, bump the date. !!!+% !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!+\ProvidesPackage{agda}+  [2021/07/14 version 2.8.0 Formatting LaTeX generated by Agda]++\RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox,+                calc, environ, xparse, xkeyval}++% https://tex.stackexchange.com/questions/47576/combining-ifxetex-and-ifluatex-with-the-logical-or-operation+\newif\ifxetexorluatex+\ifxetex+  \xetexorluatextrue+\else+  \ifluatex+    \xetexorluatextrue+  \else+    \xetexorluatexfalse+  \fi+\fi++% ----------------------------------------------------------------------+% Options++\DeclareOption{bw}   {\newcommand{\AgdaColourScheme}{bw}}+\DeclareOption{conor}{\newcommand{\AgdaColourScheme}{conor}}++\newif\if@AgdaEnableReferences\@AgdaEnableReferencesfalse+\DeclareOption{references}{+  \@AgdaEnableReferencestrue+}++\newif\if@AgdaEnableLinks\@AgdaEnableLinksfalse+\DeclareOption{links}{+  \@AgdaEnableLinkstrue+}++\ProcessOptions\relax++% ----------------------------------------------------------------------+% Font setup++\tracinglostchars=2 % If the font is missing some symbol, then say+                    % so in the compilation output.++% ----------------------------------------------------------------------+% Colour schemes.++\providecommand{\AgdaColourScheme}{standard}++% ----------------------------------------------------------------------+% References to code (needs additional post-processing of tex files to+% work, see wiki for details).++\if@AgdaEnableReferences+  \RequirePackage{catchfilebetweentags, xstring}+  \newcommand{\AgdaRef}[2][]{%+    \StrSubstitute{#2}{\_}{AgdaUnderscore}[\tmp]%+    \ifthenelse{\isempty{#1}}%+               {\ExecuteMetaData{AgdaTag-\tmp}}%+               {\ExecuteMetaData{#1}{AgdaTag-\tmp}}+  }+\fi++\providecommand{\AgdaRef}[2][]{#2}++% ----------------------------------------------------------------------+% Links (only done if the option is passed and the user has loaded the+% hyperref package).++\if@AgdaEnableLinks+  \@ifpackageloaded{hyperref}{++    % List that holds added targets.+    \newcommand{\AgdaList}[0]{}++    \newtoggle{AgdaIsElem}+    \newcounter{AgdaIndex}+    \newcommand{\AgdaLookup}[3]{%+      \togglefalse{AgdaIsElem}%+      \setcounter{AgdaIndex}{0}%+      \renewcommand*{\do}[1]{%+      \ifstrequal{#1}{##1}%+        {\toggletrue{AgdaIsElem}\listbreak}%+        {\stepcounter{AgdaIndex}}}%+      \dolistloop{\AgdaList}%+      \iftoggle{AgdaIsElem}{#2}{#3}%+    }++    \newcommand*{\AgdaTargetHelper}[1]{%+      \AgdaLookup{#1}%+        {\PackageError{agda}{``#1'' used as target more than once}%+                            {Overloaded identifiers and links do not%+                             work well, consider using unique%+                             \MessageBreak identifiers instead.}%+        }%+        {\listadd{\AgdaList}{#1}%+         \hypertarget{Agda\theAgdaIndex}{}%+        }%+    }++    \newcommand{\AgdaTarget}[1]{\forcsvlist{\AgdaTargetHelper}{#1}}++    \newcommand{\AgdaLink}[1]{%+      \AgdaLookup{#1}%+        {\hyperlink{Agda\theAgdaIndex}{#1}}%+        {#1}%+    }+  }{\PackageError{agda}{Load the hyperref package before the agda package}{}}+\fi++\providecommand{\AgdaTarget}[1]{}+\providecommand{\AgdaLink}[1]{#1}++% ----------------------------------------------------------------------+% Font styles.++\newcommand{\AgdaFontStyle}[1]{\textsf{#1}}+\ifthenelse{\equal{\AgdaColourScheme}{bw}}{+    \newcommand{\AgdaKeywordFontStyle}[1]{\underline{#1}}+}{+    \newcommand{\AgdaKeywordFontStyle}[1]{\textsf{#1}}+}+\newcommand{\AgdaStringFontStyle}[1]{\texttt{#1}}+\newcommand{\AgdaCommentFontStyle}[1]{\texttt{#1}}+\newcommand{\AgdaBoundFontStyle}[1]{\textit{#1}}++% ----------------------------------------------------------------------+% Colours.++% ----------------------------------+% The black and white colour scheme.+\ifthenelse{\equal{\AgdaColourScheme}{bw}}{++    % Aspect colours.+    \definecolor{AgdaComment}      {HTML}{000000}+    \definecolor{AgdaPragma}       {HTML}{000000}+    \definecolor{AgdaKeyword}      {HTML}{000000}+    \definecolor{AgdaString}       {HTML}{000000}+    \definecolor{AgdaNumber}       {HTML}{000000}+    \definecolor{AgdaSymbol}       {HTML}{000000}+    \definecolor{AgdaPrimitiveType}{HTML}{000000}++    % NameKind colours.+    \definecolor{AgdaBound}                 {HTML}{000000}+    \definecolor{AgdaGeneralizable}         {HTML}{000000}+    \definecolor{AgdaInductiveConstructor}  {HTML}{000000}+    \definecolor{AgdaCoinductiveConstructor}{HTML}{000000}+    \definecolor{AgdaDatatype}              {HTML}{000000}+    \definecolor{AgdaField}                 {HTML}{000000}+    \definecolor{AgdaFunction}              {HTML}{000000}+    \definecolor{AgdaMacro}                 {HTML}{000000}+    \definecolor{AgdaModule}                {HTML}{000000}+    \definecolor{AgdaPostulate}             {HTML}{000000}+    \definecolor{AgdaPrimitive}             {HTML}{000000}+    \definecolor{AgdaRecord}                {HTML}{000000}+    \definecolor{AgdaArgument}              {HTML}{000000}++    % Other aspect colours.+    \definecolor{AgdaDottedPattern}     {HTML}{000000}+    \definecolor{AgdaUnsolvedMeta}      {HTML}{D3D3D3}+    \definecolor{AgdaUnsolvedConstraint}{HTML}{D3D3D3}+    \definecolor{AgdaTerminationProblem}{HTML}{BEBEBE}+    \definecolor{AgdaIncompletePattern} {HTML}{D3D3D3}+    \definecolor{AgdaErrorWarning}      {HTML}{BEBEBE}+    \definecolor{AgdaError}             {HTML}{696969}++    % Misc.+    \definecolor{AgdaHole}              {HTML}{BEBEBE}++% ----------------------------------+% Conor McBride's colour scheme.+}{ \ifthenelse{\equal{\AgdaColourScheme}{conor}}{++    % Aspect colours.+    \definecolor{AgdaComment}      {HTML}{B22222}+    \definecolor{AgdaPragma}       {HTML}{000000}+    \definecolor{AgdaKeyword}      {HTML}{000000}+    \definecolor{AgdaString}       {HTML}{000000}+    \definecolor{AgdaNumber}       {HTML}{000000}+    \definecolor{AgdaSymbol}       {HTML}{000000}+    \definecolor{AgdaPrimitiveType}{HTML}{0000CD}++    % NameKind colours.+    \definecolor{AgdaBound}                 {HTML}{A020F0}+    \definecolor{AgdaGeneralizable}         {HTML}{A020F0}+    \definecolor{AgdaInductiveConstructor}  {HTML}{8B0000}+    \definecolor{AgdaCoinductiveConstructor}{HTML}{8B0000}+    \definecolor{AgdaDatatype}              {HTML}{0000CD}+    \definecolor{AgdaField}                 {HTML}{8B0000}+    \definecolor{AgdaFunction}              {HTML}{006400}+    \definecolor{AgdaMacro}                 {HTML}{006400}+    \definecolor{AgdaModule}                {HTML}{006400}+    \definecolor{AgdaPostulate}             {HTML}{006400}+    \definecolor{AgdaPrimitive}             {HTML}{006400}+    \definecolor{AgdaRecord}                {HTML}{0000CD}+    \definecolor{AgdaArgument}              {HTML}{404040}++    % Other aspect colours.+    \definecolor{AgdaDottedPattern}     {HTML}{000000}+    \definecolor{AgdaUnsolvedMeta}      {HTML}{FFD700}+    \definecolor{AgdaUnsolvedConstraint}{HTML}{FFD700}+    \definecolor{AgdaTerminationProblem}{HTML}{FF0000}+    \definecolor{AgdaIncompletePattern} {HTML}{A020F0}+    \definecolor{AgdaErrorWarning}      {HTML}{FF0000}+    \definecolor{AgdaError}             {HTML}{F4A460}++    % Misc.+    \definecolor{AgdaHole}              {HTML}{9DFF9D}++% ----------------------------------+% The standard colour scheme.+}{+    % Aspect colours.+    \definecolor{AgdaComment}      {HTML}{B22222}+    \definecolor{AgdaPragma}       {HTML}{000000}+    \definecolor{AgdaKeyword}      {HTML}{CD6600}+    \definecolor{AgdaString}       {HTML}{B22222}+    \definecolor{AgdaNumber}       {HTML}{A020F0}+    \definecolor{AgdaSymbol}       {HTML}{404040}+    \definecolor{AgdaPrimitiveType}{HTML}{0000CD}++    % NameKind colours.+    \definecolor{AgdaBound}                 {HTML}{000000}+    \definecolor{AgdaGeneralizable}         {HTML}{000000}+    \definecolor{AgdaInductiveConstructor}  {HTML}{008B00}+    \definecolor{AgdaCoinductiveConstructor}{HTML}{8B7500}+    \definecolor{AgdaDatatype}              {HTML}{0000CD}+    \definecolor{AgdaField}                 {HTML}{EE1289}+    \definecolor{AgdaFunction}              {HTML}{0000CD}+    \definecolor{AgdaMacro}                 {HTML}{458B74}+    \definecolor{AgdaModule}                {HTML}{A020F0}+    \definecolor{AgdaPostulate}             {HTML}{0000CD}+    \definecolor{AgdaPrimitive}             {HTML}{0000CD}+    \definecolor{AgdaRecord}                {HTML}{0000CD}+    \definecolor{AgdaArgument}              {HTML}{404040}++    % Other aspect colours.+    \definecolor{AgdaDottedPattern}     {HTML}{000000}+    \definecolor{AgdaUnsolvedMeta}      {HTML}{FFFF00}+    \definecolor{AgdaUnsolvedConstraint}{HTML}{FFFF00}+    \definecolor{AgdaTerminationProblem}{HTML}{FFA07A}+    \definecolor{AgdaIncompletePattern} {HTML}{F5DEB3}+    \definecolor{AgdaErrorWarning}      {HTML}{FFA07A}+    \definecolor{AgdaError}             {HTML}{FF0000}++    % Misc.+    \definecolor{AgdaHole}              {HTML}{9DFF9D}+}}++% ----------------------------------------------------------------------+% Commands.++\newcommand{\AgdaNoSpaceMath}[1]+    {\begingroup\thickmuskip=0mu\medmuskip=0mu#1\endgroup}++% Aspect commands.+\newcommand{\AgdaComment}     [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaComment}{\AgdaCommentFontStyle{#1}}}}+\newcommand{\AgdaPragma}      [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaPragma}{\AgdaCommentFontStyle{#1}}}}+\newcommand{\AgdaKeyword}     [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaKeyword}{\AgdaKeywordFontStyle{#1}}}}+\newcommand{\AgdaString}      [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaString}{\AgdaStringFontStyle{#1}}}}+\newcommand{\AgdaNumber}      [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaNumber}{\AgdaFontStyle{#1}}}}+\newcommand{\AgdaSymbol}      [1]+    {\AgdaNoSpaceMath{\textcolor{AgdaSymbol}{\AgdaFontStyle{#1}}}}+\newcommand{\AgdaPrimitiveType}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaPrimitiveType}{\AgdaFontStyle{#1}}}}+%% Andreas, 2021-07-14, issue #5471+%% To make italics correction \/ work, the font-style modifier+%% needs to be inside, in particular inside the \textcolor modifier,+%% as the \textcolor{} wrapping around something hides its content+%% to the logic that resolves \/ into a space or not.++% Note that, in code generated by the LaTeX backend, \AgdaOperator is+% always applied to a NameKind command.+\newcommand{\AgdaOperator}    [1]{#1}++% NameKind commands.++% The user can control the typesetting of (certain) individual tokens+% by redefining the following command. The first argument is the token+% and the second argument the thing to be typeset (sometimes just the+% token, sometimes \AgdaLink{<the token>}). Example:+%+%   \usepackage{ifthen}+%+%   % Insert extra space before some tokens.+%   \DeclareRobustCommand{\AgdaFormat}[2]{%+%     \ifthenelse{+%       \equal{#1}{≡⟨} \OR+%       \equal{#1}{≡⟨⟩} \OR+%       \equal{#1}{∎}+%     }{\ }{}#2}+%+% Note the use of \DeclareRobustCommand.++\newcommand{\AgdaFormat}[2]{#2}++\newcommand{\AgdaBound}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaBound}{\AgdaBoundFontStyle{\AgdaFormat{#1}{#1}}}}}+\newcommand{\AgdaGeneralizable}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaGeneralizable}{\AgdaBoundFontStyle{\AgdaFormat{#1}{#1}}}}}+\newcommand{\AgdaInductiveConstructor}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaInductiveConstructor}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaCoinductiveConstructor}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaCoinductiveConstructor}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaDatatype}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaDatatype}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaField}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaField}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaFunction}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaFunction}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaMacro}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaMacro}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaModule}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaModule}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaPostulate}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaPostulate}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaPrimitive}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaPrimitive}{\AgdaFontStyle{\AgdaFormat{#1}{#1}}}}}+\newcommand{\AgdaRecord}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaRecord}{\AgdaFontStyle{\AgdaFormat{#1}{\AgdaLink{#1}}}}}}+\newcommand{\AgdaArgument}[1]+    {\AgdaNoSpaceMath{\textcolor{AgdaArgument}{\AgdaBoundFontStyle{\AgdaFormat{#1}{#1}}}}}++% Other aspect commands.+\newcommand{\AgdaFixityOp}          [1]{\AgdaNoSpaceMath{$#1$}}+\newcommand{\AgdaDottedPattern}     [1]{\textcolor{AgdaDottedPattern}{#1}}+\newcommand{\AgdaUnsolvedMeta}      [1]+    {\AgdaFontStyle{\colorbox{AgdaUnsolvedMeta}{#1}}}+\newcommand{\AgdaUnsolvedConstraint}[1]+    {\AgdaFontStyle{\colorbox{AgdaUnsolvedConstraint}{#1}}}+\newcommand{\AgdaTerminationProblem}[1]+    {\AgdaFontStyle{\colorbox{AgdaTerminationProblem}{#1}}}+\newcommand{\AgdaIncompletePattern} [1]{\colorbox{AgdaIncompletePattern}{#1}}+\newcommand{\AgdaErrorWarning}      [1]{\colorbox{AgdaErrorWarning}{#1}}+\newcommand{\AgdaError}             [1]+    {\textcolor{AgdaError}{\AgdaFontStyle{\underline{#1}}}}+\newcommand{\AgdaCatchallClause}    [1]{#1} % feel free to change this++% Used to hide code from LaTeX.+%+% Note that this macro has been deprecated in favour of giving the+% hide argument to the code environment.+\long\def\AgdaHide#1{\ignorespaces}++% Misc.+\newcommand{\AgdaHole}[1]{\colorbox{AgdaHole}{#1}}++% ----------------------------------------------------------------------+% The code environment.++\newcommand{\AgdaCodeStyle}{}+% \newcommand{\AgdaCodeStyle}{\tiny}++\ifdefined\mathindent+  {}+\else+  \newdimen\mathindent\mathindent\leftmargini+\fi++% Adds the given amount of vertical space and starts a new line.+%+% The implementation comes from lhs2TeX's polycode.fmt, written by+% Andres Löh.+\newcommand{\Agda@NewlineWithVerticalSpace}[1]{%+  {\parskip=0pt\parindent=0pt\par\vskip #1\noindent}}++% Should there be space around code?+\newboolean{Agda@SpaceAroundCode}++% Use this command to avoid extra space around code blocks.+\newcommand{\AgdaNoSpaceAroundCode}{%+  \setboolean{Agda@SpaceAroundCode}{false}}++% Use this command to include extra space around code blocks.+\newcommand{\AgdaSpaceAroundCode}{%+  \setboolean{Agda@SpaceAroundCode}{true}}++% By default space is inserted around code blocks.+\AgdaSpaceAroundCode{}++% Sometimes one might want to break up a code block into multiple+% pieces, but keep code in different blocks aligned with respect to+% each other. Then one can use the AgdaAlign environment. Example+% usage:+%+%   \begin{AgdaAlign}+%   \begin{code}+%     code+%       code  (more code)+%   \end{code}+%   Explanation...+%   \begin{code}+%     aligned with "code"+%       code  (aligned with (more code))+%   \end{code}+%   \end{AgdaAlign}+%+% Note that AgdaAlign environments should not be nested.+%+% Sometimes one might also want to hide code in the middle of a code+% block. This can be accomplished in the following way:+%+%   \begin{AgdaAlign}+%   \begin{code}+%     visible+%   \end{code}+%   \begin{code}[hide]+%     hidden+%   \end{code}+%   \begin{code}+%     visible+%   \end{code}+%   \end{AgdaAlign}+%+% However, the result may be ugly: extra space is perhaps inserted+% around the code blocks.+%+% The AgdaSuppressSpace environment ensures that extra space is only+% inserted before the first code block, and after the last one (but+% not if \AgdaNoSpaceAroundCode{} is used). Example usage:+%+%   \begin{AgdaAlign}+%   \begin{code}+%     code+%       more code+%   \end{code}+%   Explanation...+%   \begin{AgdaSuppressSpace}+%   \begin{code}+%     aligned with "code"+%       aligned with "more code"+%   \end{code}+%   \begin{code}[hide]+%     hidden code+%   \end{code}+%   \begin{code}+%       also aligned with "more code"+%   \end{code}+%   \end{AgdaSuppressSpace}+%   \end{AgdaAlign}+%+% Note that AgdaSuppressSpace environments should not be nested.+%+% There is also a combined environment, AgdaMultiCode, that combines+% the effects of AgdaAlign and AgdaSuppressSpace.++% The number of the current/next code block (excluding hidden ones).+\newcounter{Agda@Current}+\setcounter{Agda@Current}{0}++% The number of the previous code block (excluding hidden ones), used+% locally in \Agda@SuppressEnd.+\newcounter{Agda@Previous}++% Is AgdaAlign active?+\newboolean{Agda@Align}+\setboolean{Agda@Align}{false}++% The number of the first code block (if any) in a given AgdaAlign+% environment.+\newcounter{Agda@AlignStart}++\newcommand{\Agda@AlignStart}{%+  \ifthenelse{\boolean{Agda@Align}}{%+    \PackageError{agda}{Nested AgdaAlign environments}{%+      AgdaAlign and AgdaMultiCode environments must not be+      nested.}}{%+    \setboolean{Agda@Align}{true}%+    \setcounter{Agda@AlignStart}{\value{Agda@Current}}}}++\newcommand{\Agda@AlignEnd}{\setboolean{Agda@Align}{false}}++\newenvironment{AgdaAlign}{%+  \Agda@AlignStart{}}{%+  \Agda@AlignEnd{}%+  \ignorespacesafterend}++% Is AgdaSuppressSpace active?+\newboolean{Agda@Suppress}+\setboolean{Agda@Suppress}{false}++% The number of the first code block (if any) in a given+% AgdaSuppressSpace environment.+\newcounter{Agda@SuppressStart}++% Does a "do not suppress space after" label exist for the current+% code block? (This boolean is used locally in the code environment's+% implementation.)+\newboolean{Agda@DoNotSuppressSpaceAfter}++\newcommand{\Agda@SuppressStart}{%+  \ifthenelse{\boolean{Agda@Suppress}}{%+    \PackageError{agda}{Nested AgdaSuppressSpace environments}{%+      AgdaSuppressSpace and AgdaMultiCode environments must not be+      nested.}}{%+    \setboolean{Agda@Suppress}{true}%+    \setcounter{Agda@SuppressStart}{\value{Agda@Current}}}}++% Marks the given code block as one that space should not be+% suppressed after (if AgdaSpaceAroundCode and AgdaSuppressSpace are+% both active).+\newcommand{\Agda@DoNotSuppressSpaceAfter}[1]{%+  % The use of labels is intended to ensure that LaTeX will provide a+  % warning if the document needs to be recompiled.+  \label{Agda@DoNotSuppressSpaceAfter@#1}}++\newcommand{\Agda@SuppressEnd}{%+  \ifthenelse{\value{Agda@SuppressStart} = \value{Agda@Current}}{}{%+    % Mark the previous code block in the .aux file.+    \setcounter{Agda@Previous}{\theAgda@Current-1}%+    \immediate\write\@auxout{%+      \noexpand\Agda@DoNotSuppressSpaceAfter{\theAgda@Previous}}}%+  \setboolean{Agda@Suppress}{false}}++\newenvironment{AgdaSuppressSpace}{%+  \Agda@SuppressStart{}}{%+  \Agda@SuppressEnd{}%+  \ignorespacesafterend}++\newenvironment{AgdaMultiCode}{%+  \Agda@AlignStart{}%+  \Agda@SuppressStart{}}{%+  \Agda@SuppressEnd{}%+  \Agda@AlignEnd{}%+  \ignorespacesafterend}++% Vertical space used for empty lines. By default \abovedisplayskip.+\newlength{\AgdaEmptySkip}+\setlength{\AgdaEmptySkip}{\abovedisplayskip}++% Extra space to be inserted for empty lines (the difference between+% \AgdaEmptySkip and \baselineskip). Used internally.+\newlength{\AgdaEmptyExtraSkip}++% Counter used for code numbers.+\newcounter{AgdaCodeNumber}+% Formats a code number.+\newcommand{\AgdaFormatCodeNumber}[1]{(#1)}++% A boolean used to handle the option number.+\newboolean{Agda@Number}+\setboolean{Agda@Number}{false}++% A boolean used to handle the option inline*. (For some reason the+% approach used for hide and inline does not work for inline*.)+\newboolean{Agda@InlineStar}+\setboolean{Agda@InlineStar}{false}++% Keys used by the code environment.+\define@boolkey[Agda]{code}{hide}[true]{}+\define@boolkey[Agda]{code}{inline}[true]{}+\define@boolkey[Agda]{code}{inline*}[true]{%+  \setboolean{Agda@InlineStar}{true}}+\define@key[Agda]{code}{number}[]{%+  \ifthenelse{\boolean{Agda@Number}}{}{%+    \setboolean{Agda@Number}{true}%+    % Increase the counter if this has not already been done.+    \refstepcounter{AgdaCodeNumber}}%+  % If the label is non-empty, set it. Note that it is possible to+  % give several labels for a single code listing.+  \ifthenelse{\equal{#1}{}}{}{\label{#1}}}++% The code environment.+%+% Options:+%+% * hide: The code is hidden. Other options are ignored.+%+% * number: Give the code an equation number.+%+% * number=l: Give the code an equation number and the label l. It is+%   possible to use this option several times with different labels.+%+% * inline/inline*: The code is inlined. In this case most of the+%   discussion above does not apply, alignment is not respected, and so+%   on. It is recommended to only use this option for a single line of+%   code, and to not use two consecutive spaces in this piece of code.+%+%   Note that this environment ignores spaces after its end. If a space+%   (\AgdaSpace{}) should be inserted after the inline code, use+%   inline*, otherwise use inline.+%+%   When this option is used number is ignored.+%+% The implementation is based on plainhscode in lhs2TeX's+% polycode.fmt, written by Andres Löh.+\NewEnviron{code}[1][]{%+  % Process the options. Complain about unknown options.+  \setkeys[Agda]{code}[number]{#1}%+  \ifAgda@code@hide%+    % Hide the code.+  \else%+  \ifAgda@code@inline%+    % Inline code.+    %+    % Make the polytable primitives emitted by the LaTeX backend+    % do nothing.+    \DeclareDocumentCommand{\>}{O{}O{}}{}%+    \DeclareDocumentCommand{\<}{O{}}{}%+    \AgdaCodeStyle\BODY%+  \else%+  \ifthenelse{\boolean{Agda@InlineStar}}{%+    % Inline code with space at the end.+    %+    \DeclareDocumentCommand{\>}{O{}O{}}{}%+    \DeclareDocumentCommand{\<}{O{}}{}%+    \AgdaCodeStyle\BODY\AgdaSpace{}}{%+    %+    % Displayed code.+    %+    % Conditionally emit space before the code block. Unconditionally+    % switch to a new line.+    \ifthenelse{\boolean{Agda@SpaceAroundCode} \and%+                \(\not \boolean{Agda@Suppress} \or%+                  \value{Agda@SuppressStart} = \value{Agda@Current}\)}{%+      \Agda@NewlineWithVerticalSpace{\abovedisplayskip}}{%+      \Agda@NewlineWithVerticalSpace{0pt}}%+    %+    % Check if numbers have been requested. If they have, then a side+    % effect of this call is that Agda@Number is set to true, the code+    % number counter is increased, and the label (if any) is set.+    \setkeys[Agda]{code}[hide,inline,inline*]{#1}%+    \ifthenelse{\boolean{Agda@Number}}{%+      % Equation numbers have been requested. Use a minipage, so that+      % there is room for the code number to the right, and the code+      % number becomes centered vertically.+      \begin{minipage}{%+          \linewidth-%+          \widthof{%+            \AgdaSpace{}%+            \AgdaFormatCodeNumber{\theAgdaCodeNumber}}}}{}%+    %+    % Indent the entire code block.+    \advance\leftskip\mathindent%+    %+    % The code's style can be customised.+    \AgdaCodeStyle%+    %+    % Used to control the height of empty lines.+    \setlength{\AgdaEmptyExtraSkip}{\AgdaEmptySkip - \baselineskip}%+    %+    % The environment used to handle indentation (of individual lines)+    % and alignment.+    \begin{pboxed}%+      %+      % Conditionally preserve alignment between code blocks.+      \ifthenelse{\boolean{Agda@Align}}{%+        \ifthenelse{\value{Agda@AlignStart} = \value{Agda@Current}}{%+          \savecolumns}{%+          \restorecolumns}}{}%+      %+      % The code.+      \BODY%+    \end{pboxed}%+    %+    \ifthenelse{\boolean{Agda@Number}}{%+      % Equation numbers have been requested.+      \end{minipage}%+      % Insert the code number to the right.+      \hfill \AgdaFormatCodeNumber{\theAgdaCodeNumber}}{}%+    %+    % Does the label Agda@DoNotSuppressAfter@<current code block+    % number> exist?+    \ifcsdef{r@Agda@DoNotSuppressSpaceAfter@\theAgda@Current}{%+      \setboolean{Agda@DoNotSuppressSpaceAfter}{true}}{%+      \setboolean{Agda@DoNotSuppressSpaceAfter}{false}}%+    %+    % Conditionally emit space after the code block. Unconditionally+    % switch to a new line.+    \ifthenelse{\boolean{Agda@SpaceAroundCode} \and%+                \(\not \boolean{Agda@Suppress} \or%+                  \boolean{Agda@DoNotSuppressSpaceAfter}\)}{%+      \Agda@NewlineWithVerticalSpace{\belowdisplayskip}}{%+      \Agda@NewlineWithVerticalSpace{0pt}}%+    %+    % Step the code block counter, but only for non-hidden code.+    \stepcounter{Agda@Current}}%+  \fi%+  \fi%+  % Reset Agda@Number and Agda@InlineStar.+  \setboolean{Agda@Number}{false}%+  \setboolean{Agda@InlineStar}{false}}++% Space inserted after tokens.+\newcommand{\AgdaSpace}{ }++% Space inserted to indent something.+\newcommand{\AgdaIndentSpace}{\AgdaSpace{}$\;\;$}++% Default column for polytable.+\defaultcolumn{@{}l@{\AgdaSpace{}}}++% \AgdaIndent expects a non-negative integer as its only argument.+% This integer should be the distance, in code blocks, to the thing+% relative to which the text is indented.+%+% The default implementation only indents if the thing that the text+% is indented relative to exists in the same code block or is wrapped+% in the same AgdaAlign or AgdaMultiCode environment.+\newcommand{\AgdaIndent}[1]{%+  \ifthenelse{#1 = 0+                \or+              \( \boolean{Agda@Align}+                   \and+                 \cnttest{\value{Agda@Current} - #1}{>=}{+                          \value{Agda@AlignStart}}+              \)}{\AgdaIndentSpace{}}{}}++% Underscores are typeset using \AgdaUnderscore{}.+\newcommand{\AgdaUnderscore}{\_}++\endinput
+ src/data/latex/postprocess-latex.pl view
@@ -0,0 +1,24 @@+#!/usr/bin/env perl++use strict;+use warnings;++my $tag_prefix = "AgdaTag";+my $underscore = "AgdaUnderscore";+my $commands   = qr"(InductiveConstructor|CoinductiveConstructor\+                    |Datatype|Field|Function|Module|Postulate|Record)";++while (<>) {++  s|(\\Agda$commands)\{(.*?)\}++   | my $cmd = $1;+     my $arg = $3;+     my $tag = "$tag_prefix-$3" =~ s/\\_/$underscore/gr;++     $_ = "%\n%<*$tag>\n$cmd\{$arg\}%\n%</$tag>\n";+   |gxe;++  print;++}
src/data/lib/prim/Agda/Builtin/Bool.agda view
@@ -1,4 +1,5 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Bool where @@ -9,8 +10,6 @@ {-# BUILTIN FALSE false #-} {-# BUILTIN TRUE  true  #-} -{-# COMPILED_DATA_UHC Bool __BOOL__ __FALSE__ __TRUE__ #-}--{-# COMPILED_JS Bool  function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}-{-# COMPILED_JS false false #-}-{-# COMPILED_JS true  true  #-}+{-# COMPILE JS Bool  = function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}+{-# COMPILE JS false = false #-}+{-# COMPILE JS true  = true  #-}
src/data/lib/prim/Agda/Builtin/Char.agda view
@@ -1,4 +1,5 @@-{-# OPTIONS --without-K #-}+{-# 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
@@ -0,0 +1,10 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Char.Properties where++open import Agda.Builtin.Char+open import Agda.Builtin.Equality++primitive++  primCharToNatInjective : ∀ a b → primCharToNat a ≡ primCharToNat b → a ≡ b
src/data/lib/prim/Agda/Builtin/Coinduction.agda view
@@ -1,4 +1,5 @@-{-# OPTIONS --without-K #-}+{-# 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
@@ -0,0 +1,18 @@+{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-}++module Agda.Builtin.Cubical.Glue where++open import Agda.Primitive+open import Agda.Primitive.Cubical+open import Agda.Builtin.Cubical.Equiv public++primitive+    primGlue    : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}+      → (T : Partial φ (Set ℓ')) → (e : PartialP φ (λ o → T o ≃ A))+      → Set ℓ'+    prim^glue   : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}+      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}+      → (t : PartialP φ T) → (a : A) → primGlue A T e+    prim^unglue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}+      → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}+      → primGlue A T e → A
+ src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda view
@@ -0,0 +1,78 @@+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}++module Agda.Builtin.Cubical.HCompU 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 outS)++module Helpers where+    -- Homogeneous filling+    hfill : ∀ {ℓ} {A : Set ℓ} {φ : I}+              (u : ∀ i → Partial φ A)+              (u0 : A [ φ ↦ u i0 ]) (i : I) → A+    hfill {φ = φ} u u0 i =+      hcomp (λ j → \ { (φ = i1) → u (i ∧ j) 1=1+                     ; (i = i0) → outS u0 })+            (outS u0)++    -- Heterogeneous filling defined using comp+    fill : ∀ {ℓ : I → Level} (A : ∀ i → Set (ℓ i)) {φ : I}+             (u : ∀ i → Partial φ (A i))+             (u0 : A i0 [ φ ↦ u i0 ]) →+             ∀ i →  A i+    fill A {φ = φ} u u0 i =+      comp (λ j → A (i ∧ j))+           (λ j → \ { (φ = i1) → u (i ∧ j) 1=1+                    ; (i = i0) → outS u0 })+           (outS {φ = φ} u0)++    module _ {ℓ} {A : Set ℓ} where+      refl : {x : A} → x ≡ x+      refl {x = x} = λ _ → x++      sym : {x y : A} → x ≡ y → y ≡ x+      sym p = λ i → p (~ i)++      cong : ∀ {ℓ'} {B : A → Set ℓ'} {x y : A}+             (f : (a : A) → B a) (p : x ≡ y)+           → PathP (λ i → B (p i)) (f x) (f y)+      cong f p = λ i → f (p i)++    isContr : ∀ {ℓ} → Set ℓ → Set ℓ+    isContr A = Σ A \ x → (∀ y → x ≡ y)++    fiber : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) (y : B) → Set (ℓ ⊔ ℓ')+    fiber {A = A} f y = Σ A \ x → f x ≡ y++open Helpers+++primitive+  prim^glueU : {la : Level} {φ : I} {T : I → Partial φ (Set la)}+                 {A : Set la [ φ ↦ T i0 ]} →+                 PartialP φ (T i1) → outS A → hcomp T (outS A)+  prim^unglueU : {la : Level} {φ : I} {T : I → Partial φ (Set la)}+                   {A : Set la [ φ ↦ T i0 ]} →+                   hcomp T (outS A) → outS A+  -- Needed for transp.+  primFaceForall : (I → I) → I++transpProof : ∀ {l} → (e : I → Set l) → (φ : I) → (a : Partial φ (e i0)) → (b : e i1 [ φ ↦ (\ o → transp (\ i → e i) i0 (a o)) ] ) → fiber (transp (\ i → e i) i0) (outS b)+transpProof e φ a b = f , \ j → comp (\ i → e i) (\ i →+                                               \ { (φ = i1) → transp (\ j → e (j ∧ i)) (~ i) (a 1=1)+                                                 ; (j = i0) → transp (\ j → e (j ∧ i)) (~ i) f+                                                 ; (j = i1) → g (~ i) })+                                        f+    where+      b' = outS {u = (\ o → transp (\ i → e i) i0 (a o))} b+      g : (k : I) → e (~ k)+      g k = fill (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1)+                                          ; (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) (inS b') k+      f = comp (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1); (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) b'++{-# BUILTIN TRANSPPROOF transpProof #-}
+ src/data/lib/prim/Agda/Builtin/Cubical/Path.agda view
@@ -0,0 +1,15 @@+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}++module Agda.Builtin.Cubical.Path where++  open import Agda.Primitive.Cubical using (PathP) public+++  infix 4 _≡_++  -- We have a variable name in `(λ i → A)` as a hint for case+  -- splitting.+  _≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ+  _≡_ {A = A} = PathP (λ i → A)++  {-# BUILTIN PATH         _≡_     #-}
+ src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda view
@@ -0,0 +1,18 @@+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}++module Agda.Builtin.Cubical.Sub where++  open import Agda.Primitive.Cubical++  {-# BUILTIN SUB Sub #-}++  postulate+    inS : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x)++  {-# BUILTIN SUBIN inS #-}++  -- 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,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Equality where @@ -7,4 +7,3 @@   instance refl : x ≡ x  {-# BUILTIN EQUALITY _≡_ #-}-{-# BUILTIN REFL refl #-}
+ src/data/lib/prim/Agda/Builtin/Equality/Erase.agda view
@@ -0,0 +1,7 @@+{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Equality.Erase where++open import Agda.Builtin.Equality++primitive primEraseEquality : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≡ y
+ src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda view
@@ -0,0 +1,7 @@+{-# OPTIONS --cubical-compatible --rewriting --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Equality.Rewrite where++open import Agda.Builtin.Equality++{-# BUILTIN REWRITE _≡_ #-}
src/data/lib/prim/Agda/Builtin/Float.agda view
@@ -1,36 +1,209 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Float where  open import Agda.Builtin.Bool-open import Agda.Builtin.Nat open import Agda.Builtin.Int+open import Agda.Builtin.Maybe+open import Agda.Builtin.Nat+open import Agda.Builtin.Sigma open import Agda.Builtin.String+open import Agda.Builtin.Word  postulate Float : Set {-# BUILTIN FLOAT Float #-}  primitive-  primFloatEquality : Float → Float → Bool-  primFloatNumericalEquality : Float → Float → Bool-  primFloatNumericalLess     : Float → Float → Bool-  primNatToFloat    : Nat → Float-  primFloatPlus     : Float → Float → Float-  primFloatMinus    : Float → Float → Float-  primFloatTimes    : Float → Float → Float-  primFloatNegate   : Float → Float-  primFloatDiv      : Float → Float → Float-  primFloatSqrt     : Float → Float-  primRound         : Float → Int-  primFloor         : Float → Int-  primCeiling       : Float → Int-  primExp           : Float → Float-  primLog           : Float → Float-  primSin           : Float → Float-  primCos           : Float → Float-  primTan           : Float → Float-  primASin          : Float → Float-  primACos          : Float → Float-  primATan          : Float → Float-  primATan2         : Float → Float → Float-  primShowFloat     : Float → String+  -- Relations+  primFloatInequality        : Float → Float → Bool+  primFloatEquality          : Float → Float → Bool+  primFloatLess              : Float → Float → Bool+  primFloatIsInfinite        : Float → Bool+  primFloatIsNaN             : Float → Bool+  primFloatIsNegativeZero    : Float → Bool+  primFloatIsSafeInteger     : Float → Bool+  -- Conversions+  primFloatToWord64          : Float → Maybe Word64+  primNatToFloat             : Nat → Float+  primIntToFloat             : Int → Float+  primFloatRound             : Float → Maybe Int+  primFloatFloor             : Float → Maybe Int+  primFloatCeiling           : Float → Maybe Int+  primFloatToRatio           : Float → (Σ Int λ _ → Int)+  primRatioToFloat           : Int → Int → Float+  primFloatDecode            : Float → Maybe (Σ Int λ _ → Int)+  primFloatEncode            : Int → Int → Maybe Float+  primShowFloat              : Float → String+  -- Operations+  primFloatPlus              : Float → Float → Float+  primFloatMinus             : Float → Float → Float+  primFloatTimes             : Float → Float → Float+  primFloatDiv               : Float → Float → Float+  primFloatPow               : Float → Float → Float+  primFloatNegate            : Float → Float+  primFloatSqrt              : Float → Float+  primFloatExp               : Float → Float+  primFloatLog               : Float → Float+  primFloatSin               : Float → Float+  primFloatCos               : Float → Float+  primFloatTan               : Float → Float+  primFloatASin              : Float → Float+  primFloatACos              : Float → Float+  primFloatATan              : Float → Float+  primFloatATan2             : Float → Float → Float+  primFloatSinh              : Float → Float+  primFloatCosh              : Float → Float+  primFloatTanh              : Float → Float+  primFloatASinh             : Float → Float+  primFloatACosh             : Float → Float+  primFloatATanh             : Float → Float++{-# COMPILE JS+    primFloatRound = function(x) {+        x = agdaRTS._primFloatRound(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatFloor = function(x) {+        x = agdaRTS._primFloatFloor(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatCeiling = function(x) {+        x = agdaRTS._primFloatCeiling(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+        }+    };+#-}+{-# COMPILE JS+    primFloatToRatio = function(x) {+        x = agdaRTS._primFloatToRatio(x);+        return z_jAgda_Agda_Builtin_Sigma["_,_"](x.numerator)(x.denominator);+    };+#-}+{-# COMPILE JS+    primFloatDecode = function(x) {+        x = agdaRTS._primFloatDecode(x);+        if (x === null) {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+        }+        else {+            return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](+                z_jAgda_Agda_Builtin_Sigma["_,_"](x.mantissa)(x.exponent));+        }+    };+#-}+{-# COMPILE JS+    primFloatEncode = function(x) {+        return function (y) {+            x = agdaRTS.uprimFloatEncode(x, y);+            if (x === null) {+                return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"];+            }+            else {+                return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](x);+            }+        }+    };+#-}++primFloatNumericalEquality = primFloatEquality+{-# WARNING_ON_USAGE primFloatNumericalEquality+"Warning: primFloatNumericalEquality was deprecated in Agda v2.6.2.+Please use primFloatEquality instead."+#-}++primFloatNumericalLess = primFloatLess+{-# WARNING_ON_USAGE primFloatNumericalLess+"Warning: primFloatNumericalLess was deprecated in Agda v2.6.2.+Please use primFloatLess instead."+#-}++primRound = primFloatRound+{-# WARNING_ON_USAGE primRound+"Warning: primRound was deprecated in Agda v2.6.2.+Please use primFloatRound instead."+#-}++primFloor = primFloatFloor+{-# WARNING_ON_USAGE primFloor+"Warning: primFloor was deprecated in Agda v2.6.2.+Please use primFloatFloor instead."+#-}++primCeiling = primFloatCeiling+{-# WARNING_ON_USAGE primCeiling+"Warning: primCeiling was deprecated in Agda v2.6.2.+Please use primFloatCeiling instead."+#-}++primExp = primFloatExp+{-# WARNING_ON_USAGE primExp+"Warning: primExp was deprecated in Agda v2.6.2.+Please use primFloatExp instead."+#-}++primLog = primFloatLog+{-# WARNING_ON_USAGE primLog+"Warning: primLog was deprecated in Agda v2.6.2.+Please use primFloatLog instead."+#-}++primSin = primFloatSin+{-# WARNING_ON_USAGE primSin+"Warning: primSin was deprecated in Agda v2.6.2.+Please use primFloatSin instead."+#-}++primCos = primFloatCos+{-# WARNING_ON_USAGE primCos+"Warning: primCos was deprecated in Agda v2.6.2.+Please use primFloatCos instead."+#-}++primTan = primFloatTan+{-# WARNING_ON_USAGE primTan+"Warning: primTan was deprecated in Agda v2.6.2.+Please use primFloatTan instead."+#-}++primASin = primFloatASin+{-# WARNING_ON_USAGE primASin+"Warning: primASin was deprecated in Agda v2.6.2.+Please use primFloatASin instead."+#-}+++primACos = primFloatACos+{-# WARNING_ON_USAGE primACos+"Warning: primACos was deprecated in Agda v2.6.2.+Please use primFloatACos instead."+#-}++primATan = primFloatATan+{-# WARNING_ON_USAGE primATan+"Warning: primATan was deprecated in Agda v2.6.2.+Please use primFloatATan instead."+#-}++primATan2 = primFloatATan2+{-# WARNING_ON_USAGE primATan2+"Warning: primATan2 was deprecated in Agda v2.6.2.+Please use primFloatATan2 instead."+#-}
+ src/data/lib/prim/Agda/Builtin/Float/Properties.agda view
@@ -0,0 +1,10 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Float.Properties where++open import Agda.Builtin.Float+open import Agda.Builtin.Equality++primitive++  primFloatToWord64Injective : ∀ a b → primFloatToWord64 a ≡ primFloatToWord64 b → a ≡ b
src/data/lib/prim/Agda/Builtin/FromNat.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# 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,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# 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,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# 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,9 +1,10 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.IO where  postulate IO : ∀ {a} → Set a → Set a+{-# POLARITY IO ++ ++ #-} {-# BUILTIN IO IO #-} -{-# HASKELL type AgdaIO a b = IO b #-}-{-# COMPILED_TYPE IO MAlonzo.Code.Agda.Builtin.IO.AgdaIO #-}+{-# FOREIGN GHC type AgdaIO a b = IO b #-}+{-# COMPILE GHC IO = type AgdaIO #-}
src/data/lib/prim/Agda/Builtin/Int.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# 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,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.List where @@ -8,15 +8,9 @@   _∷_ : (x : A) (xs : List A) → List A  {-# BUILTIN LIST List #-}-{-# BUILTIN NIL  []   #-}-{-# BUILTIN CONS _∷_  #-} -{-# HASKELL type AgdaList a b = [b] #-}--{-# COMPILED_DATA List MAlonzo.Code.Agda.Builtin.List.AgdaList [] (:) #-}-{-# COMPILED_DATA_UHC List __LIST__ __NIL__ __CONS__ #-}-{-# COMPILED_JS List function(x,v) {+{-# COMPILE JS  List = function(x,v) {   if (x.length < 1) { return v["[]"](); } else { return v["_∷_"](x[0], x.slice(1)); } } #-}-{-# COMPILED_JS [] Array() #-}-{-# COMPILED_JS _∷_ function (x) { return function(y) { return Array(x).concat(y); }; } #-}+{-# COMPILE JS [] = Array() #-}+{-# COMPILE JS _∷_ = function (x) { return function(y) { return Array(x).concat(y); }; } #-}
+ src/data/lib/prim/Agda/Builtin/Maybe.agda view
@@ -0,0 +1,9 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Maybe where++data Maybe {a} (A : Set a) : Set a where+  just : A → Maybe A+  nothing : Maybe A++{-# BUILTIN MAYBE Maybe #-}
src/data/lib/prim/Agda/Builtin/Nat.agda view
@@ -1,4 +1,5 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Nat where @@ -47,16 +48,87 @@  {-# BUILTIN NATLESS _<_ #-} -div-helper : Nat → Nat → Nat → Nat → Nat+-- Helper function  div-helper  for Euclidean division.+---------------------------------------------------------------------------+--+-- div-helper computes n / 1+m via iteration on n.+--+--   n div (suc m) = div-helper 0 m n m+--+-- The state of the iterator has two accumulator variables:+--+--   k: The quotient, returned once n=0.  Initialized to 0.+--+--   j: A counter, initialized to the divisor m, decreased on each iteration step.+--      Once it reaches 0, the quotient k is increased and j reset to m,+--      starting the next countdown.+--+-- Under the precondition j ≤ m, the invariant is+--+--   div-helper k m n j = k + (n + m - j) div (1 + m)++div-helper : (k m n j : Nat) → Nat div-helper k m  zero    j      = k div-helper k m (suc n)  zero   = div-helper (suc k) m n m-div-helper k m (suc n) (suc j) = div-helper k m n j+div-helper k m (suc n) (suc j) = div-helper k       m n j  {-# BUILTIN NATDIVSUCAUX div-helper #-} -mod-helper : Nat → Nat → Nat → Nat → Nat+-- Proof of the invariant by induction on n.+--+--   clause 1: div-helper k m 0 j+--           = k                                        by definition+--           = k + (0 + m - j) div (1 + m)              since m - j < 1 + m+--+--   clause 2: div-helper k m (1 + n) 0+--           = div-helper (1 + k) m n m                 by definition+--           = 1 + k + (n + m - m) div (1 + m)          by induction hypothesis+--           = 1 + k +          n  div (1 + m)          by simplification+--           = k +   (n + (1 + m)) div (1 + m)          by expansion+--           = k + (1 + n + m - 0) div (1 + m)          by expansion+--+--   clause 3: div-helper k m (1 + n) (1 + j)+--           = div-helper k m n j                       by definition+--           = k + (n + m - j) div (1 + m)              by induction hypothesis+--           = k + ((1 + n) + m - (1 + j)) div (1 + m)  by expansion+--+-- Q.e.d.++-- Helper function  mod-helper  for the remainder computation.+---------------------------------------------------------------------------+--+-- (Analogous to div-helper.)+--+-- mod-helper computes n % 1+m via iteration on n.+--+--   n mod (suc m) = mod-helper 0 m n m+--+-- The invariant is:+--+--   m = k + j  ==>  mod-helper k m n j = (n + k) mod (1 + m).++mod-helper : (k m n j : Nat) → Nat mod-helper k m  zero    j      = k-mod-helper k m (suc n)  zero   = mod-helper 0 m n m+mod-helper k m (suc n)  zero   = mod-helper 0       m n m mod-helper k m (suc n) (suc j) = mod-helper (suc k) m n j  {-# BUILTIN NATMODSUCAUX mod-helper #-}++-- Proof of the invariant by induction on n.+--+--   clause 1: mod-helper k m 0 j+--           = k                               by definition+--           = (0 + k) mod (1 + m)             since m = k + j, thus k < m+--+--   clause 2: mod-helper k m (1 + n) 0+--           = mod-helper 0 m n m              by definition+--           = (n + 0)       mod (1 + m)       by induction hypothesis+--           = (n + (1 + m)) mod (1 + m)       by expansion+--           = (1 + n) + k)  mod (1 + m)       since k = m (as l = 0)+--+--   clause 3: mod-helper k m (1 + n) (1 + j)+--           = mod-helper (1 + k) m n j        by definition+--           = (n + (1 + k)) mod (1 + m)       by induction hypothesis+--           = ((1 + n) + k) mod (1 + m)       by commutativity+--+-- Q.e.d.
src/data/lib/prim/Agda/Builtin/Reflection.agda view
@@ -1,15 +1,18 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Reflection where  open import Agda.Builtin.Unit open import Agda.Builtin.Bool open import Agda.Builtin.Nat+open import Agda.Builtin.Word open import Agda.Builtin.List open import Agda.Builtin.String open import Agda.Builtin.Char open import Agda.Builtin.Float open import Agda.Builtin.Int+open import Agda.Builtin.Sigma+open import Agda.Primitive  -- Names -- @@ -29,7 +32,7 @@   non-assoc   : Associativity  data Precedence : Set where-  related   : Int → Precedence+  related   : Float → Precedence   unrelated : Precedence  data Fixity : Set where@@ -47,12 +50,27 @@ {-# BUILTIN FIXITY       Fixity #-} {-# BUILTIN FIXITYFIXITY fixity #-} -{-# COMPILED_DATA Associativity MAlonzo.RTE.Assoc MAlonzo.RTE.LeftAssoc MAlonzo.RTE.RightAssoc MAlonzo.RTE.NonAssoc #-}-{-# COMPILED_DATA Precedence MAlonzo.RTE.Precedence MAlonzo.RTE.Related MAlonzo.RTE.Unrelated #-}-{-# COMPILED_DATA Fixity MAlonzo.RTE.Fixity MAlonzo.RTE.Fixity #-}+{-# COMPILE GHC Associativity = data MAlonzo.RTE.Assoc (MAlonzo.RTE.LeftAssoc | MAlonzo.RTE.RightAssoc | MAlonzo.RTE.NonAssoc) #-}+{-# COMPILE GHC Precedence    = data MAlonzo.RTE.Precedence (MAlonzo.RTE.Related | MAlonzo.RTE.Unrelated) #-}+{-# COMPILE GHC Fixity        = data MAlonzo.RTE.Fixity (MAlonzo.RTE.Fixity) #-} +{-# COMPILE JS Associativity  = function (x,v) { return v[x](); } #-}+{-# COMPILE JS left-assoc     = "left-assoc"  #-}+{-# COMPILE JS right-assoc    = "right-assoc" #-}+{-# COMPILE JS non-assoc      = "non-assoc"   #-}++{-# COMPILE JS Precedence     =+  function (x,v) {+    if (x === "unrelated") { return v[x](); } else { return v["related"](x); }} #-}+{-# COMPILE JS related        = function(x) { return x; } #-}+{-# COMPILE JS unrelated      = "unrelated"               #-}++{-# COMPILE JS Fixity         = function (x,v) { return v["fixity"](x["assoc"], x["prec"]); } #-}+{-# COMPILE JS fixity         = function (x) { return function (y) { return { "assoc": x, "prec": y}; }; } #-}+ primitive   primQNameFixity : Name → Fixity+  primQNameToWord64s : Name → Σ Word64 (λ _ → Word64)  -- Metavariables -- @@ -63,6 +81,7 @@   primMetaEquality : Meta → Meta → Bool   primMetaLess     : Meta → Meta → Bool   primShowMeta     : Meta → String+  primMetaToNat    : Meta → Nat  -- Arguments -- @@ -83,10 +102,25 @@ {-# BUILTIN RELEVANT   relevant   #-} {-# BUILTIN IRRELEVANT irrelevant #-} +-- Arguments also have a quantity.+data Quantity : Set where+  quantity-0 quantity-ω : Quantity++{-# BUILTIN QUANTITY   Quantity   #-}+{-# BUILTIN QUANTITY-0 quantity-0 #-}+{-# BUILTIN QUANTITY-ω quantity-ω #-}++-- Relevance and quantity are combined into a modality.+data Modality : Set where+  modality : (r : Relevance) (q : Quantity) → Modality++{-# BUILTIN MODALITY             Modality #-}+{-# BUILTIN MODALITY-CONSTRUCTOR modality #-}+ data ArgInfo : Set where-  arg-info : (v : Visibility) (r : Relevance) → ArgInfo+  arg-info : (v : Visibility) (m : Modality) → ArgInfo -data Arg (A : Set) : Set where+data Arg {a} (A : Set a) : Set a where   arg : (i : ArgInfo) (x : A) → Arg A  {-# BUILTIN ARGINFO    ArgInfo  #-}@@ -94,9 +128,19 @@ {-# 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 : Set) : Set where+data Abs {a} (A : Set a) : Set a where   abs : (s : String) (x : A) → Abs A  {-# BUILTIN ABS    Abs #-}@@ -106,6 +150,7 @@  data Literal : Set where   nat    : (n : Nat)    → Literal+  word64 : (n : Word64) → Literal   float  : (x : Float)  → Literal   char   : (c : Char)   → Literal   string : (s : String) → Literal@@ -114,36 +159,22 @@  {-# BUILTIN AGDALITERAL   Literal #-} {-# BUILTIN AGDALITNAT    nat     #-}+{-# BUILTIN AGDALITWORD64 word64  #-} {-# BUILTIN AGDALITFLOAT  float   #-} {-# BUILTIN AGDALITCHAR   char    #-} {-# BUILTIN AGDALITSTRING string  #-} {-# BUILTIN AGDALITQNAME  name    #-} {-# BUILTIN AGDALITMETA   meta    #-} --- Patterns -- -data Pattern : Set where-  con    : (c : Name) (ps : List (Arg Pattern)) → Pattern-  dot    : Pattern-  var    : (s : String)  → Pattern-  lit    : (l : Literal) → Pattern-  proj   : (f : Name)    → Pattern-  absurd : Pattern--{-# BUILTIN AGDAPATTERN   Pattern #-}-{-# BUILTIN AGDAPATCON    con     #-}-{-# BUILTIN AGDAPATDOT    dot     #-}-{-# BUILTIN AGDAPATVAR    var     #-}-{-# BUILTIN AGDAPATLIT    lit     #-}-{-# BUILTIN AGDAPATPROJ   proj    #-}-{-# BUILTIN AGDAPATABSURD absurd  #-}---- Terms --+-- Terms and patterns -- -data Sort   : Set-data Clause : Set-data Term   : Set+data Term    : Set+data Sort    : Set+data Pattern : Set+data Clause  : Set Type = Term+Telescope = List (Σ String λ _ → Arg Type)  data Term where   var       : (x : Nat) (args : List (Arg Term)) → Term@@ -160,15 +191,27 @@ data Sort where   set     : (t : Term) → Sort   lit     : (n : Nat) → Sort+  prop    : (t : Term) → Sort+  propLit : (n : Nat) → Sort+  inf     : (n : Nat) → Sort   unknown : Sort +data Pattern where+  con    : (c : Name) (ps : List (Arg Pattern)) → Pattern+  dot    : (t : Term)    → Pattern+  var    : (x : Nat)     → Pattern+  lit    : (l : Literal) → Pattern+  proj   : (f : Name)    → Pattern+  absurd : (x : Nat)     → Pattern  -- absurd patterns counts as variables+ data Clause where-  clause        : (ps : List (Arg Pattern)) (t : Term) → Clause-  absurd-clause : (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 AGDASORT    Sort   #-}-{-# BUILTIN AGDATERM    Term   #-}-{-# BUILTIN AGDACLAUSE  Clause #-}+{-# BUILTIN AGDATERM      Term    #-}+{-# BUILTIN AGDASORT      Sort    #-}+{-# BUILTIN AGDAPATTERN   Pattern #-}+{-# BUILTIN AGDACLAUSE    Clause  #-}  {-# BUILTIN AGDATERMVAR         var       #-} {-# BUILTIN AGDATERMCON         con       #-}@@ -183,8 +226,18 @@  {-# BUILTIN AGDASORTSET         set     #-} {-# BUILTIN AGDASORTLIT         lit     #-}+{-# BUILTIN AGDASORTPROP        prop    #-}+{-# BUILTIN AGDASORTPROPLIT     propLit #-}+{-# BUILTIN AGDASORTINF         inf     #-} {-# BUILTIN AGDASORTUNSUPPORTED unknown #-} +{-# BUILTIN AGDAPATCON    con     #-}+{-# BUILTIN AGDAPATDOT    dot     #-}+{-# BUILTIN AGDAPATVAR    var     #-}+{-# BUILTIN AGDAPATLIT    lit     #-}+{-# BUILTIN AGDAPATPROJ   proj    #-}+{-# BUILTIN AGDAPATABSURD absurd  #-}+ {-# BUILTIN AGDACLAUSECLAUSE clause        #-} {-# BUILTIN AGDACLAUSEABSURD absurd-clause #-} @@ -193,8 +246,8 @@ data Definition : Set where   function    : (cs : List Clause) → Definition   data-type   : (pars : Nat) (cs : List Name) → Definition-  record-type : (c : Name) → Definition-  data-cons   : (d : Name) → Definition+  record-type : (c : Name) (fs : List (Arg Name)) → Definition+  data-cons   : (d : Name) (q : Quantity) → Definition   axiom       : Definition   prim-fun    : Definition @@ -211,65 +264,223 @@ 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 --  postulate-  TC            : ∀ {a} → Set a → Set a-  returnTC      : ∀ {a} {A : Set a} → A → TC A-  bindTC        : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B-  unify         : Term → Term → TC ⊤-  typeError     : ∀ {a} {A : Set a} → List ErrorPart → TC A-  inferType     : Term → TC Type-  checkType     : Term → Type → TC Term-  normalise     : Term → TC Term-  reduce        : Term → TC Term-  catchTC       : ∀ {a} {A : Set a} → TC A → TC A → TC A-  quoteTC       : ∀ {a} {A : Set a} → A → TC Term-  unquoteTC     : ∀ {a} {A : Set a} → Term → TC A-  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-  freshName     : String → TC Name-  declareDef    : Arg Name → Type → TC ⊤-  defineFun     : Name → List Clause → TC ⊤-  getType       : Name → TC Type-  getDefinition : Name → TC Definition-  blockOnMeta   : ∀ {a} {A : Set a} → Meta → TC A-  commitTC      : TC ⊤-  isMacro       : Name → TC Bool+  TC               : ∀ {a} → Set a → Set a+  returnTC         : ∀ {a} {A : Set a} → A → TC A+  bindTC           : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B+  unify            : Term → Term → TC ⊤+  typeError        : ∀ {a} {A : Set a} → List ErrorPart → TC A+  inferType        : Term → TC Type+  checkType        : Term → Type → TC Term+  normalise        : Term → TC Term+  reduce           : Term → TC Term+  catchTC          : ∀ {a} {A : Set a} → TC A → TC A → TC A+  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 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+  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 -{-# BUILTIN AGDATCM              TC            #-}-{-# BUILTIN AGDATCMRETURN        returnTC      #-}-{-# BUILTIN AGDATCMBIND          bindTC        #-}-{-# BUILTIN AGDATCMUNIFY         unify         #-}-{-# BUILTIN AGDATCMTYPEERROR     typeError     #-}-{-# BUILTIN AGDATCMINFERTYPE     inferType     #-}-{-# BUILTIN AGDATCMCHECKTYPE     checkType     #-}-{-# BUILTIN AGDATCMNORMALISE     normalise     #-}-{-# BUILTIN AGDATCMREDUCE        reduce        #-}-{-# BUILTIN AGDATCMCATCHERROR    catchTC       #-}-{-# BUILTIN AGDATCMQUOTETERM     quoteTC       #-}-{-# BUILTIN AGDATCMUNQUOTETERM   unquoteTC     #-}-{-# BUILTIN AGDATCMGETCONTEXT    getContext    #-}-{-# BUILTIN AGDATCMEXTENDCONTEXT extendContext #-}-{-# BUILTIN AGDATCMINCONTEXT     inContext     #-}-{-# BUILTIN AGDATCMFRESHNAME     freshName     #-}-{-# BUILTIN AGDATCMDECLAREDEF    declareDef    #-}-{-# BUILTIN AGDATCMDEFINEFUN     defineFun     #-}-{-# BUILTIN AGDATCMGETTYPE       getType       #-}-{-# BUILTIN AGDATCMGETDEFINITION getDefinition #-}-{-# BUILTIN AGDATCMBLOCKONMETA   blockOnMeta   #-}-{-# BUILTIN AGDATCMCOMMIT        commitTC      #-}-{-# BUILTIN AGDATCMISMACRO       isMacro       #-}-{-# BUILTIN AGDATCMWITHNORMALISATION withNormalisation #-}+  -- If 'true', makes the following primitives to reconstruct hidden arguments:+  -- getDefinition, normalise, reduce, inferType, checkType and getContext+  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 ⊤++  -- 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                     #-}+{-# BUILTIN AGDATCMUNIFY                      unify                      #-}+{-# BUILTIN AGDATCMTYPEERROR                  typeError                  #-}+{-# BUILTIN AGDATCMINFERTYPE                  inferType                  #-}+{-# BUILTIN AGDATCMCHECKTYPE                  checkType                  #-}+{-# BUILTIN AGDATCMNORMALISE                  normalise                  #-}+{-# BUILTIN AGDATCMREDUCE                     reduce                     #-}+{-# BUILTIN AGDATCMCATCHERROR                 catchTC                    #-}+{-# BUILTIN AGDATCMQUOTETERM                  quoteTC                    #-}+{-# BUILTIN AGDATCMUNQUOTETERM                unquoteTC                  #-}+{-# BUILTIN AGDATCMQUOTEOMEGATERM             quoteωTC                   #-}+{-# BUILTIN AGDATCMGETCONTEXT                 getContext                 #-}+{-# BUILTIN AGDATCMEXTENDCONTEXT              extendContext              #-}+{-# BUILTIN AGDATCMINCONTEXT                  inContext                  #-}+{-# 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 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 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+-- that code will run properly.+{-# COMPILE JS returnTC          = _ => _ => _ =>      undefined #-}+{-# COMPILE JS bindTC            = _ => _ => _ => _ =>+                                   _ => _ =>           undefined #-}+{-# COMPILE JS unify             = _ => _ =>           undefined #-}+{-# COMPILE JS typeError         = _ => _ => _ =>      undefined #-}+{-# COMPILE JS inferType         = _ =>                undefined #-}+{-# COMPILE JS checkType         = _ => _ =>           undefined #-}+{-# COMPILE JS normalise         = _ =>                undefined #-}+{-# COMPILE JS reduce            = _ =>                undefined #-}+{-# COMPILE JS catchTC           = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS quoteTC           = _ => _ => _ =>      undefined #-}+{-# COMPILE JS unquoteTC         = _ => _ => _ =>      undefined #-}+{-# COMPILE JS quoteωTC          = _ => _ =>           undefined #-}+{-# COMPILE JS getContext        =                     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 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 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 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
@@ -0,0 +1,17 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Reflection.External where++open import Agda.Builtin.List+open import Agda.Builtin.Nat+open import Agda.Builtin.Sigma+open import Agda.Builtin.String+open import Agda.Builtin.Reflection++postulate+  execTC : String → List String → String+         → TC (Σ Nat (λ _ → Σ String (λ _ → String)))++{-# BUILTIN AGDATCMEXEC execTC #-}++{-# COMPILE JS execTC = _ => _ => _ => undefined #-}
+ src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda view
@@ -0,0 +1,11 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Reflection.Properties where++open import Agda.Builtin.Reflection+open import Agda.Builtin.Equality++primitive++  primMetaToNatInjective : ∀ a b → primMetaToNat a ≡ primMetaToNat b → a ≡ b+  primQNameToWord64sInjective : ∀ a b → primQNameToWord64s a ≡ primQNameToWord64s b → a ≡ b
+ src/data/lib/prim/Agda/Builtin/Sigma.agda view
@@ -0,0 +1,17 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Sigma where++open import Agda.Primitive++record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where+  constructor _,_+  field+    fst : A+    snd : B fst++open Σ public++infixr 4 _,_++{-# BUILTIN SIGMA Σ #-}
src/data/lib/prim/Agda/Builtin/Size.agda view
@@ -1,10 +1,21 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --no-universe-polymorphism --sized-types+            --no-guardedness --level-universe #-}  module Agda.Builtin.Size where -{-# BUILTIN SIZEUNIV SizeU #-}-{-# BUILTIN SIZE     Size   #-}-{-# BUILTIN SIZELT   Size<_ #-}-{-# BUILTIN SIZESUC  ↑_     #-}-{-# BUILTIN SIZEINF  ω      #-}-{-# BUILTIN SIZEMAX  _⊔ˢ_  #-}+{-# BUILTIN SIZEUNIV SizeUniv #-}+{-# BUILTIN SIZE     Size     #-}+{-# BUILTIN SIZELT   Size<_   #-}+{-# BUILTIN SIZESUC  ↑_       #-}+{-# BUILTIN SIZEINF  ∞        #-}+{-# BUILTIN SIZEMAX  _⊔ˢ_     #-}++{-# FOREIGN GHC+  type SizeLT i = ()+  #-}++{-# COMPILE GHC Size   = type ()     #-}+{-# COMPILE GHC Size<_ = type SizeLT #-}+{-# COMPILE GHC ↑_     = \_ -> ()    #-}+{-# COMPILE GHC ∞      = ()          #-}+{-# COMPILE GHC _⊔ˢ_   = \_ _ -> ()  #-}
src/data/lib/prim/Agda/Builtin/Strict.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --without-K #-}+{-# 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,25 +1,36 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.String where  open import Agda.Builtin.Bool-open import Agda.Builtin.List open import Agda.Builtin.Char+open import Agda.Builtin.List+open import Agda.Builtin.Maybe+open import Agda.Builtin.Nat using (Nat)+open import Agda.Builtin.Sigma  postulate String : Set {-# BUILTIN STRING String #-}  primitive+  primStringUncons   : String → Maybe (Σ Char (λ _ → String))   primStringToList   : String → List Char   primStringFromList : List Char → String   primStringAppend   : String → String → String   primStringEquality : String → String → Bool   primShowChar       : Char → String   primShowString     : String → String+  primShowNat        : Nat → String -{-# COMPILED_JS primStringToList function(x) { return x.split(""); } #-}-{-# COMPILED_JS primStringFromList function(x) { return x.join(""); } #-}-{-# COMPILED_JS primStringAppend function(x) { return function(y) { return x+y; }; } #-}-{-# COMPILED_JS primStringEquality function(x) { return function(y) { return x===y; }; } #-}-{-# COMPILED_JS primShowChar function(x) { return x; } #-}-{-# COMPILED_JS primShowString function(x) { return x; } #-}+{-# COMPILE JS primStringUncons = function(x) {+   if (x === "") { return z_jAgda_Agda_Builtin_Maybe["Maybe"]["nothing"]; };+   return z_jAgda_Agda_Builtin_Maybe["Maybe"]["just"](z_jAgda_Agda_Builtin_Sigma["_,_"](x.charAt(0))(x.slice(1)));+   }+ #-}+{-# COMPILE JS primStringToList = function(x) { return x.split(""); } #-}+{-# COMPILE JS primStringFromList = function(x) { return x.join(""); } #-}+{-# COMPILE JS primStringAppend = function(x) { return function(y) { return x+y; }; } #-}+{-# 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 x.toString(); } #-}
+ src/data/lib/prim/Agda/Builtin/String/Properties.agda view
@@ -0,0 +1,11 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.String.Properties where++open import Agda.Builtin.String+open import Agda.Builtin.Equality++primitive++  primStringToListInjective : ∀ a b → primStringToList a ≡ primStringToList b → a ≡ b+  primStringFromListInjective : ∀ a b → primStringFromList a ≡ primStringFromList b → a ≡ b
src/data/lib/prim/Agda/Builtin/TrustMe.agda view
@@ -1,7 +1,15 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.TrustMe where  open import Agda.Builtin.Equality+open import Agda.Builtin.Equality.Erase -primitive primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y+private+  postulate+    unsafePrimTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y++primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y+primTrustMe = primEraseEquality unsafePrimTrustMe++{-# DISPLAY primEraseEquality unsafePrimTrustMe = primTrustMe #-}
src/data/lib/prim/Agda/Builtin/Unit.agda view
@@ -1,4 +1,5 @@-{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Unit where @@ -6,4 +7,4 @@   instance constructor tt  {-# BUILTIN UNIT ⊤ #-}-{-# COMPILED_DATA ⊤ () () #-}+{-# COMPILE GHC ⊤ = data () (()) #-}
+ src/data/lib/prim/Agda/Builtin/Word.agda view
@@ -0,0 +1,13 @@+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Word where++open import Agda.Builtin.Nat++postulate Word64 : Set+{-# BUILTIN WORD64 Word64 #-}++primitive+  primWord64ToNat   : Word64 → Nat+  primWord64FromNat : Nat → Word64
+ src/data/lib/prim/Agda/Builtin/Word/Properties.agda view
@@ -0,0 +1,10 @@+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}++module Agda.Builtin.Word.Properties where++open import Agda.Builtin.Word+open import Agda.Builtin.Equality++primitive++  primWord64ToNatInjective : ∀ a b → primWord64ToNat a ≡ primWord64ToNat b → a ≡ b
src/data/lib/prim/Agda/Primitive.agda view
@@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --without-K #-}+{-# OPTIONS --cubical-compatible --no-import-sorts --level-universe #-}  module Agda.Primitive where @@ -10,17 +10,26 @@  infixl 6 _⊔_ +{-# 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. -{-# COMPILED_TYPE Level () #-}-{-# BUILTIN LEVEL Level    #-}+{-# BUILTIN LEVEL Level #-}  postulate   lzero : Level
+ src/data/lib/prim/Agda/Primitive/Cubical.agda view
@@ -0,0 +1,78 @@+{-# OPTIONS --erased-cubical #-}++module Agda.Primitive.Cubical where++{-# BUILTIN CUBEINTERVALUNIV IUniv #-}  -- IUniv : SSet₁+{-# BUILTIN INTERVAL I  #-}  -- I : IUniv++{-# BUILTIN IZERO    i0 #-}+{-# BUILTIN IONE     i1 #-}++-- I is treated as the type of booleans.+{-# COMPILE JS i0 = false #-}+{-# COMPILE JS i1 = true  #-}++infix  30 primINeg+infixr 20 primIMin primIMax++primitive+    primIMin : I → I → I+    primIMax : I → I → I+    primINeg : I → I++{-# BUILTIN ISONE    IsOne    #-}  -- IsOne : I → Setω++postulate+  itIsOne : IsOne i1+  IsOne1  : ∀ i j → IsOne i → IsOne (primIMax i j)+  IsOne2  : ∀ i j → IsOne j → IsOne (primIMax i j)++{-# BUILTIN ITISONE  itIsOne  #-}+{-# BUILTIN ISONE1   IsOne1   #-}+{-# BUILTIN ISONE2   IsOne2   #-}++-- IsOne i is treated as the unit type.+{-# COMPILE JS itIsOne = { "tt" : a => a["tt"]() } #-}+{-# COMPILE JS IsOne1 =+  _ => _ => _ => { return { "tt" : a => a["tt"]() } }+  #-}+{-# COMPILE JS IsOne2 =+  _ => _ => _ => { return { "tt" : a => a["tt"]() } }+  #-}++-- Partial : ∀{ℓ} (i : I) (A : Set ℓ) → Set ℓ+-- Partial i A = IsOne i → A++{-# BUILTIN PARTIAL  Partial  #-}+{-# BUILTIN PARTIALP PartialP #-}++postulate+  isOneEmpty : ∀ {ℓ} {A : Partial i0 (Set ℓ)} → PartialP i0 A++{-# BUILTIN ISONEEMPTY isOneEmpty #-}++-- Partial i A and PartialP i A are treated as IsOne i → A.+{-# COMPILE JS isOneEmpty =+  _ => x => _ => x({ "tt" : a => a["tt"]() })+  #-}++primitive+  primPOr : ∀ {ℓ} (i j : I) {A : Partial (primIMax i j) (Set ℓ)}+            → (u : PartialP i (λ z → A (IsOne1 i j z)))+            → (v : PartialP j (λ z → A (IsOne2 i j z)))+            → PartialP (primIMax i j) A++  -- Computes in terms of primHComp and primTransp+  primComp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) {φ : I} (u : ∀ i → Partial φ (A i)) (a : A i0) → A i1++syntax primPOr p q u t = [ p ↦ u , q ↦ t ]++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/data/postprocess-latex.pl 
@@ -1,24 +0,0 @@-#!/usr/bin/env perl--use strict;-use warnings;--my $tag_prefix = "AgdaTag";-my $underscore = "AgdaUnderscore";-my $commands   = qr"(InductiveConstructor|CoinductiveConstructor\-                    |Datatype|Field|Function|Module|Postulate|Record)";--while (<>) {--  s|(\\Agda$commands){(.*?)}--   | my $cmd = $1;-     my $arg = $3;-     my $tag = "$tag_prefix-$3" =~ s/\\_/$underscore/gr;--     $_ = "\n%<*$tag>\n$cmd\{$arg\}\n%</$tag>\n";-   |gxe;--  print;--}
− src/data/uhc-agda-base/LICENSE 
− src/data/uhc-agda-base/src/UHC/Agda/Builtins.hs 
@@ -1,478 +0,0 @@-module UHC.Agda.Builtins-  ( -- Integer-    primShowInteger-  , primIntegerQuot-  , primIntegerRem-  , primIntegerMinus-  , primIntegerPlus-  , primIntegerTimes-  , primIntegerGreaterOrEqual-  , primIntegerEquality-  , primIntegerLess-    -- Levels-  , primLevelZero-  , primLevelSuc-  , primLevelMax-    --  Nat-  , Nat (..)-  , primIntegerToNat-  , primNatToInteger-  , primNatMinus-  , primNatPlus-  , primNatTimes-  , primNatDivSuc-  , primNatDivSucAux-  , primNatModSuc-  , primNatModSucAux-  , primNatEquality-  , primNatLess-    -- IO-  , primReturn-  , primBind-  , primGetContents-  , primReadFile-  , primWriteFile-  , primAppendFile-  , primPutStr-  , primPutStrLn-  , primReadFiniteFile-    -- String-  , primStringAppend-  , primStringEquality-  , primStringFromList-  , primStringToList-  , primShowString-    -- Char-  , primCharToNat-  , primCharEquality-  , primShowChar-  , primIsLower-  , primIsDigit-  , primIsAlpha-  , primIsSpace-  , primIsAscii-  , primIsLatin1-  , primIsPrint-  , primIsHexDigit-  , primToUpper-  , primToLower-  , primNatToChar-    -- Float-  , primShowFloat-  , primMkFloat-  , primFloatEquality-  , primFloatNumericalEquality-  , primFloatNumericalLess-  , primNatToFloat-  , primFloatPlus-  , primFloatMinus-  , primFloatTimes-  , primFloatNegate-  , primFloatDiv-  , primFloatSqrt-  , primRound-  , primFloor-  , primCeiling-  , primExp-  , primLog-  , primSin-  , primCos-  , primTan-  , primASin-  , primACos-  , primATan-  , primATan2-    -- Reflection-  , QName (..)-  , primMkQName-  , primQNameEquality-  , primQNameLess-  , primShowQName-  , primQNameFixity-  , primMetaEquality-  , primMetaLess-  , primShowMeta--    -- Debugging-  , primTrace--    -- Misc-  , primIfThenElse-  , primSeq-  , unit-  )-where--import Prelude-import qualified Data.Char as C-import Debug.Trace-import UHC.OldException (onException)-import System.IO (openFile, IOMode (ReadMode), hClose, hFileSize, hGetContents)----------------------------------------------------------------------------------- Adapted from the ieee754 package. See the LICENSE file.-foreign import ccall "double.h identical" c_identical :: Double -> Double -> Int--identicalIEEE :: Double -> Double -> Bool-identicalIEEE x y = c_identical x y /= 0----------------------------------------------------------------------------------- internal helper for this file-notImplError :: String -> a-notImplError f = error $ "Feature " ++ f ++ " is not implemented in the UHC backend!"---- ====================--- Integer--- ====================--primShowInteger :: Integer -> String-primShowInteger = show--primIntegerQuot :: Integer -> Integer -> Integer-primIntegerQuot = quot--primIntegerRem :: Integer -> Integer -> Integer-primIntegerRem = rem--primIntegerMinus :: Integer -> Integer -> Integer-primIntegerMinus = (-)--primIntegerPlus :: Integer -> Integer -> Integer-primIntegerPlus = (+)--primIntegerTimes :: Integer -> Integer -> Integer-primIntegerTimes = (*)--primIntegerGreaterOrEqual :: Integer -> Integer -> Bool-primIntegerGreaterOrEqual = (>=)--primIntegerLess :: Integer -> Integer -> Bool-primIntegerLess = (<)--primIntegerEquality :: Integer -> Integer -> Bool-primIntegerEquality = (==)---- ====================--- Levels--- ====================--primLevelZero :: ()-primLevelZero = ()--primLevelSuc :: () -> ()-primLevelSuc _ = ()--primLevelMax :: () -> () -> ()-primLevelMax _ _ = ()---- ====================--- Nat--- ====================--newtype Nat = Nat Integer--liftN2 :: (Integer -> Integer -> Integer) -> Nat -> Nat -> Nat-liftN2 f x y = Nat (f (unNat x) (unNat y))--unNat :: Nat -> Integer-unNat (Nat i) = i--primNatToInteger :: Nat -> Integer-primNatToInteger = unNat---- unsafe!-primIntegerToNat :: Integer -> Nat-primIntegerToNat = Nat--primNatPlus :: Nat -> Nat -> Nat-primNatPlus = liftN2 (+)--primNatTimes :: Nat -> Nat -> Nat-primNatTimes = liftN2 (*)--primNatMinus :: Nat -> Nat -> Nat-primNatMinus x y = Nat $ max 0 (unNat x - unNat y)--primNatDivSuc :: Nat -> Nat -> Nat-primNatDivSuc x y = Nat $ div (unNat x) (unNat y + 1)--primNatDivSucAux :: Nat -> Nat -> Nat -> Nat -> Nat-primNatDivSucAux (Nat k) (Nat m) (Nat n) (Nat j) =-  Nat $ k + div (max 0 $ n + m - j) (m + 1)--primNatModSuc :: Nat -> Nat -> Nat-primNatModSuc x y = Nat $ mod (unNat x) (unNat y + 1)--primNatModSucAux :: Nat -> Nat -> Nat -> Nat -> Nat-primNatModSucAux (Nat k) (Nat m) (Nat n) (Nat j) =-  Nat $ if n > j then mod (n - j - 1) (m + 1) else k + n--primNatEquality :: Nat -> Nat -> Bool-primNatEquality x y = unNat x == unNat y--primNatLess :: Nat -> Nat -> Bool-primNatLess x y = unNat x < unNat y---- ====================--- IO--- ====================---- Calling haskell functions with class constraints from Agda--- isn't supported yet, so just remove the class constraints on return/bind--primReturn :: a -> IO a-primReturn = return--primBind :: IO a -> (a -> IO b) -> IO b-primBind = (>>=)--primGetContents :: IO String-primGetContents = getContents--primReadFile :: FilePath -> IO String-primReadFile = readFile--primWriteFile :: FilePath -> String -> IO ()-primWriteFile = writeFile--primAppendFile :: FilePath -> String -> IO ()-primAppendFile = appendFile--primPutStr :: String -> IO ()-primPutStr = putStr--primPutStrLn :: String -> IO ()-primPutStrLn = putStrLn--primReadFiniteFile :: FilePath -> IO String-primReadFiniteFile f = do-  h <- openFile f ReadMode-  hFileSize h `onException` hClose h-  hGetContents h---- ====================--- String--- ====================--primStringFromList :: [Char] -> String-primStringFromList = id--primStringToList :: String -> [Char]-primStringToList = id--primStringAppend :: String -> String -> String-primStringAppend = (++)--primStringEquality :: String -> String -> Bool-primStringEquality = (==)--primShowString :: String -> String-primShowString = id---- ====================--- Char--- ====================--primCharToNat :: Char -> Nat-primCharToNat c = primIntegerToNat (fromIntegral (fromEnum c))--primNatToChar :: Nat -> Char-primNatToChar i = toEnum (fromInteger (primNatToInteger i))--primCharEquality :: Char -> Char -> Bool-primCharEquality = (==)--primShowChar :: Char -> String-primShowChar c = show c--primIsLower     :: Char -> Bool-primIsLower     = C.isLower--primIsDigit     :: Char -> Bool-primIsDigit     = C.isDigit--primIsAlpha     :: Char -> Bool-primIsAlpha     = C.isAlpha--primIsSpace     :: Char -> Bool-primIsSpace     = C.isSpace--primIsAscii     :: Char -> Bool-primIsAscii     = C.isAscii--primIsLatin1    :: Char -> Bool-primIsLatin1    = C.isLatin1--primIsPrint     :: Char -> Bool-primIsPrint     = C.isPrint--primIsHexDigit  :: Char -> Bool-primIsHexDigit  = C.isHexDigit--primToUpper     :: Char -> Char-primToUpper     = C.toUpper--primToLower     :: Char -> Char-primToLower     = C.toLower---- ====================--- Float--- ====================--positiveNaN :: Double-positiveNaN = 0.0 / 0.0--primShowFloat :: Double -> String-primShowFloat x-  | isNaN x          = "NaN"-  | isInfinite x     = if x < 0 then "-Infinity" else "Infinity"-  | otherwise        = reverse . dropZeroes . reverse $ show x-  where-    -- GHC drops trailing zeroes, UHC doesn't seem to do so. Quick fix for now...-    dropZeroes s@(_ : '.' : _) = s  -- don't drop the last one though-    dropZeroes ('0' : s)       = dropZeroes s-    dropZeroes s               = s--primMkFloat :: String -> Double-primMkFloat = read---- ASR (2016-09-29). We use bitwise equality for comparing Double--- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove a--- contradiction (see Issue #2169).-primFloatEquality :: Double -> Double -> Bool-primFloatEquality x y = identicalIEEE x y || (isNaN x && isNaN y)--primFloatNumericalEquality :: Double -> Double -> Bool-primFloatNumericalEquality = (==)---- Adapted from the same function on Agda.Syntax.Literal.-compareFloat :: Double -> Double -> Ordering-compareFloat x y-  | identicalIEEE x y          = EQ-  | isNegInf x                 = LT-  | isNegInf y                 = GT-  | isNaN x && isNaN y         = EQ-  | isNaN x                    = LT-  | isNaN y                    = GT-  | otherwise                  = compare x y-  where-    isNegInf z = z < 0 && isInfinite z--primFloatNumericalLess :: Double -> Double -> Bool-primFloatNumericalLess x y =-  case compareFloat x y of-    LT -> True-    _  -> False--primNatToFloat :: Nat -> Double-primNatToFloat n = fromIntegral (unNat n)--primFloatPlus :: Double -> Double -> Double-primFloatPlus = (+)--primFloatMinus :: Double -> Double -> Double-primFloatMinus = (-)--primFloatTimes :: Double -> Double -> Double-primFloatTimes = (*)--primFloatNegate :: Double -> Double-primFloatNegate = negate--primFloatDiv :: Double -> Double -> Double-primFloatDiv = (/)--primFloatSqrt :: Double -> Double-primFloatSqrt = sqrt--primRound :: Double -> Integer-primRound = round--primFloor :: Double -> Integer-primFloor = floor--primCeiling :: Double -> Integer-primCeiling = ceiling--primExp :: Double -> Double-primExp = exp--primLog :: Double -> Double-primLog = log--primSin :: Double -> Double-primSin = sin--primCos :: Double -> Double-primCos = cos--primTan :: Double -> Double-primTan = tan--primASin :: Double -> Double-primASin = asin--primACos :: Double -> Double-primACos = acos--primATan :: Double -> Double-primATan = atan--primATan2 :: Double -> Double -> Double-primATan2 = atan2---- ====================--- Reflection--- ====================-data QName = QName { nameId, moduleId ::Integer, qnameString :: String }--primMkQName :: Integer -> Integer -> String -> QName-primMkQName = QName--instance Eq QName where-  (QName a b _) == (QName c d _) = (a, b) == (c, d)-instance Ord QName where-  compare (QName a b _) (QName c d _) = compare (a, b) (c, d)--primQNameEquality :: QName -> QName -> Bool-primQNameEquality = (==)--primQNameLess :: QName -> QName -> Bool-primQNameLess = (<)--primShowQName :: QName -> String-primShowQName = qnameString--primQNameFixity :: QName -> a-primQNameFixity = error "TODO: primQNameFixity"--type Meta = Integer--primMetaEquality :: Meta -> Meta -> Bool-primMetaEquality = (==)--primMetaLess :: Meta -> Meta -> Bool-primMetaLess = (<)--primShowMeta :: Meta -> String-primShowMeta x = "_" ++ show x---- ====================--- Debugging--- ====================-primTrace :: String -> b -> b-primTrace = trace---- ====================--- Misc--- ====================--primIfThenElse :: Bool -> a -> a -> a-primIfThenElse c t e = if c then t else e--primSeq :: a -> b -> b-primSeq = seq---- | Unit wrapper function (instead of dropping a dummy function inside each module).-unit :: ()-unit = ()
− src/data/uhc-agda-base/src/UHC/Agda/double.c 
@@ -1,12 +0,0 @@-#include <stdint.h>--union cast {-  double   x;-  uint64_t n;-};--int identical (double x, double y) {-  union cast cx = { .x = x };-  union cast cy = { .x = y };-  return cx.n == cy.n;-}
− src/data/uhc-agda-base/src/UHC/Agda/double.h 
@@ -1,2 +0,0 @@--int identical (double x, double y);
− src/data/uhc-agda-base/uhc-agda-base.cabal 
@@ -1,25 +0,0 @@--- Initial uhc-agda-base.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/---- ATTENTION: normally this package gets built using UHC directly without cabal!--- The version of this package, when built directly using UHC, is the version of Agda.--- In the long term, it would be nice if we could use "cabal install --uhc" to install this package.--name:                uhc-agda-base-version:             0.1.0.0-synopsis:            Builtins implementation for Agda UHC Backend--- description:-license:             AllRightsReserved-license-file:        LICENSE-author:              Philipp Hausmann-maintainer:          ph_git@314.ch--- copyright:-category:            Development-build-type:          Simple-cabal-version:       >=1.8--library-  exposed-modules:     UHC.Agda.Builtins-  -- other-modules:-  build-depends:       base ==4.6.*-  hs-source-dirs:      src
− src/full/Agda/Auto/Auto.hs 
@@ -1,514 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.Auto.Auto (auto) where--import Prelude hiding (null)--import Control.Monad.State-import Data.List hiding (null)-import qualified Data.Map as Map-import Data.IORef-import qualified System.Timeout-import Data.Maybe-import Data.Functor-import qualified Data.Traversable as Trav--import Agda.Utils.Permutation (permute, takeP)-import Agda.TypeChecking.Monad hiding (withCurrentModule)--- import Agda.TypeChecking.Monad.Base--- import Agda.TypeChecking.Monad.MetaVars--- import Agda.TypeChecking.Monad.Context--- import Agda.TypeChecking.Monad.Signature-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope--import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Pretty (prettyA)-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 (abstractToConcreteEnv, abstractToConcrete_, makeEnv, runAbsToCon, toConcrete)-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 qualified Agda.Utils.HashMap as HMap--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.Except ( runExceptT, MonadError(catchError) )-import Agda.Utils.Functor-import Agda.Utils.Impossible-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Utils.Tuple--#include "undefined.h"--insertAbsurdPattern :: String -> String-insertAbsurdPattern [] = []-insertAbsurdPattern s@(_:_) | take (length abspatvarname) s == abspatvarname = "()" ++ drop (length abspatvarname) s-insertAbsurdPattern (c:s) = c : insertAbsurdPattern s--getName :: A.Expr -> Maybe (Bool, I.QName)-getName (A.ScopedExpr _ e) = getName e-getName (A.Def qname) = Just (False, qname)-getName (A.Proj _ qname) = Just (False, head $ I.unAmbQ qname)-getName (A.Con qname) = Just (True, head $ I.unAmbQ qname)-getName _ = Nothing--dispmsg :: String ->-           TCM (Either [(InteractionId, String)]-                       (Either [String] String)-               , Maybe String)-dispmsg msg = return (Left [], Just msg)---- | Entry point for Auto tactic (Agsy).------     @auto ii rng s = return (res, mmsg)@------   If @mmsg = Just msg@, the message @msg@ produced by Agsy should---   be displayed to the user.------   The result @res@ of the Auto tactic can be one of the following three:------   1. @Left [(ii,s)]@---      A list of solutions @s@ for interaction ids @ii@.---      In particular, @Left []@ means Agsy found no solution.------   2. @Right (Left cs)@---      A list of clauses (the user allowed case-split).------   3. @Right (Right s)@---      A refinement for the interaction id @ii@ in which Auto was invoked.--auto-  :: InteractionId-  -> Range-  -> String-  -> TCM ( Either [(InteractionId, String)]-                  (Either [String] String)-         , Maybe String)-auto ii rng argstr = do--  -- Parse hints and other configuration.-  let (hints, timeout, pick, mode, hintmode) = parseargs argstr-  ahints <- case mode of-    MRefine{} -> return []-    _         -> mapM (parseExprIn ii rng) hints-  let failHints = dispmsg "Hints must be a list of constant names"-  caseMaybe (mapM getName ahints) failHints $ \ ehints -> do--    -- Get names for equality reasoning.-    -- @eqstuff == []@ if any of these names is not defined.-    eqstuffExprs <- mapM (parseExprIn ii rng) ["_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"]-      `catchError`-        (\_ -> return [])-    let eqstuff = fromMaybe [] $ mapM getName eqstuffExprs--    -- 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, _, _, _) -> frommy (Meta m)) $ 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 (timeout * 1000000) $ 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 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 Agda.Auto.Syntax.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 <- liftM reverse $ liftIO $ readIORef sols-                if null rsols then do-                  nsol' <- liftIO $ readIORef nsol-                  dispmsg $ 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 (/= ' ') . show-                      disp [(_, cexpr)] = ss cexpr-                      disp cexprs = concat $ map (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs-                  ticks <- liftIO $ readIORef ticks-                  dispmsg $ unlines $-                    ("Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1)) :-                    for (zip cexprss [pick..]) (\ (x, y) -> show y ++ "  " ++ disp x)-            _ -> dispmsg "Metavariable dependencies not allowed in disprove mode"-           _ -> dispmsg "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 ++ "s)"-                            | otherwise     = ""-          if listmode then do-            rsols <- liftM reverse $ liftIO $ readIORef sols-            if null rsols then do-              nsol' <- liftIO $ readIORef nsol-              dispmsg $ 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)] = show cexpr-                  disp cexprs = concat $ for cexprs $ \ (mi, cexpr) ->-                    maybe (show mi) show (lookup mi riis)-                      ++ " := " ++ show cexpr ++ " "-              ticks <- liftIO $ readIORef ticks-              dispmsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++-                        "\n" ++ unlines (map (\(x, y) -> show y ++ "  " ++ disp x) $ zip cexprss [pick..])-           else {- not listmode -}-            case res of-             Nothing -> do-              nsol' <- liftIO $ readIORef nsol-              dispmsg $ insuffsols (pick + numsols - nsol') ++ timeoutString-             Just depthreached -> do-              ticks <- liftIO $ readIORef ticks-              rsols <- liftIO $ readIORef sols-              case rsols of-                [] -> do-                  nsol' <- liftIO $ readIORef nsol-                  dispmsg $ 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 [] = return (Left [], Just "")-                  loop (term : terms') = do-                    -- On exception, try next solution-                    flip catchError (const $ loop terms') $ do-                      exprs <- getsols term-                      reportSDoc "auto" 20 $ TCM.text "Trying solution " TCM.<+> TCM.prettyTCM exprs-                      giveress <- forM exprs $ \ (mi, expr0) -> do-                        let expr = killRange expr0-                        case lookup mi riis of-                         Nothing ->-                          -- catchError-                           (giveExpr 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 ii' Nothing expr-                                        mv <- lookupMeta mi-                                        let scope = getMetaScope mv-                                        ce <- abstractToConcreteEnv (makeEnv scope) ae-                                        let cmnt = if ii' == ii then agsyinfo ticks else ""-                                        return (Just (ii', show 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' = case msgs of-                                  [] -> Nothing-                                  _ -> Just $ unlines msgs-                      return (Left $ catMaybes $ map 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 = map (\((hid, id), t) -> HI hid (id, t)) (zip 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 (timeout * 1000000) (-             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{} -> dispmsg "No solution found"-             Right cls' -> do-              cls'' <- forM cls' $ \ (I.Clause _ tel ps body t catchall) -> do-                withCurrentModule (AN.qnameModule def) $ do-                 -- Normalise the dot patterns-                 ps <- addContext tel $ normalise ps-                 body <- etaContract body-                 liftM modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange tel ps body t catchall-              moduleTel <- lookupSection (AN.qnameModule def)-              pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls''-              ticks <- liftIO $ readIORef ticks---              return (Right $ Left (map (insertAbsurdPattern . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode })) pcs), Nothing)--           Just [] -> dispmsg "No solution found" -- case not possible at the moment because case split doesnt care about search exhaustiveness-           Nothing -> dispmsg $ "No solution found at time out (" ++ show timeout ++ "s)"-         _ -> dispmsg "Metavariable dependencies not allowed in case split mode"-       _ -> dispmsg "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 elem "-a" 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-        liftM catMaybes $ mapM (\n ->-          case thisdefinfo of-           Just (def, _, _) | def == n -> return Nothing-           _ -> do-            cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n-            if head (show cn) == '.' then -- not in scope-              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 (show 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-        liftM 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 (show cn, score)-         ) modnames--      let sorthits = 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-             dispmsg $ insuffcands $ length sorthits-            else-             let showhits = take 10 $ drop pick' sorthits-             in dispmsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++-                           unlines (map (\(i, (cn, _)) -> show i ++ "  " ++ cn) (zip [pick'..pick' + length showhits - 1] showhits))-       else-        if pick >= length sorthits then-         dispmsg $ insuffcands $ length sorthits-        else-         return (Right $ Right (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 [(Bool, AN.QName)]-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 (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 []--insuffsols :: Int -> String-insuffsols 0 = "No solution found"-insuffsols n = "Only " ++ show n ++ " solution(s) found"--insuffcands :: Int -> String-insuffcands 0 = "No candidate found"-insuffcands n = "Only " ++ show n ++ " candidate(s) found"--data Mode = MNormal Bool Bool -- true if list mode, true if disprove--          | MCaseSplit--          | MRefine Bool -- true if list mode---data AutoHintMode = AHMNone-                  | AHMModule--parseargs :: String -> ([String], Int, Int, Mode, AutoHintMode)-parseargs s =- let r ("-t" : timeout : ws) (_, pick, mode, hintmode) =-      r ws (read timeout, pick, mode, hintmode)-     r ("-s" : pick : ws) (timeout, _, mode, hintmode) =-      r ws (timeout, read pick, mode, hintmode)---     r ("-l" : ws) (timeout, pick, MNormal _ disprove, hintmode) =-      r ws (timeout, pick, MNormal True disprove, hintmode)-     r ("-l" : ws) (timeout, pick, MRefine _, hintmode) =-      r ws (timeout, pick, MRefine True, hintmode)-     r ("-d" : ws) (timeout, pick, MNormal listmode _, hintmode) =-      r ws (timeout, pick, MNormal listmode True, hintmode)-     r ("-m" : ws) (timeout, pick, mode, _) =-      r ws (timeout, pick, mode, AHMModule)--     r ("-c" : ws) (timeout, pick, _, hintmode) =-      r ws (timeout, pick, MCaseSplit, hintmode)--     r ("-r" : ws) (timeout, pick, _, hintmode) =-      r ws (timeout, (-1), MRefine False, hintmode)-     r (h : ws) x =-      let (hints, timeout, pick, mode, hintmode) = r ws x-      in (h : hints, timeout, pick, mode, hintmode)-     r [] (x,y,z,w) = ([],x,y,z,w)- in r (words s) (5, 0, MNormal False False, AHMNone)
− src/full/Agda/Auto/CaseSplit.hs 
@@ -1,655 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.Auto.CaseSplit where--import Data.IORef-import Data.List (findIndex, union)-import qualified Data.IntMap as IntMap--import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax--import Agda.Auto.SearchControl-import Agda.Auto.Typecheck--#include "undefined.h"-import Agda.Utils.Impossible--abspatvarname :: String-abspatvarname = "\0absurdPattern"--costCaseSplitVeryHigh, costCaseSplitHigh, costCaseSplitLow, costAddVarDepth-  :: Nat-costCaseSplitVeryHigh = 10000-costCaseSplitHigh     = 5000-costCaseSplitLow      = 2000-costAddVarDepth       = 1000--data HI a = HI FMode 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 -> Int -> 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 depth ctx tt termcheckenv = do---      nsol <- newIORef 1-      m <- initMeta-      sol <- newIORef Nothing-      let trm = Meta m-          hsol = do trm' <- expandExp trm---                    writeIORef sol (Just trm')---          hpartsol = __IMPOSSIBLE__--          initcon = mpret $ Sidecondition (localTerminationSidecond termcheckenv recdef trm)-                                          (--                                           (case meqr of-                                            Nothing -> id-                                            Just eqr -> mpret . Sidecondition (calcEqRState eqr trm)-                                           )--                                           (tcSearch False (map (\(id, t) -> (id, closify t)) (drophid ctx)) (closify tt) trm)-                                          )-      recdefd <- readIORef recdef-      let env = RIEnv {rieHints = (recdef, HMRecCall) : map (\x -> (x, HMNormal)) chints,-                       rieDefFreeVars = cddeffreevars recdefd--                       , rieEqReasoningConsts = meqr--                      }-      depreached <- topSearch ticks nsol hsol env initcon depth (depth + 1)-      rsol <- readIORef sol-      return rsol-     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 . (Int -> CSCtx o -> MExp o -> ([Nat], Nat, [Nat]) -> IO (Maybe (MExp o))) -> Int -> Int -> ConstRef o -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o]-caseSplitSearch' branchsearch depthinterval depth recdef ctx tt pats = do-  recdefd <- readIORef recdef-  sols <- rc depth (cddeffreevars recdefd) ctx tt pats-  return sols- where-  rc :: Int -> 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 [] = 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 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 (stringToMyId 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 t of-                        Pi _ h _ it (Abs id ot) ->-                         let (xs, inft) = ff ot-                         in ((Pair h (scrut + length xs), id, lift (scrut + length xs + 1) it) : xs, inft)-                        _ -> ([], lift scrut t)-              (newvars, inftype) = ff (cdtype cond)-              constrapp = mm $ App Nothing (mm OKVal) (Const con) (foldl (\xs (Pair h v, _, _) -> mm $ ALCons h (mm $ App Nothing (mm OKVal) (Var v) (mm ALNil)) xs) (mm ALNil) (reverse newvars))-              pconstrapp = CSPatConApp con (map (\(Pair 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 (map (\((Pair hid _, id, t), i) ->-                       HI hid (Id (case id of {NoId -> newvarprefix{- ++ show i-}; Id id -> id}), t)-                      ) (zip 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 = if null mblkvar then-                         if scrut < length ctx - nscrutavoid && nothid then costCaseSplitLow + costAddVarDepth * depthofvar scrut pats else costCaseSplitVeryHigh-                        else-                         if elem scrut mblkvar then costCaseSplitLow else (if scrut < length ctx - nscrutavoid && nothid then costCaseSplitHigh else costCaseSplitVeryHigh)--                 nothid = let HI hid _ = ctx !! scrut-                          in case hid of {Hidden -> False; Instance -> False; NotHidden -> True}---             sols <- rc (depth - cost) (length ctx - 1 - scrut) ctx2 tt2 pats2-             case sols of-              [] -> return []-              _ -> do-               sols2 <- dobranches cons-               return $ concat (map (\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-replace :: Nat -> Nat -> MExp o -> MExp o -> MExp o-replace sv nnew re = r 0- where-  r n e =-   case rm e of-         App uid ok elr@(Var v) args ->-          if v >= n then-           if v - n == sv then-            betareduce (lift n re) (rs n args)-           else-            if v - n > sv then-             mm $ App uid ok (Var (v + nnew - 1)) (rs n args)-            else-             mm $ App uid ok elr (rs n args)-          else-           mm $ App uid ok elr (rs n args)-         App uid ok elr@(Const _) args ->-          mm $ App uid ok elr (rs n args)-         Lam hid (Abs mid e) -> mm $ Lam hid (Abs mid (r (n + 1) e))-         Pi uid hid possdep it (Abs mid ot) -> mm $ Pi uid hid possdep (r n it) (Abs mid (r (n + 1) ot))-         Sort{} -> e--         AbsurdLambda{} -> e---  rs n es =-   case rm es of-    ALNil -> mm $ ALNil-    ALCons hid a as -> mm $ ALCons hid (r n a) (rs n as)--    ALProj{} -> __IMPOSSIBLE__---    ALConPar as -> mm $ ALConPar (rs n as)---betareduce :: MExp o -> MArgList o -> MExp o-betareduce e args = case rm args of- ALNil -> e- ALCons _ a rargs -> case rm e of-  App uid ok elr eargs -> mm $ 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 :: MM (ArgList o) (RefInfo o) -> MArgList o -> MArgList o-concatargs xs ys = case rm xs of-  ALNil -> ys--  ALCons hid x xs -> mm $ ALCons hid x (concatargs xs ys)--  ALProj{} -> __IMPOSSIBLE__--  ALConPar as -> mm $ ALConPar (concatargs xs ys)--eqelr :: Elr o -> Elr o -> Bool-eqelr (Var v1) (Var v2) = v1 == v2-eqelr (Const c1) (Const c2) = c1 == c2-eqelr _ _ = False--replacep :: Nat -> Nat -> CSPatI o -> MExp o -> CSPat o -> CSPat o-replacep sv nnew rp re = r- where-  r (HI hid (CSPatConApp c ps)) = HI hid (CSPatConApp c (map r ps))-  r (HI hid (CSPatVar v)) = if v == sv then-                    HI hid rp-                   else-                    if v > sv then-                     HI hid (CSPatVar (v + nnew - 1))-                    else-                     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--rm :: MM a b -> a-rm (NotM x) = x-rm (Meta{}) = __IMPOSSIBLE__--mm :: a -> MM a b-mm = NotM--unifyexp :: MExp o -> MExp o -> Maybe [(Nat, MExp o)]-unifyexp e1 e2 = r e1 e2 (\unif -> Just unif) []- where-  r e1 e2 cont unif = case (rm e1, rm e2) of-   (App _ _ elr1 args1, App _ _ elr2 args2) | eqelr elr1 elr2 -> rs args1 args2 cont unif-   (Lam hid1 (Abs _ b1), Lam hid2 (Abs _ b2)) | hid1 == hid2 -> r b1 b2 cont unif-   (Pi _ hid1 _ it1 (Abs _ ot1), Pi _ hid2 _ it2 (Abs _ ot2)) | hid1 == hid2 -> r it1 it2 (r ot1 ot2 cont) unif-   (Sort _, Sort _) -> cont unif -- a bit sloppy-   (App _ _ (Var v) (NotM ALNil), App _ _ (Var u) (NotM ALNil))-     | v == u -> cont unif-   (App _ _ (Var v) (NotM ALNil), _)-     | elem v (freevars e2) -> Nothing -- Occurs check-   (_, App _ _ (Var v) (NotM ALNil))-     | elem v (freevars e1) -> Nothing -- Occurs check-   (App _ _ (Var v) (NotM ALNil), _) ->-    case lookup v unif of-     Nothing -> cont ((v, e2) : unif)-     Just e1' -> r e1' e2 cont unif-   (_, App _ _ (Var v) (NotM ALNil)) ->-    case lookup v unif of-     Nothing -> cont ((v, e1) : unif)-     Just e2' -> r e1 e2' cont unif-   _ -> Nothing-  rs args1 args2 cont unif = case (rm args1, rm args2) of-   (ALNil, ALNil) -> cont unif-   (ALCons hid1 a1 as1, ALCons hid2 a2 as2) | hid1 == hid2 -> r a1 a2 (rs as1 as2 cont) unif-   (ALConPar as1, ALCons _ _ as2) -> rs as1 as2 cont unif-   (ALCons _ _ as1, ALConPar as2) -> rs as1 as2 cont unif-   (ALConPar as1, ALConPar as2) -> rs as1 as2 cont unif-   _ -> Nothing--lift :: Nat -> MExp o -> MExp o-lift 0 = id-lift n = r 0- where-  r j e =-   case rm e of-         App uid ok elr args -> case elr of-          Var v | v >= j -> mm $ App uid ok (Var (v + n)) (rs j args)-          _ -> mm $ App uid ok elr (rs j args)-         Lam hid (Abs mid e) -> mm $ Lam hid (Abs mid (r (j + 1) e))-         Pi uid hid possdep it (Abs mid ot) -> mm $ Pi uid hid possdep (r j it) (Abs mid (r (j + 1) ot))-         Sort{} -> e--         AbsurdLambda{} -> e---  rs j es =-   case rm es of-    ALNil -> mm $ ALNil-    ALCons hid a as -> mm $ ALCons hid (r j a) (rs j as)--    ALProj{} -> __IMPOSSIBLE__---    ALConPar as -> mm $ ALConPar (rs 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'--notequal :: Nat -> Nat -> MExp o -> MExp o -> IO Bool-notequal firstnew nnew e1 e2 =-  case (rm e1, rm e2) of-   (App _ _ _ es1, App _ _ _ es2) -> rs es1 es2 (\_ -> return False) []-   _ -> __IMPOSSIBLE__- where-  rs :: MArgList o -> MArgList o -> ([(Nat, MExp o)] -> IO Bool) -> [(Nat, MExp o)] -> IO Bool-  rs es1 es2 cont unifier2 =-   case (rm es1, rm es2) of-    (ALCons _ e1 es1, ALCons _ e2 es2) -> r e1 e2 (rs es1 es2 cont) unifier2--    (ALConPar es1, ALConPar es2) -> rs es1 es2 cont unifier2--    _ -> cont unifier2--  r :: MExp o -> MExp o -> ([(Nat, MExp o)] -> IO Bool) -> [(Nat, MExp o)] -> IO Bool-  r e1 e2 cont unifier2 = case rm e2 of-   App _ _ (Var v2) es2 | firstnew <= v2 && v2 < firstnew + nnew ->-    case rm es2 of-     ALNil ->-      case lookup v2 unifier2 of-       Nothing -> cont ((v2, e1) : unifier2)-       Just e2' -> cc e1 e2'-     ALCons{} -> cont unifier2--     ALProj{} -> __IMPOSSIBLE__---     ALConPar{} -> __IMPOSSIBLE__--   _ -> cc e1 e2-   where-   cc e1 e2 = case (rm e1, rm e2) of-    (App _ _ (Const c1) es1, App _ _ (Const c2) es2) -> do-     cd1 <- readIORef c1-     cd2 <- readIORef c2-     case (cdcont cd1, cdcont cd2) of-      (Constructor{}, Constructor{}) ->-       if c1 == c2 then-        rs es1 es2 cont unifier2-       else-        return True-      _ -> cont unifier2-    _ -> cont unifier2--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 (\(x,y) -> (y,x)) (IntMap.toList m)) of-    Nothing -> Nothing-    Just i -> r (foldl (\m i -> IntMap.adjust (\x -> x - 1) i m) (IntMap.insert i (-1) m) (frees !! i)) (i : perm) (n - 1)- in r m [] (length ts)--freevars :: MExp o -> [Nat]-freevars = f 0- where-  f n e = case rm e of-   App _ _ (Var v) args -> union [v - n] (fs n args)-   App _ _ (Const _) args -> fs n args-   Lam _ (Abs _ b) -> f (n + 1) b-   Pi _ _ _ it (Abs _ ot) -> union (f n it) (f (n + 1) ot)-   Sort{} -> []--   AbsurdLambda{} -> []---  fs n es = case rm es of-   ALNil -> []-   ALCons _ e es -> union (f n e) (fs n es)--   ALProj{} -> __IMPOSSIBLE__---   ALConPar es -> fs n es--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 (renamep (ren perm)) pats- in (ctx3, tt', pats')--ren :: [Nat] -> Nat -> Int-ren n i = let Just j = findIndex (== i) n in j--rename :: (Nat -> Nat) -> MExp o -> MExp o-rename ren = r 0- where-  r j e =-   case rm e of-         App uid ok elr args -> case elr of-          Var v | v >= j -> mm $ App uid ok (Var (ren (v - j) + j)) (rs j args)-          _ -> mm $ App uid ok elr (rs j args)-         Lam hid (Abs mid e) -> mm $ Lam hid (Abs mid (r (j + 1) e))-         Pi uid hid possdep it (Abs mid ot) -> mm $ Pi uid hid possdep (r j it) (Abs mid (r (j + 1) ot))-         Sort{} -> e--         AbsurdLambda{} -> e---  rs j es =-   case rm es of-    ALNil -> mm $ ALNil-    ALCons hid a as -> mm $ ALCons hid (r j a) (rs j as)--    ALProj{} -> __IMPOSSIBLE__---    ALConPar as -> mm $ ALConPar (rs j as)---renamep :: (Nat -> Nat) -> CSPat o -> CSPat o-renamep ren = r- where-  r (HI hid (CSPatConApp c pats)) = HI hid (CSPatConApp c (map r pats))-  r (HI hid (CSPatVar i)) = HI hid (CSPatVar $ ren i)-  r (HI hid (CSPatExp e)) = HI hid (CSPatExp $ rename ren e)--  r p@(HI _ CSOmittedArg) = p--  r _ = __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') = if v == v' then [d] else []-     f _ _ = []- in depth---- ----------------------localTerminationEnv :: [CSPat o] -> ([Nat], Nat, [Nat])-localTerminationEnv pats =- let g _ [] = ([], 0, [])-     g i (hp@(HI _ p) : ps) = case p of-      CSPatConApp{} ->-       let (size, vars) = h hp-           (is, size', vars') = g (i + 1) ps-       in (i : is, size + size', vars ++ vars')-      _ -> g (i + 1) ps-     h (HI _ p) = case p of-      CSPatConApp c ps ->-       let (size, vars) = hs ps-       in (size + 1, vars)-      CSPatVar n -> (0, [n])-      CSPatExp e -> he e-      _ -> (0, [])-     hs [] = (0, [])-     hs (p : ps) =-      let (size, vars) = h p-          (size', vars') = hs ps-      in (size + size', vars ++ vars')-     he e = case rm e of-      App _ _ (Var v) _ -> (0, [v])-      App _ _ (Const _) args ->-       let (size, vars) = hes args-       in (size + 1, vars)-      _ -> (0, [])-     hes as = case rm as of-      ALNil -> (0, [])-      ALCons _ a as ->-       let (size, vars) = he a-           (size', vars') = hes as-       in (size + size', vars ++ vars')--      ALProj{} -> __IMPOSSIBLE__---      ALConPar as -> hes as-- in g 0 pats---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 | elem i 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 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-             (_:_) -> case last blks 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,797 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.Auto.Convert where--import Control.Applicative hiding (getConst, Const(..))-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Traversable (traverse)-import Control.Monad.State--import Agda.Syntax.Concrete (exprFieldA)-import qualified Agda.Syntax.Internal as I-import qualified Agda.Syntax.Internal.Pattern as IP-import qualified Agda.Syntax.Common as Common-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.Utils.Permutation (Permutation(Perm), permute, takeP, compactP)-import Agda.TypeChecking.Level (reallyUnLevelView)-import Agda.TypeChecking.Monad.Base (mvJudgement, mvPermutation, getMetaInfo, ctxEntry, 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 (piApply, applySubst, renamingR)-import Agda.TypeChecking.Telescope (piApplyM)-import qualified Agda.TypeChecking.Substitute as I (absBody)-import Agda.TypeChecking.Reduce (Normalise, normalise, instantiate)-import Agda.TypeChecking.EtaContract (etaContract)-import Agda.TypeChecking.Monad.Builtin (constructorForm)-import Agda.TypeChecking.Free (freeIn)-import qualified Agda.Utils.HashMap as HMap--import Agda.Interaction.MakeCase (getClauseForIP)--import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax--import Agda.Auto.CaseSplit hiding (lift)--import Agda.Utils.Either-import Agda.Utils.Except-  ( Error(strMsg)-  , ExceptT-  , MonadError(throwError)-  )-import Agda.Utils.Lens--import Agda.Utils.Impossible-#include "undefined.h"---norm :: Normalise t => t -> MB.TCM t-norm x = normalise x---norm x = return x--type O = (Maybe Int, 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--tomy :: I.MetaId -> [(Bool, AN.QName)] -> [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 <- fst `liftM` gets sConsts-     let (mode, c) = cmap Map.! cn-     def <- lift $ getConstInfo cn-     let typ = MB.defType def-         defn = MB.theDef def-     typ <- lift $ norm typ-     typ' <- tomyType typ-     let clausesToDef clauses = do-           clauses' <- tomyClauses 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.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.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)) = Common.Arg (Common.domInfo it) (I.var n) :-                                           pars (n - 1) (I.unAbs typ)-           pars n (I.El s (I.Shared p))  = pars n (I.El s (I.derefPtr p))-           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' <- tomyType $ contyp 0 tel-       cc <- lift $ liftIO $ readIORef c-       let Datatype [con] [] = cdcont cc-       lift $ liftIO $ modifyIORef con (\cdef -> cdef {cdtype = contyp'})--       projfcns <- mapM (\name -> getConst False name TMAll) (map Common.unArg 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' <- tomyExp sol-         modify $ \s -> s {sEqs = (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol')) (fst $ sEqs s), snd $ sEqs s)}-       let tt = MB.jMetaType $ mvJudgement mv-           minfo = getMetaInfo mv-           localVars = map (snd . Common.unDom . ctxEntry) . envContext . clEnv $ minfo-       (targettype, localVars) <- lift $ withMetaInfo minfo $ do-        vs <- getContextArgs-        targettype <- tt `piApplyM` permute (takeP (length vs) $ mvPermutation mv) vs-        targettype <- norm targettype-        localVars <- mapM norm localVars-        return (targettype, localVars)-       modify (\s -> s {sCurMeta = Just mi})-       typ' <- tomyType targettype-       ctx' <- mapM tomyType localVars-       modify (\s -> s {sCurMeta = Nothing})-       modify (\s -> s {sMetas = (Map.adjust (\(m, _, deps) -> (m, Just (typ', ctx'), deps)) mi (fst $ sMetas s), snd $ 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' <- tomyExp e-         i' <- tomyExp i-         modify (\s -> s {sEqs = (Map.adjust (\_ -> Just (ineq, e', i')) eqi (fst $ sEqs s), snd $ sEqs s)})-         r projfcns-        Nothing ->-         return projfcns- ((icns', typs'), s) <- runStateT-  (do _ <- getMeta imi-      icns' <- mapM (\(iscon, name) -> getConst iscon name TMAll) icns-      typs' <- mapM tomyType 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-   cmap <- fst `liftM` gets 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 = show name ++ ".CONS", cdorigin = (Just nomi, conname), cdtype = __IMPOSSIBLE__, cdcont = Constructor (nomi - dfv), cddeffreevars = dfv}) -- ?? correct value of deffreevars for records?-     c <- lift $ liftIO $ newIORef (ConstDef {cdname = show 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 <- fst `liftM` gets 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.theDef def-       return (Just npar, show dname ++ "." ++ show (I.qnameName name))-      else-       return (Nothing, show 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 Common.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 <- fst `liftM` gets 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 = do- eqs <- getAllConstraints- let r = mapM (\eqc -> do-          neqc <- norm eqc-          case MB.clValue $ MB.theConstraint neqc of-           MB.ValueCmp ineq _ i e -> do-            ei <- etaContract i-            ee <- etaContract e-            return [(tomyIneq ineq, ee, ei)]-           MB.TypeCmp ineq i e -> do-            I.El _ ei <- etaContract i-            I.El _ ee <- etaContract e-            return [(tomyIneq ineq, ee, ei)]-           MB.Guarded (MB.UnBlock _) pid -> return []-           _ -> return []-         )- eqs' <- r eqs- return $ concat eqs'--copatternsNotImplemented :: MB.TCM a-copatternsNotImplemented = MB.typeError $ MB.NotImplemented $-  "The Agda synthesizer (Agsy) does not support copatterns yet"--tomyClauses :: [I.Clause] -> TOM [([Pat O], MExp O)]-tomyClauses [] = return []-tomyClauses (cl:cls) = do- cl' <- tomyClause cl- cls' <- tomyClauses cls- return $ case cl' of-  Just cl' -> cl' : cls'-  Nothing -> cls'--tomyClause :: I.Clause -> TOM (Maybe ([Pat O], MExp O))-tomyClause 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 tomyPat $ IP.unnumberPatVars pats- body' <- traverse tomyExp =<< lift (norm body)- return $ case body' of-           Just body' -> Just (pats', body')-           Nothing    -> Nothing--tomyPat :: Common.Arg I.Pattern -> TOM (Pat O)-tomyPat p = case Common.unArg p of- I.ProjP{} -> lift $ copatternsNotImplemented- I.VarP n -> return $ PatVar (show 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 (tomyPat . fmap Common.namedThing) pats-  def <- lift $ getConstInfo n-  cc <- lift $ liftIO $ readIORef c-  let Just npar = fst $ cdorigin cc-  return $ PatConApp c (replicate npar PatExp ++ pats')- I.LitP _ -> throwError $ strMsg "Auto: Literals in patterns are not supported"--weaken :: Int -> MExp O -> MExp O-weaken _ e@(Meta m) = e-weaken i (NotM e) =- case e of-  App uid okh elr as ->-   let elr' = case elr of-               Var v -> if v >= i then Var (v + 1) else elr-               Const{} -> elr-       as' = weakens i as-   in NotM $ App uid okh elr' as'-  Lam hid (Abs mid t) ->-   let t' = weaken (i + 1) t-   in NotM $ Lam hid (Abs mid t')-  Pi uid hid possdep x (Abs mid y) ->-   let x' = weaken i x-       y' = weaken (i + 1) y-   in NotM $ Pi uid hid possdep x' (Abs mid y')-  Sort{} -> NotM e--  AbsurdLambda{} -> NotM e---weakens :: Int -> MArgList O -> MArgList O-weakens _ as@(Meta m) = as-weakens i (NotM as) =- case as of-  ALNil -> NotM as-  ALCons hid x xs ->-   let x' = weaken i x-       xs' = weakens i xs-   in NotM $ ALCons hid x' xs'--  ALProj{} -> __IMPOSSIBLE__--  ALConPar xs ->-   let xs' = weakens i xs-   in NotM $ ALConPar xs'---tomyType :: I.Type -> TOM (MExp O)-tomyType (I.El _ t) = tomyExp t -- sort info is thrown away--tomyExp :: I.Term -> TOM (MExp O)-tomyExp v0 =-  case I.unSpine v0 of-    I.Var v es -> do-      let Just as = I.allApplyElims es-      as' <- tomyExps as-      return $ NotM $ App Nothing (NotM OKVal) (Var v) as'-    I.Lam info b -> do-      b' <- tomyExp (I.absBody b)-      return $ NotM $ Lam (cnvh info) (Abs (Id $ I.absName b) b')-    t@I.Lit{} -> do-      t <- lift $ constructorForm t-      case t of-        I.Lit{} -> throwError $ strMsg "Auto: Literals in terms are not supported"-        _       -> tomyExp t-    I.Level l -> tomyExp =<< lift (reallyUnLevelView l)-    I.Def name es -> do-      let Just as = I.allApplyElims es-      c   <- getConst False name TMAll-      as' <- tomyExps as-      return $ NotM $ App Nothing (NotM OKVal) (Const c) as'-    I.Con con ci as -> do-      let name = I.conName con-      c   <- getConst True name TMAll-      as' <- tomyExps 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 (Common.Dom info x) b -> do-      let y    = I.absBody b-          name = I.absName b-      x' <- tomyType x-      y' <- tomyType y-      return $ NotM $ Pi Nothing (cnvh info) (Agda.TypeChecking.Free.freeIn 0 y) x' (Abs (Id name) y')-    I.Sort (I.Type (I.Max [I.ClosedLevel l])) -> return $ NotM $ Sort $ Set $ fromIntegral l-    I.Sort _ -> 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 = ( Map.adjust (\(m, x, deps) -> (m, x, mid : deps)) curmeta (fst $ sMetas s)-                                           , snd $ sMetas s-                                           ) }-          m <- getMeta mid-          return $ Meta m-        _ -> tomyExp t-    I.DontCare _ -> return $ NotM $ dontCare-    I.Shared p -> tomyExp $ I.derefPtr p--tomyExps :: I.Args -> TOM (MM (ArgList O) (RefInfo O))-tomyExps [] = return $ NotM ALNil-tomyExps (Common.Arg info a : as) = do- a' <- tomyExp a- as' <- tomyExps as- return $ NotM $ ALCons (cnvh info) a' 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 as-fmExp m (I.Pi x y)  = fmType m (Common.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 m (I.Shared p) = fmExp m $ I.derefPtr p--fmExps :: I.MetaId -> I.Args -> Bool-fmExps m [] = False-fmExps m (a : as) = fmExp m (Common.unArg a) || fmExps m as--fmLevel :: I.MetaId -> I.PlusLevel -> Bool-fmLevel m I.ClosedLevel{} = False-fmLevel m (I.Plus _ l) = case l of-  I.MetaLevel m' _   -> m == m'-  I.NeutralLevel _ v -> fmExp m v-  I.BlockedLevel _ v -> fmExp m v-  I.UnreducedLevel v -> fmExp m v---- -----------------------------------------------cnvh :: Common.LensHiding a => a -> FMode-cnvh info = case Common.getHiding info of-    Common.NotHidden -> NotHidden-    Common.Instance  -> Instance-    Common.Hidden    -> Hidden--icnvh :: FMode -> Common.ArgInfo-icnvh h = Common.setHiding h' $-          Common.setOrigin Common.Inserted $-          Common.defaultArgInfo-    where-    h' = case h of-        NotHidden -> Common.NotHidden-        Instance  -> Common.Instance-        Hidden    -> Common.Hidden---- -----------------------------------------------frommy :: MExp O -> ExceptT String IO I.Term-frommy = frommyExp--frommyType :: MExp O -> ExceptT String IO I.Type-frommyType e = do- e' <- frommyExp e- return $ I.El (I.mkType 0) e'  -- 0 is arbitrary, sort not read by Agda when reifying--frommyExp :: MExp O -> ExceptT String IO I.Term-frommyExp (Meta m) = do- bind <- lift $ readIORef $ mbind m- case bind of-  Nothing -> throwError "meta not bound"-  Just e -> frommyExp (NotM e)-frommyExp (NotM e) =- case e of-  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 -> (n, \ q -> I.Con (I.ConHead q Common.Inductive []) Common.ConOSystem) -- TODO: restore fields-                      Nothing -> (0, \ f vs -> I.Def f $ map I.Apply vs)-   frommyExps ndrop as (h name [])-  Lam hid (Abs mid t) -> do-   t' <- frommyExp t-   return $ I.Lam (icnvh hid) (I.Abs (case mid of {NoId -> "x"; Id id -> id}) t')-  Pi _ hid _ x (Abs mid y) -> do-   x' <- frommyType x-   y' <- frommyType y-   return $ I.Pi (Common.Dom (icnvh hid) x') (I.Abs (case mid of {NoId -> "x"; Id id -> id}) y')-   -- maybe have case for Pi where possdep is False which produces Fun (and has to unweaken y), return $ I.Fun (Common.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 that 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' <- frommyExp x-   frommyExps ndrop xs (addend (Common.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 (Common.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 ++ [x])-  addend x (I.Def h xs) = I.Def h (xs ++ [I.Apply x])-  addend x (I.Shared p) = addend x (I.derefPtr p)-  addend _ _ = __IMPOSSIBLE__---- ----------------------------------abslamvarname :: String-abslamvarname = "\0absurdlambda"--modifyAbstractExpr :: A.Expr -> A.Expr-modifyAbstractExpr = f- where-  f (A.App i e1 (Common.Arg info (Common.Named n e2))) =-        A.App i (f e1) (Common.Arg info (Common.Named n (f e2)))-  f (A.Lam i (A.DomainFree info n) _) | show (A.nameConcrete n) == abslamvarname =-        A.AbsurdLam i $ Common.argInfoHiding info-  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 dots (A.RHS e mc) decls catchall) =-  A.Clause lhs dots (A.RHS (modifyAbstractExpr e) mc) decls catchall-modifyAbstractClause cl = cl---- ------------------------------------constructPats :: Map AN.QName (TMode, ConstRef O) -> I.MetaId -> I.Clause -> MB.TCM ([(FMode, 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 = cnvh $ Common.argInfo p-      in case Common.namedArg p of-       I.VarP 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 (tomyExp t) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm})-        return (ns, HI hid (CSPatExp t2))-       I.ProjP{} -> copatternsNotImplemented-       _ -> __IMPOSSIBLE__- (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' <- frommyType t-      return $ I.ExtendTel (Common.Dom (icnvh hid) t') (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 Common.Inductive [] -- TODO: restore record fields!-        return (I.ConP con I.noConPatternInfo ps')-       CSPatExp e -> do-        e' <- frommyExp e {- renm e -} -- renaming before adding to clause below-        return (I.DotP e')-       CSAbsurd -> __IMPOSSIBLE__ -- CSAbsurd not used-       _ -> __IMPOSSIBLE__-      return $ Common.Arg (icnvh hid) $ Common.unnamed p'   -- TODO: recover names- ps <- cnvps 0 pats- body <- case mrhs of-          Nothing -> return $ Nothing-          Just e -> Just <$> frommyExp e- let cperm =  Perm nv perm- return $ I.Clause-   { I.clauseRange = 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-   }--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 :: Common.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-  (f, clauseNo) <- case ipCl of-    MB.IPClause f clauseNo _ -> return (f, clauseNo)-    MB.IPNoClause -> MB.typeError $ MB.GenericError $-      "Cannot apply the auto tactic here, we are not in a function clause"-  (_, c, _) <- getClauseForIP f clauseNo-  return $ Just (f, c, maybe __IMPOSSIBLE__ toplevel $ I.clauseBody c)-  where-    toplevel e =-     case I.ignoreSharing 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.ignoreSharing $ 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.ignoreSharing $ 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 I.ignoreSharing 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 (I.ignoreSharing e1, I.ignoreSharing 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 (Common.Dom info1 it1) ot1, I.Pi (Common.Dom info2 it2) ot2) | Common.argInfoHiding info1 == Common.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-     (Common.Arg info1 e1 : es1, Common.Arg info2 e2 : es2) | Common.argInfoHiding info1 == Common.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 (Common.Arg info1 e1) : es1, I.Apply (Common.Arg info2 e2) : es2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2-     _ -> Nothing
− src/full/Agda/Auto/NarrowingSearch.hs 
@@ -1,633 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Agda.Auto.NarrowingSearch where--import Data.IORef hiding (writeIORef, modifyIORef)-import qualified Data.IORef as NoUndo (writeIORef, modifyIORef)-import Control.Monad.State--#include "undefined.h"-import Agda.Utils.Impossible--type Prio = Int--class Trav a blk | a -> blk where-  trav :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m ()--instance Trav a blk => Trav (MM a blk) blk where-  trav f me = f me--data Term blk = forall a . Trav a blk => Term a---- | Result of type-checking.-data Prop blk-  = OK-    -- ^ Success.-  | Error String-    -- ^ Definite failure.-  | forall a . AddExtraRef String (Metavar a blk) (Int, RefCreateEnv 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 [(Int, RefCreateEnv 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---- --------------------------type RefCreateEnv blk = StateT ( ( (IORef [SubConstraints blk])), Int) IO--data Pair a b = Pair a b--class Refinable a blk where- refinements :: blk -> [blk] -> Metavar a blk -> IO [(Int, RefCreateEnv blk a)]---newPlaceholder :: RefCreateEnv blk (MM a blk)-newPlaceholder = do- (e@( ( mcompoint)), c) <- get- m <- lift $ newMeta mcompoint- put (e, (c + 1))- return $ Meta m--newOKHandle :: RefCreateEnv blk (OKHandle blk)-newOKHandle = 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 bind ( ( __IMPOSSIBLE__), 0)--type BlkInfo blk = (Bool, Prio, Maybe blk) -- Bool - is principal--data MM a blk = NotM a-              | Meta (Metavar a blk)--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-  case bind of-   Just x -> f x-   Nothing -> fm--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 x -> 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 $ \b -> case b of -- principle constraint is never present for okhandle so it will not be refined-  OKVal -> f--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) -> Int -> Int -> IO Bool-topSearch ticks nsol hsol envinfo p searchdepth depthinterval = do- depthreached <- newIORef False--- mainroot <- newCTree Nothing-- let-  searchSubProb :: [(CTree blk, Maybe (IORef Bool))] -> Int -> 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 :: Int -> 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 :: Refinable a blk => Metavar a blk -> Int -> IO SRes-    fork m depth = do-      blkinfos <- extractblkinfos m-      refs <- refinements envinfo blkinfos m-      f refs-     where-      f [] = do-       erefs <- readIORef $ mextrarefs m-       case erefs of-        [] -> return (Left False)-        _ -> do-         NoUndo.writeIORef (mextrarefs m) []-         f erefs-      f ((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 -> Int -> 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 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-        case res of-         True -> -- failed-          return $ Left False-         False -> 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)-  case res of-   True -> -- failed immediately-    return False-   False -> do-    Left solfound <- lift $ searchSubProb [(mainroot, Nothing)] searchdepth-    dr <- lift $ readIORef depthreached-    return dr--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 [] = return False-recalcs (c : cs) = seqc (recalc c) (recalcs 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 ->-    case res1 of-     True -> return res1-     False -> 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 = ((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 _) = if p1 > p2 then pm1 else if p2 > p1 then pm2 else if flip then pm2 else 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 (not (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 _ x _ = return [(0, return LeftDisjunct), (0, return RightDisjunct)]---instance Refinable OKVal blk where- refinements _ _ _ = __IMPOSSIBLE__ -- OKVal should never be refined----- ------------------------------------
− src/full/Agda/Auto/SearchControl.hs 
@@ -1,375 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE UndecidableInstances  #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.Auto.SearchControl where--import Control.Monad-import Data.IORef-import Control.Monad.State-import Data.Maybe (mapMaybe)--import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax--#include "undefined.h"-import Agda.Utils.Impossible--instance Refinable (ArgList o) (RefInfo o) where- refinements _ infos _ =-  return $ [-            (0, return ALNil),--            (0, cons NotHidden),-            (0, cons Hidden)---           ]--           ++-           (let isdep = rr infos-                rr (RICheckElim isdep : _) = isdep-                rr (_ : xs) = rr xs-                rr _ = __IMPOSSIBLE__-                proj hid = newPlaceholder >>= \p1 -> newPlaceholder >>= \p2 -> newPlaceholder >>= \p3 -> return $ ALProj p1 p2 hid p3-            in if isdep then-                 []-                else--                 [(0, proj NotHidden), (0, proj Hidden)]---           )--  where cons hid = newPlaceholder >>= \p1 -> newPlaceholder >>= \p2 -> return $ ALCons hid p1 p2---data ExpRefInfo o = ExpRefInfo {eriMain :: Maybe (RefInfo o), eriUnifs :: [RefInfo o], eriInfTypeUnknown, eriIsEliminand :: Bool, eriUsedVars :: Maybe ([UId o], [Elr o]),-                                eriIotaStep :: Maybe Bool, eriPickSubsVar :: Bool--                                , eriEqRState :: Maybe EqReasoningState--                               }--getinfo :: [RefInfo o] -> ExpRefInfo o-getinfo = f (ExpRefInfo {eriMain = Nothing-                        , eriUnifs = []-                        , eriInfTypeUnknown = False-                        , eriIsEliminand = False-                        , eriUsedVars = Nothing-                        , eriIotaStep = Nothing-                        , eriPickSubsVar = False-                        , eriEqRState = Nothing-                        }-            )- where-  f i [] = i-  f i (x@RIMainInfo{} : xs) = f (i {eriMain = Just x}) xs-  f i (x@RIUnifInfo{} : xs) = f (i {eriUnifs = x : eriUnifs i}) xs-  f i (RIInferredTypeUnknown : xs) = f (i {eriInfTypeUnknown = True}) xs-  f i (RINotConstructor : xs) = f (i {eriIsEliminand = True}) xs-  f i (RIUsedVars nuids nused : xs) = f (i {eriUsedVars = Just (nuids, nused)}) xs-  f i (RIIotaStep semif : xs) = f (i {eriIotaStep = Just (semif || maybe False id (eriIotaStep i))}) xs-  f i (RIPickSubsvar : xs) = f (i {eriPickSubsVar = True}) xs--  f i (RIEqRState s : xs) = f (i {eriEqRState = Just s}) xs--  f i _ = __IMPOSSIBLE__---univar :: [CAction o] -> Nat -> Maybe Nat-univar cl v = f cl v 0- where- f [] v v' = Just (v' + v)- f (Weak n : _) v v' | v < n = Nothing- f (Weak n : xs) v v' = f xs (v - n) v'- f (Sub _ : xs) v v' = f xs v (v' + 1)- f (Skip : _) 0 v' = Just v'- f (Skip : xs) v v' = f xs (v - 1) (v' + 1)--subsvars :: [CAction o] -> [Nat]-subsvars = f 0- where-  f n [] = []-  f n (Weak _ : xs) = f n xs-  f n (Sub _ : xs) = n : f (n + 1) xs-  f n (Skip : xs) = f (n + 1) xs---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, eriUsedVars = Just (uids, usedvars),-                         eriIotaStep = iotastep, eriPickSubsVar = picksubsvar--                         , eriEqRState = meqrstate--                        } = getinfo infos--   eqrstate = maybe EqRSNone id meqrstate--   app muid elr = do p <- newPlaceholder-                     p <- case elr of-                      Var{} -> return p-                      Const c -> do-                       cd <- 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-                     let uid = case muid of-                                Just _ -> muid-                                Nothing -> Just meta-                     return $ App uid okh elr p-   lam hid id = do-    p <- newPlaceholder-    return $ Lam hid (Abs id p)-   pi muid dep hid =-    do p1 <- newPlaceholder-       p2 <- newPlaceholder-       let uid = case muid of-                  Just _ -> muid-                  Nothing -> Just meta-       return $ Pi uid hid dep p1 (Abs NoId p2)-   set l = return $ Sort (Set l)-  in case unis of-   [] ->-    let--     eqr = maybe __IMPOSSIBLE__ id meqr-     foldargs [] = NotM ALNil-     foldargs ((h, a) : xs) = NotM $ ALCons h a (foldargs xs)-     eq_begin_step_step = (costEqStep,-                       do psb <- replicateM 4 newPlaceholder-                          okhb <- newOKHandle-                          pss1 <- replicateM 6 newPlaceholder-                          okhs1 <- newOKHandle-                          pss2 <- replicateM 7 newPlaceholder-                          okhs2 <- newOKHandle-                          return $ App (Just meta) okhb (Const $ eqrcBegin eqr) (foldargs (zip [Hidden, Hidden, Hidden, Hidden, NotHidden] (psb ++ [-                            NotM $ App (Just meta) okhs1 (Const $ eqrcStep eqr) (foldargs (zip [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] (pss1 ++ [-                             NotM $ App (Just meta) okhs2 (Const $ eqrcStep eqr) (foldargs (zip [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] pss2))-                            ])))-                           ])))-                      )-     eq_step = (costEqStep,-                 do ps <- replicateM 7 newPlaceholder-                    okh <- newOKHandle-                    return $ App (Just meta) okh (Const $ eqrcStep eqr) (foldargs (zip [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] ps))-                )-     eq_end = (costEqEnd,-               do ps <- replicateM 3 newPlaceholder-                  okh <- newOKHandle-                  return $ App (Just meta) okh (Const $ eqrcEnd eqr) (foldargs (zip [Hidden, Hidden, NotHidden] ps))-              )-     eq_sym = (costEqSym,-               do ps <- replicateM 5 newPlaceholder-                  okh <- newOKHandle-                  return $ App (Just meta) okh (Const $ eqrcSym eqr) (foldargs (zip [Hidden, Hidden, Hidden, Hidden, NotHidden] ps))-              )-     eq_cong = (costEqCong,-                do ps <- replicateM 8 newPlaceholder-                   okh <- newOKHandle-                   return $ App (Just meta) okh (Const $ eqrcCong eqr) (foldargs (zip [Hidden, Hidden, Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden] ps))-               )--     pcav i = if inftypeunknown then costInferredTypeUnkown else i-     pc i = pcav i-     varcost v | v < n - deffreevars = pcav (case Just usedvars of {Just usedvars -> if elem v (mapMaybe (\x -> case x of {Var v -> Just v; Const{} -> Nothing}) usedvars) then costAppVarUsed else costAppVar; Nothing -> if picksubsvar then costAppVar else costAppVarUsed})-     varcost v | otherwise = pcav costAppHint-     varapps = map (\v ->-                (varcost v,-                 app Nothing (Var v)-                )) [0..n - 1]-     hintapps = map (\(c, hm) ->-                 (cost c hm,-                  app Nothing (Const c)-                 )) hints-                 where cost c hm = pc (case iotastep of-                                        Just _ -> costIotaStep-                                        Nothing -> if elem c (mapMaybe (\x -> case x of {Var{} -> Nothing; Const c -> Just c}) usedvars) then-                                          case hm of {HMNormal -> costAppHintUsed; HMRecCall -> costAppRecCallUsed}-                                         else-                                          case hm of {HMNormal -> costAppHint; HMRecCall -> costAppRecCall})-     generics = varapps ++ hintapps-    in case tt of--     _ | eqrstate == EqRSChain ->-      return $ [eq_end, eq_step]--     HNPi _ hid possdep _ (Abs id _) -> return $ (pc (if iotastepdone then costLamUnfold else costLam), lam hid id) : (costAbsurdLam, return $ AbsurdLambda hid) : generics--     HNSort (Set l) -> return $ map (\l -> (pc costSort, set l)) [0..l - 1] ++ [(pc costPi, pi Nothing True NotHidden), (pc costPi, pi Nothing True Hidden)] ++ generics---     HNApp _ (Const c) _ -> do-      cd <- readIORef c-      return $ case cdcont cd of-       Datatype cons _--        | eqrstate == EqRSNone--         -> map (\c -> (pc (case iotastep of {Just True -> costUnification; _ -> if length cons <= 1 then costAppConstructorSingle else costAppConstructor}), app Nothing (Const c))) cons ++-            generics--            ++ if maybe False (\eqr -> c == eqrcId eqr) meqr then [eq_sym, eq_cong, eq_begin_step_step] else []-       _ | eqrstate == EqRSPrf1 -> generics ++ [eq_sym, eq_cong]-       _ | eqrstate == EqRSPrf2 -> generics ++ [eq_cong]--       _ -> generics-     _ -> return generics-   (RIUnifInfo cl hne : _) ->-    let-     subsvarapps = map (\v ->-                    (costUnification,-                     app Nothing (Var v)-                    )) (subsvars cl)-     mlam = case tt of-      HNPi _ hid _ _ (Abs id _) -> [(costUnification, lam hid id)]-      _ -> []-     generics = mlam ++ subsvarapps--     pickuid seenuids =-      case f seenuids of-       Just uid -> (uid, True)-       Nothing -> (head seenuids, False) -- ?? which uid to pick-      where f [] = Nothing-            f (Nothing:_) = Just Nothing-            f (Just u:us) = if elem u uids then f us else Just (Just u)-    in-     return $ case hne of-      HNApp seenuids (Var v) _ ->-       let (uid, isunique) = pickuid seenuids-           uni = case univar cl v of-                  Just v | v < n -> [(if isunique then costUnification else costUnificationOccurs, app uid (Var v))]-                  _ -> []-       in uni ++ generics-      HNApp seenuids (Const c) _ ->-       let (uid, isunique) = pickuid seenuids-       in (if isunique then costUnification else costUnificationOccurs, app uid (Const c)) : generics-      HNLam{} -> generics-      HNPi seenuids hid possdep _ _ ->-       let (uid, isunique) = pickuid seenuids-       in (if isunique then costUnification else costUnificationOccurs, pi uid possdep hid) : generics-      HNSort (Set l) -> map (\l -> (costUnification, set l)) [0..l] ++ generics-      HNSort _ -> generics-   _ -> __IMPOSSIBLE__--extraref :: UId o -> [Maybe (UId o)] -> ConstRef o ->-            (Int, StateT (IORef [SubConstraints (RefInfo o)], Int) IO (Exp o))-extraref meta seenuids c = (costAppExtraRef, app (head seenuids) (Const c))- where-   app muid elr = do p <- newPlaceholder-                     okh <- newOKHandle-                     let uid = case muid of-                                Just _ -> muid-                                Nothing -> Just meta-                     return $ App uid okh elr p---instance Refinable (ICExp o) (RefInfo o) where- refinements _ infos _ =-  let (RICopyInfo e : _) = infos-  in return [(0, return e)]---instance Refinable (ConstRef o) (RefInfo o) where- refinements _ [RICheckProjIndex projs] _ = return $ map (\x -> (0, return x)) projs- refinements _ _ _ = __IMPOSSIBLE__----- -----------------------------------costIncrease, costUnificationOccurs, costUnification, costAppVar,-  costAppVarUsed, costAppHint, costAppHintUsed, costAppRecCall,-  costAppRecCallUsed, costAppConstructor, costAppConstructorSingle,-  costAppExtraRef, costLam, costLamUnfold, costPi, costSort, costIotaStep,-  costInferredTypeUnkown, costAbsurdLam-  :: Int--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 :: Int-costEqStep = 2000-costEqEnd = 0-costEqSym = 0-costEqCong = 500--prioNo, prioTypeUnknown, prioTypecheckArgList, prioInferredTypeUnknown,-  prioCompBeta, prioCompBetaStructured, prioCompareArgList, prioCompIota,-  prioCompChoice, prioCompUnif, prioCompCopy, prioNoIota, prioAbsurdLambda,-  prioProjIndex-  :: Int-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 -> Int-prioTypecheck False = 1000-prioTypecheck True = 0---- -----------------------------------instance Trav a blk => Trav [a] blk where-  trav _ []     = return ()-  trav f (x:xs) = trav f x >> trav f xs--instance Trav (MId, CExp o) (RefInfo o) where-  trav f (_, ce) = trav f ce--instance Trav (TrBr a o) (RefInfo o) where-  trav f (TrBr es _) = trav f es--instance Trav (Exp o) (RefInfo o) where-  trav f e = case e of-    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) (RefInfo o) where-  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,400 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.Auto.Syntax where--import Data.IORef--import Agda.Auto.NarrowingSearch--#include "undefined.h"-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, eqrcStep, eqrcEnd, eqrcSym, eqrcCong :: ConstRef o} -- "_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"--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---- | 'Hiding' in Agda.-data FMode = Hidden-           | Instance-           | NotHidden- deriving Eq---data MId = Id String-         | NoId--stringToMyId :: String -> MId-stringToMyId = Id---- | 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 Nat) -- maybe an index to elimand argument, 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)--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 FMode (Abs (MExp o))-    -- ^ Lambda with hiding information.-  | Pi (Maybe (UId o)) FMode Bool (MExp o) (Abs (MExp o))-    -- ^ @True@ if possibly dependent (var not known to not occur).-    --   @False@ if non-dependent.-  | Sort Sort-  | AbsurdLambda FMode-    -- ^ 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 FMode (MExp o) (MArgList o)-    -- ^ Application and tail.--  | ALProj (MArgList o) (MM (ConstRef o) (RefInfo o)) FMode (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 HNExp o = HNApp [Maybe (UId o)] (Elr o) (ICArgList o)-             | HNLam [Maybe (UId o)] FMode (Abs (ICExp o))-             | HNPi [Maybe (UId o)] FMode 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 FMode (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 ()---- ---------------------------------------------metaliseokh :: MExp o -> IO (MExp o)-metaliseokh = fm- where-  fm (Meta m) = return $ Meta m-  fm (NotM e) = do-   e <- f e-   return $ NotM e-  f (App uid _ elr args) = do-   m <- initMeta-   args <- fms args-   return $ App uid (Meta m) elr args-  f (Lam hid (Abs id b)) = do-   b <- fm b-   return $ Lam hid (Abs id b)-  f (Pi uid hid posdep it (Abs id ot)) = do-   it <- fm it-   ot <- fm ot-   return $ Pi uid hid posdep it (Abs id ot)-  f e@(Sort{}) = return e--  f e@(AbsurdLambda{}) = return e---  fms (Meta m) = return $ Meta m-  fms (NotM es) = do-   es <- fs es-   return $ NotM es-  fs ALNil = return ALNil-  fs (ALCons hid a as) = do-   a <- fm a-   as <- fms as-   return $ ALCons hid a as--  fs (ALProj eas idx hid as) = do-   eas <- fms eas-   as <- fms as-   return $ ALProj eas idx hid as---  fs (ALConPar as) = do-   as <- fms as-   return $ ALConPar as----- ---------------------------------------------expandExp :: MExp o -> IO (MExp o)-expandExp = fm- where-  fm (Meta m) = do-   mb <- readIORef $ mbind m-   case mb of-    Nothing -> return $ Meta m-    Just e -> fm (NotM e)-  fm (NotM e) = do-   e <- f e-   return $ NotM e-  f (App uid okh elr args) = do-   args <- fms args-   return $ App uid okh elr args-  f (Lam hid (Abs id b)) = do-   b <- fm b-   return $ Lam hid (Abs id b)-  f (Pi uid hid posdep it (Abs id ot)) = do-   it <- fm it-   ot <- fm ot-   return $ Pi uid hid posdep it (Abs id ot)-  f e@(Sort{}) = return e--  f e@(AbsurdLambda{}) = return e---  fms (Meta m) = do-   mb <- readIORef $ mbind m-   case mb of-    Nothing -> return $ Meta m-    Just es -> fms (NotM es)-  fms (NotM es) = do-   es <- fs es-   return $ NotM es-  fs ALNil = return ALNil-  fs (ALCons hid a as) = do-   a <- fm a-   as <- fms as-   return $ ALCons hid a as--  fs (ALProj eas idx hid as) = do-   idx <- expandbind idx-   eas <- fms eas-   as <- fms as-   return $ ALProj eas idx hid as---  fs (ALConPar as) = do-   as <- fms as-   return $ ALConPar 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 :: Nat -> CExp o -> CExp o-weak n (TrBr trs e) = TrBr trs (weaki n e)--weaki :: Nat -> Clos a o -> Clos a o-weaki 0 x = x-weaki n (Clos as x) = Clos (Weak n : as) x--weakarglist :: Nat -> ICArgList o -> ICArgList o-weakarglist 0 = id-weakarglist n = f- where f CALNil = CALNil-       f (CALConcat (Clos cl as) as2) = CALConcat (Clos (Weak n : cl) as) (f as2)-weakelr :: Nat -> Elr o -> Elr o-weakelr 0 elr = elr-weakelr n (Var v) = Var (v + n)-weakelr _ elr@(Const _) = elr---- | 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 (weaki 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)
− src/full/Agda/Auto/Typecheck.hs 
@@ -1,810 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ScopedTypeVariables       #-}--module Agda.Auto.Typecheck where--import Data.IORef-import Control.Monad (liftM)--import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax-import Agda.Auto.SearchControl--#include "undefined.h"-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 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 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 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 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 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 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 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 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 (hne1, 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 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 hnityp of-   HNPi _ hid2 possdep it (Abs _ ot) | ndfv > 0 || copyarg a || hid == hid2 -> mpret $-    And (Just ((if possdep then [Term a] else []) ++ [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 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 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 :: FMode -> 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 (HNApp (uid : seenuids) (Var v') ncargs)-       Right f -> loop f ncargs (uid : seenuids)-      Const _ -> mbret $ HNDone expmeta (HNApp (uid : seenuids) elr ncargs)-    Lam hid (Abs id b) ->-     mbcase (hnarglist cargs) $ \hncargs -> case hncargs of-      HNALNil -> mbret $ HNDone expmeta (HNLam seenuids 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 (HNPi (uid : seenuids) hid possdep (Clos cl it) (Abs id (Clos (Skip : cl) ot)))-    Sort s -> checkNoArgs cargs $ mbret $ HNDone expmeta (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 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 _ _ = __IMPOSSIBLE__-- 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 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 = f (HNApp [] (Const c) (CALConcat (Clos [] args) CALNil))- where-  f hne@(HNApp _ (Const c) _) = do-   cd <- readIORef c-   let isshorthand =-        case cdcont cd of-         Def _ [(pats, _)] _ _ -> True -- all (\pat -> case pat of {PatConApp{} -> False; _ -> True}) pats-         _ -> False-   if isshorthand then-     mpret OK-    else-     noiotastep hne-  f _ = __IMPOSSIBLE__--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-        sf <- return 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 (hne1, 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 seenuids _ (Abs _ b1), HNApp uid2 elr2 args2) ->-       f True b1 CALNil seenuids $ \res1 -> fhn True mexpmeta2 (HNApp uid2 (weakelr 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weakarglist 1 args2))) $ \res2 -> g res1 res2-      (HNApp uid1 elr1 args1, HNLam seenuids _ (Abs _ b2)) ->-       fhn True mexpmeta1 (HNApp uid1 (weakelr 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weakarglist 1 args1))) $ \res1 -> f True b2 CALNil seenuids $ \res2 -> g res1 res2-{--      (HNLam _ (Abs _ b1), HNApp uid2 elr2 args2) ->-       f True b1 CALNil $ \res1 -> g res1-        (CMRigid mexpmeta2 (HNApp uid2 (weakelr 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weakarglist 1 args2))))-      (HNApp uid1 elr1 args1, HNLam _ (Abs _ b2)) ->-       f True b2 CALNil $ \res2 -> g-        (CMRigid mexpmeta1 (HNApp uid1 (weakelr 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weakarglist 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 uid1 (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 uid1 c1)-      (_, HNApp uid2 (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 uid2 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 = liftM (all id) $ 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{} -> __IMPOSSIBLE__---         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 -> Int -> 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 (all id 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 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,10 +1,4 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE IncoherentInstances       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# OPTIONS_GHC -Wunused-imports #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,16 +6,21 @@  module Agda.Benchmarking where +import Control.DeepSeq import qualified Control.Exception as E  import Data.IORef +import GHC.Generics (Generic)+ import System.IO.Unsafe +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@@ -50,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@@ -65,6 +68,8 @@     -- ^ Subphase for 'Termination'.   | ModuleName     -- ^ Subphase for 'Import'.+  | Compaction+    -- ^ Subphase for 'Deserialization': compacting interfaces.   | BuildInterface     -- ^ Subphase for 'Serialization'.   | Sort@@ -73,8 +78,10 @@     -- ^ Subphase for 'Serialization'.   | Compress     -- ^ Subphase for 'Serialization'.-  | Operators+  | OperatorsExpr     -- ^ Subphase for 'Parsing'.+  | OperatorsPattern+    -- ^ Subphase for 'Parsing'.   | Free     -- ^ Subphase for 'Typing': free variable computation.   | OccursCheck@@ -85,18 +92,54 @@     -- ^ Subphase for 'Typing': checking the RHS   | TypeSig     -- ^ Subphase for 'Typing': checking a type signature+  | Generalize+    -- ^ 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.-  deriving (Eq, Ord, Show, Enum, Bounded)+  | TopModule TopLevelModuleName+  | Typeclass QName+  | Definition QName+  deriving (Eq, Ord, Show, Generic)  instance Pretty Phase where-  pretty = text . show+  pretty (TopModule m)  = pretty m+  pretty (Definition q) = pretty q+  pretty a = text (show a) +instance NFData Phase+ type Benchmark = B.Benchmark Phase type Account   = B.Account Phase +isModuleAccount :: Account -> Bool+isModuleAccount []                = True+isModuleAccount (TopModule{} : _) = True+isModuleAccount _                 = False++isDefAccount :: Account -> Bool+isDefAccount []                 = True+isDefAccount (Definition{} : _) = True+isDefAccount _                  = False++isInternalAccount :: Account -> Bool+isInternalAccount (TopModule{}  : _) = False+isInternalAccount (Definition{} : _) = False+isInternalAccount _                  = True+ -- * Benchmarking in the IO monad.  -- | Global variable to store benchmark statistics.@@ -104,7 +147,8 @@ benchmarks :: IORef Benchmark benchmarks = unsafePerformIO $ newIORef empty -instance MonadBench Phase IO where+instance MonadBench IO where+  type BenchPhase IO = Phase   getBenchmark = readIORef benchmarks   putBenchmark = writeIORef benchmarks   finally = E.finally@@ -116,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
@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Interface for compiler backend writers.+module Agda.Compiler.Backend+  ( module Agda.Compiler.Backend.Base+  , Recompile(..), IsMain(..)+  , Flag+  , toTreeless+  , module Agda.Syntax.Treeless+  , module Agda.TypeChecking.Monad+  , module CheckResult+    -- For Agda.Main+  , backendInteraction+  , parseBackendOptions+    -- For InteractionTop+  , callBackend+  , callBackendInteractTop+  , callBackendInteractHole+  ) where++import Prelude hiding (null)++import Control.DeepSeq++import qualified Data.Map as Map+import qualified Data.Set as Set++import Agda.Utils.GetOpt++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.Utils.Null+import Agda.Utils.Maybe+import Agda.Syntax.Common (InteractionId)+import Agda.Syntax.Position (Range)++import Agda.Interaction.Command (CommandM)++-- Public interface -------------------------------------------------------++-- | 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++-- | 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 '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++-- | 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 :: [BackendName]+otherBackends = ["GHCNoMain", "QuickLaTeX"]++-- Internals --------------------------------------------------------------++data BackendWithOpts opts where+  BackendWithOpts ::+    NFData opts =>+    Backend' opts env menv mod def ->+    BackendWithOpts opts++backendWithOpts :: Backend -> Some BackendWithOpts+backendWithOpts (Backend backend) = Some (BackendWithOpts backend)++forgetOpts :: BackendWithOpts opts -> Backend+forgetOpts (BackendWithOpts backend) = Backend backend++bOptions :: Lens' (BackendWithOpts opts) opts+bOptions f (BackendWithOpts b) = f (options b) <&> \ opts -> BackendWithOpts b{ options = opts }++embedFlag :: Lens' b a -> Flag a -> Flag b+embedFlag l flag = l flag++embedOpt :: Lens' b a -> OptDescr (Flag a) -> OptDescr (Flag b)+embedOpt l = fmap (embedFlag l)++parseBackendOptions :: [Backend] -> [String] -> CommandLineOptions -> OptM ([Backend], CommandLineOptions)+parseBackendOptions backends argv opts0 =+  case makeAll backendWithOpts backends of+    Some bs -> do+      let agdaFlags    = map (embedOpt lSnd) (deadStandardOptions ++ standardOptions)+          backendFlags = do+            Some i            <- forgetAll Some $ allIndices bs+            BackendWithOpts b <- [lookupIndex bs i]+            opt               <- commandLineFlags b+            return $ embedOpt (lFst . lIndex i . bOptions) opt+      (backends, opts) <- getOptSimple (stripRTS argv)+                                       (agdaFlags ++ backendFlags) (embedFlag lSnd . inputFlag)+                                       (bs, opts0)+      opts <- checkOpts opts+      return (forgetAll forgetOpts backends, opts)++backendInteraction :: AbsolutePath -> [Backend] -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()+backendInteraction mainFile backends setup check = do+  setup+  checkResult <- check mainFile++  -- reset warnings+  stTCWarnings `setTCLens` empty++  noMain <- optCompileNoMain <$> pragmaOptions+  let isMain | noMain    = NotMain+             | otherwise = IsMain++  sequence_ [ compilerMain backend isMain checkResult | Backend backend <- backends ]++  -- print warnings that might have accumulated during compilation+  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 ()+compilerMain backend isMain0 checkResult = inCompilerEnv checkResult $ do+  locallyTC eActiveBackendName (const $ Just $ backendName backend) $ do+    -- 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) $+      typeError $ BackendDoesNotSupportOnlyScopeChecking $ backendName backend++    !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)+      {-then-} (return NotMain)+      {-else-} (return isMain0)++    env  <- preCompile backend (options backend)+    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 (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 :: HasCallStack => Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod+compileModule backend env isMain i = do+  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 (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) 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 =+  setCurrentRange (defName def) $+    compileDef backend env menv isMain def
+ 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
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-|+  Built-in backends.+-}++module Agda.Compiler.Builtin where++import Agda.Compiler.Backend (Backend)++import Agda.Compiler.MAlonzo.Compiler (ghcBackend)+import Agda.Compiler.JS.Compiler (jsBackend)+import Agda.Interaction.Highlighting.Dot (dotBackend)+import Agda.Interaction.Highlighting.HTML (htmlBackend)+import Agda.Interaction.Highlighting.LaTeX (latexBackend)++builtinBackends :: [Backend]+builtinBackends =+  [ ghcBackend+  , jsBackend+  , dotBackend+  , htmlBackend+  , latexBackend+  ]
src/full/Agda/Compiler/CallCompiler.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- | A command which calls a compiler@@ -8,14 +8,13 @@  import qualified Control.Exception as E import Control.Monad.Trans-import Data.List as L+ import System.Exit import System.IO import System.Process  import Agda.TypeChecking.Monad -#include "undefined.h" import Agda.Utils.Impossible  -- | Calls a compiler:@@ -34,15 +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 =+callCompiler doCall cmd args cwd enc =   if doCall then do-    merrors <- callCompiler' cmd args+    merrors <- callCompiler' cmd args cwd enc     case merrors of       Nothing     -> return ()       Just errors -> typeError (CompilationError errors)   else-    reportSLn "compile.cmd" 1 $ "NOT calling: " ++ intercalate " " (cmd : args)+    alwaysReportSLn "compile.cmd" 1 $ "NOT calling: " ++ unwords (cmd : args)  -- | Generalisation of @callCompiler@ where the raised exception is -- returned.@@ -51,13 +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 = do-  reportSLn "compile.cmd" 1 $ "Calling: " ++ intercalate " " (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@@ -67,14 +79,20 @@     Just out -> forkTCM $ do       -- The handle should be in text mode.       liftIO $ hSetBinaryMode out False+      case enc of+        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__     Just err -> do       -- The handle should be in text mode.       hSetBinaryMode err False+      case enc of+        Nothing  -> return ()+        Just enc -> liftIO $ hSetEncoding err enc       hGetContents err    exitcode <- liftIO $ do
src/full/Agda/Compiler/Common.hs view
@@ -1,122 +1,118 @@-{-# LANGUAGE CPP #-}--module Agda.Compiler.Common where+{-# OPTIONS_GHC -Wunused-imports #-} +module Agda.Compiler.Common+  ( module Agda.Compiler.Common+  , IsMain(..)+  )+  where -#if __GLASGOW_HASKELL__ <= 708-import Prelude hiding (foldl, mapM_, mapM, sequence, concat)-#endif+import Prelude hiding ((!!)) -import Data.List as List-import Data.Map (Map)+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+import Data.Function (on)  import Control.Monad-import Control.Monad.State  hiding (mapM_, forM_, mapM, forM, sequence)+import Control.Monad.State  import Agda.Syntax.Common-import qualified Agda.Syntax.Abstract.Name as A-import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Internal as I+import Agda.Syntax.TopLevelModuleName -import Agda.Interaction.FindFile-import Agda.Interaction.Imports import Agda.Interaction.Options+import Agda.Interaction.Imports  ( CheckResult, crInterface, crSource, Source(..) )+import Agda.Interaction.Library -import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Monad as TCM  import Agda.Utils.FileName-import qualified Agda.Utils.HashMap as HMap import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1          ( pattern (:|) ) import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Utils.WithDefault    ( lensCollapseDefault ) -#include "undefined.h" import Agda.Utils.Impossible -data IsMain = IsMain | NotMain-  deriving (Eq, Show)--doCompile :: IsMain -> Interface -> (IsMain -> Interface -> TCM ()) -> TCM ()-doCompile isMain i f = 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 $ comp NotMain agdaPrimInter >> comp isMain i+doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r+doCompile f isMain i = do+  flip evalStateT Set.empty $ compilePrim $ doCompile' f isMain i   where-    comp :: IsMain -> Interface -> StateT (Set ModuleName) TCM ()-    comp isMain i = do-      alreadyDone <- Set.member (iModuleName i) <$> get-      when (not alreadyDone) $ do-        imps <- lift $-          map miInterface . catMaybes <$>-            mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)-        mapM_ (comp NotMain) imps-        lift $ setInterface i-        lift $ f isMain i-        modify (Set.insert $ iModuleName i)+  -- 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).+doCompile'+  :: Monoid r+  => (IsMain -> Interface -> TCM r) -> (IsMain -> Interface -> StateT (Set ModuleName) TCM r)+doCompile' f isMain i = do+  alreadyDone <- gets (Set.member (iModuleName i))+  if alreadyDone then return mempty else do+    imps <- lift $+      map miInterface . catMaybes <$>+        mapM (getVisitedModule . fst) (iImportedModules i)+    ri <- mconcat <$> mapM (doCompile' f NotMain) imps+    lift $ setInterface i+    r <- lift $ f isMain i+    modify (Set.insert $ iModuleName i)+    return $ mappend ri r+ setInterface :: Interface -> TCM () setInterface i = do-  opts <- gets (stPersistentOptions . stPersistentState)+  opts <- getsTC (stPersistentOptions . stPersistentState)   setCommandLineOptions opts-  mapM_ setOptionsFromPragma (iPragmaOptions i)-  stImportedModules .= Set.empty-  stCurrentModule   .= Just (iModuleName i)+  mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions 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 :: TCM Interface+curIF :: ReadTCState m => m Interface curIF = do-  mName <- use stCurrentModule-  case mName of-    Nothing   -> __IMPOSSIBLE__-    Just name -> do-      mm <- getVisitedModule (toTopLevelModuleName name)-      case mm of-        Nothing -> __IMPOSSIBLE__-        Just mi -> return $ miInterface mi---curSig :: TCM Signature-curSig = iSignature <$> curIF+  name <- curMName+  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule name -curMName :: TCM ModuleName-curMName = sigMName <$> curSig+curMName :: ReadTCState m => m TopLevelModuleName+curMName = maybe __IMPOSSIBLE__ snd <$> useTC stCurrentModule -curDefs :: TCM Definitions-curDefs = (^. sigDefinitions) <$> curSig+curDefs :: ReadTCState m => m Definitions+curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF  sortDefs :: Definitions -> [(QName, Definition)] sortDefs defs =   -- 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 -sigMName :: Signature -> ModuleName-sigMName sig = case Map.keys (sig ^. sigSections) of-  []    -> __IMPOSSIBLE__-  m : _ -> m---compileDir :: TCM FilePath+compileDir :: HasOptions m => m FilePath compileDir = do   mdir <- optCompileDir <$> commandLineOptions-  case mdir of-    Just dir -> return dir-    Nothing  -> __IMPOSSIBLE__+  maybe __IMPOSSIBLE__ return mdir   repl :: [String] -> String -> String@@ -127,51 +123,68 @@   go []    = []  --- | Copy pasted from MAlonzo....---   Move somewhere else!-conArityAndPars :: QName -> TCM (Nat, Nat)-conArityAndPars q = do-  def <- getConstInfo q-  TelV tel _ <- telView $ defType def-  let Constructor{ conPars = np } = theDef def-      n = length (telToList tel)-  return (n - np, np)- -- | Sets up the compilation environment.-inCompilerEnv :: Interface -> TCM a -> TCM a-inCompilerEnv mainI cont =+inCompilerEnv :: CheckResult -> TCM a -> TCM a+inCompilerEnv checkResult cont = do+  let mainI = crInterface checkResult+      checkedSource = crSource checkResult+   -- Preserve the state (the compiler modifies the state).   -- Andreas, 2014-03-23 But we might want to collect Benchmark info,   -- so use localTCState.-  localTCState $ do+  -- FNF, 2017-02-22 we also want to keep the warnings we have encountered,+  -- so use localTCStateSaving and pick them out.+  (a , s) <- localTCStateSaving $ do      -- Compute the output directory. Note: using commandLineOptions would make     -- the current pragma options persistent when we setCommandLineOptions     -- below.-    opts <- gets $ stPersistentOptions . stPersistentState+    opts <- getsTC $ stPersistentOptions . stPersistentState     compileDir <- case optCompileDir opts of-      Just dir -> return dir-      Nothing  -> do-        -- The default output directory is the project root.-        let tm = toTopLevelModuleName $ iModuleName mainI-        f <- findFile tm-        return $ filePath $ C.projectRoot f tm+        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 } -    ignoreAbstractMode $ do-      cont+    -- Andreas, 2017-08-23, issue #2714 recover pragma option --no-main+    -- 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.+    let iFilePragmaStrings = map pragmaStrings . iFilePragmaOptions+    when (["--no-main"] `elem` iFilePragmaStrings mainI) $+      setTCLens (stPragmaOptions . lensOptCompileMain . lensCollapseDefault) False -topLevelModuleName :: ModuleName -> TCM ModuleName+    -- 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`) $ 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+  -- keep generated warnings+  let newWarnings = stPostTCWarnings $  stPostScopeState $ s+  stTCWarnings `setTCLens` newWarnings+  return a++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/Epic/AuxAST.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE CPP #-}---- | Intermediate abstract syntax tree used in the compiler. Pretty close to---   Epic syntax.-module Agda.Compiler.Epic.AuxAST where--import Data.Set (Set)-import qualified Data.Set as Set--import Agda.Syntax.Abstract.Name--import Agda.Compiler.Epic.Interface--#include "undefined.h"-import Agda.Utils.Impossible--type Comment  = String-type Inline   = Bool--data Fun-  = Fun-      { funInline  :: Inline-      , funName    :: Var-      , funQName   :: Maybe QName-      , funComment :: Comment-      , funArgs    :: [Var]-      , funExpr    :: Expr-      }-  | EpicFun-      { funName     :: Var-      , funQName    :: Maybe QName-      , funComment  :: Comment-      , funEpicCode :: String --EpicCode-      }-  deriving (Eq, Ord, Show)--data Lit-  = LInt    Integer-  | LChar   Char-  | LString String-  | LFloat  Double-  deriving (Show, Ord, Eq)---data Expr-  = Var Var-  | Lit Lit-  | Lam Var Expr-  | Con Tag QName [Expr]-  | App Var [Expr]-  | Case Expr [Branch]-  | If Expr Expr Expr-  | Let Var Expr Expr-  | Lazy Expr-  | UNIT-  | IMPOSSIBLE-  deriving (Show, Ord, Eq)--data Branch-  = Branch  {brTag  :: Tag, brName :: QName, brVars :: [Var], brExpr :: Expr}-  | BrInt   {brInt  :: Int, brExpr :: Expr}-  | Default {brExpr :: Expr}-  deriving (Show, Ord, Eq)--getBrVars :: Branch -> [Var]-getBrVars (Branch {brVars = vs}) = vs-getBrVars _                      = []------------------------------------------------------------------------------------- * Some smart constructors---- | Smart constructor for let expressions to avoid unneceessary lets-lett :: Var -> Expr -> Expr -> Expr-lett v (Var v') e' = subst v v' e'-lett v e        e' = if v `elem` fv e' then Let v e e' else e'---- | Some things are pointless to make lazy-lazy :: Expr -> Expr-lazy (Lazy e) = Lazy e-lazy (Lit l)  = Lit l-lazy UNIT     = UNIT-lazy x        = Lazy x---- | If casing on the same expression in a sub-expression, we know what branch to---   pick-casee :: Expr -> [Branch] -> Expr-casee x brs = Case x [br{brExpr = casingE br (brExpr br)} | br <- brs]-  where-    casingE br expr = let rec = casingE br in case expr of-      Var v -> Var v-      Lit l -> Lit l-      Lam v e -> Lam v (rec e)-      Con t n es -> Con t n (map rec es)-      App v es   -> App v (map rec es)-      Case e brs | expr == e -> case filter (sameCon br) brs of-        []  -> Case (rec e) [b {brExpr = rec (brExpr b)} | b <- brs]-        [b] -> substs (getBrVars br `zip` getBrVars b) (brExpr b)-        _   -> __IMPOSSIBLE__-                 | otherwise -> Case (rec e) [b {brExpr = rec (brExpr b)} | b <- brs]-      If e1 e2 e3 -> If (rec e1) (rec e2) (rec e3)-      Let v e1 e2 -> Let v (rec e1) (rec e2)-      Lazy e      -> Lazy (rec e)-      UNIT        -> UNIT-      IMPOSSIBLE  -> IMPOSSIBLE-    sameCon (Branch {brTag = t1}) (Branch {brTag = t2}) = t1 == t2-    sameCon (BrInt  {brInt = i1}) (BrInt  {brInt = i2}) = i1 == i2-    sameCon _                     _                     = False---- | Smart constructor for applications to avoid empty applications-apps :: Var -> [Expr] -> Expr-apps v [] = Var v-apps v as = App v as------------------------------------------------------------------------------------- * Substitution---- | Substitution-subst :: Var  -- ^ Substitute this ...-      -> Var  -- ^ with this ...-      -> Expr -- ^ in this.-      -> Expr-subst var var' expr = case expr of-    Var v      | var == v  -> Var var'-               | otherwise -> Var v-    Lit l -> Lit l-    Lam v e    | var == v  -> Lam v e-               | otherwise -> Lam v (subst var var' e)-    Con t q es -> Con t q (map (subst var var') es)-    App v es   | var == v  -> App var' (map (subst var var') es)-               | otherwise -> App v    (map (subst var var') es)-    Case e brs -> Case (subst var var' e) (map (substBranch var var') brs)-    If a b c -> let s = subst var var'-                 in If (s a) (s b) (s c)-    Let v e e' | var == v  -> Let v (subst var var' e) e'-               | otherwise -> Let v (subst var var' e) (subst var var' e')-    Lazy e     -> Lazy (subst var var' e)-    UNIT       -> UNIT-    IMPOSSIBLE -> IMPOSSIBLE--substs :: [(Var, Var)] -> Expr -> Expr-substs ss e = foldr (uncurry subst) e ss--substBranch :: Var -> Var -> Branch -> Branch-substBranch x e br = br { brExpr = subst x e (brExpr br) }---- | Get the free variables in an expression-fv :: Expr -> [Var]-fv = Set.toList . fv'-  where-    fv' :: Expr -> Set Var-    fv' expr = case expr of-      Var v      -> Set.singleton v-      Lit _      -> Set.empty-      Lam v e1   -> Set.delete v (fv' e1)-      Con _ _ es -> Set.unions (map fv' es)-      App v es   -> Set.insert v $ Set.unions (map fv' es)-      Case e brs -> fv' e `Set.union` Set.unions (map fvBr brs)-      If a b c   -> Set.unions (map fv' [a,b,c])-      Let v e e' -> fv' e `Set.union` (Set.delete v $ fv' e')-      Lazy e     -> fv' e-      UNIT       -> Set.empty-      IMPOSSIBLE -> Set.empty--    fvBr :: Branch -> Set Var-    fvBr b = case b of-      Branch _ _ vs e -> fv' e Set.\\ Set.fromList vs-      BrInt _ e       -> fv' e-      Default e       -> fv' e
− src/full/Agda/Compiler/Epic/CaseOpts.hs 
@@ -1,40 +0,0 @@--- | Perform simple optimisations based on case-laws-module Agda.Compiler.Epic.CaseOpts where--import Control.Applicative--import Agda.TypeChecking.Monad--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState--caseOpts :: [Fun] -> Compile TCM [Fun]-caseOpts = mapM  $ \ def -> case def of-  Fun{} -> do-    e' <- caseOptsExpr (funExpr def)-    return def { funExpr = e' }-  _     -> return def---- | Run the case-opts on an expression-caseOptsExpr :: Expr -> Compile TCM Expr-caseOptsExpr expr = case expr of-  Var v       -> return $ Var v-  Lit l       -> return $ Lit l-  Lam v e     -> Lam v <$> caseOptsExpr e-  Con c n es  -> Con c n <$> mapM caseOptsExpr es-  App v es    -> apps v <$> mapM caseOptsExpr es-  -- If there is only one constructor branch, perform a projection to get the result-  Case e [Branch {brVars = vs, brExpr = eorg}] -> do-      e' <- caseOptsExpr eorg-      bindExpr e $ \var ->-        return $ foldr (\(v, n) -> lett v $ App "proj" [Lit (LInt n), Var var]) e'-               $ zip vs [0..]-  -- If there is only a default branch, the case is not necessary-  Case e [Default{brExpr = e'}] -> caseOptsExpr e'-  Case e brs  -> Case <$> caseOptsExpr e <*> (mapM (\br -> do e' <- caseOptsExpr (brExpr br)-                                                              return br {brExpr = e'}) brs)-  If a b c    -> If <$> caseOptsExpr a <*> caseOptsExpr b <*> caseOptsExpr c-  Let v e1 e2 -> Let v <$> caseOptsExpr e1 <*> caseOptsExpr e2-  Lazy e      -> Lazy <$> caseOptsExpr e-  UNIT        -> return UNIT-  IMPOSSIBLE  -> return IMPOSSIBLE
− src/full/Agda/Compiler/Epic/CompileState.hs 
@@ -1,215 +0,0 @@-{-# LANGUAGE CPP #-}---- | Contains the state monad that the compiler works in and some functions---   for tampering with the state.-module Agda.Compiler.Epic.CompileState where--import Control.Applicative-import Control.Monad.State-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set--import Agda.Compiler.Epic.AuxAST as AuxAST-import Agda.Compiler.Epic.Interface-import Agda.Interaction.Options-import Agda.Syntax.Internal-import Agda.Syntax.Concrete(TopLevelModuleName)-import Agda.Syntax.Common-import Agda.TypeChecking.Monad (TCM, internalError, defType, theDef, getConstInfo, sigDefinitions, stImports, stPersistentOptions, stPersistentState)-import qualified Agda.TypeChecking.Monad as TM-import Agda.TypeChecking.Reduce--import qualified Agda.Utils.HashMap as HM-import Agda.Utils.Lens--#include "undefined.h"-import Agda.Utils.Impossible---- | Stuff we need in our compiler-data CompileState = CompileState-    { nameSupply      :: [Var]-    , compiledModules :: Map TopLevelModuleName (EInterface, Set FilePath)-    , curModule       :: EInterface-    , importedModules :: EInterface-    , curFun          :: String-    } deriving Show---- | The initial (empty) state-initCompileState :: CompileState-initCompileState = CompileState-    { nameSupply        = map (('h':) . show) [0 :: Integer ..]-    , compiledModules   = Map.empty-    , curModule         = mempty-    , importedModules   = mempty-    , curFun            = undefined-    }---- | Compiler monad-type Compile = StateT CompileState---- | When normal errors are not enough-epicError :: String -> Compile TCM a-epicError = lift . internalError---- | Modify the state of the current module's Epic Interface-modifyEI :: (EInterface -> EInterface) -> Compile TCM ()-modifyEI f = modify $ \s -> s {curModule = f (curModule s)}---- | Get the state of the current module's Epic Interface-getsEI :: (EInterface -> a) -> Compile TCM a-getsEI f = gets (f . curModule)---- | Returns the type of a definition given its name-getType :: QName -> Compile TCM Type-getType q = do-    map <- lift $ use $ stImports . sigDefinitions-    return $ maybe __IMPOSSIBLE__ defType (HM.lookup q map)---- | Create a name which can be used in Epic code from a QName.-unqname :: QName -> Var-unqname qn = case nameId $ qnameName qn of-    NameId name modul -> 'd' : show modul-                     ++ "_" ++ show name---- * State modifiers--resetNameSupply :: Compile TCM ()-resetNameSupply = modify $ \s -> s {nameSupply = nameSupply initCompileState}--getDelayed :: QName -> Compile TCM Bool-getDelayed q = lookInterface (Map.lookup q . defDelayed) (return False)--putDelayed :: QName -> Bool -> Compile TCM ()-putDelayed q d = modifyEI $ \s -> s {defDelayed = Map.insert q d (defDelayed s)}--newName :: Compile TCM Var-newName = do-    n:ns <- gets nameSupply-    modify $ \s -> s { nameSupply = ns}-    return n--putConstrTag :: QName -> Tag -> Compile TCM ()-putConstrTag q t = modifyEI $ \s -> s { constrTags = Map.insert q t $ constrTags s }--assignConstrTag :: QName -> Compile TCM Tag-assignConstrTag constr = assignConstrTag' constr []--assignConstrTag' :: QName -> [QName] -> Compile TCM Tag-assignConstrTag' constr constrs = do-    constrs <- concat <$> mapM ((getDataCon =<<) . getConData) (constr : constrs)-    tags    <- catMaybes <$> mapM getConstrTag' constrs-    let tag =  head $ map Tag [0..] \\ tags-    putConstrTag constr tag-    return tag--getConData :: QName -> Compile TCM QName-getConData con = do-    lmap <- lift $ use $ TM.stImports . TM.sigDefinitions-    case HM.lookup con lmap of-        Just def -> case theDef def of-            c@(TM.Constructor{}) -> return $ TM.conData c-            _                 -> __IMPOSSIBLE__-        Nothing -> __IMPOSSIBLE__--getDataCon :: QName -> Compile TCM [QName]-getDataCon con = do-    lmap <- lift $ use $ TM.stImports . TM.sigDefinitions-    case HM.lookup con lmap of-        Just def -> case theDef def of-            d@(TM.Datatype{}) -> return $ TM.dataCons d-            r@(TM.Record{})   -> return [ TM.recCon r]-            _                 -> __IMPOSSIBLE__-        Nothing -> __IMPOSSIBLE__--getConstrTag :: QName -> Compile TCM Tag-getConstrTag con = lookInterface (Map.lookup con . constrTags)-                                 (assignConstrTag con)--getConstrTag' :: QName -> Compile TCM (Maybe Tag)-getConstrTag' con = do-    cur <- gets curModule-    case Map.lookup con (constrTags cur) of-        Just x -> return (Just x)-        Nothing -> do-            imps <- gets importedModules-            return $ Map.lookup con (constrTags imps)--addDefName :: QName -> Compile TCM ()-addDefName q = do-    modifyEI $ \s -> s {definitions = Set.insert (unqname q) $ definitions s }--topBindings :: Compile TCM (Set Var)-topBindings = Set.union <$> gets (definitions . importedModules) <*> gets (definitions . curModule)--getConArity :: QName -> Compile TCM Int-getConArity n = lookInterface (Map.lookup n . conArity) __IMPOSSIBLE__--putConArity :: QName -> Int -> Compile TCM ()-putConArity n p = modifyEI $ \s -> s { conArity = Map.insert n p (conArity s) }--putMain :: QName -> Compile TCM ()-putMain m = modifyEI $ \s -> s { mainName = Just m }--getMain :: Compile TCM Var-getMain = maybe (epicError "Where is main? :(") (return . unqname) =<< getsEI mainName--lookInterface :: (EInterface -> Maybe a) -> Compile TCM a -> Compile TCM a-lookInterface f def = do-    cur <- gets curModule-    case f cur of-        Just x -> return x-        Nothing -> do-            imps <- gets importedModules-            case f imps of-                Nothing -> def-                Just x  -> return x--constrInScope :: QName -> Compile TCM Bool-constrInScope name = do-    cur <- gets curModule-    case Map.lookup name (constrTags cur) of-        Just x -> return True-        Nothing -> do-            imps <- gets importedModules-            case Map.lookup name (constrTags imps) of-                Nothing -> return False-                Just x  -> return True--getForcedArgs :: QName -> Compile TCM ForcedArgs-getForcedArgs q = lookInterface (Map.lookup q . forcedArgs) __IMPOSSIBLE__--putForcedArgs :: QName -> ForcedArgs -> Compile TCM ()-putForcedArgs n f = do-  b <- lift $ gets (optForcing . stPersistentOptions . stPersistentState)-  let f' | b = f-         | otherwise = replicate (length f) NotForced-  modifyEI $ \s -> s {forcedArgs = Map.insert n f' $ forcedArgs s}--replaceAt :: Int -- ^ replace at-          -> [a] -- ^ to replace-          -> [a] -- ^ replace with-          -> [a] -- ^ result?-replaceAt n xs inserts = let (as, _:bs) = splitAt n xs in as ++ inserts ++ bs---- | Copy pasted from MAlonzo, HAHA!!!---   Move somewhere else!-constructorArity :: Num a => QName -> TCM a-constructorArity q = do-  def <- getConstInfo q-  a <- normalise $ defType def-  case theDef def of-    TM.Constructor{ TM.conPars = np } -> return . fromIntegral $ arity a - np-    _ -> internalError $ "constructorArity: non constructor: " ++ show q---- | Bind an expression to a fresh variable name-bindExpr :: Expr -> (Var -> Compile TCM Expr) -> Compile TCM Expr-bindExpr expr f = case expr of-  AuxAST.Var v -> f v-  _     -> do-      v <- newName-      lett v expr <$> f v
− src/full/Agda/Compiler/Epic/Compiler.hs 
@@ -1,278 +0,0 @@-{-# LANGUAGE CPP #-}---- | Epic compiler backend.-module Agda.Compiler.Epic.Compiler(compilerMain) where--import Control.Applicative-import Control.Monad-import Control.Monad.Reader-import Control.Monad.State--import qualified Data.ByteString.Lazy as BS-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set--import System.Directory ( canonicalizePath, createDirectoryIfMissing-                        , getCurrentDirectory, setCurrentDirectory-                        )-import System.Exit-import System.FilePath hiding (normalise)-import System.Process hiding (env)--import Paths_Agda--import Agda.Interaction.FindFile-import Agda.Interaction.Options-import Agda.Interaction.Imports--import Agda.Syntax.Common (Delayed(..))-import qualified Agda.Syntax.Concrete.Name as CN-import Agda.Syntax.Internal hiding (Term(..))--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Serialise--import Agda.Compiler.CallCompiler--import Agda.Compiler.Epic.CompileState-import qualified Agda.Compiler.Epic.CaseOpts     as COpts-import qualified Agda.Compiler.Epic.ForceConstrs as ForceC-import Agda.Compiler.Epic.Epic-import Agda.Compiler.Epic.Interface-import qualified Agda.Compiler.Epic.Erasure      as Eras-import qualified Agda.Compiler.Epic.FromAgda     as FAgda-import qualified Agda.Compiler.Epic.Forcing      as Forcing-import qualified Agda.Compiler.Epic.Injection    as ID-import qualified Agda.Compiler.Epic.NatDetection as ND-import qualified Agda.Compiler.Epic.Primitive    as Prim-import qualified Agda.Compiler.Epic.Smashing     as Smash--import Agda.Utils.FileName-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Pretty ( prettyShow )--#include "undefined.h"-import Agda.Utils.Impossible--compilePrelude :: Compile TCM ()-compilePrelude = do-    dataDir <- (</> "EpicInclude") <$> liftIO getDataDir-    pwd <- liftIO $ getCurrentDirectory-    liftIO $ setCurrentDirectory dataDir-    let prelude = "AgdaPrelude"-    uptodate <- liftIO $ (prelude <.> "ei") `isNewerThan` (prelude <.> "e")-    when (not uptodate) $ callEpic False [ "-c" , prelude <.> "e" ]-    liftIO $ setCurrentDirectory pwd---- | Compile an interface into an executable using Epic-compilerMain :: Interface -> TCM ()-compilerMain inter = do-    (epic_exist, _, _) <--       liftIO $ readProcessWithExitCode-                  "ghc-pkg"-                  ["-v0", "field", "epic", "id"]-                  ""-    case epic_exist of-        ExitSuccess -> flip evalStateT initCompileState $ do-            compilePrelude-            setEpicDir inter-            (_, imports) <- compileModule inter-            main <- getMain-            runEpicMain main (Set.toList imports) (iModuleName inter)--        ExitFailure _ -> internalError $ unlines-           [ "Agda cannot find the Epic compiler."-           , "This can perhaps be fixed by running `cabal install epic'."-           , "See the README for more information."-           ]--outFile :: CN.TopLevelModuleName -> Compile TCM FilePath-outFile mod = do-  let (dir, fn) = splitFileName . foldl1 (</>) $ CN.moduleNameParts mod-      fp  | dir == "./"  = "src" </> fn-          | otherwise = "src" </> dir </> fn-  liftIO $ createDirectoryIfMissing True ("src" </> dir)-  return $ fp-  where-  repldot c = map (\c' -> if c' == '.' then c else c')--readEInterface :: FilePath -> Compile TCM EInterface-readEInterface file = fromMaybe __IMPOSSIBLE__-                   <$> lift (decode =<< liftTCM (liftIO (BS.readFile file)))--compileModule :: Interface -> Compile TCM (EInterface, Set FilePath)-compileModule i = do-    cm <- gets compiledModules-    let moduleName = toTopLevelModuleName $ iModuleName i-    file  <- outFile moduleName-    case Map.lookup moduleName cm of-        Just eifs -> return eifs-        Nothing  -> do-            imports <- map miInterface . catMaybes-                                      <$> mapM (lift . getVisitedModule . toTopLevelModuleName . fst)-                                               (iImportedModules i)-            (ifaces, limps) <- mapAndUnzipM compileModule imports-            let imps = Set.unions limps-            modify $ \s -> s { importedModules = importedModules s `mappend` mconcat ifaces }-            ifile <- maybe __IMPOSSIBLE__ filePath <$> lift (findInterfaceFile moduleName)-            let eifFile = file <.> "aei"-            uptodate <- liftIO $ isNewerThan eifFile ifile-            (eif, imps') <- case uptodate of-                True  -> do-                    lift $ reportSLn "compile.epic" 2 $-                      (prettyShow . iModuleName) i ++ " : no compilation is needed."-                    eif <- readEInterface eifFile-                    modify $ \s -> s { curModule = eif }-                    return (eif, Set.insert file imps)-                False -> do-                    lift $ reportSLn "compile.epic" 1 $-                        "Compiling: " ++ (prettyShow . iModuleName) i-                    resetNameSupply-                    initialAnalysis i-                    let defns = HMap.toList $ iSignature i ^. sigDefinitions-                    -- Epic cannot parse files with no definitions-                    if (not $ null defns) then do-                        code <- compileDefns defns-                        runEpic file (Set.toList imps) code-                        eif <- gets curModule-                        lift $ do-                            bif <- encode eif-                            liftIO $ BS.writeFile eifFile bif-                        return (eif, Set.insert file imps)-                     else-                        flip (,) imps <$> gets curModule-            modify $ \s -> s { compiledModules = (Map.insert moduleName (eif, imps') (compiledModules s))}-            return (eif, imps')---- | Before running the compiler, we need to store some things in the state,---   namely constructor tags, constructor irrelevancies and the delayed field---   in functions (for coinduction).-initialAnalysis :: Interface -> Compile TCM ()-initialAnalysis inter = do-  Prim.initialPrims-  modify $ \s -> s {curModule = mempty}-  let defs = HMap.toList $ iSignature inter ^. sigDefinitions-  forM_ defs $ \(q, def) -> do-    addDefName q-    case theDef def of-      d@(Datatype {}) -> do-        saker <- ND.isNatish q d-        case saker of-            Just (_, [zer, suc]) -> do-                putConstrTag zer (PrimTag "primZero")-                putConstrTag suc (PrimTag "primSuc")-            _ -> return ()-      Constructor {conPars = np} -> do-        putForcedArgs q . drop np . ForceC.makeForcedArgs $ defType def-        putConArity q =<< lift (constructorArity q)-      f@(Function{}) -> do-        when ("main" == (prettyShow . qnameName) q) $ do-            -- lift $ liftTCM $ checkTypeOfMain q (defType def)-            putMain q-        putDelayed q $ case funDelayed f of-          Delayed -> True-          NotDelayed -> False-      a@(Axiom {}) -> do-        case defEpicDef def of-          Nothing -> putDelayed q True-          _       -> return ()-      AbstractDefn -> __IMPOSSIBLE__-      _ -> return ()--idPrint :: String -> (a -> Compile TCM b) -> a -> Compile TCM b-idPrint s m x = do-  lift $ reportSLn "epic.phases" 10 s-  m x---- | Perform the chain of compilation stages, from definitions to epic code-compileDefns :: [(QName, Definition)] -> Compile TCM EpicCode-compileDefns defs = do-    -- We need to handle sharp (coinduction) differently, so we get it here.-    msharp <- lift $ getBuiltin' builtinSharp-    emits   <- return defs-               >>= idPrint "findInjection" ID.findInjection-               >>= idPrint "fromAgda"   (FAgda.fromAgda msharp)-               >>= idPrint "forcing"     Forcing.remForced-               >>= idPrint "irr"         ForceC.forceConstrs-               >>= idPrint "primitivise" Prim.primitivise-               >>= idPrint "smash"       Smash.smash'em-               >>= idPrint "erasure"     Eras.erasure-               >>= idPrint "caseOpts"    COpts.caseOpts-               >>= idPrint "done" return-    unlines <$> mapM prettyEpicFun emits---- | Change the current directory to Epic folder, create it if it doesn't already---   exist.-setEpicDir :: Interface -> Compile (TCMT IO) ()-setEpicDir mainI = do-    let tm = toTopLevelModuleName $ iModuleName mainI-    f <- lift $ findFile tm-    compileDir' <- lift $ gets (fromMaybe (filePath $ CN.projectRoot f tm) .-                                  optCompileDir . stPersistentOptions . stPersistentState)-    compileDir <- liftIO $ canonicalizePath compileDir'-    liftIO $ setCurrentDirectory compileDir-    liftIO $ createDirectoryIfMissing False "Epic"-    liftIO $ setCurrentDirectory $ compileDir </> "Epic"---- | Make a program from the given Epic code.------ The program is written to the file @../m@, where m is the last--- component of the given module name.-runEpic :: FilePath -> [FilePath] -> EpicCode -> Compile TCM ()-runEpic fp imports code = do-    dataDir <- (</> "EpicInclude") <$> liftIO getDataDir-    let imports' = unlines ["include \"" ++ imp ++ "\""-                           | imp <- (dataDir </> "AgdaPrelude.ei")-                                    : map (<.> "ei") imports]-        code'    = imports' ++ code-    liftIO $ writeFile (fp <.> "e") code'-    callEpic True $-        [ "-c", fp <.> "e" ]---- | Create the Epic main file, which calls the Agda main function-runEpicMain :: Var -> [FilePath] -> ModuleName -> Compile TCM ()-runEpicMain mainName imports m = do-    dataDir <- (</> "EpicInclude") <$> liftIO getDataDir-    let imports' = (dataDir </> "AgdaPrelude") : imports-    let code = unlines ["include \"" ++ imp <.> "ei" ++ "\""-                       | imp <- imports'-                       ] ++ "main() -> Unit = init() ; " ++ mainName ++ "(unit)"-    liftIO $ writeFile ("main" <.> "e") code--    let outputName :: CN.Name-        outputName = maybe __IMPOSSIBLE__ nameConcrete $ lastMaybe $ mnameToList m--    callEpic'  $ \epic ->-        [ "main" <.> "e"-        , "-o", ".." </> prettyShow outputName-        ]-        ++ epic ++ map (<.> "o") imports'---- | Call epic, with a given set of flags, if the |Bool| is True then include--- the command line flags at the end-callEpic :: Bool -> [String] -> Compile TCM ()-callEpic incEFlags flags = callEpic' $ \epicFlags ->-  flags ++ if incEFlags then epicFlags else []---- | Call epic with a given set of flags, the argument function receives the flags given--- at the command line-callEpic' :: ([String] -> [String]) -> Compile TCM ()-callEpic' flags = do-    epicFlags <- optEpicFlags <$> lift commandLineOptions-    dataDir   <- (</> "EpicInclude") <$> liftIO getDataDir-    let epic        = "epic"-        epicCommand =-          [ "-keepc"-          -- , "-g"-          -- , "-checking", "0"-          -- , "-trace"-          , "-i", dataDir </> "stdagda" <.> "c"-          ] ++ flags epicFlags--    lift $ callCompiler True epic epicCommand
− src/full/Agda/Compiler/Epic/Epic.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE CPP #-}---- | Pretty-print the AuxAST to valid Epic code.-module Agda.Compiler.Epic.Epic-  ( prettyEpicFun-  , prettyEpic-  ) where--import Data.Char-import Data.List--import Agda.TypeChecking.Monad--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface--#include "undefined.h"-import Agda.Utils.Impossible---- * Some auxilliary pretty-printer functions-(<+>) :: String -> String -> String-x <+> y = x ++ " " ++ y-infixr 6 <+>--($$) :: String -> String -> String-x $$ y  = x ++ "\n" ++ y-infixr 5 $$--many :: [String] -> String-many vs = paren $ intercalate ", " vs--many' :: [String] -> String-many' [] = ""-many' vs = paren $ intercalate ", " vs--paren :: String -> String-paren s = "(" <+> s <+> ")"--curly :: String -> String-curly s = "{-" <+> s <+> "-}"---- * Pretty-printer--- | Print a function to an Epic string-prettyEpicFun :: MonadTCM m => Fun -> Compile m String-prettyEpicFun (Fun inline name mqname comment vars e) = do-    {--    defs <- lift (gets (sigDefinitions . stImports))-    typ <- case mqname >>= flip M.lookup defs of-      Nothing -> return "-"-      Just def -> do-        doc <- lift $ prettyTCM =<< normalise (defType def)-        return $ show doc-    -}-    return $-      "--" <+> comment $$-      -- unlines (map ("-- " <+>) (lines typ)) $$-      (if inline then "%inline " else "") ++ name-        <+> many (map typVar vars) <+> "-> Any" <+> "=" <+> prettyEpic e--prettyEpicFun (EpicFun name _mqname comment def) = return $-    "--" <+> comment $$-    {-"%inline" <+> -} name <+> def---- | Print expression to Epic expression-prettyEpic :: Expr -> String-prettyEpic expr = case expr of-    Var v -> v-    Lit l -> prettyEpicLit l-    Lam x e -> paren $ "\\" <+> typVar x <+> "." <+> paren (prettyEpic e)-- __IMPOSSIBLE__ -- We have lambda lifted away all λs-    Con (Tag t) q args -> curly (show q) <+> paren ("Con" <+> show t <+> many (map prettyEpic args))-    If a b c -> "if" <+> prettyEpic a <+> "then" <+> prettyEpic b <+> "else" <+> prettyEpic c-    Let v e e' -> "let" <+> typVar v <+> "=" <+> prettyEpic (id e) <+> "in" <+> prettyEpic e'-    App "proj" (Lit (LInt n) : e : es) -> paren (prettyEpic e <+> "!" <+> show n) <+> many' (map prettyEpic es)-    App v es -> v <+> many' (map (prettyEpic . id) es)-    Case e brs -> "case" <+> prettyEpic e <+> "of {"-               <+> intercalate "\n | " (map prettyEpicBr brs) <+> "}"-    Lazy e -> "lazy" <+> paren (prettyEpic e)-    UNIT -> "unit"-    IMPOSSIBLE -> "impossible"-    _ -> __IMPOSSIBLE__--prettyEpicBr :: Branch -> String-prettyEpicBr br = case br of-    Branch (Tag c) q vs e ->-       curly (show q)  <+>-       "Con" <+> show c-       <+> many (map typVar vs)-       <+> "->" <+> prettyEpic e-    BrInt n e       ->  show n <+> "->" <+> prettyEpic e-    Default e       -> "Default ->" <+> prettyEpic e-    _ -> __IMPOSSIBLE__--prettyEpicLit :: Lit -> String-prettyEpicLit l = case l of-    LInt n    -> show n ++ "L"-    LChar c   -> show (ord c)-    LString s -> show s-    LFloat f  -> show f--typVar :: Var -> String-typVar v = v <+> ":" <+> "Any"
− src/full/Agda/Compiler/Epic/Erasure.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE CPP #-}---- | Some arguments to functions (types in particular) will not be used in the---   body. Wouldn't it be useful if these wasn't passed around at all?---   Fear not, we here perform some analysis and try to remove as many of these---   occurences as possible.------   We employ the worker/wrapper transform, so if f x1 .. xn = e---   and we notice that some is not needed we create: f' xj .. xk = e [xi := unit]---   and f x1 .. xn = f' xj .. xk.---   i.e we erase them in f' and replace by unit, and the original f function---   calls the new f'. The idea is that f should be inlined and then peace on earth.-module Agda.Compiler.Epic.Erasure where--import Control.Applicative-import Control.Monad.State-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface--import Agda.TypeChecking.Monad.Base (TCM)-import qualified Agda.Syntax.Internal as SI-import qualified Agda.Syntax.Common   as Common-import Agda.TypeChecking.Monad (reportSDoc)-import Agda.TypeChecking.Pretty as P--#include "undefined.h"-import Agda.Utils.Impossible--isIrr :: Relevance -> Bool-isIrr Irr      = True-isIrr Rel      = False--isRel :: Relevance -> Bool-isRel = not . isIrr---- | Relevance "or"-(||-) :: Relevance -> Relevance -> Relevance-Irr      ||- b      = b-_        ||- _      = Rel-infixr 2 ||----- | Relevance "and"-(&&-) :: Relevance -> Relevance -> Relevance-Rel      &&- b      = b-_        &&- _      = Irr-infixr 3 &&---data ErasureState = ErasureState-  { relevancies :: Map Var [Relevance]-  , funs        :: Map Var Fun-  }--type Erasure = StateT ErasureState---- | Try to find as many unused variables as possible-erasure :: [Fun] -> Compile TCM [Fun]-erasure fs = do-    orgRel <- gets (relevantArgs . importedModules)-    (rels, erasureState) <- flip runStateT (ErasureState orgRel Map.empty) $ do-        mapM_ initiate fs-        fu <- gets funs-        Map.mapKeys (fromMaybe __IMPOSSIBLE__ . flip Map.lookup fu) <$> step 1-    modifyEI $ \s -> s { relevantArgs = Map.mapKeys funName rels }-    concat <$> mapM (\f -> map (rem (relevancies erasureState)) <$> check f (Map.lookup f rels)) fs-  where--    rem rels f@Fun{} = f { funExpr = removeUnused rels (funExpr f) }-    rem _    f       = f-    -- | Perform the worker//wrapper transform-    check :: Fun -> Maybe [Relevance] -> Compile TCM [Fun]-    -- If the function is already marked as to inline we don't need to create a-    -- new function. Also If all arguments are relevant there is nothing to do.-    check f@Fun{} (Just rs) | any isIrr rs && not (funInline f) = do-        f' <- (funName f ++) <$> newName-        let args' = pairwiseFilter (map isRel rs) (funArgs f)-            subs  = pairwiseFilter (map isIrr rs) (funArgs f)-            e'    = foldr (\v e -> subst v "primUnit" e) (funExpr f) subs-        return [ Fun { funInline  = True-                     , funName    = funName f-                     , funQName   = funQName f-                     , funComment = funComment f-                     , funArgs    = funArgs f-                     , funExpr    = App f' $ map Var args'-                     }-               , Fun { funInline  = False-                     , funName    = f'-                     , funQName   = Nothing-                     , funComment = funComment f ++ " [ERASED]"-                     , funArgs    = args'-                     , funExpr    = e'-                     }-               ]-    check f _ = return [f]--removeUnused :: Map Var [Relevance] -> Expr -> Expr-removeUnused rels t = let rem = removeUnused rels-                       in case t of-    Var _         -> t-    Lit _         -> t-    Lam v e       -> Lam v (rem e)-    Con tag qn es -> Con tag qn (map rem es)-    App v es      -> case Map.lookup v rels of-       Just re -> App v $ zipWith (\r x -> if isIrr r then UNIT else rem x)-                                  (re ++ repeat Rel) es-       Nothing    -> App v $ map rem es-    Case e brs    -> Case (rem e) (map (\br -> br {brExpr = rem $ brExpr br}) brs)-    If a b c      -> If (rem a) (rem b) (rem c)-    Let v e1 e2   -> lett v (rem e1) (rem e2)-    Lazy e        -> lazy (rem e)-    UNIT          -> t-    IMPOSSIBLE    -> t---- | Initiate a function's relevancies-initiate :: Fun -> Erasure (Compile TCM) ()-initiate f@(Fun _ name mqname _ args _) = do-    let rels = replicate (length args) Irr-    modify $ \s -> s { relevancies = Map.insert name rels (relevancies s)-                     , funs        = Map.insert name f (funs s)-                     }-initiate f@(EpicFun {funName = name, funQName = mqname}) = case mqname of-    Just qn -> do-        ty <- lift $ getType qn-        let rels = initialRels ty Rel-        return ()-        modify $ \s -> s { relevancies = Map.insert name rels (relevancies s)-                         , funs        = Map.insert name f (funs s)-                         }-    Nothing -> return ()--initialRels :: SI.Type -> Relevance -> [Relevance]-initialRels ty rel = case SI.ignoreSharing $ SI.unEl ty of-  SI.Pi  a b -> mkRel a : initialRels (SI.unAbs b) rel-  _          -> []-  where-    mkRel :: Common.Dom SI.Type -> Relevance-    mkRel a | ignoreForced (Common.getRelevance a) = Irr-    mkRel a = case SI.ignoreSharing $ SI.unEl (Common.unDom a) of-       SI.Sort _ -> Irr-       _         -> rel--ignoreForced :: Common.Relevance -> Bool-ignoreForced Common.Relevant = False-ignoreForced _           = True---- | Calculate if a variable is relevant in an expression-relevant-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, Monad m)-#else-  :: Monad m-#endif-  => Var -> Expr -> Erasure m Relevance-relevant var expr = case expr of-    Var v  | v == var  -> return Rel-           | otherwise -> return Irr-    Lit _l      -> return Irr-    Lam _ e     -> relevant var e-    Con _ _ es  -> relevants var es-    App v es | v == var  -> return Rel-             | otherwise -> do-                -- The variable is relevant if it is used in a relevant position-                mvrs <- gets (Map.lookup v . relevancies)-                case mvrs of-                  Nothing  -> relevants var es-                  Just vrs ->-                      relevants var-                        $ map snd-                        $ filter ((==) Rel . fst)-                        $ zip (vrs ++ repeat Rel) es-                      -- foldr (||-) Irr <$> zipWith (&&-) (vrs ++ repeat Rel) <$> mapM (relevant var) es-    -- {--    Case e [br@Branch{}] -> do-        cvars <- foldr (||-) Irr <$> mapM (flip relevant $ brExpr br) (brVars br)-        vare  <- relevant var e-        varbr <- relevant var (brExpr br)-        return ((vare &&- cvars) ||- varbr)-    -- -}-    Case e brs  -> (||-) <$> relevant var e  <*> relevants var (map brExpr brs)-    If a b c    -> relevants var [a,b,c]-    Let x e1 e2 -> (||-) <$> ((&&-) <$> relevant var e1 <*> relevant x e2) <*> relevant var e2-    Lazy e      -> relevant var e-    UNIT        -> return Irr-    IMPOSSIBLE  -> return Irr-  where-    relevants-#if __GLASGOW_HASKELL__ <= 708-      :: (Functor m, Monad m)-#else-      :: Monad m-#endif-      => Var -> [Expr] -> Erasure m Relevance-    relevants v [] = return Irr-    relevants v (e : es) = do-      r <- relevant v e-      case r of-        Rel -> return r-        _   -> relevants v es-    -- relevants v es = return . foldr (\x y -> x ||- y) Irr =<< mapM (relevant v) es---- | Try to find a fixpoint for all the functions relevance.-step :: Integer -> Erasure (Compile TCM) (Map Var [Relevance])-step nrOfLoops = do-    s  <- get-    newRels <- (Map.fromList <$>) $ forM (Map.toList (funs s)) $ \(v, f) -> ((,) v <$>) $ do-               let funRels = fromMaybe __IMPOSSIBLE__ $ Map.lookup v (relevancies s)-               case f of-                  EpicFun{} -> return funRels-                  Fun{} -> do-                     forM (zip (funArgs f) (funRels ++ repeat Rel)) $ \ (x, rel) -> case rel of-                        Rel -> return Rel-                        Irr -> do-                          lift $ lift $ reportSDoc "epic.erasure" 10 $ P.text "running erasure:" P.<+> (P.text . show) (funQName f)-                          relevant x (funExpr f)-    let relsm = newRels `Map.union` relevancies s-    if relevancies s == relsm-       then return newRels-       else do-         put s {relevancies = relsm}-         step (nrOfLoops + 1)--diff :: Eq a => Map k a -> Map k a -> [(k,(a,a))]-diff m1 m2 = catMaybes $ zipWith (\(k, x) (_, y) -> if x == y then Nothing else Just (k, (x, y))) (Map.toList m1) (Map.toList m2)
− src/full/Agda/Compiler/Epic/ForceConstrs.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE CPP #-}---- | Remove forced arguments from constructors.-module Agda.Compiler.Epic.ForceConstrs where--import Control.Applicative--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface--import qualified Agda.Syntax.Common   as Common-import qualified Agda.Syntax.Internal as T-import Agda.TypeChecking.Monad (TCM)--#include "undefined.h"-import Agda.Utils.Impossible---- | Check which arguments are forced-makeForcedArgs :: T.Type -> ForcedArgs-makeForcedArgs (T.El _ term) = case T.ignoreSharing term of-    T.Pi  arg ab  -> isRel arg : makeForcedArgs (T.unAbs ab)-    _             -> []-  where-    isRel :: Common.Dom T.Type -> Forced-    isRel arg = case Common.getRelevance arg of-      Common.Relevant   -> NotForced-      Common.Irrelevant -> Forced-      Common.UnusedArg  -> Forced-      Common.NonStrict  -> Forced  -- can never be executed-      Common.Forced{}   -> Forced  -- It can be inferred---- | Remove forced arguments from constructors and branches-forceConstrs :: [Fun] -> Compile TCM [Fun]-forceConstrs fs = mapM forceFun fs--forceFun :: Fun -> Compile TCM Fun-forceFun e@(EpicFun{}) = return e-forceFun (Fun inline name qname comment args expr) =-    Fun inline name qname comment args <$> forceExpr expr-  where-    -- | Remove all arguments to constructors that we don't need to store in an-    --   expression.-    forceExpr :: Expr -> Compile TCM Expr-    forceExpr expr = case expr of-        Var v        -> return $ Var v-        Lit l        -> return $ Lit l-        Lam v e      -> Lam v <$> forceExpr e-        Con tag q es -> do-            -- We only need to apply the non-forced arguments-            forcArgs <- getForcedArgs q-            return $ Con tag q $ notForced forcArgs es-        App v es     -> App v <$> mapM forceExpr es-        Case e bs    -> Case <$> forceExpr e <*> mapM forceBranch bs-        Let v e e'   -> lett v <$> forceExpr e <*> forceExpr e'-        If a b c     -> If <$> forceExpr a <*> forceExpr b <*> forceExpr c-        Lazy e       -> Lazy <$> forceExpr e-        UNIT         -> return expr-        IMPOSSIBLE   -> return expr--    -- | Remove all the arguments that don't need to be stored in the constructor-    --   For the branch-    forceBranch :: Branch -> Compile TCM Branch-    forceBranch br = case br of-        Branch  tag name vars e -> do-            ir <- getForcedArgs name-            let vs = notForced ir vars-                subs = forced ir vars--            e'' <- if all (`notElem` fv e) subs-                  then return e-                  else __IMPOSSIBLE__ -- If so, the removal of forced args has gone wrong-            Branch tag name vs <$> forceExpr e''-        BrInt i e -> BrInt i <$> forceExpr e-        Default e -> Default <$> forceExpr e
− src/full/Agda/Compiler/Epic/Forcing.hs 
@@ -1,313 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.Compiler.Epic.Forcing where--import Control.Applicative-import Control.Monad-import Control.Monad.State--import Data.Char-import Data.List hiding (sort)-import Data.Maybe--import Agda.Syntax.Common-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Literal-import Agda.Syntax.Position(noRange)-import Agda.Syntax.Internal(Tele(..), Telescope, Term, Abs(..), unAbs, absName, Type, Args, QName, unEl)-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Rules.LHS.Problem (FlexibleVars, defaultFlexibleVar)-import Agda.TypeChecking.Rules.LHS.Unify-import Agda.TypeChecking.Substitute-  (applySubst, apply, piApply, wkS, raiseS, dropS, (++#), TelV(..))-import qualified Agda.TypeChecking.Substitute as S-import Agda.TypeChecking.Pretty as P-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Telescope-import Agda.Utils.List-import Agda.Utils.Monad-import Agda.Utils.Size-import qualified Agda.Utils.HashMap as HM--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Epic-import Agda.Compiler.Epic.Interface-import qualified Agda.Compiler.Epic.FromAgda as FA--#include "undefined.h"-import Agda.Utils.Impossible-import Agda.Utils.Lens---- | Returns how many parameters a datatype has-dataParameters :: QName -> Compile TCM Nat-dataParameters = lift . dataParametersTCM---- | Returns how many parameters a datatype has-dataParametersTCM :: QName -> TCM Nat-dataParametersTCM name = do-    m <- use $ stImports . sigDefinitions-    return $ maybe __IMPOSSIBLE__ (defnPars . theDef) (HM.lookup name m)-  where-    defnPars :: Defn -> Nat-    defnPars (Datatype {dataPars = p}) = p-    defnPars (Record   {recPars  = p}) = p-    defnPars d                         = 0 -- error (show d) -- __IMPOSSIBLE__ -- Not so sure about this.--report :: Int -> TCM P.Doc -> Compile TCM ()-report n s = lift $ reportSDoc "epic.forcing" n s--piApplyM' :: Type -> Args -> TCM Type-piApplyM' t as = do- {- reportSDoc "" 10 $ vcat-    [ text "piApplyM'"-    , text "type: " <+> prettyTCM t-    , text "args: " <+> prettyTCM as-    ]-}-  piApplyM t as--{- |-insertTele i xs t tele-                  tpos-  tele := Gamma ; (i : T as) ; Delta-  n    := parameters T-  xs'  := xs `apply` (take n as)-becomes-                  tpos-  ( Gamma ; xs' ; Delta[i := t] --note that Delta still reference Gamma correctly-  , T as ^ (size xs')-  )--we raise the type since we have added xs' new bindings before Gamma, and as can-only bind to Gamma.--}-insertTele ::(QName, Args) -> Int        -- ^ ABS `pos` in tele-            -> Maybe Type -- ^ If Just, it is the type to insert patterns from-                          --   is nothing if we only want to delete a binding.-            -> Term       -- ^ Term to replace at pos-            -> Telescope  -- ^ The telescope `tele` where everything is at-            -> Compile TCM ( Telescope -- Resulting telescope-                           , ( Telescope-                             , Type -- The type at pos in tele-                             , Type -- The return Type of the inserted type-                             )-                           )-insertTele x 0 ins term (ExtendTel t to) = do-    t' <- lift $ normalise t-    report 12 $ vcat-      [ text "t' :" <+> prettyTCM t'-      , text "term:" <+> prettyTCM term-      , text "to:"   <+> prettyTCM (unAbs to)-      ]-    (st, arg) <- case I.ignoreSharing . I.unEl . unDom $ t' of-            I.Def st es -> return (st, fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es)-            s          -> do-              report 10 $ vcat-                [ text "ERROR!!!"-                , text "found: " <+> (text . show) s-                , text "ins"     <+> (prettyTCM . fromMaybe __IMPOSSIBLE__) ins-                ]-              return x-    -- Apply the parameters of the type of t-    -- Because: parameters occurs in the type of constructors but are not bound by it.-    pars <- dataParameters st-    report 10 $ text "apply in insertTele"-    TelV ctele ctyp <- lift $ telView =<< maybe (return $ unDom t')-                            (`piApplyM'` genericTake pars arg) ins---                            (`piApplyM'` take (fromIntegral pars) arg) ins-{- OLD CODE:-    () <- if length (take (fromIntegral pars) arg) == fromIntegral pars-        then return ()-        else __IMPOSSIBLE__--}-    when (genericLength arg < pars) __IMPOSSIBLE__-    -- we deal with absBody to directly since we remove t-    return ( ctele +:+  (S.subst 0 term $ S.raiseFrom 1 (size ctele) (unAbs to))-           , (ctele, S.raise (size ctele) $ unDom t , ctyp)-           )-  where-    -- Append the telescope, we raise since we add a new binding and all the previous-    -- bindings need to be preserved-    (+:+) :: Telescope -> Telescope -> Telescope-    EmptyTel       +:+ t2 = t2-    ExtendTel t t1 +:+ t2 = ExtendTel t (Abs (absName t1) $ unAbs t1 +:+ {-raise 1-} t2 )--- This case is impossible since we are trying to split a variable outside the tele-insertTele x n ins term EmptyTel = __IMPOSSIBLE__-insertTele er n ins term (ExtendTel x xs) = do-    (xs', typ) <- insertTele er (n - 1) ins term (unAbs xs)-    return (ExtendTel x $ Abs (absName xs) xs' , typ)---- TODO: restore fields in ConHead-mkCon :: QName -> Int -> Term-mkCon c n = I.Con (I.ConHead c Inductive []) ConOSystem $ map (defaultArg . I.var) $ downFrom n--unifyI :: Telescope -> FlexibleVars -> Type -> Args -> Args -> Compile TCM [Maybe Term]-unifyI tele flex typ a1 a2 = lift $ typeError $ NotImplemented "using the new unification algorithm for forcing"--takeTele :: Int -> Telescope -> Telescope-takeTele 0 _ = EmptyTel-takeTele n (ExtendTel t ts) = ExtendTel t $ Abs (absName ts) $ takeTele (n-1) (unAbs ts)-takeTele _ _ = __IMPOSSIBLE__---- | Main function for removing pattern matching on forced variables-remForced :: [Fun] -> Compile TCM [Fun]-remForced fs = do-    defs <- lift $ use $ stImports . sigDefinitions-    forM fs $ \f -> case f of-        Fun{} -> case funQName f >>= flip HM.lookup defs of-            Nothing -> __IMPOSSIBLE__-            Just def -> do-                TelV tele _ <- lift $ telView (defType def)-                report 10 $ vcat-                  [ text "compiling fun" <+> (text . show) (funQName f)-                  ]-                e <- forcedExpr (funArgs f) tele (funExpr f)-                report 10 $ vcat-                  [ text "compilied fun" <+> (text . show) (funQName f)-                  , text "before:" <+> (text . prettyEpic) (funExpr f)-                  , text "after:" <+> (text . prettyEpic) e-                  ]-                return $ f { funExpr = e}-        EpicFun{} -> return f---- | For a given expression, in a certain telescope (the list of Var) is a mapping--- of variable name to the telescope.-forcedExpr :: [Var] -> Telescope -> Expr -> Compile TCM Expr-forcedExpr vars tele expr = case expr of-    Var _ -> return expr-    Lit _ -> return expr-    Lam x e -> Lam x <$> rec e -- necessary?-    Con t q es -> Con t q <$> mapM rec es-    App v es -> App v <$> mapM rec es-    If a b c -> If <$> rec a <*> rec b <*> rec c-    Let v e1 e2 -> Let v <$> rec e1 <*> rec e2-    Lazy e -> Lazy <$> rec e-    UNIT   -> return expr-    IMPOSSIBLE -> return expr-    Case v@(Var x) brs -> do-        let n = fromMaybe __IMPOSSIBLE__ $ elemIndex x vars-        (Case v <$>) . forM brs $ \ br -> case br of-            BrInt i e -> do-              (tele'', _) <-  insertTele __IMPOSSIBLE__ n Nothing (I.Lit (LitChar noRange (chr i))) tele-              BrInt i <$> forcedExpr (replaceAt n vars []) tele'' e--            Default e -> Default <$> rec e-            Branch t constr as e -> do-                typ <- getType constr-                forc <- getForcedArgs constr-                (tele'', (_, ntyp, ctyp)) <- insertTele __IMPOSSIBLE__ n (Just typ)-                                                        (mkCon constr (length as)) tele-                ntyp <- lift $ reduce ntyp-                ctyp <- lift $ reduce ctyp--                if null (forced forc as)-                  then Branch t constr as <$> forcedExpr (replaceAt n vars as) tele'' e-                  else do-                    -- unify the telescope type with the return type of the constructor-                    unif <- case (I.ignoreSharing $ unEl ntyp, I.ignoreSharing $ unEl ctyp) of-                        (I.Def st es1, I.Def st' es2) | st == st' -> do-                            let a1 = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es1-                            let a2 = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es2-                            typPars <- dataParameters st-                            setType <- getType st-                            report 10 $ vcat-                              [ text "ntyp:" <+> prettyTCM ntyp-                              , text "ctyp:" <+> prettyTCM ctyp-                              ]-                            unifyI (takeTele (n + length as) tele'')-                                   (map defaultFlexibleVar [0 .. n + length as])-                                   (setType `piApply` take typPars a1)-                                   (drop typPars a1)-                                   (drop typPars a2)-                        _ -> __IMPOSSIBLE__-                    let-                        lower = wkS (-1) . dropS 1-                        subT 0 tel = let ss = [fromMaybe (I.Var n []) t-                                                | (n , t) <- zip [0..] unif] ++#-                                              raiseS (length unif)-                                      in (applySubst ss tel, lower ss)-                        subT n (ExtendTel a t) = let-                               (tb' , ss) = subT (n - 1) (unAbs t)-                            in (ExtendTel a $ Abs (absName t) tb', lower ss)-                        subT _ _ = __IMPOSSIBLE__-                        (tele'''', _) = subT (n + length as) tele''-                    report 10 $ nest 2 $ vcat-                      [ text "remforced"-                      , text "tele=" <+> prettyTCM tele''-                      , text "tele'=" <+> prettyTCM tele''''-                      , text "unif=" <+> (text . show) unif-                      , text "forced=" <+> (text . show) (forced forc as)-                      , text "constr" <+> prettyTCM constr-                      ]-                    -- replace all forced variables found using the unification-                    Branch t constr as <$>-                        replaceForced (replaceAt n vars as, reverse $ take n vars ++ as)-                                      (tele'''') (forced forc as) unif e-    _ -> __IMPOSSIBLE__-  where-    rec = forcedExpr vars tele---- | replace the forcedVar with pattern matching from the outside.-replaceForced :: ([Var],[Var]) -> Telescope -> [Var] -> [Maybe I.Term] -> Expr -> Compile TCM Expr-replaceForced (vars,_) tele [] _ e = forcedExpr vars tele e-replaceForced (vars,uvars) tele (fvar : fvars) unif e = do-    let n = fromMaybe __IMPOSSIBLE__ $ elemIndex fvar uvars-    mpos <- findPosition n unif-    case mpos of-        Nothing -> case fromMaybe __IMPOSSIBLE__ $ unif !!! n of-            Nothing | fvar `notElem` fv e ->-              replaceForced (vars, uvars) tele fvars unif e-            Nothing -> do-              report 10 $ vcat-                [ text "failure comming!"-                , text "unif" <+> (text . show) unif-                , text "n" <+> (text . show) n-                , text "fvar" <+> (text fvar)-                , text "fv" <+> (text . show) (fv e)-                ]-              __IMPOSSIBLE__-            Just t  -> do-                v <- newName-                te <- FA.substTerm uvars t-                subst fvar v <$> replaceForced (vars, uvars)-                                               tele fvars unif (Let v te e)-        Just (pos , term) -> do-            (build, v) <- buildTerm (fromMaybe __IMPOSSIBLE__ $ uvars !!! pos) n term-            build . subst fvar v <$> replaceForced (vars, uvars) tele fvars unif-                                     e-  where-    sub fvar v = map $ \x -> if x == fvar then v else x---- | Given a term containg the forced var, dig out the variable by inserting--- the proper case-expressions.-buildTerm :: Var -> Nat -> Term -> Compile TCM (Expr -> Expr, Var)-buildTerm var idx (I.Shared p) = buildTerm var idx $ I.derefPtr p-buildTerm var idx (I.Var i _) | idx == i = return (id, var)-buildTerm var idx (I.Con con _ args) = do-    let c = I.conName con-    vs <- replicateM (length args) newName-    (pos , arg) <- fromMaybe __IMPOSSIBLE__ <$> findPosition idx (map (Just . unArg) args)-    (fun2 , v) <- buildTerm (fromMaybe __IMPOSSIBLE__ $ vs !!! pos) idx arg-    tag <- getConstrTag c-    let fun1 e = casee (Var var) [Branch tag c vs e]-    return (fun1 . fun2 , v)-buildTerm _ _ _ = __IMPOSSIBLE__----- | Find the location where a certain Variable index is by searching the constructors---   aswell. i.e find a term that can be transformed into a pattern that contains the---   same value the index. This fails if no such term is present.-findPosition :: Nat -> [Maybe I.Term] -> Compile TCM (Maybe (Nat, I.Term))-findPosition var ts = (listToMaybe . catMaybes <$>) . forM (zip [0..] ts) $ \ (n, mt) -> do-    ifM (maybe (return False) pred mt)-        (return (Just (n, fromMaybe __IMPOSSIBLE__ mt)))-        (return Nothing)-  where-    pred :: Term -> Compile TCM Bool-    pred t = case I.ignoreSharing t of-      I.Var i _ | var == i -> return True-      I.Con c _ args -> do-          forc <- getForcedArgs $ I.conName c-          or <$> mapM (pred . unArg) (notForced forc args)-      _ -> return False
− src/full/Agda/Compiler/Epic/FromAgda.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}---- | Convert from Agda's internal representation to our auxiliary AST.-module Agda.Compiler.Epic.FromAgda where--import Control.Applicative-import Control.Monad-import Control.Monad.State-import Data.Char-import qualified Data.Map as Map-import Data.Maybe--import Agda.Syntax.Common-import Agda.Syntax.Internal hiding (Term(..))-import qualified Agda.Syntax.Internal as T-import qualified Agda.Syntax.Literal  as TL-import qualified Agda.TypeChecking.CompiledClause as CC-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Level (reallyUnLevelView)-import qualified Agda.TypeChecking.Substitute as S-import Agda.TypeChecking.Pretty-import Agda.Utils.List--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface-import Agda.Compiler.Epic.Static--import Agda.Compiler.Epic.Epic--#include "undefined.h"-import Agda.Utils.Impossible---- | Convert from Agda's internal representation to our auxiliary AST.-fromAgda :: Maybe T.Term -> [(QName, Definition)] -> Compile TCM [Fun]-fromAgda msharp defs = catMaybes <$> mapM (translateDefn msharp) defs---- | Translate an Agda definition to an Epic function where applicable-translateDefn :: Maybe T.Term -> (QName, Definition) -> Compile TCM (Maybe Fun)-translateDefn msharp (n, defini) =-  let n' = unqname n-      epDef = compiledEpic $ defCompiledRep defini-  in case theDef defini of-    d@(Datatype {}) -> do -- become functions returning unit-        vars <- replicateM (dataPars d + dataIxs d) newName-        return . return $ Fun True n' (Just n) ("datatype: " ++ show n) vars UNIT-    f@(Function{}) -> do-        let projArgs = projectionArgs f-            cc       = fromMaybe __IMPOSSIBLE__ $ funCompiled f-        ccs  <- reverseCCBody projArgs <$> normaliseStatic cc-        let len   = (+ projArgs) . length . namedClausePats . head .  funClauses $ f-            toEta = arity (defType defini) - len-        -- forcing <- lift $ gets (optForcing . stPersistentOptions)-        lift $ reportSDoc "epic.fromagda" 5 $ text "compiling fun:" <+> prettyTCM n-        lift $ reportSDoc "epic.fromagda" 5 $ text "len:" <+> (text . show) len-        lift $ reportSDoc "epic.fromagda" 5 $ text "pats:" <+> (text . show) (clausePats-                    $ head $ funClauses f)-        modify $ \s -> s {curFun = show n}-        lift $ reportSDoc "epic.fromagda" 5 $ text "ccs: " <+> (text . show) ccs-        res <- return <$> (etaExpand toEta =<< compileClauses n len ccs)-        pres <- case res of-          Nothing -> return Nothing-          Just  c -> return <$> prettyEpicFun c-        lift $ reportSDoc "" 5 $ text $ show pres -- (fmap prettyEpicFun res)-        return res-    Constructor{} -> do -- become functions returning a constructor with their tag-        arit <- lift $ constructorArity n-        tag   <- getConstrTag n-        -- Sharp has to use the primSharp function from AgdaPrelude.e-        case msharp of-          Just (T.Def sharp []) | sharp == n -> return <$> mkFun n n' "primSharp" 3-          _    -> return <$> mkCon n tag arit-    r@(Record{}) -> do-        vars <- replicateM (recPars r) newName-        return . return $ Fun True n' (Just n) ("record: " ++ show n) vars UNIT-    a@(Axiom{}) -> do -- Axioms get their code from COMPILED_EPIC pragmas-        case epDef of-            Nothing -> return . return $ EpicFun n' (Just n) ("AXIOM_UNDEFINED: " ++ show n)-                $ "() -> Any = lazy(error \"Axiom " ++ show n ++ " used but has no computation\")"-            Just x  -> return . return $ EpicFun n' (Just n) ("COMPILED_EPIC: " ++ show n) x-    p@(Primitive{}) -> do -- Primitives use primitive functions from AgdaPrelude.e of the same name.-                          -- Hopefully they are defined!-      let ar = arity $ defType defini-      return <$> mkFun n n' (primName p) ar-    AbstractDefn -> __IMPOSSIBLE__-  where-    mkFun q = mkFunGen q apps ("primitive: " ++)-    mkCon q tag ari = do-        let name = unqname q-        mkFunGen q (flip Con q) (const $ "constructor: " ++ show q) name tag ari-    mkFunGen :: QName                    -- ^ Original name-            -> (name -> [Expr] -> Expr) -- ^ combinator-            -> (name -> String)         -- ^ make comment-            -> Var                      -- ^ Name of the function-            -> name                     -- ^ Primitive function name-            -> Int                      -- ^ Arity ofthe function-            -> Compile TCM Fun            -- ^ Result?-    mkFunGen qn comb sh name primname arit = do-        vars <- replicateM arit newName-        return $ Fun True name (Just qn) (sh primname) vars (comb primname (map Var vars))--    etaExpand :: Int -> Fun -> Compile TCM Fun-    etaExpand num fun = return fun -- do-{-        names <- replicateM num newName-        return $ fun-            { funExpr = funExpr fun @@ names-            , funArgs = funArgs fun ++ names-            }--}-    (@@) :: Expr -> [Var] -> Expr-    e @@ [] = e-    e @@ vs = let ts = map Var vs in case e of-      Var var -> apps var ts-      Lam var expr -> case vs of-          v:vs' -> subst var v expr @@ vs'-          []    -> __IMPOSSIBLE__-      Con tag qName es -> Con tag qName (es ++ ts)-      App var es       -> App var (es ++ ts)-      Case expr bs     -> Case expr (map (flip appBranch vs) bs)-      If ea eb ec      -> If ea (eb @@ vs) (ec @@ vs)-      Let var el e'    -> lett var el (e' @@ vs)-      Lazy e'          -> Lazy (e' @@ vs)-      Lit _lit         -> IMPOSSIBLE -- Right?-      UNIT             -> IMPOSSIBLE-      IMPOSSIBLE       -> IMPOSSIBLE--    appBranch :: Branch -> [Var] -> Branch-    appBranch b vs = b {brExpr = brExpr b @@ vs}--reverseCCBody :: Int -> CC.CompiledClauses -> CC.CompiledClauses-reverseCCBody c cc = case cc of-    CC.Case n (CC.Branches cop cbr lbr cabr) -> CC.Case (fmap (c+) n)-        $ CC.Branches cop (Map.map (fmap $ reverseCCBody c) cbr)-          (Map.map (reverseCCBody c) lbr)-          (fmap  (reverseCCBody c) cabr)-    CC.Done i t -> CC.Done i (S.applySubst-                                (S.parallelS $ map (flip T.Var []) $-                                   reverse $ take (length i) [c..])-                                t)-    CC.Fail     -> CC.Fail---- | Translate from Agda's desugared pattern matching (CompiledClauses) to our AuxAST.---   This is all done by magic. It uses 'substTerm' to translate the actual---   terms when the cases have been gone through.---   The case expressions that we get use de Bruijn indices that change after---   each case in the following way.---   Say we have this pattern:------ > f (X x y) (Y z) = term------   Initially, the variables have these indexes:------ > f 0@(X x y) 1@(Y z) = term------   The first case will be on @0@, and the variables bound inside the @X@---   pattern will replace the outer index, so we get something like this:------ > f 0 2@(Y z) = case 0 of X 0 1 -> term------   Notice how @(Y z)@ now has index @2@.---   Then the second pattern is desugared in the same way:------ > f 0 2 = case 0 of X 0 1 -> case 2 of Y 2 -> term------   This replacement is what is done using the replaceAt function.------   CompiledClauses also have default branches for when all branches fail (even---   inner branches), the catchAllBranch. Epic does not support this, so---   we have to add the catchAllBranch to each inner case (here we are calling---   it omniDefault). To avoid code duplication it is first bound by a let---   expression.-compileClauses :: QName-               -> Int -- ^ Number of arguments in the definition-               -> CC.CompiledClauses -> Compile TCM Fun-compileClauses name nargs c = do-    let n' = unqname name-    vars <- replicateM nargs newName-    e    <- compileClauses' vars Nothing c-    return $ Fun False n' (Just name) ("function: " ++ show name) vars e-  where-    compileClauses' :: [Var] -> Maybe Var -> CC.CompiledClauses -> Compile TCM Expr-    compileClauses' env omniDefault cc = case cc of-        CC.Case (Arg _ n) nc -> case length env <= n of-           True -> __IMPOSSIBLE__-           False -> case CC.catchAllBranch nc of-            Nothing -> Case (Var (fromMaybe __IMPOSSIBLE__ $ env !!! n)) <$>-                         compileCase env omniDefault n nc-            Just de -> do-                def <- compileClauses' env omniDefault de-                bindExpr (lazy def) $ \ var ->-                  Case (Var (fromMaybe __IMPOSSIBLE__ $ env !!! n)) <$>-                    compileCase env (Just var) n nc-        CC.Done _ t -> substTerm ({- reverse -} env) t-        CC.Fail     -> return IMPOSSIBLE--    compileCase :: [Var] -> Maybe Var -> Int -> CC.Case CC.CompiledClauses-                -> Compile TCM [Branch]-    compileCase env omniDefault casedvar nc = do-        cb <- if Map.null (CC.conBranches nc)-           -- Lit branch-           then forM (Map.toList (CC.litBranches nc)) $ \(l, cc) -> do-               cc' <- compileClauses' (replaceAt casedvar env []) omniDefault cc-               case l of-                   TL.LitChar _ cha -> return $ BrInt (ord cha) cc'-                   -- TODO: Handle other literals-                   _ -> epicError $ "case on literal not supported: " ++ show l-           -- Con branch-           else forM (Map.toList (CC.conBranches nc)) $ \(b, CC.WithArity ar cc) -> do-               arit  <- getConArity b -- Andreas, 2012-10-12: is the constructor arity @ar@ from Agda the same as the one from the Epic backen?-               tag  <- getConstrTag b-               vars <- replicateM arit newName-               cc'  <- compileClauses' (replaceAt casedvar env vars) omniDefault cc-               return $ Branch tag b vars cc'--        case omniDefault of-            Nothing -> return cb-            Just cc -> do-              return $ cb ++ [Default (Var cc)]---- | Translate the actual Agda terms, with an environment of all the bound variables---   from patternmatching. Agda terms are in de Bruijn so we just check the new---   names in the position.-substTerm :: [Var] -> T.Term -> Compile TCM Expr-substTerm env term = case T.ignoreSharing $ T.unSpine term of-    T.Var ind es -> do-      let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      case length env <= ind of-        True  -> __IMPOSSIBLE__-        False -> apps (fromMaybe __IMPOSSIBLE__ $ env !!! ind) <$>-                   mapM (substTerm env . unArg) args-    T.Lam _ (Abs _ te) -> do-       name <- newName-       Lam name <$> substTerm (name : env) te-    T.Lam _ (NoAbs _ te) -> do-       name <- newName-       Lam name <$> substTerm env te-    T.Lit l -> Lit <$> substLit l-    T.Level l -> substTerm env =<< lift (reallyUnLevelView l)-    T.Def q es -> do-      let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      let name = unqname q-      del <- getDelayed q-      def <- theDef <$> lift (getConstInfo q)-      let nr = projectionArgs def-      f <- apps name . (replicate nr UNIT ++) <$> mapM (substTerm env . unArg) args-      return $ case del of-        True  -> Lazy f-        False -> f-    T.Con c ci args -> do-        let con = unqname $ conName c-        apps con <$> mapM (substTerm env . unArg) args-    T.Shared p -> substTerm env $ derefPtr p-    T.Pi _ _ -> return UNIT-    T.Sort _  -> return UNIT-    T.MetaV _ _ -> return UNIT-    T.DontCare _ -> return UNIT---- | Translate Agda literals to our AUX definition-substLit :: TL.Literal -> Compile TCM Lit-substLit lit = case lit of-  TL.LitNat    _ i -> return $ LInt i-  TL.LitString _ s -> return $ LString s-  TL.LitChar   _ c -> return $ LChar c-  TL.LitFloat  _ f -> return $ LFloat f-  _ -> epicError $ "literal not supported: " ++ show lit
− src/full/Agda/Compiler/Epic/Injection.hs 
@@ -1,383 +0,0 @@-{-# LANGUAGE CPP               #-}--module Agda.Compiler.Epic.Injection where--import Control.Monad.State-import Control.Monad.Reader--import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set--import Agda.Syntax.Common-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern (FunArity(..), unnumberPatVars)-import Agda.Syntax.Literal-import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.Utils.List-import Agda.Utils.Monad-import Agda.Utils.Null--import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface as Interface--#include "undefined.h"-import Agda.Utils.Impossible-import Agda.Utils.Lens---- | Find potentially injective functions, solve constraints to fix some constructor---   tags and make functions whose constraints are fulfilled injections-findInjection :: [(QName, Definition)] -> Compile TCM [(QName, Definition)]-findInjection defs = do-    funs <- forM defs $ \(name, def) -> case theDef def of-        f@(Function{}) -> isInjective name (funClauses f)-        _              -> return Nothing-    newNames <- Map.keys <$> gets (Interface.conArity . curModule)-    injFuns <- solve newNames (catMaybes funs)-    defs' <- forM defs $ \(q, def) -> case q `isIn` injFuns of-        Nothing -> return (q, def)-        Just inj@(InjectiveFun nvar arity) -> case theDef def of-            f@(Function{})   -> do-                modifyEI $ \s -> s { injectiveFuns = Map.insert q inj (injectiveFuns s) }-                let ns = replicate arity (defaultArg empty)-                return $ (,) q $ def { theDef = f { funCompiled = Just $ Done ns $-                                                      var $ arity - nvar - 1 } }-            _                -> __IMPOSSIBLE__--    lift $ reportSLn "epic.injection" 10 $ "injfuns: " ++ show injFuns-    return defs'-  where-    q `isIn` funs = case filter (\(nam, _) -> q == nam) funs of-        []   -> Nothing-        (_,x):_  -> Just x--replaceFunCC :: QName -> CompiledClauses -> Compile TCM ()-replaceFunCC name cc = lift $ do-    stSignature %= updateDefinition name replaceDef-    stImports   %= updateDefinition name replaceDef-  where-    replaceDef :: Definition -> Definition-    replaceDef def = case theDef def of-        f@(Function{}) -> def {theDef = f { funCompiled = Just $ cc } }-        x                -> __IMPOSSIBLE__---- | If the pairs of constructor names have the same tags, the function is---   injective. If Nothing, the function is not injective.-type InjConstraints = Maybe [(QName,QName)]---isInjective :: QName    -- ^ Name of the function being tested-            -> [Clause] -- ^ The function's clauses-            -> Compile TCM (Maybe ((QName, InjectiveFun)-                                  , [(QName, QName)] -- These construtors should have the same name-                                  ))-isInjective nam []  = return Nothing-isInjective nam cls@(cl : _) = do-    lift $ reportSLn "epic.injection" 20 $ "checking isInjective " ++ show nam-    let total = funArity cls-    (listToMaybe . catMaybes <$>) . forM [0 .. total - 1] $ \i -> do-        cli <- forM cls $ \ cl -> isInjectiveHere nam i  cl-        let cli' = catMaybes cli-        return $ if length cli == length cli'-             then Just ((nam, InjectiveFun i total), concat cli')-             else Nothing--patternToTerm :: Nat -> Pattern -> Term-patternToTerm n p = case p of-    VarP v          -> var n-    DotP t          -> t-    ConP c typ args -> Con c ci $ zipWith (\ arg t -> arg {unArg = t}) args-                             $ snd-                             $ foldr (\ arg (n, ts) -> (n + nrBinds arg, patternToTerm n arg : ts))-                                     (n , [])-                             $ map namedArg args-      where ci = fromConPatternInfo typ-    LitP l          -> Lit l-    ProjP _ d       -> Def d [] -- Andreas, 2012-10-31 that might not be enought to get a term from list of patterns (TODO)--nrBinds :: Num i => Pattern -> i-nrBinds p = case p of-    VarP v          -> 1-    DotP t          -> 0-    ConP c typ args -> sum $ map (nrBinds . namedArg) args-    LitP l          -> 0-    ProjP{}         -> 0--substForDot :: [NamedArg (Pattern' a)] -> Substitution-substForDot = makeSubst 0 0 . reverse . calcDots-  where-    makeSubst i accum [] = raiseS (i + accum)-    makeSubst i accum (True  : ps) = makeSubst i (accum +1) ps-    makeSubst i accum (False : ps) = consS (var $ i + accum) $ makeSubst (i+1) accum ps--    calcDots = concatMap calcDots' . map namedArg-    calcDots' p = case p of-        VarP v          -> [False]-        DotP t          -> [True]-        ConP c typ args -> calcDots args-        LitP l          -> [False]-        ProjP{}         -> [False]--isInjectiveHere :: QName  -- ^ Name of the function being tested-                -> Int    -- ^ The current argument-                -> Clause-                -> Compile TCM InjConstraints-isInjectiveHere nam idx clause = do- lift $ reportSDoc "epic.injection" 40 $ sep-   [ text "isInjectiveHere"-   , prettyTCM nam-   , text ("argumentNo=" ++ show idx)-   -- , prettyTCM (clausePats clause)-   ]- case compiledClauseBody clause of-  Nothing -> return emptyC-  Just body -> do-    let vars = unnumberPatVars $ namedClausePats clause-    let t    = patternToTerm idxR $ namedArg $ fromMaybe __IMPOSSIBLE__ $-                 vars !!! idx-        t'   = applySubst (substForDot $ namedClausePats clause) t-        idxR = sum . map (nrBinds . namedArg) . drop (idx + 1) $ vars-    body' <- lift $ reduce body-    lift $ reportSLn "epic.injection" 40 "reduced body"-    injFs <- gets (injectiveFuns . importedModules)-    lift $ reportSLn "epic.injection" 40 "calculated injFs"-    res <- (t' <: body') `runReaderT` (Map.insert nam (InjectiveFun idx-                                                      (length (namedClausePats clause))) injFs)-    lift $ reportSDoc "epic.injection" 20 $ vcat-      [ text "isInjective:" <+> text (show nam)-      , text "at Index   :" <+> text (show idx)-      , nest 2 $ vcat-          [ text "clause     :" <+> text (show clause)-          , text "t          :" <+> prettyTCM t-          , text "idxR       :" <+> (text . show) idxR-          , text "body'      :" <+> (text . show) body'-          ]-      , text "res      :" <+> text (show res)-      ]-    return res---- | Turn NATURAL literal n into suc^n zero.-litToCon :: Literal -> TCM Term-litToCon l = case l of-    LitNat   r n | n > 0     -> apply1 <$> primSuc <*> litToCon (LitNat r (n - 1))-                 | otherwise -> primZero---    LitLevel _ n -> -- Does not really matter-    lit          -> return $ Lit lit--litInt :: Literal -> Bool-litInt LitNat{} = True-litInt _        = False--insertAt :: (Nat,Term) -> Term -> Term-insertAt (index, ins) = applySubst $-  [var i | i <- [0 .. index - 1]] ++# consS ins (raiseS $ index + 1)--solve :: [QName] -> [((QName, InjectiveFun), [(QName,QName)])] -> Compile TCM [(QName, InjectiveFun)]-solve newNames xs = do-    lift $ reportSDoc "epic.injection" 30 $-      sep $ text "Epic.Injection.solve" : map prettyTCM newNames-    -- Only primitive lists should be in the current module at this point,-    -- but we still want them-    conGraph <- Map.union <$> gets (constrTags . curModule) <*> gets (constrTags . importedModules)-    (funs, mconstr) <- ($ xs) $ flip foldM ([] , Just $ initialTags conGraph newNames) $ \ (xs , prev) (fun , con) -> do-         m <- foldM solvable prev con-         return $ case m of-            Nothing -> (xs, prev)-            Just next -> (fun : xs, m)-    case mconstr of-        Nothing -> __IMPOSSIBLE__-        Just constr -> updateTags constr-    return funs-  where-    solvable :: Maybe Tags -> (QName, QName)-             -> Compile TCM (Maybe Tags)-    solvable Nothing _          = return Nothing-    solvable (Just st) (c1, c2) = unify c1 c2 st--    updateTags :: Tags -> Compile TCM ()-    updateTags tags = do-        let (hasTags, eqs) = Map.partition isTag (constrGroup tags)-            isTag (IsTag _) = True-            isTag _         = False-        forM_ (Map.toList hasTags) $ \ (c, tagged) -> case tagged of-            IsTag tag -> putCon c tag-            _         -> __IMPOSSIBLE__-        case Map.toList eqs of-            (c, Same n) : _ -> do-                let grp = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n $ eqGroups tags-                tag <- assignConstrTag' c (Set.toList grp)-                updateTags . fromMaybe __IMPOSSIBLE__ =<< setTag n tag tags { constrGroup = eqs }-            _              -> return ()-    putCon :: QName -> Tag -> Compile TCM ()-    putCon con tag = do-        m <- gets (constrTags . importedModules)-        case Map.lookup con m of-            Nothing -> putConstrTag con tag-            Just _  -> return () -- old--emptyC :: InjConstraints-emptyC = Just []--addConstraint :: QName -> QName -> InjConstraints -> InjConstraints-addConstraint q1 q2 Nothing   = Nothing-addConstraint q1 q2 (Just xs) = Just (if q1 == q2 then xs else (q1,q2) : xs)--unionConstraints :: [InjConstraints] -> InjConstraints-unionConstraints [] = Just []-unionConstraints (Nothing : _) = Nothing-unionConstraints (Just c : cs) = do-    cs' <- unionConstraints cs-    return (c ++ cs')---- | Are two terms injectible?---   Tries to find a mapping between constructors that equates the terms.------   Precondition: t1 is normalised, t2 is in WHNF--- When reducing t2, it may become a literal, which makes this not work in some cases...-class Injectible a where-  (<:) :: a -> a -> ReaderT (Map QName InjectiveFun) (Compile TCM) InjConstraints--instance Injectible a => Injectible (Arg a) where-  a1 <: a2 = unArg a1 <: unArg a2--instance Injectible a => Injectible [a] where-  l1 <: l2-    | length l1 == length l2 = unionConstraints <$> zipWithM (<:) l1 l2-    | otherwise              = return Nothing--instance Injectible a => Injectible (Elim' a) where-  e1 <: e2 =-    case (e1, e2) of-      (Proj _ f1, Proj _ f2) | f1==f2 -> return $ Just []-      (Apply a1, Apply a2)            -> a1 <: a2-      _                               -> return Nothing--instance Injectible Term where-  t1 <: t2 = do-    injs <- ask-    -- Andreas, 2013-10-18: ignoring the precondition (NF, WHNF) since I am not maintaining it-    -- in recursive calls.-    -- The original code did not follow this invariant in the Var-Var and Def-Def case,-    -- thus, I am not trusting it.  Also the call site does not seem to ensure it.-    -- It could be restored by only reducing the right argument in the Arg-instance.--    -- (t1, t2) <- lift . lift . reduce $ (t1, t2)  -- NOTE: reduce *introduces* Lit! Loops!-    case (ignoreSharing t1, ignoreSharing t2) of-      (Lit l, Lit l') | l == l' -> return $ Just []-      (Lit l, _) | litInt l -> do-        l' <- lift . lift $ litToCon l-        l' <: t2-      (_,  Lit l) | litInt l -> do-        l' <- lift . lift $ litToCon l-        t1 <: l'-      (_, Def n2 es2) | Just (InjectiveFun argn arit) <- Map.lookup n2 injs -> do-        if genericLength es2 /= arit-          then return Nothing-          else do-            case es2 !!! argn of-              Nothing        -> __IMPOSSIBLE__-              Just (Proj{})  -> __IMPOSSIBLE__-              Just (Apply a) -> t1 <: unArg a-      (Var i1 es1, Var i2 es2) | i1 == i2 -> es1 <: es2-      (Def q1 es1, Def q2 es2) | q1 == q2 -> es1 <: es2-      (Con con1 _ args1, Con con2 _ args2) -> do-        let c1 = conName con1-            c2 = conName con2-        args1' <- flip notForced args1 <$> do lift . getForcedArgs $ c1-        args2' <- flip notForced args2 <$> do lift . getForcedArgs $ c2-        addConstraint c1 c2 <$> do-          args1' <: args2'-      _ -> return Nothing-{--      (_, Def n2 args2) | Just (InjectiveFun argn arit) <- Map.lookup n2 injs -> do-        if genericLength args2 /= arit-          then return Nothing-          else do-              arg <- lift . lift . reduce $ unArg $ args2 !! argn-              t1 <: arg-      (Var n1 args1, Var n2 args2) | n1 == n2 && length args1 == length args2 -> do-        args1' <- map unArg <$> mapM (lift . lift . reduce) args1-        args2' <- map unArg <$> mapM (lift . lift . reduce) args2-        unionConstraints <$> zipWithM (\a b -> (a <: b)) args1' args2'-      (Def q1 args1, Def q2 args2) | q1 == q2 && length args1 == length args2 -> do-        args1' <- map unArg <$> mapM (lift . lift . reduce) args1-        args2' <- map unArg <$> mapM (lift . lift . reduce) args2-        unionConstraints <$> zipWithM (\a b -> (a <: b)) args1' args2'-      (Con con1 _ args1, Con con2 _ args2) -> do-        let c1 = conName con1-            c2 = conName con2-        args1' <- map unArg <$> flip notForced args1 <$> getForcedArgs c1-        args2' <- map unArg <$> (mapM (lift . lift . reduce) =<< flip notForced args2 <$> getForcedArgs c2)-        if length args1' == length args2'-            then addConstraint c1 c2 <$> unionConstraints <$> zipWithM (\a b -> (a <: b)) args1' args2'-            else return Nothing-      _ -> return Nothing--}-data TagEq-    = Same Int-    | IsTag Tag-  deriving Eq--data Tags = Tags-    { eqGroups    :: IntMap (Set QName)-    , constrGroup :: Map QName TagEq-    }--initialTags :: Map QName Tag -> [QName] -> Tags-initialTags setTags newNames = Tags-    { eqGroups    = IntMap.fromList $ zip [0..] (map Set.singleton newNames)-    , constrGroup = Map.map IsTag setTags `Map.union` Map.fromList (zip newNames (map Same [0..]))-    }--unify :: QName -> QName -> Tags -> Compile TCM (Maybe Tags)-unify c1 c2 ts = do-    let g1 = constrGroup ts !!!! c1-        g2 = constrGroup ts !!!! c2-    case (g1, g2) of-        (Same n1, Same n2)   | n1 == n2 -> return $ Just ts-        (IsTag t1, IsTag t2) | t1 == t2 -> return $ Just ts-        (Same n1, Same n2)   -> mergeGroups n1 n2 ts-        (Same n1, IsTag t2)  -> setTag n1 t2 ts-        (IsTag t1 , Same n2) -> setTag n2 t1 ts-        _                    -> return $ Nothing--setTag :: Int -> Tag -> Tags -> Compile TCM (Maybe Tags)-setTag gid tag ts = return $ Just $ ts-    { constrGroup = foldr (\ c -> Map.insert c (IsTag tag))-                          (constrGroup ts)-                          (Set.toList $ fromMaybe __IMPOSSIBLE__ $ IntMap.lookup gid $ eqGroups ts) }--mergeGroups :: Int -> Int -> Tags -> Compile TCM (Maybe Tags)-mergeGroups n1 n2 ts = do-    let g1s = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n1 $ eqGroups ts-        g2s = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n2 $ eqGroups ts-        gs  = Set.union g1s g2s-        g1l = Set.toList g1s-        g2l = Set.toList g2s-    ifNotM (andM $ zipWith unifiable g1l g2l)-        (return Nothing) $-        return $ Just $ ts-            { eqGroups    = IntMap.delete n2 $ IntMap.insert n1 gs (eqGroups ts)-            , constrGroup = Map.fromList [ (e2, Same n1) | e2 <- g2l ] `Map.union` constrGroup ts-            }--unifiable :: QName -> QName -> Compile TCM Bool-unifiable c1 c2 = do-    d1 <- getConData c1-    d2 <- getConData c2-    return $ d1 /= d2--(!!!!) :: Ord k => Map k v -> k -> v-m !!!!  k = case Map.lookup k m of-    Nothing -> __IMPOSSIBLE__-    Just x  -> x
− src/full/Agda/Compiler/Epic/Interface.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | Epic interface data structure, which is serialisable and stored for each---   compiled file-module Agda.Compiler.Epic.Interface where--import Control.Monad--import Data.Function-import Data.Map(Map)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)-import Data.Set (Set)-import Data.Typeable ( Typeable )--import Agda.Syntax.Common (Nat)-import Agda.Syntax.Internal--type Var       = String-data Tag       = Tag Int-               | PrimTag Var-  deriving (Show, Eq, Ord, Typeable)--data Forced = NotForced | Forced-  deriving (Show, Typeable, Eq)---- | Filter a list using a list of Bools specifying what to keep.-pairwiseFilter :: [Bool] -> [a] -> [a]-pairwiseFilter (True :bs) (a:as) = a : pairwiseFilter bs as-pairwiseFilter (False:bs) (_:as) = pairwiseFilter bs as-pairwiseFilter _           _     = []--notForced :: ForcedArgs -> [a] -> [a]-notForced = pairwiseFilter . map (== NotForced)--forced :: ForcedArgs -> [a] -> [a]-forced = pairwiseFilter . map (== Forced)--data Relevance-  = Irr-  | Rel-  deriving (Eq, Ord, Show, Typeable)--type ForcedArgs   = [Forced]-type RelevantArgs = [Relevance]--data InjectiveFun = InjectiveFun-  { injArg     :: Nat-  , injArity   :: Nat-  }-  deriving (Show, Typeable, Eq)--data EInterface = EInterface-    { constrTags    :: Map QName Tag-    , definitions   :: Set Var-    , defDelayed    :: Map QName Bool-    , conArity      :: Map QName Int-    , mainName      :: Maybe QName-    , relevantArgs  :: Map Var   RelevantArgs-    , forcedArgs    :: Map QName ForcedArgs-    , injectiveFuns :: Map QName InjectiveFun-    } deriving (Typeable, Show)--instance Semigroup EInterface where-  x <> y = EInterface-      { constrTags    = comb constrTags-      , definitions   = comb definitions-      , defDelayed    = comb defDelayed-      , conArity      = comb conArity-      , mainName      = mainName x `mplus` mainName y-      , relevantArgs  = comb relevantArgs-      , forcedArgs    = comb forcedArgs-      , injectiveFuns = comb injectiveFuns-      }-    where-      comb :: Semigroup a => (EInterface -> a) -> a-      comb f = ((<>) `on` f) x y--instance Monoid EInterface where-  mempty = EInterface-      { constrTags    = mempty-      , definitions   = mempty-      , defDelayed    = mempty-      , conArity      = mempty-      , mainName      = Nothing-      , relevantArgs  = mempty-      , forcedArgs    = mempty-      , injectiveFuns = mempty-      }-  mappend = (<>)
− src/full/Agda/Compiler/Epic/NatDetection.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE CPP #-}---- | Detect if a datatype could be represented as a primitive integer.---   If it has one constructor with no arguments and one with a recursive---   argument this is true. This is done using IrrFilters which filter out---   forced arguments, so for example Fin becomes primitive.-module Agda.Compiler.Epic.NatDetection where--import Control.Applicative-import Control.Monad-import Control.Monad.State-import Data.Function-import Data.List-import Data.Maybe--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.TypeChecking.Monad-import Agda.Utils.Monad (andM)--import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface--import qualified Agda.Utils.HashMap as HM--#include "undefined.h"-import Agda.Utils.Impossible-import Agda.Utils.Lens---- | Get a list of all the datatypes that look like nats. The [QName] is on the---   form [zeroConstr, sucConstr]-getNatish :: Compile TCM [(ForcedArgs, [QName])]-getNatish = do-  sig <- lift $ use $ stImports . sigDefinitions-  let defs = HM.toList sig-  fmap catMaybes $ forM defs $ \(q, def) ->-    case theDef def of-      d@(Datatype {}) -> isNatish q d--      _ -> return Nothing--isNatish :: QName -> Defn -> Compile TCM (Maybe (ForcedArgs, [QName]))-isNatish q d = do -- A datatype ...-    case dataCons d of-        constrs | length constrs == 2 -> do -- with two constructors ...-            b <- andM $ map constrInScope constrs-            if b-              then do-                z <- zip constrs <$> mapM getForcedArgs constrs-                case sortBy (compare `on` nrRel . snd) z of-                  [(cz,fz), (cs,fs)] -> do-                    sig <- lift $ use $ stImports . sigDefinitions-                    let ts = defType $ sig HM.! cs-                        nr = dataPars d-                    return $ do-                     guard (nrRel fz == 0) -- where one constructor has zero arguments ...-                     guard (nrRel fs == 1) -- and the other one one argument ...-                     guard (isRec ((fromMaybe __IMPOSSIBLE__ $ elemIndex NotForced fs) + nr) ts q) -- which is recursive.-                     return (fs, [cz, cs]) -- It's natish!-                  _ -> return Nothing-              else return Nothing-        _       -> return Nothing---- | Count the number of relevant arguments-nrRel :: ForcedArgs -> Integer-nrRel = sum . map (const 1) . filter (== NotForced)---- | Check if argument n is recursive-isRec :: Int -> Type -> QName -> Bool-isRec 0 (El _ t) dat = case ignoreSharing t of-    Pi  arg _ -> argIsDef (unDom arg) dat-    _         -> False-isRec n (El _ t) dat = case t of-    Pi  _ ab  -> isRec (n - 1) (unAbs ab) dat-    _         -> False--argIsDef :: Type -> QName -> Bool-argIsDef (El _ t) dat = case ignoreSharing t of-    Def q _ -> q == dat-    _       -> False
− src/full/Agda/Compiler/Epic/Primitive.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE CPP #-}---- | Change constructors and cases on builtins and natish datatypes to use---   primitive data-module Agda.Compiler.Epic.Primitive where--import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe--import Agda.Syntax.Internal(QName)-import qualified Agda.Syntax.Internal as T-import Agda.TypeChecking.Monad hiding (defName)-import Agda.TypeChecking.Monad.Builtin-import Agda.Utils.Monad (andM)--import Agda.Compiler.Epic.AuxAST-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface-import Agda.Compiler.Epic.NatDetection--import Agda.Utils.List-import Agda.Utils.Impossible--#include "undefined.h"--{- Stacken, Heapen -- Optimizern -}--data PrimTransform = PrimTF-  { mapCon        :: Map QName Var-  , translateCase :: Expr -> [Branch] -> Expr-  }--prZero, prSuc, prTrue, prFalse, prPred, prNatEquality :: Var-prZero  = "primZero"-prSuc   = "primSuc"-prTrue  = "primTrue"-prFalse = "primFalse"-prPred  = "primPred"-prNatEquality = "primNatEquality"---- | Change constructors and cases on builtins and natish datatypes to use---   primitive data-primitivise :: [Fun] -> Compile TCM [Fun]-primitivise funs = do-    ptfs   <- getBuiltins-    natish <- getNatish-    mapM (primFun $ ptfs ++ map (uncurry natPrimTF) natish) funs---- | Map primitive constructors to primitive tags-initialPrims :: Compile TCM () -- [Fun]-initialPrims = do-  -- TODO: Natishness is calculated here and could be stored so it does not have-  --       to be recalculated in primitivise-  natish <- getNatish-  -- This has to be done because injection detection may otherwise flag injections-  -- between non-primitive and primitive datatypes in the wrong way-  sequence_ [zipWithM_ putConstrTag [zc, sc] (prim [prZero, prSuc])-            | (_, [zc, sc]) <- natish]-  sequence_-    [ [builtinNil, builtinCons]           ~> tags [0, 1]-    , [builtinZero, builtinSuc  ]         ~> prim [prZero, prSuc]-    , [builtinLevelZero, builtinLevelSuc] ~> prim [prZero, prSuc]-    , [builtinTrue, builtinFalse]         ~> prim [prTrue, prFalse]-    , [builtinRefl]                       ~> tags [0]-    ]-  where-    prim = map PrimTag-    tags = map Tag-    constrs ~> tags = do-        builtins  <- lift $ mapM getBuiltin' constrs-        if all isJust builtins-           then do-                let names = map (defName . fromMaybe __IMPOSSIBLE__) builtins-                -- b <- and <$>  mapM constrInScope names-                -- if b then return $ Just (transf names) else return Nothing-                zipWithM_ putConstrTag names tags-           else return ()---- | Build transforms using the names of builtins-getBuiltins :: Compile TCM [PrimTransform]-getBuiltins =-    catMaybes <$> sequence-      [ [builtinZero, builtinSuc  ]         ~> natPrimTF [NotForced]-       -- ? is this ok to have [NotForced]-      , [builtinLevelZero, builtinLevelSuc] ~> natPrimTF [NotForced]-      , [builtinTrue, builtinFalse]         ~> boolPrimTF-      ]-  where-    constrs ~> transf = do-        builtins  <- lift $ mapM getBuiltin' constrs-        if all isJust builtins-           then do-                let names = map (defName . fromMaybe __IMPOSSIBLE__) builtins-                b <- andM $ map constrInScope names-                if b then return $ Just (transf names) else return Nothing-           else return Nothing--defName :: T.Term -> QName-defName v = case T.ignoreSharing v of-  T.Def q [] -> q-  T.Con q ci [] -> T.conName q-  _          -> __IMPOSSIBLE__---- | Translation to primitive integer functions-natPrimTF :: ForcedArgs -> [QName] -> PrimTransform-natPrimTF filt [zero, suc] = PrimTF-  { mapCon = Map.fromList [(zero, prZero), (suc, prSuc)]-  , translateCase = \ce brs -> case brs of-        -- Assuming only the first two branches are relevant when casing on Nats-        (Branch _ n vs e:Branch _ _n' vs'' e'':_) ->-            if n == zero-               then primNatCaseZS ce e  (headWithDefault __IMPOSSIBLE__ vs'') e''-               else primNatCaseZS ce e'' (headWithDefault __IMPOSSIBLE__ vs) e-        (Branch _ n vs e:Default e'':_) ->-            if n == zero-               then primNatCaseZD ce e e'' -- zero-               else primNatCaseZS ce e'' (headWithDefault __IMPOSSIBLE__ vs) e -- suc-        [ Branch _ n vs e ] ->-            if n == zero-              then e-              else lett (headWithDefault __IMPOSSIBLE__ vs) (App prPred [ce]) e-        _ -> __IMPOSSIBLE__-  }-natPrimTF _ _ = __IMPOSSIBLE__---- | Corresponds to a case for natural numbers-primNatCaseZS :: Expr -- ^ Expression that is cased on-              -> Expr -- ^ Expression for the zero branch-              -> Var  -- ^ Variable that is bound in suc branch-              -> Expr -- ^ Expression used for suc branch-              -> Expr -- ^ Result?-primNatCaseZS n zeroBr v sucBr =-    If (App prNatEquality [n, Var prZero]) zeroBr (lett v (App prPred [n]) sucBr)---- | Corresponds to a case with a zero and default branch-primNatCaseZD :: Expr -- ^ Expression that is cased on-              -> Expr -- ^ Zero branch-              -> Expr -- ^ Default branch-              -> Expr -- ^ Result?-primNatCaseZD n zeroBr defBr = If (App prNatEquality [n, Var prZero]) zeroBr defBr---- | Translation to primitive bool functions-boolPrimTF :: [QName] -> PrimTransform-boolPrimTF [true, false] = PrimTF-  { mapCon = Map.fromList [(true, prTrue), (false, prFalse)]-  , translateCase = \ce brs ->-    case brs of-        (Branch _ n _vs e:b':_) ->-                    (if n == true-                             then If ce e (brExpr b')-                             else If ce (brExpr b') e)-        _ -> __IMPOSSIBLE__-  }-boolPrimTF _ = __IMPOSSIBLE__---- | Change all the primitives in the function using the PrimTransform-primFun :: [PrimTransform] -> Fun -> Compile TCM Fun-primFun ptfs (Fun i n qn c args e) =-    Fun i n qn c args <$> primExpr ptfs e-primFun _ e@(EpicFun {}) = return e----- | Change all the primitives in an expression using PrimTransform-primExpr :: [PrimTransform] -> Expr -> Compile TCM Expr-primExpr prim ex = case ex of-    Var{}    -> return ex-    Lit{}    -> return ex-    Lam v e1 -> Lam v <$> primExpr prim e1-    Con c n es -> case testCon prim n of-        Just pn -> do-            filt <- getForcedArgs n-            apps pn <$> mapM (primExpr prim) es-        Nothing -> Con c n <$> mapM (primExpr prim) es-    App v es   -> App v <$> mapM (primExpr prim) es-    Case e brs -> case testBranch prim brs of-       Just p  -> primExpr prim $ translateCase p e brs-       Nothing -> Case <$> primExpr prim e <*> mapM primBranch brs-    If a b c   -> If <$> primExpr prim a <*> primExpr prim b <*> primExpr prim c-    Let v e e' -> Let v <$> primExpr prim e <*> primExpr prim e'-    Lazy e     -> Lazy <$> primExpr prim e-    UNIT       -> return ex-    IMPOSSIBLE -> return ex-  where-    -- | Test if any PrimTransform have any primitive function for-    --   a constructor, gives the name of that primitive function in that-    --   case, otherwise Nothing.-    testCon :: [PrimTransform] -> QName -> Maybe Var-    testCon [] _ = Nothing-    testCon (p : ps) k = Map.lookup k (mapCon p) `mplus` testCon ps k--    -- | Test if we should transform the case, based on the branches. Returns-    --   the (first) PrimTransform that is applicable.-    testBranch :: [PrimTransform] -> [Branch] -> Maybe PrimTransform-    testBranch [] _       = Nothing-    testBranch (p:ps) brs = msum (map (check p) brs) `mplus` testBranch ps brs--    -- | Check if a particular PrimTransform can be used on a particular Branch-    --   Returns the PrimTransform in that case.-    check :: PrimTransform -> Branch -> Maybe PrimTransform-    check p br = case br of-        Branch  _ n _ _ -> fmap (const p) $ Map.lookup n (mapCon p)-        BrInt _ _       -> Nothing-        Default _       -> Nothing--    -- | Change all primitives in a branch-    primBranch :: Branch -> Compile TCM Branch-    primBranch br = do-        e' <- primExpr prim (brExpr br)-        return br {brExpr = e'}
− src/full/Agda/Compiler/Epic/Smashing.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE CPP #-}---- | Smash functions which return something that can be inferred---   (something of a type with only one element)--module Agda.Compiler.Epic.Smashing where--import Control.Monad.State--import Data.List-import Data.Maybe--import Data.Set (Set)-import qualified Data.Set as Set--import Agda.Syntax.Common-import Agda.Syntax.Internal as SI-import Agda.TypeChecking.Monad hiding (funInline)-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce--import Agda.Compiler.Epic.AuxAST as AA-import Agda.Compiler.Epic.CompileState-import Agda.Compiler.Epic.Interface--import Agda.Utils.Lens-import Agda.Utils.Monad-import Agda.Utils.Size-import qualified Agda.Utils.HashMap as HM--#include "undefined.h"-import Agda.Utils.Impossible--defnPars :: Integral n => Defn -> n-defnPars (Record      {recPars = p}) = fromIntegral p-defnPars (Constructor {conPars = p}) = fromIntegral p-defnPars d                           = 0---- | Main function, smash as much as possible-smash'em :: [Fun] -> Compile TCM [Fun]-smash'em funs = do-    defs <- lift $ use $ stImports . sigDefinitions-    funs' <- forM funs $ \f -> case f of-      AA.Fun{} -> case funQName f >>= flip HM.lookup defs of-          Nothing -> do-              lift $ reportSDoc "epic.smashing" 10 $ vcat-                [ (text . show) f <+> text " was not found"]-              return f--          Just def -> do-              lift $ reportSLn "epic.smashing" 10 $ "running on:" ++ (show (funQName f))-              minfered <- smashable (length (funArgs f) + defnPars (theDef def)) (defType def)-              case minfered of-                  Just infered -> do-                      lift $ reportSDoc "smashing" 5 $ vcat-                        [ prettyTCM (defName def) <+> text "is smashable"]-                      return f { funExpr = infered-                               , funInline = True-                               , funComment = funComment f ++ " [SMASHED]"-                               }-                  Nothing -> return f-      _ -> do-        lift $ reportSLn "epic.smashing" 10 $ "smashing!"-        return f-    return funs'--(+++) :: Telescope -> Telescope -> Telescope-xs +++ ys = unflattenTel names $ map (raise (size ys)) (flattenTel xs) ++ flattenTel ys-  where names = teleNames xs ++ teleNames ys---- | Can a datatype be inferred? If so, return the only possible value.-inferable :: Set QName -> QName -> [Arg Term] ->  Compile TCM (Maybe Expr)-inferable visited dat args | dat `Set.member` visited = return Nothing-inferable visited dat args = do-  lift $ reportSLn "epic.smashing" 10 $ "  inferring:" ++ (show dat)-  defs <- lift $ use $ stImports . sigDefinitions-  let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup dat defs-  case theDef def of-      d@Datatype{} -> do-          case dataCons d of-            [c] -> inferableArgs c (dataPars d)-            _   -> return Nothing-      r@Record{}   -> inferableArgs (recCon r) (recPars r)-      f@Function{} -> do-        term <- lift $ normalise $ Def dat $ map SI.Apply args-        inferableTerm visited' term-      d -> do-        lift $ reportSLn "epic.smashing" 10 $ "  failed (inferable): " ++ (show d)-        return Nothing-  where-    inferableArgs c pars = do-        defs <- lift $ use $ stImports . sigDefinitions-        let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup c defs-        forc <- getForcedArgs c-        TelV tel _ <- lift $ telView (defType def `piApply` genericTake pars args)-        tag <- getConstrTag c-        lift $ reportSDoc "epic.smashing" 10 $ nest 2 $ vcat-          [ text "inferableArgs!"-          , text "tele" <+> prettyTCM tel-          , text "constr:" <+> prettyTCM c-          ]-        (AA.Con tag c <$>) <$> sequence <$> forM (notForced forc $ flattenTel tel) (inferableTerm visited' . unEl . unDom)-    visited' = Set.insert dat visited--inferableTerm :: Set QName -> Term -> Compile TCM (Maybe Expr)-inferableTerm visited t = do-  case ignoreSharing t of-    Def q es    ->-      case allApplyElims es of-        Just vs -> inferable visited q vs-        Nothing -> return Nothing-    Pi _   b    -> (AA.Lam "_" <$>) <$> inferableTerm visited (unEl $ unAbs b)-    Sort {}     -> return . return $ AA.UNIT-    t           -> do-      lift $ reportSLn "epic.smashing" 10 $ "  failed to infer: " ++ show t-      return Nothing---- | Find the only possible value for a certain type. If we fail return Nothing-smashable :: Int -> Type -> Compile TCM (Maybe Expr)-smashable origArity typ = do-    defs <- lift $ use $ stImports . sigDefinitions-    TelV tele retType <- lift $ telView typ-    retType' <- return retType -- lift $ reduce retType--    inf <- inferableTerm Set.empty (unEl retType')-    lift $ reportSDoc "epic.smashing" 10 $ nest 2 $ vcat-      [ text "Result is"-      , text "inf: " <+> (text . show) inf-      , text "type: " <+> prettyTCM retType'-      ]-    return $ buildLambda (size tele - origArity) <$> inf--buildLambda :: (Ord n, Num n) => n -> Expr -> Expr-buildLambda n e | n <= 0    = e-buildLambda n e | otherwise = AA.Lam "_" (buildLambda (n - 1) e)
− src/full/Agda/Compiler/Epic/Static.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP #-}---- | Find the places where the builtin static is used and do some normalisation---   there.-module Agda.Compiler.Epic.Static where--import Control.Applicative-import Control.Monad-import Control.Monad.State--import qualified Data.Map as Map-import Data.Traversable (traverse)--import Agda.Syntax.Common-import Agda.Syntax.Internal as I--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Options-import Agda.TypeChecking.Monad.Sharing-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Pretty--import Agda.Utils.List (downFrom)-import Agda.Utils.Monad-import qualified Agda.Utils.HashMap as HM--import Agda.Compiler.Epic.CompileState--#include "undefined.h"-import Agda.Utils.Impossible-import Agda.Utils.Lens--normaliseStatic :: CompiledClauses -> Compile TCM CompiledClauses-normaliseStatic = evaluateCC--evaluateCC :: CompiledClauses -> Compile TCM CompiledClauses-evaluateCC ccs = case ccs of-    Case n brs -> do-        cbrs <- forM (Map.toList $ conBranches brs) $ \(c, WithArity n cc) -> (,) c <$> (WithArity n <$> evaluateCC cc)-        lbrs <- forM (Map.toList $ litBranches brs) $ \(l, cc) -> (,) l <$> evaluateCC cc-        cab <- case catchAllBranch brs of-            Nothing -> return Nothing-            Just cc -> Just <$> evaluateCC cc-        return $ Case n Branches-            { projPatterns   = projPatterns brs-            , conBranches    = Map.fromList cbrs-            , litBranches    = Map.fromList lbrs-            , catchAllBranch = cab-            }-    Done n t   -> Done n <$> evaluate t-    Fail       -> return Fail--etaExpand :: Term -> Compile TCM Term-etaExpand def@(Def n ts) = do-    defs <- lift $ use $ stImports . sigDefinitions-    let f   = maybe __IMPOSSIBLE__ theDef (HM.lookup n defs)-        len = length . namedClausePats . head .  funClauses $ f-        toEta :: Num a => a-        toEta = fromIntegral $ len - length ts-        term  = raise toEta def `applys` map var (downFrom toEta)-        info  = setOrigin Inserted defaultArgInfo-    return $ foldr (\ v t -> Lam info (Abs v t)) term $ replicate toEta "staticVar"-etaExpand x = return x--class Evaluate a where-  evaluate :: a -> Compile TCM a--instance Evaluate a => Evaluate [a] where-  evaluate = traverse evaluate--instance Evaluate a => Evaluate (Arg a) where-  evaluate = traverse evaluate--instance Evaluate a => Evaluate (Abs a) where-  evaluate = traverse evaluate  -- TODO: maintain context--instance Evaluate a => Evaluate (Elim' a) where-  evaluate = traverse evaluate--instance Evaluate Term where-  evaluate term = case term of-    Var x es     -> Var x <$> evaluate es-    Lam h b      -> Lam h <$> evaluate b-{--      ab' <- evaluateTerm (unAbs ab)-      return $ Lam h $ Abs (absName ab) ab'--}-    Lit l        -> return $ Lit l-    Def n es     -> ifNotM (isStatic n) {- then -} (Def n <$> evaluate es) $ {- else -} do-        feta <- return term -- etaExpand term-        f <- lift $ normalise feta-        lift $ reportSDoc "epic.static" 10 $ vcat-          [ text "STATIC pragma fired"-          , nest 2 $ vcat-            [ text "before :" <+> prettyTCM term-            , text "after  :" <+> prettyTCM f-            ]-          ]-        return f-    Con c ci args   -> Con c ci <$> evaluate args-    Pi  arg abs  -> return term-    Sort s       -> return term-    MetaV i args -> return term-    Level l      -> return term-    DontCare i   -> return term-    Shared{}     -> updateSharedTermT evaluate term-    where-{--    evaluateTerms :: Args -> Compile TCM Args-    evaluateTerms as = forM as $ \x -> do-      y <- evaluateTerm (unArg x)-      return x { unArg = y }--}-    isStatic :: QName -> Compile TCM Bool-    isStatic q = do-      defs <- lift $ use $ stImports . sigDefinitions-      return $ maybe False (^. theDefLens . funStatic) $ HM.lookup q defs
− src/full/Agda/Compiler/HaskellTypes.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE CPP #-}---- | Translating Agda types to Haskell types. Used to ensure that imported---   Haskell functions have the right type.--module Agda.Compiler.HaskellTypes where--import Control.Applicative-import Data.Maybe (fromMaybe)--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Free--import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Impossible--#include "undefined.h"--type HaskellKind = String--hsStar :: HaskellKind-hsStar = "*"--hsKFun :: HaskellKind -> HaskellKind -> HaskellKind-hsKFun k l = "(" ++ k ++ " -> " ++ l ++ ")"--hsFun :: HaskellKind -> HaskellKind -> HaskellKind-hsFun a b = "(" ++ a ++ " -> " ++ b ++ ")"--hsUnit :: HaskellType-hsUnit = "()"--hsVar :: Name -> HaskellType-hsVar x = "x" ++ concatMap encode (show x)-  where-    okChars = ['a'..'z'] ++ ['A'..'Y'] ++ "_'"-    encode 'Z' = "ZZ"-    encode c-      | c `elem` okChars = [c]-      | otherwise        = "Z" ++ show (fromEnum c)---hsApp :: String -> [HaskellType] -> HaskellType-hsApp d [] = d-hsApp d as = "(" ++ unwords (d : as) ++ ")"--hsForall :: String -> HaskellType -> HaskellType-hsForall x a = "(forall " ++ x ++ ". " ++ a ++ ")"--notAHaskellType :: Type -> TCM a-notAHaskellType a = do-  err <- fsep $ pwords "The type" ++ [prettyTCM a] ++-                pwords "cannot be translated to a Haskell type."-  typeError $ GenericError $ show err--getHsType :: QName -> TCM HaskellType-getHsType x = do-  d <- compiledHaskell . defCompiledRep <$> getConstInfo x-  case d of-    Just (HsType t)   -> return t-    Just (HsDefn t c) -> return hsUnit-    _                 -> notAHaskellType (El Prop $ Def x [])--getHsVar :: Nat -> TCM HaskellCode-getHsVar i = hsVar <$> nameOfBV i---- | Note that @Inf a b@, where @Inf@ is the INFINITY builtin, is--- translated to @<translation of b>@ (assuming that all coinductive--- builtins are defined).------ Note that if @haskellType@ supported universe polymorphism then the--- special treatment of INFINITY might not be needed.--haskellType :: Type -> TCM HaskellType-haskellType t = fromType t-  where-    err      = notAHaskellType t-    fromArgs = mapM (fromTerm . unArg)-    fromType = fromTerm . unEl-    fromTerm v = do-      v   <- unSpine <$> reduce v-      reportSLn "compile.haskell.type" 50 $ "toHaskellType " ++ show v-      kit <- liftTCM coinductionKit-      case v of-        Var x es -> do-          let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          hsApp <$> getHsVar x <*> fromArgs args-        Def d es | Just d == (nameOfInf <$> kit) ->-          case es of-            [Apply a, Apply b] -> fromTerm (unArg b)-            _                  -> err-        Def d es -> do-          let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          hsApp <$> getHsType d <*> fromArgs args-        Pi a b ->-          if isBinderUsed b  -- Andreas, 2012-04-03.  Q: could we rely on Abs/NoAbs instead of again checking freeness of variable?-          then do-            hsA <- fromType (unDom a)-            underAbstraction a b $ \b ->-              hsForall <$> getHsVar 0 <*> (hsFun hsA <$> fromType b)-          else hsFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)-        Con c ci args -> hsApp <$> getHsType (conName c) <*> fromArgs args-        Lam{}      -> err-        Level{}    -> return hsUnit-        Lit{}      -> return hsUnit-        Sort{}     -> return hsUnit-        Shared p   -> fromTerm $ derefPtr p-        MetaV{}    -> err-        DontCare{} -> err
src/full/Agda/Compiler/JS/Compiler.hs view
@@ -1,98 +1,284 @@-{-# LANGUAGE CPP            #-}+-- | Main module for JS backend.  module Agda.Compiler.JS.Compiler where  import Prelude hiding ( null, writeFile )-import Control.Applicative-import Control.Monad.Reader ( liftIO )++import Control.DeepSeq import Control.Monad.Trans-import Data.List ( intercalate, genericLength, partition )-import Data.Maybe ( isJust )-import Data.Set ( Set, null, insert, difference, delete )-import Data.Traversable (traverse)-import Data.Map ( fromList, elems )++import Data.Char     ( isSpace )+import Data.Foldable ( forM_ )+import Data.Functor  ( (<&>) )+import Data.List     ( dropWhileEnd, elemIndex, intercalate, partition )+import Data.Maybe    ( listToMaybe )+import Data.Set      ( Set )+ import qualified Data.Set as Set import qualified Data.Map as Map-import System.Directory ( createDirectoryIfMissing )-import System.FilePath ( splitFileName, (</>) )+import qualified Data.Text as T -import Agda.Interaction.FindFile ( findFile, findInterfaceFile )-import Agda.Interaction.Imports ( isNewerThan )-import Agda.Interaction.Options ( optCompileDir )-import Agda.Syntax.Common ( Nat, unArg, namedArg, NameId(..) )-import Agda.Syntax.Concrete.Name ( projectRoot )+import GHC.Generics (Generic)++import System.Directory   ( createDirectoryIfMissing )+import System.Environment ( setEnv )+import System.FilePath    ( splitFileName, (</>) )+import System.Process     ( callCommand )++import Agda.Setup         ( getDataDir )++import Agda.Interaction.Options++import Agda.Syntax.Common+import Agda.Syntax.Concrete.Name ( isNoName ) import Agda.Syntax.Abstract.Name-  ( ModuleName(MName), QName,-    mnameToConcrete,-    mnameToList, qnameName, qnameModule, isInModule, nameId )+  ( QName,+    mnameToList, qnameName, qnameModule, nameId ) import Agda.Syntax.Internal-  ( Name, Args, Type,-    conName,-    toTopLevelModuleName, arity, unEl, unAbs, nameFixity )-import Agda.Syntax.Literal ( Literal(LitNat,LitFloat,LitString,LitChar,LitQName,LitMeta) )-import Agda.Syntax.Fixity+  ( 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-import Agda.TypeChecking.Substitute ( absBody )-import Agda.TypeChecking.Level ( reallyUnLevelView )-import Agda.TypeChecking.Monad hiding (Global, Local)-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Options ( setCommandLineOptions, commandLineOptions, reportSLn )-import Agda.TypeChecking.Reduce ( instantiateFull, normalise )-import Agda.TypeChecking.Substitute (TelV(..))-import Agda.TypeChecking.Telescope++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Reduce ( instantiateFull )+import Agda.TypeChecking.Substitute as TC ( TelV(..), raise, subst ) import Agda.TypeChecking.Pretty-import Agda.Utils.FileName ( filePath )+import Agda.TypeChecking.Telescope ( telViewPath )+import Agda.TypeChecking.Warnings  ( warning )++import Agda.Utils.FileName ( isNewerThan ) import Agda.Utils.Function ( iterate' )-import Agda.Utils.Maybe-import Agda.Utils.Monad ( (<$>), (<*>), ifM )-import Agda.Utils.Pretty (prettyShow)-import qualified Agda.Utils.Pretty as P+import Agda.Utils.List ( downFrom, headWithDefault )+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, whenM )+import Agda.Utils.Null  ( null )+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 qualified Agda.Utils.HashMap as HMap+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.DelayCoinduction+import Agda.Compiler.Treeless.EliminateDefaults import Agda.Compiler.Treeless.EliminateLiteralPatterns import Agda.Compiler.Treeless.GuardsToPrims+import Agda.Compiler.Treeless.Erase ( computeErasedConstructorArgs, isErasable )+import Agda.Compiler.Treeless.Subst ()+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..))  import Agda.Compiler.JS.Syntax-  ( Exp(Self,Local,Global,Undefined,String,Char,Integer,Double,Lambda,Object,Apply,Lookup,If,BinOp,PlainJS),-    LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId), Export(Export), Module(Module),-    modName, expName, uses )+  ( Exp(Self,Local,Global,Undefined,Null,String,Char,Integer,Double,Lambda,Object,Array,Apply,Lookup,If,BinOp,PlainJS),+    LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId,MemberIndex), Export(Export), Module(Module, modName, callMain), Comment(Comment),+    modName, expName, uses+  , JSQName+  ) import Agda.Compiler.JS.Substitution-  ( curriedLambda, curriedApply, emp, subst, apply )+  ( curriedLambda, curriedApply, emp, apply, substShift ) import qualified Agda.Compiler.JS.Pretty as JSPretty--import Paths_Agda+import Agda.Compiler.JS.Pretty (JSModuleStyle(..)) -#include "undefined.h"-import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )+import Agda.Utils.Impossible (__IMPOSSIBLE__)  -------------------------------------------------- -- Entry point into the compiler -------------------------------------------------- -compilerMain :: Interface -> TCM ()-compilerMain mainI = inCompilerEnv mainI $ do-  doCompile IsMain mainI $ do-    compile-  copyRTEModules+jsBackend :: Backend+jsBackend = Backend jsBackend' -compile :: IsMain -> Interface -> TCM ()-compile isMain i = do-  ifM uptodate noComp $ do-    yesComp-    writeModule =<< curModule isMain+jsBackend' :: Backend' JSOptions JSOptions JSModuleEnv Module (Maybe Export)+jsBackend' = Backend'+  { backendName           = jsBackendName+  , backendVersion        = Nothing+  , options               = defaultJSOptions+  , commandLineFlags      = jsCommandLineFlags+  , isEnabled             = optJSCompile+  , preCompile            = jsPreCompile+  , postCompile           = jsPostCompile+  , preModule             = jsPreModule+  , postModule            = jsPostModule+  , compileDef            = jsCompileDef+  , scopeCheckingSuffices = False+  , mayEraseType          = const $ return True+      -- Andreas, 2019-05-09, see issue #3732.+      -- If you want to use JS data structures generated from Agda+      -- @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 ---++data JSOptions = JSOptions+  { optJSCompile  :: Bool+  , optJSOptimize :: Bool+  , optJSMinify   :: Bool+      -- ^ 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+defaultJSOptions = JSOptions+  { optJSCompile  = False+  , optJSOptimize = False+  , optJSMinify   = False+  , optJSVerify   = False+  , optJSModuleStyle = JSCJS+  }++jsCommandLineFlags :: [OptDescr (Flag JSOptions)]+jsCommandLineFlags =+    [ Option [] ["js"] (NoArg enable) "compile program using the JS backend"+    , Option [] ["js-optimize"] (NoArg enableOpt) "turn on optimizations during JS code generation"+    -- 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-  uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)-  ifile    = maybe __IMPOSSIBLE__ filePath <$>-               (findInterfaceFile . toTopLevelModuleName =<< curMName)-  noComp   = reportSLn "compile.js" 2 . (++ " : no compilation is needed.") . prettyShow =<< curMName-  yesComp  = reportSLn "compile.js" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<-             sequence [prettyShow <$> curMName, ifile, outFile_] :: TCM ()+    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 = opts <$ do+  mapM_ (typeError . CubicalCompilationNotSupported) =<< cubicalOption++-- | After all modules have been compiled, copy RTE modules and verify compiled modules.++jsPostCompile ::+  JSOptions -> IsMain -> Map.Map TopLevelModuleName Module -> TCM ()+jsPostCompile opts _ ms = do++  -- Copy RTE modules.++  compDir  <- compileDir+  liftIO $ do+    dataDir <- getDataDir+    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).++  reportSLn "compile.js.verify" 10 $ "Considering to verify generated JS modules"+  when (optJSVerify opts) $ do++    reportSLn "compile.js.verify" 10 $ "Verifying generated JS modules"+    liftIO $ setEnv "NODE_PATH" compDir++    forM_ ms $ \ Module{ modName, callMain } -> do+      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+      -- have a call to main.+      -- Atm, modules whose compilation was skipped are also skipped during verification+      -- (they appear here as main modules).+      whenNothing callMain $ do+        -- 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++--- Module compilation ---++data JSModuleEnv = JSModuleEnv+  { jsCoinductionKit :: Maybe CoinductionKit+  , jsCompile        :: Bool+    -- ^ Should this module be compiled?+  }++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+        Just CErased -> True+        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+    ifileDesc = fromMaybe "(memory)" mifile++    noComp = do+      reportSLn "compile.js" 2 . (++ " : no compilation is needed.") . prettyShow =<< curMName+      return $ Skip skippedModule++    -- A skipped module acts as a fake main module, to be skipped by --js-verify as well.+    skippedModule = Module (jsMod m) mempty mempty (Just __IMPOSSIBLE__)++    yesComp compile = do+      m   <- prettyShow <$> curMName+      out <- outFile_+      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 -> TopLevelModuleName ->+  [Maybe Export] -> TCM Module+jsPostModule opts _ isMain _ defs = do+  m  <- jsMod <$> curMName+  is <- map (jsMod . fst) . iImportedModules <$> curIF+  let mod = Module m is (reorder es) callMain+  writeModule (optJSMinify opts) (optJSModuleStyle opts) mod+  return mod+  where+  es       = catMaybes defs+  main     = MemberId "main"+  -- Andreas, 2020-10-27, only add invocation of "main" if such function is defined.+  -- This allows loading of generated .js files into an interpreter+  -- even if they do not define "main".+  hasMain  = isMain == IsMain && any ((singleton main ==) . expName) es+  callMain :: Maybe Exp+  callMain = boolToMaybe hasMain $ Apply (Lookup Self main) [Lambda 1 emp]+++jsCompileDef :: JSOptions -> JSModuleEnv -> IsMain -> Definition -> TCM (Maybe Export)+jsCompileDef opts kit _isMain def = definition (opts, kit) (defName def, def)+ -------------------------------------------------- -- Naming --------------------------------------------------@@ -100,48 +286,56 @@ prefix :: [Char] prefix = "jAgda" -jsMod :: ModuleName -> GlobalId-jsMod m = GlobalId (prefix : map show (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 =+jsMember n   -- Anonymous fields are used for where clauses,   -- and they're all given the concrete name "_",   -- so we disambiguate them using their name id.-  case show n of-    "_" -> MemberId ("_" ++ show (nameId n))-    l   -> MemberId l---- Rather annoyingly, the anonymous construtor of a record R in module M--- is given the name M.recCon, but a named constructor C--- is given the name M.R.C, sigh. This causes a lot of hoop-jumping--- in the map from Agda names to JS names, which we patch by renaming--- anonymous constructors to M.R.record.+  | isNoName n = MemberId ("_" ++ show (nameId n))+  | otherwise  = MemberId $ prettyShow n -global' :: QName -> TCM (Exp,[MemberId])+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-    nm = map jsMember (drop (length $ mnameToList modNm) qms ++ [qnameName q])-  if modNm == i+    -- File-local module prefix+    localms = drop (size top) qms+    nm = fmap jsMember $ List1.snoc localms $ qnameName q+  if top == i     then return (Self, nm)-    else return (Global (jsMod modNm), nm)+    else return (Global (jsMod top), nm) -global :: QName -> TCM (Exp,[MemberId])+global :: QName -> TCM (Exp, JSQName) global q = do   d <- getConstInfo q   case d of     Defn { theDef = Constructor { conData = p } } -> do-      e <- getConstInfo p-      case e of+      getConstInfo p >>= \case+        -- Andreas, 2020-10-27, comment quotes outdated fact.+        -- anon. constructors are now M.R.constructor.+        -- We could simplify/remove the workaround by switching "record"+        -- to "constructor", but this changes the output of the JS compiler+        -- maybe in ways that break user's developments+        -- (if they link to Agda-generated JS).+        -- -- Rather annoyingly, the anonymous constructor of a record R in module M+        -- -- is given the name M.recCon, but a named constructor C+        -- -- is given the name M.R.C, sigh. This causes a lot of hoop-jumping+        -- -- in the map from Agda names to JS names, which we patch by renaming+        -- -- anonymous constructors to M.R.record.         Defn { theDef = Record { recNamedCon = False } } -> do           (m,ls) <- global' p-          return (m, ls ++ [MemberId "record"])+          return (m, ls <> singleton (MemberId "record"))         _ -> global' (defName d)     _ -> global' (defName d) @@ -160,154 +354,279 @@     (vs, funs)    = partition isTopLevelValue es     (datas, vals) = partition isEmptyObject vs -reorder' :: Set [MemberId] -> [Export] -> [Export]+reorder' :: Set JSQName -> [Export] -> [Export] reorder' defs [] = [] reorder' defs (e : es) =-  let us = uses e `difference` defs in-  case null us of-    True -> e : (reorder' (insert (expName e) defs) es)-    False -> reorder' defs (insertAfter us e es)+  let us = uses e `Set.difference` defs+  in  if null us+        then e : (reorder' (Set.insert (expName e) defs) es)+        else reorder' defs (insertAfter us e es)  isTopLevelValue :: Export -> Bool-isTopLevelValue (Export _ isCoind e) = case e of-  _ | isCoind -> False+isTopLevelValue (Export _ e) = case e of+  Object m | flatName `Map.member` m -> False   Lambda{} -> False   _        -> True  isEmptyObject :: Export -> Bool-isEmptyObject (Export _ _ e) = case e of-  Object m -> Map.null m+isEmptyObject (Export _ e) = case e of+  Object m -> null m   Lambda{} -> True   _        -> False -insertAfter :: Set [MemberId] -> Export -> [Export] -> [Export]-insertAfter us e []                 = [e]-insertAfter us e (f:fs) | null us   = e : f : fs-insertAfter us e (f:fs) | otherwise = f : insertAfter (delete (expName f) us) e fs+insertAfter :: Set JSQName -> Export -> [Export] -> [Export]+insertAfter us e []                   = [e]+insertAfter us e (f : fs) | null us   = e : f : fs+insertAfter us e (f : fs) | otherwise =+  f : insertAfter (Set.delete (expName f) us) e fs  -------------------------------------------------- -- Main compiling clauses -------------------------------------------------- -curModule :: IsMain -> TCM Module-curModule isMain = do-  kit <- coinductionKit-  m <- (jsMod <$> curMName)-  is <- map jsMod <$> (map fst . iImportedModules <$> curIF)-  es <- catMaybes <$> (mapM (definition kit) =<< (sortDefs <$> curDefs))-  return $ Module m (reorder es) main-  where-    main = case isMain of-      IsMain -> Just $ Apply (Lookup Self $ MemberId "main") [Lambda 1 emp]-      NotMain -> Nothing+type EnvWithOpts = (JSOptions, JSModuleEnv) -definition :: Maybe CoinductionKit -> (QName,Definition) -> TCM (Maybe Export)+definition :: EnvWithOpts -> (QName,Definition) -> TCM (Maybe Export) definition kit (q,d) = do-  reportSDoc "compile.js" 10 $ text "compiling def:" <+> prettyTCM q+  reportSDoc "compile.js" 10 $ "compiling def:" <+> prettyTCM q   (_,ls) <- global q   d <- instantiateFull d    definition' kit q d (defType d) ls -definition' :: Maybe CoinductionKit -> QName -> Definition -> Type -> [MemberId] -> TCM (Maybe Export)+-- | Ensure that there is at most one pragma for a name.+checkCompilerPragmas :: QName -> TCM ()+checkCompilerPragmas q =+  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 =+  case defCompilerPragmas jsBackendName def of+    [CompilerPragma _ s] -> Just (dropEquals s)+    []                   -> Nothing+    _:_:_                -> __IMPOSSIBLE__+  where+    dropEquals = dropWhile $ \ c -> isSpace c || c == '='++definition' :: EnvWithOpts -> QName -> Definition -> Type -> JSQName -> TCM (Maybe Export) definition' kit q d t ls =+  if not (jsCompile (snd kit)) || not (usableModality d)+  then return Nothing+  else do+  checkCompilerPragmas q   case theDef d of     -- coinduction-    Constructor{} | Just q == (nameOfSharp <$> kit) -> do-      ret $  Lambda 1 $ local 0-    Function{} | Just q == (nameOfFlat <$> kit) -> do-      ret $ Lambda 1 $ Apply (local 0) [Integer 0]+    Constructor{}+      | Just q == (nameOfSharp <$> jsCoinductionKit (snd kit)) -> do+      return Nothing+    Function{}+      | Just q == (nameOfFlat <$> jsCoinductionKit (snd kit)) -> do+      ret $ Lambda 1 $ Apply (Lookup (local 0) flatName) [] -    Axiom | Just e <- defJSDef d -> plainJS e-    Axiom | otherwise -> ret Undefined+    DataOrRecSig{} -> __IMPOSSIBLE__ +    Axiom{} | Just e <- defJSDef d -> plainJS e+    Axiom{} | otherwise -> ret Undefined++    GeneralizableVar{} -> return Nothing+     Function{} | Just e <- defJSDef d -> plainJS e     Function{} | otherwise -> do-      isInfVal <- outputIsInf kit t -      reportSDoc "compile.js" 5 $ text "compiling fun:" <+> prettyTCM q-      caseMaybeM (toTreeless q) (pure Nothing) $ \ treeless -> do-        funBody <- eliminateLiteralPatterns $ convertGuards $ treeless-        funBody' <- delayCoinduction funBody t-        reportSDoc "compile.js" 30 $ text " compiled treeless fun:" <+> pretty funBody'-        funBody'' <- compileTerm funBody'-        reportSDoc "compile.js" 30 $ text " compiled JS fun:" <+> (text . show) funBody''-        return $ Just $ Export ls isInfVal funBody''+      reportSDoc "compile.js" 5 $ "compiling fun:" <+> prettyTCM q+      let mTreeless = toTreeless T.EagerEvaluation q+      caseMaybeM mTreeless (pure Nothing) $ \ treeless -> do+        used <- fromMaybe [] <$> getCompiledArgUse q+        funBody <- eliminateCaseDefaults =<<+          eliminateLiteralPatterns+          (convertGuards treeless)+        reportSDoc "compile.js" 30 $ " compiled treeless fun:" <+> pretty funBody+        reportSDoc "compile.js" 40 $ " argument usage:" <+> (text . show) used -    Primitive{primName = p} | p `Set.member` primitives ->-      plainJS $ "agdaRTS." ++ p-    Primitive{} | Just e <- defJSDef d -> plainJS e-    Primitive{} | otherwise -> ret Undefined+        funBody' <- compileTerm kit funBody -    Datatype{} -> ret emp-    Record{} -> return Nothing+        reportSDoc "compile.js" 30 $ " compiled JS fun:" <+> (text . show) funBody'+        return $+          if funBody' == Null then Nothing+          else Just $ Export ls funBody' +    Primitive{primName = p}+      | p == builtin_glueU ->+        -- The string prim^glueU is not a valid JS name.+        plainJS "agdaRTS.prim_glueU"+      | p == builtin_unglueU ->+        -- The string prim^unglueU is not a valid JS name.+        plainJS "agdaRTS.prim_unglueU"+      | p `Set.member` primitives ->+        plainJS $ "agdaRTS." ++ getBuiltinId p+      | Just e <- defJSDef d ->+        plainJS e+      | otherwise ->+        ret Undefined+    PrimitiveSort{} -> return Nothing++    Datatype{} -> do+        computeErasedConstructorArgs q+        ret emp+    Record{} -> do+        computeErasedConstructorArgs q+        return Nothing+     Constructor{} | Just e <- defJSDef d -> plainJS e-    Constructor{conData = p, conPars = nc} | otherwise -> do-      np <- return (arity t - nc)+    -- Implements Scott-Encoding of constructor definitions+    -- (see the note "Implementing data types")+    Constructor{conData = p, conPars = nc} -> do+      TelV tel _ <- telViewPath t+      let nargs = length (telToList tel) - nc+          args = [ Local $ LocalId $ nargs - i | i <- [0 .. nargs-1] ]       d <- getConstInfo p-      case theDef d of-        Record { recFields = flds } ->-          ret (curriedLambda np (Object (fromList-            ( (last ls , Lambda 1-                 (Apply (Lookup (Local (LocalId 0)) (last ls))-                   [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))-            : (zip [ jsMember (qnameName (unArg fld)) | fld <- flds ]-                 [ Local (LocalId (np - i)) | i <- [1 .. np] ])))))-        _ ->-          ret (curriedLambda (np + 1)-            (Apply (Lookup (Local (LocalId 0)) (last ls))-              [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))+      let l = List1.last ls+      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__+    AbstractDefn{} -> __IMPOSSIBLE__   where-    ret = return . Just . Export ls False-    plainJS = return . Just . Export ls False . PlainJS+    ret = return . Just . Export ls+    plainJS = ret . PlainJS +-- Implementing data types+-------------------------- -compileTerm :: T.TTerm -> TCM Exp-compileTerm term = do-  case term of-    T.TVar x -> return $ Local $ LocalId x-    T.TDef q -> do-      d <- getConstInfo q-      case theDef d of-        -- Datatypes and records are erased-        Datatype {} -> return (String "*")-        Record {} -> return (String "*")-        _ -> qname q-    T.TApp t xs -> curriedApply <$> compileTerm t <*> mapM compileTerm xs-    T.TLam t -> Lambda 1 <$> compileTerm t-    -- TODO This is not a lazy let, but it should be...-    T.TLet t e -> apply <$> (Lambda 1 <$> compileTerm e) <*> traverse compileTerm [t]-    T.TLit l -> return $ literal l-    T.TCon q -> do-      d <- getConstInfo q-      qname q-    T.TCase sc (T.CTData dt) def alts -> do-      dt <- getConstInfo dt-      alts' <- traverse compileAlt alts-      let obj = Object $ Map.fromList alts'-      case (theDef dt, defJSDef dt) of-        (_, Just e) -> do-          return $ apply (PlainJS e) [Local (LocalId sc), obj]-        (Record{}, _) -> do-          memId <- visitorName $ recCon $ theDef dt-          return $ apply (Lookup (Local $ LocalId sc) memId) [obj]-        (Datatype{}, _) -> do-          return $ curriedApply (Local (LocalId sc)) [obj]-        _ -> __IMPOSSIBLE__-    T.TCase _ _ _ _ -> __IMPOSSIBLE__+-- Data types are implemented using a variant of Scott Encoding,+-- which uses JavaScript dicts instead of some lambda-expressions -    T.TPrim p -> return $ compilePrim p-    T.TUnit -> unit-    T.TSort -> unit-    T.TErased -> unit-    T.TError T.TUnreachable -> return Undefined+-- 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-    unit = return $ Integer 0+    go :: T.TTerm -> TCM Exp+    go = \case+      T.TVar x -> return $ Local $ LocalId x+      T.TDef q -> do+        d <- getConstInfo q+        case theDef d of+          -- Datatypes and records are erased+          Datatype {} -> return (String "*")+          Record {} -> return (String "*")+          _ -> qname q+      T.TApp (T.TCon q) [x]+        | Just q == (nameOfSharp <$> jsCoinductionKit (snd kit)) -> do+        x <- go x+        let evalThunk = unlines+              [ "function() {"+              , "  delete this.flat;"+              , "  var result = this.__flat_helper();"+              , "  delete this.__flat_helper;"+              , "  this.flat = function() { return result; };"+              , "  return result;"+              , "}"+              ]+        return $ Object $ Map.fromListWith __IMPOSSIBLE__+          [(flatName, PlainJS evalThunk)+          ,(MemberId "__flat_helper", Lambda 0 x)]+      T.TApp t xs -> do+            curriedApply <$> go t <*> mapM go xs+      T.TLam t -> Lambda 1 <$> 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+      -- 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__ alts'+        case (theDef dt, defJSDef dt) of+          (_, Just e) -> do+            return $ apply (PlainJS e) [Local (LocalId sc), obj]+          (Record{}, _) -> do+            memId <- visitorName $ recCon $ theDef dt+            return $ apply (Lookup (Local $ LocalId sc) memId) [obj]+          (Datatype{}, _) -> do+            return $ curriedApply (Local (LocalId sc)) [obj]+          _ -> __IMPOSSIBLE__+      T.TCase _ _ _ _ -> __IMPOSSIBLE__ +      T.TPrim p -> return $ compilePrim p+      T.TUnit -> unit+      T.TSort -> unit+      T.TErased -> unit+      T.TError T.TUnreachable -> return Undefined+      T.TError T.TMeta{}      -> return Undefined+      T.TCoerce t -> go t++    getDef (T.TDef f) = Just (Left f)+    getDef (T.TCon c) = Just (Right c)+    getDef (T.TCoerce x) = getDef x+    getDef _ = Nothing++    unit = return Null++    mkArray 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 ]+ compilePrim :: T.TPrim -> Exp compilePrim p =   case p of@@ -315,28 +634,45 @@     T.PEqI -> binOp "agdaRTS.uprimIntegerEqual"     T.PEqF -> binOp "agdaRTS.uprimFloatEquality"     T.PEqQ -> binOp "agdaRTS.uprimQNameEquality"-    p | T.isPrimEq p -> curriedLambda 2 $ BinOp (local 1) "===" (local 0)+    T.PEqS -> primEq+    T.PEqC -> primEq     T.PGeq -> binOp "agdaRTS.uprimIntegerGreaterOrEqualThan"     T.PLt -> binOp "agdaRTS.uprimIntegerLessThan"     T.PAdd -> binOp "agdaRTS.uprimIntegerPlus"     T.PSub -> binOp "agdaRTS.uprimIntegerMinus"     T.PMul -> binOp "agdaRTS.uprimIntegerMultiply"+    T.PRem -> binOp "agdaRTS.uprimIntegerRem"+    T.PQuot -> binOp "agdaRTS.uprimIntegerQuot"+    T.PAdd64 -> binOp "agdaRTS.uprimWord64Plus"+    T.PSub64 -> binOp "agdaRTS.uprimWord64Minus"+    T.PMul64 -> binOp "agdaRTS.uprimWord64Multiply"+    T.PRem64 -> binOp "agdaRTS.uprimIntegerRem"     -- -|+    T.PQuot64 -> binOp "agdaRTS.uprimIntegerQuot"   --  > These can use the integer functions+    T.PEq64 -> binOp "agdaRTS.uprimIntegerEqual"    --  |+    T.PLt64 -> binOp "agdaRTS.uprimIntegerLessThan" -- -|+    T.PITo64 -> unOp "agdaRTS.primWord64FromNat"+    T.P64ToI -> unOp "agdaRTS.primWord64ToNat"     T.PSeq -> binOp "agdaRTS.primSeq"-    _ -> __IMPOSSIBLE__   where binOp js = curriedLambda 2 $ apply (PlainJS js) [local 1, local 0]-+        unOp js  = curriedLambda 1 $ apply (PlainJS js) [local 0]+        primEq   = curriedLambda 2 $ BinOp (local 1) "===" (local 0) -compileAlt :: T.TAlt -> TCM (MemberId, Exp)-compileAlt a = case a of-  T.TACon con ar body -> do+-- 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 nargs body -> do     memId <- visitorName con-    body <- Lambda ar <$> compileTerm body+    body <- Lambda nargs <$> compileTerm kit body     return (memId, body)   _ -> __IMPOSSIBLE__  visitorName :: QName -> TCM MemberId-visitorName q = do (m,ls) <- global q; return (last ls)+visitorName q = List1.last . snd <$> global q +flatName :: MemberId+flatName = MemberId "flat"+ local :: Nat -> Exp local = Local . LocalId @@ -346,92 +682,194 @@   return (foldl Lookup e ls)  literal :: Literal -> Exp-literal l = case l of-  (LitNat    _ x) -> Integer x-  (LitFloat  _ x) -> Double  x-  (LitString _ x) -> String  x-  (LitChar   _ x) -> Char    x-  (LitQName  _ x) -> litqname x-  LitMeta{}       -> __IMPOSSIBLE__+literal = \case+  (LitNat    x) -> Integer x+  (LitWord64 x) -> Integer (fromIntegral x)+  (LitFloat  x) -> Double  x+  (LitString x) -> String  x+  (LitChar   x) -> Char    x+  (LitQName  x) -> litqname x+  (LitMeta _ m) -> litmeta m  litqname :: QName -> Exp litqname q =-  Object $ Map.fromList+  Object $ Map.fromListWith __IMPOSSIBLE__     [ (mem "id", Integer $ fromIntegral n)     , (mem "moduleId", Integer $ fromIntegral m)-    , (mem "name", String $ show q)+    , (mem "name", String $ T.pack $ prettyShow q)     , (mem "fixity", litfixity fx)]   where     mem = MemberId-    NameId n m = nameId $ qnameName q+    NameId n (ModuleNameHash m) = nameId $ qnameName q     fx = theFixity $ nameFixity $ qnameName q      litfixity :: Fixity -> Exp-    litfixity fx = Object $ Map.fromList+    litfixity fx = Object $ Map.fromListWith __IMPOSSIBLE__       [ (mem "assoc", litAssoc $ fixityAssoc fx)       , (mem "prec", litPrec $ fixityLevel fx)]      -- TODO this will probably not work well together with the necessary FFI bindings-    litAssoc NonAssoc   = String "NonAssoc"-    litAssoc LeftAssoc  = String "LeftAssoc"-    litAssoc RightAssoc = String "RightAssoc"+    litAssoc NonAssoc   = String "non-assoc"+    litAssoc LeftAssoc  = String "left-assoc"+    litAssoc RightAssoc = String "right-assoc" -    litPrec Unrelated   = String "Unrelated"-    litPrec (Related l) = Integer l+    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 :: Module -> TCM ()-writeModule m = do-  out <- outFile (modName m)-  liftIO (writeFile out (JSPretty.pretty 0 0 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 PrimitiveId+primitives = Set.fromList+  [ PrimShowInteger +  -- Natural number functions+  -- , PrimNatPlus                 -- missing+  , PrimNatMinus+  -- , PrimNatTimes                -- missing+  -- , PrimNatDivSucAux            -- missing+  -- , PrimNatModSucAux            -- missing+  -- , PrimNatEquality             -- missing+  -- , PrimNatLess                 -- missing+  -- , PrimShowNat                 -- missing -copyRTEModules :: TCM ()-copyRTEModules = do-  dataDir <- lift getDataDir-  let srcDir = dataDir </> "JS"-  (lift . copyDirContent srcDir) =<< compileDir+  -- Machine words+  , PrimWord64ToNat+  , PrimWord64FromNat+  -- , PrimWord64ToNatInjective    -- missing --- | Primitives implemented in the JS Agda RTS.-primitives :: Set String-primitives = Set.fromList-  [ "primExp"-  , "primFloatDiv"-  , "primFloatEquality"-  , "primFloatNumericalEquality"-  , "primFloatNumericalLess"-  , "primFloatNegate"-  , "primFloatMinus"-  , "primFloatPlus"-  , "primFloatSqrt"-  , "primFloatTimes"-  , "primNatMinus"-  , "primShowFloat"-  , "primShowInteger"-  , "primSin"-  , "primCos"-  , "primTan"-  , "primASin"-  , "primACos"-  , "primATan"-  , "primATan2"-  , "primShowQName"-  , "primQNameEquality"+  -- Level functions+  -- , 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++  -- 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++  -- 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++  -- Other stuff+  -- , 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+  , builtinPOr+  , builtinComp+  , builtinTrans+  , builtinHComp+  , builtinSubOut+  , builtin_glueU+  , builtin_unglueU+  , builtinFaceForall+  -- , builtinGlue                   -- missing+  -- , builtin_glue                  -- missing+  -- , builtin_unglue                -- missing   ]
src/full/Agda/Compiler/JS/Pretty.hs view
@@ -1,23 +1,193 @@ module Agda.Compiler.JS.Pretty where -import Prelude hiding ( null )+import GHC.Generics (Generic)++import Data.Char ( isAsciiLower, isAsciiUpper, isDigit ) import Data.List ( intercalate )-import Data.Set ( Set, toList, singleton, insert, member )-import Data.Map ( Map, toAscList, empty, null )+import Data.String ( IsString (fromString) )+import Data.Semigroup ( Semigroup, (<>) )+import Data.Set ( Set, toList, insert, member )+import qualified Data.Set as Set+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 (:|), (<|) )+import qualified Agda.Utils.List1 as List1++import Agda.Utils.Impossible+ import Agda.Compiler.JS.Syntax hiding (exports)  -- Pretty-print a lambda-calculus expression as ECMAScript. --- Since ECMAScript is C-like rather than Haskell-like, it's easier to--- do the pretty-printing directly than use the Pretty library, which--- assumes Haskell-like indentation.+--- The indentation combinators of the pretty library does not fit C-like languages+--- like ECMAScript.+--- A simple pretty printer is implemented with a better `indent` and punctuation compaction.+---+--- More explanation:+---+--- I have struggled with different pretty printers, and at the end it was much easier+--- to implement and use this ~100 SLOC code pretty printer library.+--- It produces really better quality indentation than I could achieve with the+--  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 -br :: Int -> String-br i = "\n" ++ take (2*i) (repeat ' ')+data Doc+    = Doc String+    | Indent Int Doc+    | Group Doc+    | Beside Doc Doc+    | Above Doc Doc+    | Enclose Doc Doc Doc+    | Space+    | Empty +minifiedCodeLinesLength :: Int+minifiedCodeLinesLength = 500++render :: Bool -> Doc -> String+render minify = intercalate "\n" . joinLines . map (uncurry mkIndent) . go 0+  where+    joinLines :: [String] -> [String]+    joinLines = applyWhen minify $ chunks 0 []+      where+        chunks len acc [] = [concat (reverse acc)]+        chunks len acc (s: ss)+            | len + n <= minifiedCodeLinesLength = chunks (len + n) (s: acc) ss+            | otherwise = concat (reverse acc): chunks n [s] ss+          where+            n = length s++    joinBy f [x] (y: ys) = f x y ++ ys+    joinBy f (x:xs) ys = x: joinBy f xs ys+    joinBy f xs ys = xs ++ ys++    mkIndent n s | minify = s+    mkIndent n "" = ""+    mkIndent n s = replicate n ' ' ++ s++    overlay (i, s) (j, s') | all punctuation (s ++ s') && n > 0 = [(i, s ++ mkIndent n s')]+      where n = j - (i + length s)+    overlay (j, s') (i, s) | all punctuation (s ++ s') && n > 0 = [(i, s' ++ mkIndent n s)]+      where n = j - (i + length s)+    overlay a b = [a, b]++    punctuation = (`elem` ("(){}[];:, " :: String))++    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 (Enclose open close d) = go i $ Group $ Above open $ Above d close+    go i (Group d)+        | size ss < 40 = compact ss+        | otherwise    = ss+      where+        ss = go i d+        size = sum . map (length . snd)+        compact [] = []+        compact ((i, x): xs) = [(i, x ++ concatMap snd xs)]++instance IsString Doc where+    fromString = Doc++instance Semigroup Doc where+    Empty <> d = d+    d <> Empty = d+    d <> d' = Beside d d'++instance Monoid Doc where+    mempty = Empty+    mappend = (<>)++infixr 5 $+$+infixr 5 $++$+infixr 6 <+>  -- fixity has to match the one of Semigroup.(<>)++($+$) :: Doc -> Doc -> Doc+Empty $+$ d = d+d $+$ Empty = d+d $+$ d' = Above d d'++-- | Separate by blank line.++($++$) :: Doc -> Doc -> Doc+Empty $++$ d = d+d $++$ Empty = d+d $++$ d' = d `Above` "" `Above` d'++-- | Separate by space that will be removed by minify.+--+-- For non-removable space, use @d <> " " <> d'@.++(<+>) :: Doc -> Doc -> Doc+Empty <+> d = d+d <+> Empty = d+d <+> d' = d `Beside` Space `Beside` d'++text :: String -> Doc+text = Doc++group :: Doc -> Doc+group = Group++indentBy :: Int -> Doc -> Doc+indentBy i Empty = Empty+indentBy i (Indent j d) = Indent (i + j) d+indentBy i d = Indent i d++enclose :: Doc -> Doc -> Doc -> Doc+enclose open close (Enclose o c d) = Enclose (open <> o) (c <> close) d+enclose open close (Indent _ (Enclose o c d)) = Enclose (open <> o) (c <> close) d+enclose open close d = Enclose open close d++----------------------------------------------------------------------------------------------++space :: Doc+space = Space++indent :: Doc -> Doc+indent = indentBy 2++hcat :: [Doc] -> Doc+hcat = foldr (<>) mempty++vcat :: [Doc] -> Doc+vcat = foldr ($+$) mempty++-- | Concatenate vertically, separated by blank lines.++vsep :: [Doc] -> Doc+vsep = foldr ($++$) mempty++punctuate :: Doc -> [Doc] -> Doc+punctuate _ []     = mempty+punctuate p (x:xs) = indent $ vcat $ go x xs+                   where go y []     = [y]+                         go y (z:zs) = (y <> p) : go z zs++parens, brackets, braces :: Doc -> Doc+parens   = enclose "(" ")"+brackets = enclose "[" "]"+braces   = enclose "{" "}"++-- | Apply 'parens' to 'Doc' if boolean is true.+mparens :: Bool -> Doc -> Doc+mparens True  d = parens d+mparens False d = d++----------------------------------------------------------------------------------------------+ unescape :: Char -> String unescape '"'      = "\\\"" unescape '\\'     = "\\\\"@@ -27,94 +197,175 @@ unescape '\x2029' = "\\u2029" unescape c        = [c] -unescapes :: String -> String-unescapes s = concat (map unescape s)+unescapes :: String -> Doc+unescapes s = text $ concatMap unescape s --- pretty n i e pretty-prints e, under n levels of de Bruijn binding,--- with i levels of indentation.+-- pretty (n,b) i e pretty-prints e, under n levels of de Bruijn binding+--   if b is true then the output is minified  class Pretty a where-    pretty :: Nat -> Int -> a -> String+    pretty :: (Nat, Bool, JSModuleStyle) -> a -> Doc+    prettyPrec :: Int -> (Nat, Bool, JSModuleStyle) -> a -> Doc +    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+  prettyPrec p n = maybe mempty (prettyPrec p n)+ instance (Pretty a, Pretty b) => Pretty (a,b) where-  pretty n i (x,y) = pretty n i x ++ ": " ++ pretty n (i+1) y+  pretty n (x,y) = pretty n x <> ":" <+> pretty n y  -- Pretty-print collections  class Pretties a where-    pretties :: Nat -> Int -> a -> [String]+    pretties :: (Nat, Bool, JSModuleStyle) -> a -> [Doc]  instance Pretty a => Pretties [a] where-  pretties n i = map (pretty n i)+  pretties n = map (pretty n) +instance Pretty a => Pretties (List1 a) where+  pretties n = pretties n . List1.toList+ instance (Pretty a, Pretty b) => Pretties (Map a b) where-  pretties n i o = pretties n i (toAscList o)+  pretties n = pretties n . toAscList  -- Pretty print identifiers  instance Pretty LocalId where-  pretty n i (LocalId x) = "x" ++ show (n - x - 1)+  pretty (n, _, _) (LocalId x) = text $ indexWithDefault __IMPOSSIBLE__ vars (n - x - 1)+    where+      vars = ("": map show [0..]) >>= \s -> map (:s) ['a'..'z']  instance Pretty GlobalId where-  pretty n i (GlobalId m) = intercalate "_" m+  pretty n (GlobalId m) = text $ variableName $ intercalate "_" m  instance Pretty MemberId where-  pretty n i (MemberId s) = "\"" ++ unescapes s ++ "\""+  pretty _ (MemberId s) = "\"" <> unescapes s <> "\""+  pretty n (MemberIndex i comment) = text (show i) <> pretty n comment +instance Pretty Comment where+  pretty _ (Comment "") = mempty+  pretty (_, True, _) _ = mempty+  pretty _ (Comment s) = text $ "/* " ++ s ++ " */"+ -- Pretty print expressions  instance Pretty Exp where-  pretty n i (Self)                 = "exports"-  pretty n i (Local x)              = pretty n i x-  pretty n i (Global m)             = pretty n i m-  pretty n i (Undefined)            = "undefined"-  pretty n i (String s)             = "\"" ++ unescapes s ++ "\""-  pretty n i (Char c)               = "\"" ++ unescape c ++ "\""-  pretty n i (Integer x)            = "agdaRTS.primIntegerFromString(\"" ++ show x ++ "\")"-  pretty n i (Double x)             = show x-  pretty n i (Lambda x e)           =-    "function (" ++-      intercalate ", " (pretties (n+x) i (map LocalId [x-1, x-2 .. 0])) ++-    ") " ++ block (n+x) i e-  pretty n i (Object o) | null o    = "{}"-  pretty n i (Object o) | otherwise =-    "{" ++ br (i+1) ++ intercalate ("," ++ br (i+1)) (pretties n i o) ++ br i ++ "}"-  pretty n i (Apply f es)           = pretty n i f ++ "(" ++ intercalate ", " (pretties n i es) ++ ")"-  pretty n i (Lookup e l)           = pretty n i e ++ "[" ++ pretty n i l ++ "]"-  pretty n i (If e f g)             =-    "(" ++ pretty n i e ++ "? " ++ pretty n i f ++ ": " ++ pretty n i g ++ ")"-  pretty n i (PreOp op e)           = "(" ++ op ++ " " ++ pretty n i e ++ ")"-  pretty n i (BinOp e op f)         = "(" ++ pretty n i e ++ " " ++ op ++ " " ++ pretty n i f ++ ")"-  pretty n i (Const c)              = c-  pretty n i (PlainJS js)           = "(" ++ 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 -> Int -> Exp -> String-block n i (If e f g) = "{" ++ br (i+1) ++ block' n (i+1) (If e f g) ++ br i ++ "}"-block n i e          = "{" ++ br (i+1) ++ "return " ++ pretty n (i+1) e ++ ";" ++ br i ++ "}"+block :: (Nat, Bool, JSModuleStyle) -> Exp -> Doc+block n e = mparens (doNest e) $ prettyPrec 2 n e+  where+    doNest Object{} = True+    doNest _ = False -block' :: Nat -> Int -> Exp -> String-block' n i (If e f g) = "if (" ++ pretty n i e ++ ") " ++ block n i f ++ " else " ++ block' n i g-block' n i e          = block n i e+modname :: GlobalId -> Doc+modname (GlobalId ms) = text $ intercalate "." ms -modname :: GlobalId -> String-modname (GlobalId ms) = "\"" ++ intercalate "." ms ++ "\""+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+  | maybe True (`member` lss) parent =+      "exports" <> hcat (map brackets (pretties n ls)) <+> "=" <+> indent (pretty n e) <> ";" $+$+      exports n (insert ls lss) es+  -- If the parent is not yet defined, first define it as empty object, and then continue with @ls@.+  | otherwise =+      exports n lss $ maybe es0 (\ ls' -> Export ls' (Object mempty) : es0) parent+  where+  parent = List1.nonEmpty $ List1.init ls -exports :: Nat -> Int -> Set [MemberId] -> [Export] -> String-exports n i lss [] = ""-exports n i lss (Export ls _ e : es) | member (init ls) lss =-  "exports[" ++ intercalate "][" (pretties n i ls) ++ "] = " ++ pretty n (i+1) e ++ ";" ++ br i ++-  exports n i (insert ls lss) es-exports n i lss (Export ls isCoind e : es) | otherwise =-  exports n i lss (Export (init ls) False (Object empty) : Export ls isCoind e : es)+instance Pretty [(GlobalId, Export)] where+  pretty n es+    = vcat [ pretty n g <> hcat (map brackets (pretties n ls)) <+> "=" <+> indent (pretty n e) <> ";"+           | (g, Export ls e) <- es ]  instance Pretty Module where-  pretty n i (Module m es ex) =-    imports ++ br i-      ++ exports n i (singleton []) es ++ br i-      ++ maybe "" (pretty n i) ex+  pretty opt@(n, min, JSES6) (Module m is es callMain) = vsep+    [ "import agdaRTS from \"./agda-rts.mjs\";"+    , imports+    , "const exports = {};"+    , exports opt Set.empty es+    , pretty opt callMain+    , ";export default exports;"+    ]+    $+$ ""     where-      js = toList (globals es)-      imports = unlines $-            ["var agdaRTS = require(\"agda-rts\");"] ++-            ["var " ++ pretty n (i+1) e ++ " = require(" ++ modname e ++ ");"-            | e <- js]+      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)++-- | Check if a string is a valid JS identifier. The check ignores keywords+-- as we prepend z_ to our identifiers. The check+-- is conservative and may not admit all valid JS identifiers.++isValidJSIdent :: String -> Bool+isValidJSIdent []     = False+isValidJSIdent (c:cs) = validFirst c && all validOther cs+  where+  validFirst :: Char -> Bool+  validFirst c = isAsciiUpper c || isAsciiLower c || c == '_' || c == '$'++  validOther :: Char -> Bool+  validOther c = validFirst c || isDigit c
src/full/Agda/Compiler/JS/Substitution.hs view
@@ -2,13 +2,13 @@  import Prelude hiding ( map, lookup ) import Data.Map ( empty, unionWith, singleton, findWithDefault )-import qualified Data.Map as M ( map )+import qualified Data.Map as Map import Data.List ( genericIndex )-import qualified Data.List as L ( map )+import qualified Data.List as List  import Agda.Syntax.Common ( Nat ) import Agda.Compiler.JS.Syntax-  ( Exp(Self,Undefined,Local,Lambda,Object,Apply,Lookup,If,BinOp,PreOp),+  ( Exp(Self,Undefined,Local,Lambda,Object,Array,Apply,Lookup,If,BinOp,PreOp),     MemberId, LocalId(LocalId) ) import Agda.Utils.Function ( iterate' ) @@ -17,8 +17,9 @@ map :: Nat -> (Nat -> LocalId -> Exp) -> Exp -> Exp map m f (Local i)       = f m i map m f (Lambda i e)    = Lambda i (map (m + i) f e)-map m f (Object o)      = Object (M.map (map m f) o)-map m f (Apply e es)    = Apply (map m f e) (L.map (map m f) es)+map m f (Object o)      = Object (Map.map (map m f) o)+map m f (Array es)      = Array (List.map (\(c, e) -> (c, map m f e)) es)+map m f (Apply e es)    = Apply (map m f e) (List.map (map m f) es) map m f (Lookup e l)    = Lookup (map m f e) l map m f (If e e' e'')   = If (map m f e) (map m f e') (map m f e'') map m f (PreOp op e)    = PreOp op (map m f e)@@ -49,13 +50,17 @@ 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  map' :: Nat -> (Nat -> LocalId -> Exp) -> Exp -> Exp map' m f (Local i)       = f m i map' m f (Lambda i e)    = Lambda i (map' (m + i) f e)-map' m f (Object o)      = Object (M.map (map' m f) o)-map' m f (Apply e es)    = apply (map' m f e) (L.map (map' m f) es)+map' m f (Object o)      = Object (Map.map (map' m f) o)+map' m f (Array es)      = Array (List.map (\(c, e) -> (c, map' m f e)) es)+map' m f (Apply e es)    = apply (map' m f e) (List.map (map' m f) es) map' m f (Lookup e l)    = lookup (map' m f e) l map' m f (If e e' e'')   = If (map' m f e) (map' m f e') (map' m f e'') map' m f (PreOp op e)    = PreOp op (map' m f e)@@ -84,10 +89,11 @@  self :: Exp -> Exp -> Exp self e (Self)         = e-self e (Object o)     = Object (M.map (self e) o)+self e (Object o)     = Object (Map.map (self e) o)+self e (Array es)     = Array (List.map (\(c, x) -> (c, self e x)) es) self e (Apply f es)   = case (self e f) of   (Lambda n g) -> self e (subst' n es g)-  g            -> Apply g (L.map (self e) es)+  g            -> Apply g (List.map (self e) es) self e (Lookup f l)   = lookup (self e f) l self e (If f g h)     = If (self e f) (self e g) (self e h) self e (BinOp f op g) = BinOp (self e f) op (self e g)
src/full/Agda/Compiler/JS/Syntax.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE DeriveDataTypeable #-}  module Agda.Compiler.JS.Syntax where -import Data.Typeable ( Typeable )-import Data.Map ( Map, fold )-import Data.Set ( Set, empty, singleton, union )+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Semigroup ( Semigroup ) +import Data.Text (Text)+ import Agda.Syntax.Common ( Nat ) +import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+ -- An untyped lambda calculus with records, -- and a special self-binder for recursive declarations @@ -16,12 +21,14 @@   Local LocalId |   Global GlobalId |   Undefined |-  String String |+  Null |+  String Text |   Char Char |   Integer Integer |   Double Double |   Lambda Nat Exp |   Object (Map MemberId Exp) |+  Array [(Comment, Exp)] |   Apply Exp [Exp] |   Lookup Exp MemberId |   If Exp Exp Exp |@@ -29,83 +36,121 @@   PreOp String Exp |   Const String |   PlainJS String -- ^ Arbitrary JS code.-  deriving (Typeable, Show)+  deriving (Show, Eq)  -- Local identifiers are named by De Bruijn indices. -- Global identifiers are named by string lists. -- Object members are named by strings.  newtype LocalId = LocalId Nat-  deriving (Typeable, Eq, Ord, Show)+  deriving (Eq, Ord, Show)  newtype GlobalId = GlobalId [String]-  deriving (Typeable, Eq, Ord, Show)+  deriving (Eq, Ord, Show) -newtype MemberId = MemberId String-  deriving (Typeable, Eq, Ord, Show)+data MemberId+    = MemberId String+    | MemberIndex Int Comment+  deriving (Eq, Ord, Show) +newtype Comment = Comment String+  deriving (Show, Semigroup, Monoid)++instance Eq Comment where _ == _ = True+instance Ord Comment where compare _ _ = EQ+ -- The top-level compilation unit is a module, which names -- the GId of its exports, and a list of definitions -data Export = Export { expName :: [MemberId], isCoind :: Bool, defn :: Exp }-  deriving (Typeable, Show)+data Export = Export { expName :: JSQName, defn :: Exp }+  deriving Show -data Module = Module { modName :: GlobalId, exports :: [Export], postscript :: Maybe Exp }-  deriving (Typeable, Show)+type JSQName = List1 MemberId +data Module = Module+  { modName  :: GlobalId+  , imports  :: [GlobalId]+  , exports  :: [Export]+  , callMain :: Maybe Exp+  }+  deriving Show+ -- Note that modules are allowed to be recursive, via the Self expression, -- which is bound to the exported module.  -- Top-level uses of the form exports.l1....lN.  class Uses a where-  uses :: a -> Set [MemberId]+  uses :: a -> Set JSQName -instance Uses a => Uses [a] where-  uses = foldr (union . uses) empty+  default uses :: (a ~ t b, Foldable t, Uses b) => a -> Set JSQName+  uses = foldMap uses -instance Uses a => Uses (Map k a) where-  uses = fold (union . uses) empty+instance Uses a => Uses [a]+instance Uses a => Uses (Map k a) +instance (Uses a, Uses b) => Uses (a, b) where+  uses (a, b) = uses a `Set.union` uses b++instance (Uses a, Uses b, Uses c) => Uses (a, b, c) where+  uses (a, b, c) = uses a `Set.union` uses b `Set.union` uses c++instance Uses Comment where+  uses _ = Set.empty+ instance Uses Exp where-  uses (Object o)     = fold (union . uses) empty o-  uses (Apply e es)   = foldr (union . uses) (uses e) es-  uses (Lookup e l)   = uses' e [l] where-      uses' Self         ls = singleton ls-      uses' (Lookup e l) ls = uses' e (l : ls)+  uses (Object o)     = uses o+  uses (Array es)     = uses es+  uses (Apply e es)   = uses (e, es)+  uses (Lookup e l)   = uses' e (List1.singleton l)+    where+      uses' :: Exp -> JSQName -> Set JSQName+      uses' Self         ls = Set.singleton ls+      uses' (Lookup e l) ls = uses' e (l <| ls)       uses' e            ls = uses e-  uses (If e f g)     = uses e `union` uses f `union` uses g-  uses (BinOp e op f) = uses e `union` uses f+  uses (If e f g)     = uses (e, f, g)+  uses (BinOp e op f) = uses (e, f)   uses (PreOp op e)   = uses e-  uses e              = empty+  uses e              = Set.empty  instance Uses Export where-  uses (Export _ _ e) = uses e+  uses (Export _ e) = uses e  -- All global ids  class Globals a where   globals :: a -> Set GlobalId -instance Globals a => Globals [a] where-  globals = foldr (union . globals) empty+  default globals :: (a ~ t b, Foldable t, Globals b) => a -> Set GlobalId+  globals = foldMap globals -instance Globals a => Globals (Map k a) where-  globals = fold (union . globals) empty+instance Globals a => Globals [a]+instance Globals a => Globals (Maybe a)+instance Globals a => Globals (Map k a) +instance (Globals a, Globals b) => Globals (a, b) where+  globals (a, b) = globals a `Set.union` globals b++instance (Globals a, Globals b, Globals c) => Globals (a, b, c) where+  globals (a, b, c) = globals a `Set.union` globals b `Set.union` globals c++instance Globals Comment where+  globals _ = Set.empty+ instance Globals Exp where-  globals (Global i) = singleton i+  globals (Global i) = Set.singleton i   globals (Lambda n e) = globals e   globals (Object o) = globals o-  globals (Apply e es) = globals e `union` globals es+  globals (Array es) = globals es+  globals (Apply e es) = globals (e, es)   globals (Lookup e l) = globals e-  globals (If e f g) = globals e `union` globals f `union` globals g-  globals (BinOp e op f) = globals e `union` globals f+  globals (If e f g) = globals (e, f, g)+  globals (BinOp e op f) = globals (e, f)   globals (PreOp op e) = globals e-  globals _ = empty+  globals _ = Set.empty  instance Globals Export where-  globals (Export _ _ e) = globals e+  globals (Export _ e) = globals e  instance Globals Module where-  globals (Module m es _) = globals es+  globals (Module _ _ es me) = globals (es, me)
+ src/full/Agda/Compiler/MAlonzo/Coerce.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Compiler.MAlonzo.Coerce (addCoercions, erasedArity) where++import Agda.Syntax.Common (Nat)+import Agda.Syntax.Treeless++import Agda.TypeChecking.Monad+  ( HasConstInfo+  , getErasedConArgs+  , getTreeless+  )++-- | Insert unsafeCoerce (in the form of 'TCoerce') everywhere it's needed in+--   the right-hand side of a definition.+addCoercions :: HasConstInfo m => TTerm -> m TTerm+addCoercions = coerceTop+  where+    -- Don't coerce top-level lambdas.+    coerceTop (TLam b) = TLam <$> coerceTop b+    coerceTop t        = coerce t++    -- Coerce a term `t`. The result (when translated to Haskell) has type+    -- `forall a. a`.+    coerce t =+      case t of+        TVar{}    -> return $ TCoerce t+        TPrim{}   -> return $ TCoerce t+        TDef{}    -> return $ TCoerce t+        TCon{}    -> return $ TCoerce t+        TLit{}    -> return $ TCoerce t+        TUnit{}   -> return $ TCoerce t+        TSort{}   -> return $ TCoerce t+        TErased{} -> return t+        TCoerce{} -> return t+        TError{}  -> return t+        TApp f vs -> do+          ar <- funArity f+          if length vs > ar+            then TApp (TCoerce f) <$> mapM softCoerce vs+            else TCoerce . TApp f <$> mapM coerce vs+        TLam b         -> TCoerce . TLam <$> softCoerce b+        TLet e b       -> TLet <$> softCoerce e <*> coerce b+        TCase x t d bs -> TCase x t <$> coerce d <*> mapM coerceAlt bs++    coerceAlt (TACon c a b) = TACon c a <$> coerce b+    coerceAlt (TAGuard g b) = TAGuard   <$> coerce g <*> coerce b+    coerceAlt (TALit l b)   = TALit l   <$> coerce b++    -- Insert TCoerce in subterms. When translated to Haskell, the resulting+    -- term is well-typed with some type arbitrary type.+    softCoerce t =+      case t of+        TVar{}    -> return t+        TPrim{}   -> return t+        TDef{}    -> return t+        TCon{}    -> return t+        TLit{}    -> return t+        TUnit{}   -> return t+        TSort{}   -> return t+        TErased{} -> return t+        TCoerce{} -> return t+        TError{}  -> return t+        TApp f vs -> do+          ar <- funArity f+          if length vs > ar+            then TApp (TCoerce f) <$> mapM softCoerce vs+            else TApp f <$> mapM coerce vs+        TLam b         -> TLam <$> softCoerce b+        TLet e b       -> TLet <$> softCoerce e <*> softCoerce b+        TCase x t d bs -> TCase x t <$> coerce d <*> mapM coerceAlt bs++funArity :: HasConstInfo m => TTerm -> m Nat+funArity (TDef q)  = maybe 0 (fst . tLamView) <$> getTreeless q+funArity (TCon q)  = erasedArity q+funArity (TPrim _) = return 3 -- max arity of any primitive+funArity _         = return 0++-- | The number of retained arguments after erasure.+erasedArity :: HasConstInfo m => QName -> m Nat+erasedArity q = length . filter not <$> getErasedConArgs q
src/full/Agda/Compiler/MAlonzo/Compiler.hs view
@@ -1,735 +1,1322 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.Compiler.MAlonzo.Compiler where--#if __GLASGOW_HASKELL__ <= 708-import Prelude hiding (foldl, mapM_, mapM, sequence, concat)-#endif--import Control.Applicative-import Control.Monad.Reader hiding (mapM_, forM_, mapM, forM, sequence)-import Control.Monad.State  hiding (mapM_, forM_, mapM, forM, sequence)--import Data.Generics.Geniplate-import Data.Foldable hiding (any, all, foldr, sequence_)-import Data.Function-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Traversable hiding (for)--import Numeric.IEEE--import qualified Agda.Utils.Haskell.Syntax as HS--import System.Directory (createDirectoryIfMissing)-import System.FilePath hiding (normalise)--import Agda.Compiler.CallCompiler-import Agda.Compiler.Common-import Agda.Compiler.MAlonzo.Misc-import Agda.Compiler.MAlonzo.Pretty-import Agda.Compiler.MAlonzo.Primitives-import Agda.Compiler.ToTreeless-import Agda.Compiler.Treeless.Unused-import Agda.Compiler.Treeless.Erase--import Agda.Interaction.FindFile-import Agda.Interaction.Imports-import Agda.Interaction.Options--import Agda.Syntax.Common-import Agda.Syntax.Fixity-import qualified Agda.Syntax.Abstract.Name as A-import qualified Agda.Syntax.Concrete.Name as C-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.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Level (reallyUnLevelView)--import Agda.TypeChecking.CompiledClause--import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.IO.Directory-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow, Pretty)-import qualified Agda.Utils.IO.UTF8 as UTF8-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Paths_Agda--#include "undefined.h"-import Agda.Utils.Impossible--compilerMain :: IsMain -> Interface -> TCM ()-compilerMain isMain i =-  inCompilerEnv i $ do-    doCompile isMain i $-      \_ -> compile-    copyRTEModules-    callGHC isMain i--compile :: Interface -> TCM ()-compile i = do-  ifM uptodate noComp $ {- else -} do-    yesComp-    writeModule =<< decl <$> curHsMod <*> (definitions =<< curDefs) <*> imports-  where-  decl mn ds imp = HS.Module mn [] imp (map fakeDecl (reverse $ iHaskellCode i) ++ ds)-  uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)-  ifile    = maybe __IMPOSSIBLE__ filePath <$>-               (findInterfaceFile . toTopLevelModuleName =<< curMName)-  noComp   = reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . show . A.mnameToConcrete =<< curMName-  yesComp  = reportSLn "compile.ghc" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<-             sequence [show . A.mnameToConcrete <$> curMName, ifile, outFile_] :: TCM ()------------------------------------------------------- imported modules---   I use stImportedModules in a non-standard way,---   accumulating in it what are acutally used in Misc.xqual-----------------------------------------------------imports :: TCM [HS.ImportDecl]-imports = (++) <$> hsImps <*> imps where-  hsImps :: TCM [HS.ImportDecl]-  hsImps = ((unqualRTE :) . List.map decl . Set.toList .-            Set.insert mazRTE . Set.map HS.ModuleName) <$>-             getHaskellImports--  unqualRTE :: HS.ImportDecl-  unqualRTE = HS.ImportDecl mazRTE False $ Just $-              (False, [ HS.IVar $ HS.Ident x-                      | x <- [mazCoerceName, mazErasedName] ++-                             map treelessPrimName [T.PAdd, T.PSub, T.PMul, T.PQuot, T.PRem, T.PGeq, T.PLt, T.PEqI, T.PEqF] ])--  imps :: TCM [HS.ImportDecl]-  imps = List.map decl . uniq <$>-           ((++) <$> importsForPrim <*> (List.map mazMod <$> mnames))--  decl :: HS.ModuleName -> HS.ImportDecl-  decl m = HS.ImportDecl m True Nothing--  mnames :: TCM [ModuleName]-  mnames = Set.elems <$> use stImportedModules--  uniq :: [HS.ModuleName] -> [HS.ModuleName]-  uniq = List.map head . List.group . List.sort------------------------------------------------------- Main compiling clauses-----------------------------------------------------definitions :: Definitions -> TCM [HS.Decl]-definitions defs = do-  kit <- coinductionKit-  concat <$>-    (mapM (\(_, d) -> definition kit =<< instantiateFull d) $-    -- sort defs to ensure consistent order (see Issue 1900)-     sortDefs defs-    )---- | Note that the INFINITY, SHARP and FLAT builtins are translated as--- follows (if a 'CoinductionKit' is given):------ @---   type Infinity a b = b------   sharp :: a -> a---   sharp x = x------   flat :: a -> a---   flat x = x--- @--definition :: Maybe CoinductionKit -> Definition -> TCM [HS.Decl]--- ignore irrelevant definitions-{- Andreas, 2012-10-02: Invariant no longer holds-definition kit (Defn Forced{}  _ _  _ _ _ _ _ _) = __IMPOSSIBLE__-definition kit (Defn UnusedArg _ _  _ _ _ _ _ _) = __IMPOSSIBLE__-definition kit (Defn NonStrict _ _  _ _ _ _ _ _) = __IMPOSSIBLE__--}-definition kit Defn{defArgInfo = info, defName = q} | isIrrelevant info = do-  reportSDoc "compile.ghc.definition" 10 $-    text "Not compiling" <+> prettyTCM q <> text "."-  return []-definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef = d} = do-  reportSDoc "compile.ghc.definition" 10 $ vcat-    [ text "Compiling" <+> prettyTCM q <> text ":"-    , nest 2 $ text (show d)-    ]-  checkTypeOfMain q ty $ do-    infodecl q <$> case d of--      _ | Just (HsDefn hsty hs) <- compiledHaskell compiled -> do-        -- Make sure we have imports for all names mentioned in the type.-        ty <- normalise ty-        sequence_ [ xqual x (HS.Ident "_") | x <- Set.toList (namesIn ty) ]-        return $ fbWithType hsty (fakeExp hs)--      -- Special treatment of coinductive builtins.-      Datatype{} | Just q == (nameOfInf <$> kit) -> do-        let infT = unqhname "T" q-            infV = unqhname "d" q-            a    = ihname "a" 0-            b    = ihname "a" 1-            vars = [a, b]-        return [ HS.TypeDecl infT-                             (List.map HS.UnkindedVar vars)-                             (HS.TyVar b)-               , HS.FunBind [HS.Match infV-                                      (List.map HS.PVar vars)-                                      (HS.UnGuardedRhs HS.unit_con)-                                      emptyBinds]-               ]-      Constructor{} | Just q == (nameOfSharp <$> kit) -> do-        let sharp = unqhname "d" q-            x     = ihname "x" 0-        return $-          [ HS.TypeSig [sharp] $ fakeType $-              "forall a. a -> a"-          , HS.FunBind [HS.Match sharp-                                 [HS.PVar x]-                                 (HS.UnGuardedRhs (HS.Var (HS.UnQual x)))-                                 emptyBinds]-          ]-      Function{} | Just q == (nameOfFlat <$> kit) -> do-        let flat = unqhname "d" q-            x    = ihname "x" 0-        return $-          [ HS.TypeSig [flat] $ fakeType $-              "forall a. a -> a"-          , HS.FunBind [HS.Match flat-                                 [HS.PVar x]-                                 (HS.UnGuardedRhs (HS.Var (HS.UnQual x)))-                                 emptyBinds]-          ]--      Axiom{} -> return $ fb axiomErr-      Primitive{ primName = s } -> fb <$> primBody s--      Function{} -> function (exportHaskell compiled) $ functionViaTreeless q--      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl, dataCons = cs }-        | Just (HsType ty) <- compiledHaskell compiled -> do-        ccscov <- ifM (noCheckCover q) (return []) $ do-            ccs <- List.concat <$> mapM checkConstructorType cs-            cov <- checkCover q ty (np + ni) cs-            return $ ccs ++ cov-        return $ tvaldecl q (dataInduction d) 0 (np + ni) [] (Just __IMPOSSIBLE__) ++ ccscov-      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl, dataCons = cs } -> do-        computeErasedConstructorArgs q-        (ars, cds) <- unzip <$> mapM condecl cs-        return $ tvaldecl q (dataInduction d) (List.maximum (np:ars) - np) (np + ni) cds cl-      Constructor{} -> return []-      Record{ recClause = cl, recConHead = con, recFields = flds } -> do-        computeErasedConstructorArgs q-        let c = conName con-        let noFields = length flds-        let ar = I.arity ty-        cd <- snd <$> condecl c-  --       cd <- case c of-  --         Nothing -> return $ cdecl q noFields-  --         Just c  -> snd <$> condecl c-        return $ tvaldecl q Inductive noFields ar [cd] cl-      AbstractDefn -> __IMPOSSIBLE__-  where-  function :: Maybe HaskellExport -> TCM [HS.Decl] -> TCM [HS.Decl]-  function mhe fun = do-    ccls <- mkwhere <$> fun-    case mhe of-      Nothing -> return ccls-      Just (HsExport t name) -> do-        let tsig :: HS.Decl-            tsig = HS.TypeSig [HS.Ident name] (fakeType t)--            def :: HS.Decl-            def = HS.FunBind [HS.Match (HS.Ident name) [] (HS.UnGuardedRhs (hsVarUQ $ dname q)) emptyBinds]-        return ([tsig,def] ++ ccls)--  functionViaTreeless :: QName -> TCM [HS.Decl]-  functionViaTreeless q = caseMaybeM (toTreeless q) (pure []) $ \ treeless -> do--    used <- getCompiledArgUse q-    let dostrip = any not used--    e <- if dostrip then closedTerm (stripUnusedArguments used treeless)-                    else closedTerm treeless-    let (ps, b) = lamView e-        lamView e =-          case stripTopCoerce e of-            HS.Lambda ps b -> (ps, b)-            b                -> ([], b)-        stripTopCoerce (HS.Lambda ps b) = HS.Lambda ps $ stripTopCoerce b-        stripTopCoerce e =-          case hsAppView e of-            [c,  e] | c == mazCoerce -> e-            _                        -> e--        funbind f ps b = HS.FunBind [HS.Match f ps (HS.UnGuardedRhs b) emptyBinds]--    -- The definition of the non-stripped function-    (ps0, _) <- lamView <$> closedTerm (foldr ($) T.TErased $ replicate (length used) T.TLam)-    let b0 = foldl HS.App (hsVarUQ $ duname q) [ hsVarUQ x | (~(HS.PVar x), True) <- zip ps0 used ]--    return $ if dostrip-      then [ funbind (dname q) ps0 b0-           , funbind (duname q) ps b ]-      else [ funbind (dname q) ps b ]--  mkwhere :: [HS.Decl] -> [HS.Decl]-  mkwhere (HS.FunBind [m0, HS.Match dn ps rhs emptyBinds] : fbs@(_:_)) =-          [HS.FunBind [m0, HS.Match dn ps rhs bindsAux]]-    where-    bindsAux :: Maybe HS.Binds-    bindsAux = Just $ HS.BDecls fbs--  mkwhere fbs = fbs--  fbWithType :: HaskellType -> HS.Exp -> [HS.Decl]-  fbWithType ty e =-    [ HS.TypeSig [unqhname "d" q] $ fakeType ty ] ++ fb e--  fb :: HS.Exp -> [HS.Decl]-  fb e  = [HS.FunBind [HS.Match (unqhname "d" q) []-                                (HS.UnGuardedRhs $ e) emptyBinds]]--  axiomErr :: HS.Exp-  axiomErr = rtmError $ "postulate evaluated: " ++ show (A.qnameToConcrete q)---- | Environment for naming of local variables.---   Invariant: @reverse ccCxt ++ ccNameSupply@-data CCEnv = CCEnv-  { ccNameSupply :: NameSupply  -- ^ Supply of fresh names-  , ccCxt        :: CCContext   -- ^ Names currently in scope-  }--type NameSupply = [HS.Name]-type CCContext  = [HS.Name]--mapNameSupply :: (NameSupply -> NameSupply) -> CCEnv -> CCEnv-mapNameSupply f e = e { ccNameSupply = f (ccNameSupply e) }--mapContext :: (CCContext -> CCContext) -> CCEnv -> CCEnv-mapContext f e = e { ccCxt = f (ccCxt e) }---- | Initial environment for expression generation.-initCCEnv :: CCEnv-initCCEnv = CCEnv-  { ccNameSupply = map (ihname "v") [0..]  -- DON'T CHANGE THESE NAMES!-  , ccCxt        = []-  }---- | Term variables are de Bruijn indices.-lookupIndex :: Int -> CCContext -> HS.Name-lookupIndex i xs = fromMaybe __IMPOSSIBLE__ $ xs !!! i--type CC = ReaderT CCEnv TCM--freshNames :: Int -> ([HS.Name] -> CC a) -> CC a-freshNames n _ | n < 0 = __IMPOSSIBLE__-freshNames n cont = do-  (xs, rest) <- splitAt n <$> asks ccNameSupply-  local (mapNameSupply (const rest)) $ cont xs---- | Introduce n variables into the context.-intros :: Int -> ([HS.Name] -> CC a) -> CC a-intros n cont = freshNames n $ \xs ->-  local (mapContext (reverse xs ++)) $ cont xs--checkConstructorType :: QName -> TCM [HS.Decl]-checkConstructorType q = do-  Just (HsDefn ty hs) <- compiledHaskell . defCompiledRep <$> getConstInfo q-  return [ HS.TypeSig [unqhname "check" q] $ fakeType ty-         , HS.FunBind [HS.Match (unqhname "check" q) []-                                (HS.UnGuardedRhs $ fakeExp hs) emptyBinds]-         ]--checkCover :: QName -> HaskellType -> Nat -> [QName] -> TCM [HS.Decl]-checkCover q ty n cs = do-  let tvs = [ "a" ++ show i | i <- [1..n] ]-      makeClause c = do-        a <- erasedArity c-        Just (HsDefn _ hsc) <- compiledHaskell . defCompiledRep <$> getConstInfo c-        let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ replicate a HS.PWildCard-        return $ HS.Alt pat (HS.UnGuardedRhs $ HS.unit_con) emptyBinds--  cs <- mapM makeClause cs-  let rhs = case cs of-              [] -> fakeExp "()" -- There is no empty case statement in Haskell-              _  -> HS.Case (HS.Var $ HS.UnQual $ HS.Ident "x") cs--  return [ HS.TypeSig [unqhname "cover" q] $ fakeType $ unwords (ty : tvs) ++ " -> ()"-         , HS.FunBind [HS.Match (unqhname "cover" q) [HS.PVar $ HS.Ident "x"]-                                (HS.UnGuardedRhs rhs) emptyBinds]-         ]--closedTerm :: T.TTerm -> TCM HS.Exp-closedTerm v = hsCast <$> term v `runReaderT` initCCEnv---- | Extract Agda term to Haskell expression.---   Erased arguments are extracted as @()@.---   Types are extracted as @()@.-term :: T.TTerm -> CC HS.Exp-term tm0 = case tm0 of-  T.TVar i -> do-    x <- lookupIndex i <$> asks ccCxt-    return $ hsVarUQ x-  T.TApp (T.TDef f) ts -> do-    used <- lift $ getCompiledArgUse f-    let given   = length ts-        needed  = length used-        missing = drop given used-    if any not used-      then if any not missing then term (etaExpand (needed - given) tm0) else do-        f <- lift $ HS.Var <$> xhqn "du" f  -- used stripped function-        f `apps` [ t | (t, True) <- zip ts $ used ++ repeat True ]-      else do-        t' <- term (T.TDef f)-        t' `apps` ts-  T.TApp (T.TCon c) ts -> do-    kit <- lift coinductionKit-    if Just c == (nameOfSharp <$> kit)-      then do-        t' <- HS.Var <$> lift (xhqn "d" c)-        apps t' ts-      else do-        (ar, _) <- lift $ conArityAndPars c-        erased  <- lift $ getErasedConArgs c-        let missing = drop (length ts) erased-            notErased = not-        case all notErased missing of-          False -> term $ etaExpand (length missing) tm0-          True  -> do-            f <- lift $ HS.Con <$> conhqn c-            f `apps` [ t | (t, False) <- zip ts erased ]-  T.TApp t ts -> do-    t' <- term t-    t' `apps` ts-  T.TLam at -> do-    (nm:_) <- asks ccNameSupply-    intros 1 $ \ [x] ->-      hsLambda [HS.PVar x] <$> term at-  T.TLet t1 t2 -> do-    t1' <- term t1-    intros 1 $ \[x] -> do-      t2' <- term t2-      return $ hsLet x (hsCast t1') t2'--  T.TCase sc ct def alts -> do-    sc' <- term (T.TVar sc)-    alts' <- traverse (alt sc) alts-    def' <- term def-    let defAlt = HS.Alt HS.PWildCard (HS.UnGuardedRhs def') emptyBinds--    return $ HS.Case (hsCast sc') (alts' ++ [defAlt])--  T.TLit l -> return $ literal l-  T.TDef q -> do-    HS.Var <$> (lift $ xhqn "d" q)-  T.TCon q   -> term (T.TApp (T.TCon q) [])-  T.TPrim p  -> return $ compilePrim p-  T.TUnit    -> return HS.unit_con-  T.TSort    -> return HS.unit_con-  T.TErased  -> return $ hsVarUQ $ HS.Ident mazErasedName-  T.TError e -> return $ case e of-    T.TUnreachable ->  rtmUnreachableError-  where apps =  foldM (\ h a -> HS.App h <$> term a)-        etaExpand n t =-          foldr (const T.TLam)-                (T.mkTApp (raise n t) [T.TVar i | i <- [n - 1, n - 2..0]])-                (replicate n ())---compilePrim :: T.TPrim -> HS.Exp-compilePrim s = HS.Var $ hsName $ treelessPrimName s--alt :: Int -> T.TAlt -> CC HS.Alt-alt sc a = do-  case a of-    T.TACon {T.aCon = c} -> do-      intros (T.aArity a) $ \ xs -> do-        erased <- lift $ getErasedConArgs c-        hConNm <- lift $ conhqn c-        mkAlt (HS.PApp hConNm $ map HS.PVar [ x | (x, False) <- zip xs erased ])-    T.TAGuard g b -> do-      g <- term g-      b <- term b-      return $ HS.Alt HS.PWildCard-                      (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b])-                      emptyBinds-    T.TALit { T.aLit = LitQName _ q } -> mkAlt (litqnamepat q)-    T.TALit { T.aLit = l@LitFloat{},   T.aBody = b } -> mkGuarded (treelessPrimName T.PEqF) (literal l) b-    T.TALit { T.aLit = LitString _ s , T.aBody = b } -> mkGuarded "(==)" (litString s) b-    T.TALit {} -> mkAlt (HS.PLit $ hslit $ T.aLit a)-  where-    mkGuarded eq lit b = do-      b  <- term b-      sc <- term (T.TVar sc)-      let guard =-            HS.Var (HS.UnQual (HS.Ident eq)) `HS.App`-              sc `HS.App` lit-      return $ HS.Alt HS.PWildCard-                      (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier guard] b])-                      emptyBinds--    mkAlt :: HS.Pat -> CC HS.Alt-    mkAlt pat = do-        body' <- term $ T.aBody a-        return $ HS.Alt pat (HS.UnGuardedRhs $ hsCast body') emptyBinds--literal :: Literal -> HS.Exp-literal l = case l of-  LitNat    _ _   -> typed "Integer"-  LitFloat  _ x   -> floatExp x "Double"-  LitQName  _ x   -> litqname x-  LitString _ s   -> litString s-  _               -> l'-  where-    l'    = HS.Lit $ hslit l-    typed = HS.ExpTypeSig l' . HS.TyCon . rtmQual--    -- ASR (2016-09-14): See Issue #2169.-    -- Ulf, 2016-09-28: and #2218.-    floatExp :: Double -> String -> HS.Exp-    floatExp x s-      | isNegativeZero x = rte "negativeZero"-      | isNegativeInf  x = rte "negativeInfinity"-      | isInfinite x     = rte "positiveInfinity"-      | isNegativeNaN x  = rte "negativeNaN"-      | isNaN x          = rte "positiveNaN"-      | otherwise        = typed s--    rte = HS.Var . HS.Qual mazRTE . HS.Ident--    isNegativeInf x = isInfinite x && x < 0.0-    isNegativeNaN x = isNaN x && not (identicalIEEE x (0.0 / 0.0))--hslit :: Literal -> HS.Literal-hslit l = case l of LitNat    _ x -> HS.Int    x-                    LitFloat  _ x -> HS.Frac   (toRational x)-                    LitChar   _ x -> HS.Char   x-                    LitQName  _ x -> __IMPOSSIBLE__-                    LitString _ _ -> __IMPOSSIBLE__-                    LitMeta{}     -> __IMPOSSIBLE__--litString :: String -> HS.Exp-litString s =-  HS.Var (HS.Qual (HS.ModuleName "Data.Text") (HS.Ident "pack")) `HS.App`-    (HS.Lit $ HS.String s)--litqname :: QName -> HS.Exp-litqname x =-  rteCon "QName" `apps`-  [ hsTypedInt n-  , hsTypedInt m-  , HS.Lit $ HS.String $ show x-  , rteCon "Fixity" `apps`-    [ litAssoc (fixityAssoc fx)-    , litPrec  (fixityLevel fx) ] ]-  where-    apps = foldl HS.App-    rteCon name = HS.Con $ HS.Qual mazRTE $ HS.Ident name-    NameId n m = nameId $ qnameName x-    fx = theFixity $ nameFixity $ qnameName x--    litAssoc NonAssoc   = rteCon "NonAssoc"-    litAssoc LeftAssoc  = rteCon "LeftAssoc"-    litAssoc RightAssoc = rteCon "RightAssoc"--    litPrec Unrelated   = rteCon "Unrelated"-    litPrec (Related l) = rteCon "Related" `HS.App` hsTypedInt l--litqnamepat :: QName -> HS.Pat-litqnamepat x =-  HS.PApp (HS.Qual mazRTE $ HS.Ident "QName")-          [ HS.PLit (HS.Int $ fromIntegral n)-          , HS.PLit (HS.Int $ fromIntegral m)-          , HS.PWildCard, HS.PWildCard ]-  where-    NameId n m = nameId $ qnameName x--erasedArity :: QName -> TCM Nat-erasedArity q = do-  (ar, _) <- conArityAndPars q-  erased  <- length . filter id <$> getErasedConArgs q-  return (ar - erased)--condecl :: QName -> TCM (Nat, HS.ConDecl)-condecl q = do-  (ar, np) <- conArityAndPars q-  erased   <- length . filter id <$> getErasedConArgs q-  let ar' = ar - erased-  return $ (ar' + np, cdecl q ar')--cdecl :: QName -> Nat -> HS.ConDecl-cdecl q n = HS.ConDecl (unqhname "C" q)-            [ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ]--tvaldecl :: QName-         -> Induction-            -- ^ Is the type inductive or coinductive?-         -> Nat -> Nat -> [HS.ConDecl] -> Maybe Clause -> [HS.Decl]-tvaldecl q ind ntv npar cds cl =-  HS.FunBind [HS.Match vn pvs (HS.UnGuardedRhs HS.unit_con) emptyBinds] :-  maybe [HS.DataDecl kind tn tvs cds []]-        (const []) cl-  where-  (tn, vn) = (unqhname "T" q, unqhname "d" q)-  tvs = [ HS.UnkindedVar $ ihname "a" i | i <- [0 .. ntv  - 1]]-  pvs = [ HS.PVar        $ ihname "a" i | i <- [0 .. npar - 1]]--  -- Inductive data types consisting of a single constructor with a-  -- single argument are translated into newtypes.-  kind = case (ind, cds) of-    (Inductive, [HS.ConDecl _ [_]]) -> HS.NewType-    _                               -> HS.DataType--infodecl :: QName -> [HS.Decl] -> [HS.Decl]-infodecl _ [] = []-infodecl q ds = fakeD (unqhname "name" q) (show $ prettyShow q) : ds------------------------------------------------------- Inserting unsafeCoerce-----------------------------------------------------hsCast :: HS.Exp -> HS.Exp-{--hsCast = addcast . go where-  addcast [e@(HS.Var(HS.UnQual(HS.Ident(c:ns))))] | c == 'v' && all isDigit ns = e-  addcast es = foldl HS.App mazCoerce es-  -- this need to be extended if you generate other kinds of exps.-  go (HS.App e1 e2    ) = go e1 ++ [hsCast e2]-  go (HS.Lambda _ ps e) = [ HS.Lambda ps (hsCast e) ]-  go e = [e]--}---- TODO: what's the specification for hsCast, hsCast' and hsCoerce???-hsCast e = hsCoerce (hsCast' e)--hsCast' :: HS.Exp -> HS.Exp-hsCast' (HS.InfixApp e1 op e2) = hsCoerce $ HS.InfixApp (hsCast' e1) op (hsCast' e2)-hsCast' (HS.Lambda ps e)       = HS.Lambda ps $ hsCast' e-hsCast' (HS.Let bs e)          = HS.Let bs $ hsCast' e-hsCast' (HS.Case sc alts)      = HS.Case (hsCast' sc) (map (hsMapAlt hsCast') alts)-hsCast' e =-  case hsAppView e of-    f : es -> foldl HS.App (hsCoerce f) (map hsCastApp es)-    _      -> __IMPOSSIBLE__---- We still have to coerce function applications in arguments to coerced--- functions.-hsCastApp :: HS.Exp -> HS.Exp-hsCastApp (HS.Lambda ps b) = HS.Lambda ps (hsCastApp b)-hsCastApp (HS.Case sc bs) = HS.Case (hsCastApp sc) (map (hsMapAlt hsCastApp) bs)-hsCastApp (HS.InfixApp e1 op e2) = HS.InfixApp (hsCastApp e1) op (hsCastApp e2)-hsCastApp e =-  case hsAppView e of-    f : es@(_:_) -> foldl HS.App (hsCoerce f) $ map hsCastApp es-    _ -> e---- No coercion for literal integers-hsCoerce :: HS.Exp -> HS.Exp-hsCoerce e@(HS.ExpTypeSig (HS.Lit (HS.Int{})) _) = e-hsCoerce (HS.Case sc alts) = HS.Case sc (map (hsMapAlt hsCoerce) alts)-hsCoerce (HS.Let bs e) = HS.Let bs $ hsCoerce e-hsCoerce e =-  case hsAppView e of-    c : _ | c == mazCoerce || c == mazIncompleteMatch -> e-    _ -> mazCoerce `HS.App` e------------------------------------------------------- Writing out a haskell module-----------------------------------------------------copyRTEModules :: TCM ()-copyRTEModules = do-  dataDir <- lift getDataDir-  let srcDir = dataDir </> "MAlonzo" </> "src"-  (lift . copyDirContent srcDir) =<< compileDir--writeModule :: HS.Module -> TCM ()-writeModule (HS.Module m ps imp ds) = do-  -- Note that GHC assumes that sources use ASCII or UTF-8.-  out <- outFile m-  liftIO $ UTF8.writeFile out $ prettyPrint $-    HS.Module m (p : ps) imp ds-  where-  p = HS.LanguagePragma $ List.map HS.Ident $-        [ "EmptyDataDecls"-        , "ExistentialQuantification"-        , "ScopedTypeVariables"-        , "NoMonomorphismRestriction"-        , "Rank2Types"-        ]---outFile' :: Pretty a => a -> TCM (FilePath, FilePath)-outFile' m = do-  mdir <- compileDir-  let (fdir, fn) = splitFileName $ repldot pathSeparator $-                   prettyPrint m-  let dir = mdir </> fdir-      fp  = dir </> replaceExtension fn "hs"-  liftIO $ createDirectoryIfMissing True dir-  return (mdir, fp)-  where-  repldot c = List.map $ \ c' -> if c' == '.' then c else c'--outFile :: HS.ModuleName -> TCM FilePath-outFile m = snd <$> outFile' m--outFile_ :: TCM FilePath-outFile_ = outFile =<< curHsMod--callGHC :: IsMain -> Interface -> TCM ()-callGHC modIsMain i = do-  setInterface i-  mdir          <- compileDir-  hsmod         <- prettyPrint <$> curHsMod-  MName agdaMod <- curMName-  let outputName = case agdaMod of-        [] -> __IMPOSSIBLE__-        ms -> last ms-  (mdir, fp) <- outFile' =<< curHsMod-  opts       <- optGhcFlags <$> commandLineOptions--  let overridableArgs =-        [ "-O"] ++-        (if modIsMain == IsMain then ["-o", mdir </> show (nameConcrete outputName)] else []) ++-        [ "-Werror"]-      otherArgs       =-        [ "-i" ++ mdir] ++-        (if modIsMain == IsMain then ["-main-is", hsmod] else []) ++-        [ fp-        , "--make"-        , "-fwarn-incomplete-patterns"-        , "-fno-warn-overlapping-patterns"-        ]-      args     = overridableArgs ++ opts ++ otherArgs-      compiler = "ghc"--  -- Note: Some versions of GHC use stderr for progress reports. For-  -- those versions of GHC we don't print any progress information-  -- unless an error is encountered.-  doCall <- optGhcCallGhc <$> commandLineOptions-  callCompiler doCall compiler args++module Agda.Compiler.MAlonzo.Compiler+  ( ghcBackend+  , ghcInvocationStrings+  )+  where++import Control.Arrow (second)+import Control.DeepSeq+import Control.Monad.Except   ( throwError )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Reader   ( MonadReader(..), asks, ReaderT, runReaderT, withReaderT)+import Control.Monad.Trans    ( lift )+import Control.Monad.Writer   ( MonadWriter(..), WriterT, runWriterT )++import qualified Data.HashSet as HashSet+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Monoid (Monoid, mempty, mappend)+import Data.Semigroup ((<>))++import GHC.Generics (Generic)++import qualified Agda.Utils.Haskell.Syntax as HS++import System.Directory (createDirectoryIfMissing)+import System.Environment (setEnv)+import System.FilePath hiding (normalise)+import System.IO (utf8)++import Agda.Compiler.CallCompiler+import Agda.Compiler.Common+import Agda.Compiler.MAlonzo.Coerce+import Agda.Compiler.MAlonzo.Misc+import Agda.Compiler.MAlonzo.Pretty+import Agda.Compiler.MAlonzo.Primitives+import Agda.Compiler.MAlonzo.HaskellTypes+import Agda.Compiler.MAlonzo.Pragmas+import Agda.Compiler.MAlonzo.Strict+import Agda.Compiler.ToTreeless+import Agda.Compiler.Treeless.Unused+import Agda.Compiler.Treeless.Erase+import Agda.Compiler.Backend++import Agda.Interaction.Options++import Agda.Syntax.Common+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.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings++import Agda.Utils.FileName (isNewerThan)+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Float+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.Singleton+import qualified Agda.Utils.IO.UTF8 as UTF8++import Agda.Setup ( getDataDir )++import Agda.Utils.Impossible++-- The backend callbacks --------------------------------------------------++ghcBackend :: Backend+ghcBackend = Backend ghcBackend'++ghcBackend' :: Backend' GHCFlags GHCEnv GHCModuleEnv GHCModule GHCDefinition+ghcBackend' = Backend'+  { backendName           = "GHC"+  , backendVersion        = Nothing+  , options               = defaultGHCFlags+  , commandLineFlags      = ghcCommandLineFlags+  , isEnabled             = flagGhcCompile+  , preCompile            = ghcPreCompile+  , postCompile           = ghcPostCompile+  , preModule             = ghcPreModule+  , postModule            = ghcPostModule+  , compileDef            = ghcCompileDef+  , scopeCheckingSuffices = False+  , mayEraseType          = ghcMayEraseType+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing+  }++--- Command-line flags ---++data GHCFlags = GHCFlags+  { flagGhcCompile :: Bool+  , flagGhcCallGhc :: Bool+  , flagGhcBin     :: Maybe FilePath+    -- ^ Use the compiler at PATH instead of "ghc"+  , flagGhcFlags      :: [String]+  , flagGhcStrictData :: Bool+    -- ^ Make inductive constructors strict?+  , flagGhcStrict :: Bool+    -- ^ Make functions strict?+  }+  deriving Generic++instance NFData GHCFlags++defaultGHCFlags :: GHCFlags+defaultGHCFlags = GHCFlags+  { flagGhcCompile    = False+  , flagGhcCallGhc    = True+  , flagGhcBin        = Nothing+  , flagGhcFlags      = []+  , flagGhcStrictData = False+  , 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 =+    [ 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")+                    "give the flag GHC-FLAG to GHC"+    , Option []     ["with-compiler"] (ReqArg withCompilerFlag "PATH")+                    "use the compiler available at PATH"+    , Option []     ["ghc-strict-data"] (NoArg strictData)+                    "make inductive constructors strict"+    , Option []     ["ghc-strict"] (NoArg strict)+                    "make functions strict"+    ]+  where+    dontCallGHC o = pure o{ flagGhcCallGhc    = False }+    ghcFlag f   o = pure o{ flagGhcFlags      = flagGhcFlags o ++ [f] }+    strictData  o = pure o{ flagGhcStrictData = True }+    strict      o = pure o{ flagGhcStrictData = True+                          , flagGhcStrict     = True+                          }++withCompilerFlag :: FilePath -> Flag GHCFlags+withCompilerFlag fp o = case flagGhcBin o of+ 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@+class Monad m => ReadGHCOpts m where+  askGhcOpts :: m GHCOptions++instance Monad m => ReadGHCOpts (ReaderT GHCOptions m) where+  askGhcOpts = ask++instance Monad m => ReadGHCOpts (ReaderT GHCEnv m) where+  askGhcOpts = withReaderT ghcEnvOpts askGhcOpts++instance Monad m => ReadGHCOpts (ReaderT GHCModuleEnv m) where+  askGhcOpts = withReaderT ghcModEnv askGhcOpts++data GHCModule = GHCModule+  { ghcModModuleEnv :: GHCModuleEnv+  , ghcModMainFuncs :: [MainFunctionDef]+  -- ^ The `main` function definition(s), if both the module is+  --   the @IsMain@ module (root/focused) and a suitable `main`+  --   function was defined.+  }++instance Monad m => ReadGHCOpts (ReaderT GHCModule m) where+  askGhcOpts = withReaderT ghcModModuleEnv askGhcOpts++instance Monad m => ReadGHCModuleEnv (ReaderT GHCModule m) where+  askGHCModuleEnv = withReaderT ghcModModuleEnv askGHCModuleEnv++data GHCDefinition = GHCDefinition+  { ghcDefUsesFloat  :: UsesFloat+  , ghcDefDecls      :: [HS.Decl]+  , ghcDefDefinition :: Definition+  , ghcDefMainDef    :: Maybe MainFunctionDef+  , ghcDefImports    :: Set TopLevelModuleName+  }++--- Top-level compilation ---++ghcPreCompile :: GHCFlags -> TCM GHCEnv+ghcPreCompile flags = do+  whenJustM cubicalOption \case+    CErased -> pure ()+    CFull   -> typeError $ CubicalCompilationNotSupported CFull++  outDir <- compileDir+  let ghcOpts = GHCOptions+                { optGhcCallGhc    = flagGhcCallGhc flags+                , optGhcBin        = fromMaybe "ghc" (flagGhcBin flags)+                , optGhcFlags      = flagGhcFlags flags+                , optGhcCompileDir = outDir+                , optGhcStrictData = flagGhcStrictData flags+                , optGhcStrict     = flagGhcStrict flags+                }++  mbool       <- getBuiltinName builtinBool+  mtrue       <- getBuiltinName builtinTrue+  mfalse      <- getBuiltinName builtinFalse+  mlist       <- getBuiltinName builtinList+  mnil        <- getBuiltinName builtinNil+  mcons       <- getBuiltinName builtinCons+  mmaybe      <- getBuiltinName builtinMaybe+  mnothing    <- getBuiltinName builtinNothing+  mjust       <- getBuiltinName builtinJust+  mnat        <- getBuiltinName builtinNat+  minteger    <- getBuiltinName builtinInteger+  mword64     <- getBuiltinName builtinWord64+  minf        <- getBuiltinName builtinInf+  msharp      <- getBuiltinName builtinSharp+  mflat       <- getBuiltinName builtinFlat+  minterval   <- getBuiltinName builtinInterval+  mizero      <- getBuiltinName builtinIZero+  mione       <- getBuiltinName builtinIOne+  misone      <- getBuiltinName builtinIsOne+  mitisone    <- getBuiltinName builtinItIsOne+  misone1     <- getBuiltinName builtinIsOne1+  misone2     <- getBuiltinName builtinIsOne2+  misoneempty <- getBuiltinName builtinIsOneEmpty+  mpathp      <- getBuiltinName builtinPathP+  msub        <- getBuiltinName builtinSub+  msubin      <- getBuiltinName builtinSubIn++  istcbuiltin <- do+    builtins <- mapM getBuiltinName+      [ builtinAgdaTCMReturn+      , builtinAgdaTCMBind+      , builtinAgdaTCMUnify+      , builtinAgdaTCMTypeError+      , builtinAgdaTCMInferType+      , builtinAgdaTCMCheckType+      , builtinAgdaTCMNormalise+      , builtinAgdaTCMReduce+      , builtinAgdaTCMCatchError+      , builtinAgdaTCMQuoteTerm+      , builtinAgdaTCMUnquoteTerm+      , builtinAgdaTCMQuoteOmegaTerm+      , builtinAgdaTCMGetContext+      , builtinAgdaTCMExtendContext+      , builtinAgdaTCMInContext+      , builtinAgdaTCMFreshName+      , builtinAgdaTCMDeclareDef+      , builtinAgdaTCMDeclarePostulate+      , builtinAgdaTCMDeclareData+      , builtinAgdaTCMDefineData+      , builtinAgdaTCMDefineFun+      , builtinAgdaTCMGetType+      , builtinAgdaTCMGetDefinition+      , builtinAgdaTCMBlock+      , builtinAgdaTCMCommit+      , builtinAgdaTCMIsMacro+      , builtinAgdaTCMWithNormalisation+      , builtinAgdaTCMWithReconstructed+      , builtinAgdaTCMWithExpandLast+      , builtinAgdaTCMWithReduceDefs+      , builtinAgdaTCMAskNormalisation+      , builtinAgdaTCMAskReconstructed+      , builtinAgdaTCMAskExpandLast+      , builtinAgdaTCMAskReduceDefs+      , builtinAgdaTCMFormatErrorParts+      , builtinAgdaTCMDebugPrint+      , 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+    , ghcEnvTrue        = mtrue+    , ghcEnvFalse       = mfalse+    , ghcEnvMaybe       = mmaybe+    , ghcEnvNothing     = mnothing+    , ghcEnvJust        = mjust+    , ghcEnvList        = mlist+    , ghcEnvNil         = mnil+    , ghcEnvCons        = mcons+    , ghcEnvNat         = mnat+    , ghcEnvInteger     = minteger+    , ghcEnvWord64      = mword64+    , ghcEnvInf         = minf+    , ghcEnvSharp       = msharp+    , ghcEnvFlat        = mflat+    , ghcEnvInterval    = minterval+    , ghcEnvIZero       = mizero+    , ghcEnvIOne        = mione+    , ghcEnvIsOne       = misone+    , ghcEnvItIsOne     = mitisone+    , ghcEnvIsOne1      = misone1+    , ghcEnvIsOne2      = misone2+    , ghcEnvIsOneEmpty  = misoneempty+    , ghcEnvPathP       = mpathp+    , ghcEnvSub         = msub+    , ghcEnvSubIn       = msubin+    , ghcEnvIsTCBuiltin = istcbuiltin+    , ghcEnvListArity   = listArity+    , ghcEnvMaybeArity  = maybeArity+    }++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+  -- 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++--- Module compilation ---++ghcPreModule+  :: GHCEnv+  -> IsMain      -- ^ Are we looking at the main module?+  -> 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 <- cubicalOption+      case cubical of+        -- Code that uses --cubical is not compiled.+        Just CFull   -> noComp+        Just CErased -> check+        Nothing      -> check)+    `runReaderT` GHCModuleEnv cenv (HsModuleEnv m (isMain == IsMain))+  where+    uptodate = case mifile of+      Nothing -> pure False+      Just ifile -> liftIO =<< isNewerThan <$> curOutFile <*> pure ifile+    ifileDesc = fromMaybe "(memory)" mifile++    noComp = do+      reportSLn "compile.ghc" 2 .+        (++ " : no compilation is needed.") . prettyShow =<< curMName+      menv <- ask+      mainDefs <- ifM curIsMainModule+                         (mainFunctionDefs <$> curIF)+                         (pure [])+      return . Skip $ GHCModule menv mainDefs++    yesComp = do+      m   <- prettyShow <$> curMName+      out <- curOutFile+      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?+  -> TopLevelModuleName+  -> [GHCDefinition]   -- ^ Compiled module content.+  -> TCM GHCModule+ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do+  builtinThings <- getsTC stBuiltinThings++  -- Accumulate all of the modules, definitions, declarations, etc.+  let (usedFloat, decls, defs, mainDefs, usedModules) = mconcat $+        (\(GHCDefinition useFloat' decls' def' md' imps')+         -> (useFloat', decls', [def'], maybeToList md', imps'))+        <$> ghcDefs++  let imps = mazRTEFloatImport usedFloat ++ imports builtinThings usedModules defs++  i <- curIF++  -- Get content of FOREIGN pragmas.+  let (headerPragmas, hsImps, code) = foreignHaskell i++  flip runReaderT menv $ do+    hsModuleName <- curHsMod+    writeModule $ HS.Module+      hsModuleName+      (map HS.OtherPragma $ List.nub headerPragmas)+      imps+      (map fakeDecl (List.nub hsImps ++ code) ++ decls)++  return $ GHCModule menv mainDefs++ghcCompileDef :: GHCEnv -> GHCModuleEnv -> IsMain -> Definition -> TCM GHCDefinition+ghcCompileDef _cenv menv _isMain def = do+  ((usesFloat, decls, mainFuncDef), (HsCompileState imps)) <-+    definition def `runHsCompileT` menv+  return $ GHCDefinition usesFloat decls def (checkedMainDef <$> mainFuncDef) imps++-- | We do not erase types that have a 'HsData' pragma.+--   This is to ensure a stable interface to third-party code.+ghcMayEraseType :: QName -> TCM Bool+ghcMayEraseType q = getHaskellPragma q <&> \case+  -- Andreas, 2019-05-09, issue #3732.+  -- We restrict this to 'HsData' since types like @Size@, @Level@+  -- should be erased although they have a 'HsType' binding to the+  -- Haskell unit type.+  Just HsData{} -> False+  _ -> True++-- Compilation ------------------------------------------------------------++imports ::+  BuiltinThings -> Set TopLevelModuleName -> [Definition] ->+  [HS.ImportDecl]+imports builtinThings usedModules defs = hsImps ++ imps where+  hsImps :: [HS.ImportDecl]+  hsImps = [unqualRTE, decl mazRTE]++  unqualRTE :: HS.ImportDecl+  unqualRTE = HS.ImportDecl mazRTE False $ Just $+              (False, [ HS.IVar $ HS.Ident x+                      | x <- [mazCoerceName, mazErasedName, mazAnyTypeName] +++                             map treelessPrimName rtePrims ])++  rtePrims = [T.PAdd, T.PSub, T.PMul, T.PQuot, T.PRem, T.PGeq, T.PLt, T.PEqI,+              T.PAdd64, T.PSub64, T.PMul64, T.PQuot64, T.PRem64, T.PLt64, T.PEq64,+              T.PITo64, T.P64ToI] -- Excludes T.PEqF, which is defined in MAlonzo.RTE.Float++  imps :: [HS.ImportDecl]+  imps = map decl $ uniq $ importsForPrim builtinThings defs ++ map mazMod mnames++  decl :: HS.ModuleName -> HS.ImportDecl+  decl m = HS.ImportDecl m True Nothing++  mnames :: [TopLevelModuleName]+  mnames = Set.elems usedModules++  uniq :: [HS.ModuleName] -> [HS.ModuleName]+  uniq = List.map List1.head . List1.group . List.sort++-- Should we import MAlonzo.RTE.Float+newtype UsesFloat = UsesFloat Bool deriving (Eq, Show)++pattern YesFloat :: UsesFloat+pattern YesFloat = UsesFloat True++pattern NoFloat :: UsesFloat+pattern NoFloat = UsesFloat False++instance Semigroup UsesFloat where+  UsesFloat a <> UsesFloat b = UsesFloat (a || b)++instance Monoid UsesFloat where+  mempty  = NoFloat+  mappend = (<>)++mazRTEFloatImport :: UsesFloat -> [HS.ImportDecl]+mazRTEFloatImport (UsesFloat b) = [ HS.ImportDecl mazRTEFloat True Nothing | b ]++--------------------------------------------------+-- Main compiling clauses+--------------------------------------------------++definition :: Definition -> HsCompileM (UsesFloat, [HS.Decl], Maybe CheckedMainFunctionDef)+-- ignore irrelevant definitions+definition Defn{defArgInfo = info, defName = q} | not $ usableModality info = do+  reportSDoc "compile.ghc.definition" 10 $+    ("Not compiling" <+> prettyTCM q) <> "."+  return (mempty, mempty, Nothing)+definition def@Defn{defName = q, defType = ty, theDef = d} = do+  reportSDoc "compile.ghc.definition" 10 $ vcat+    [ ("Compiling" <+> prettyTCM q) <> ":"+    , nest 2 $ pretty d+    ]+  pragma <- liftTCM $ getHaskellPragma q+  env <- askGHCEnv+  let is p = Just q == p env+  typeCheckedMainDef <- checkTypeOfMain def+  let mainDecl = maybeToList $ checkedMainDecl <$> typeCheckedMainDef+  let retDecls ds = return (mempty, ds)+  (uncurry (,,typeCheckedMainDef)) . second ((mainDecl ++) . infodecl q) <$>+    case d of++      _ | 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)++          -- Check that the function isn't INLINE (since that will make this+          -- definition pointless).+            inline <- (^. funInline) . theDef <$> getConstInfo q+            when inline $ warning $ UselessInline q++            retDecls $ fbWithType hsty (fakeExp hs)++      -- Compiling Bool+      Datatype{} | is ghcEnvBool -> do+        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+        cs <- mapM (compiledcondecl Nothing) [false, true]+        retDecls $ [ compiledTypeSynonym q "Bool" 0+                   , HS.FunBind [HS.Match d [] (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs++      -- Compiling List+      Datatype{ dataPars = np } | is ghcEnvList -> do+        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+        Just cons <- getBuiltinName builtinCons+        let vars f n = map (f . ihname A) [0 .. n - 1]+        cs <- mapM (compiledcondecl Nothing) [nil, cons]+        retDecls $ [ HS.TypeDecl t (vars HS.UnkindedVar (np - 1)) (HS.FakeType "[]")+                   , HS.FunBind [HS.Match d (vars HS.PVar np) (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs++      -- Compiling Maybe+      Datatype{ dataPars = np } | is ghcEnvMaybe -> do+        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+        Just just    <- getBuiltinName builtinJust+        let vars f n = map (f . ihname A) [0 .. n - 1]+        cs <- mapM (compiledcondecl Nothing) [nothing, just]+        retDecls $ [ HS.TypeDecl t (vars HS.UnkindedVar (np - 1)) (HS.FakeType "Maybe")+                   , HS.FunBind [HS.Match d (vars HS.PVar np) (HS.UnGuardedRhs HS.unit_con) emptyBinds] ] +++                   cs++      -- Compiling Inf+      _ | is ghcEnvInf -> do+        _ <- primSharp -- To get a proper error for missing SHARP.+        Just sharp <- getBuiltinName builtinSharp+        sharpC     <- (compiledcondecl Nothing) sharp+        let d   = dname q+            err = "No term-level implementation of the INFINITY builtin."+        retDecls $ [ compiledTypeSynonym q "MAlonzo.RTE.Infinity" 2+                   , HS.FunBind [HS.Match d [HS.PVar (ihname A 0)]+                       (HS.UnGuardedRhs (HS.FakeExp ("error " ++ show err)))+                       emptyBinds]+                   , sharpC+                   ]++      -- 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]+        Just i0 <- getBuiltinName builtinIZero+        Just i1 <- getBuiltinName builtinIOne+        cs      <- mapM (compiledcondecl (Just 0)) [i0, i1]+        retDecls $+          [ compiledTypeSynonym q "Bool" 0+          , HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs HS.unit_con) emptyBinds]+          ] +++          cs++      -- IsOne is compiled as the constant function to the unit type.+      -- Partial/PartialP are compiled as functions from the unit type+      -- to the underlying type.+      Axiom{} | is ghcEnvIsOne -> do+        retDecls $+          [ HS.TypeDecl (unqhname TypeK q) [HS.UnkindedVar (ihname A 0)]+              (HS.FakeType "()")+          , HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs HS.unit_con) emptyBinds]+          ]++      -- itIsOne.+      Axiom{} | is ghcEnvItIsOne -> do+        retDecls $+          [ HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs HS.unit_con) emptyBinds]+          ]++      -- IsOne1/IsOne2.+      Axiom{} | is ghcEnvIsOne1 || is ghcEnvIsOne2 -> do+        retDecls $+          [ HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp "\\_ _ _ -> ()"))+                 emptyBinds]+          ]++      -- isOneEmpty.+      Axiom{} | is ghcEnvIsOneEmpty -> do+        retDecls $+          [ HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp "\\_ x _ -> x ()"))+                 emptyBinds]+          ]++      -- PathP is compiled as a function from the interval (booleans)+      -- to the underlying type.+      Axiom{} | is ghcEnvPathP -> 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.TyFun (HS.TyCon int) mazAnyType)+          , HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp "\\_ _ _ _ -> ()"))+                 emptyBinds]+          ]++      -- Sub is compiled as the underlying type.+      Axiom{} | is ghcEnvSub -> do+        retDecls $+          [ HS.TypeDecl (unqhname TypeK q)+              [HS.UnkindedVar (ihname A i) | i <- [0..3]]+              (HS.TyVar (ihname A 1))+          , HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp "\\_ _ _ _ -> ()"))+                 emptyBinds]+          ]++      -- subIn.+      Axiom{} | is ghcEnvSubIn -> do+        retDecls $+          [ HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp "\\_ _ _ x -> x"))+                 emptyBinds]+          ]++      -- TC builtins are compiled to erased, which is an ∞-ary+      -- function.+      Axiom{} | ghcEnvIsTCBuiltin env q -> do+        retDecls $+          [ HS.FunBind+              [HS.Match (dname q) []+                 (HS.UnGuardedRhs (HS.FakeExp mazErasedName))+                 emptyBinds]+          ]++      DataOrRecSig{} -> __IMPOSSIBLE__++      Axiom{} -> do+        ar <- liftTCM $ typeArity ty+        retDecls $ [ compiledTypeSynonym q ty ar | Just (HsType r ty) <- [pragma] ] +++                   fb axiomErr+      Primitive{ primName = s } -> (mempty,) . fb <$> (liftTCM . primBody) s++      PrimitiveSort{} -> retDecls []++      Function{} -> function pragma $ functionViaTreeless q++      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl+              , dataPathCons = pcs+              } | Just hsdata@(HsData r ty hsCons) <- pragma ->+        setCurrentRange r $ do+        reportSDoc "compile.ghc.definition" 40 $ hsep $+          [ "Compiling data type with COMPILE pragma ...", pretty hsdata ]+        liftTCM $ computeErasedConstructorArgs q+        cs <- liftTCM $ getNotErasedConstructors q+        ccscov <- constructorCoverageCode q (np + ni) cs ty hsCons+        cds <- mapM (compiledcondecl Nothing) cs+        let result = concat $+              [ tvaldecl q Inductive (np + ni) [] (Just __IMPOSSIBLE__)+              , [ compiledTypeSynonym q ty np ]+              , cds+              , ccscov+              ]+        retDecls result+      Datatype{ dataPars = np, dataIxs = ni, dataClause = cl+              , dataPathCons = pcs+              } -> do+        liftTCM $ computeErasedConstructorArgs q+        cs <- liftTCM $ getNotErasedConstructors q+        cds <- mapM (flip condecl Inductive) cs+        retDecls $ tvaldecl q Inductive (np + ni) cds cl+      Constructor{} -> retDecls []+      GeneralizableVar{} -> retDecls []+      Record{ recPars = np, recClause = cl, recConHead = con,+              recInduction = ind } ->+        let -- Non-recursive record types are treated as being+            -- inductive.+            inductionKind = fromMaybe Inductive ind+        in case pragma of+          Just (HsData r ty hsCons) -> setCurrentRange r $ do+            let cs = [conName con]+            liftTCM $ computeErasedConstructorArgs q+            ccscov <- constructorCoverageCode q np cs ty hsCons+            cds <- mapM (compiledcondecl Nothing) cs+            retDecls $+              tvaldecl q inductionKind np [] (Just __IMPOSSIBLE__) +++              [compiledTypeSynonym q ty np] ++ cds ++ ccscov+          _ -> do+            liftTCM $ computeErasedConstructorArgs q+            cd <- condecl (conName con) inductionKind+            retDecls $ tvaldecl q inductionKind (I.arity ty) [cd] cl+      AbstractDefn{} -> __IMPOSSIBLE__+  where+  function :: Maybe HaskellPragma -> HsCompileM (UsesFloat, [HS.Decl]) -> HsCompileM (UsesFloat, [HS.Decl])+  function mhe fun = do+    (imp, ccls) <- fun+    case mhe of+      Just (HsExport r name) -> do+          t <- setCurrentRange r $ haskellType q+          let tsig :: HS.Decl+              tsig = HS.TypeSig [HS.Ident name] t++              def :: HS.Decl+              def = HS.FunBind [HS.Match (HS.Ident name) [] (HS.UnGuardedRhs (hsCoerce $ hsVarUQ $ dname q)) emptyBinds]+          return (imp, [tsig,def] ++ ccls)+      _ -> return (imp, ccls)++  functionViaTreeless :: QName -> HsCompileM (UsesFloat, [HS.Decl])+  functionViaTreeless q = do+    strict <- optGhcStrict <$> askGhcOpts+    let eval = if strict then EagerEvaluation else LazyEvaluation+    caseMaybeM (liftTCM $ toTreeless eval q) (pure mempty) $ \ treeless -> do++      used <- fromMaybe [] <$> getCompiledArgUse q+      let dostrip = ArgUnused `elem` used++      -- Compute the type approximation+      def <- getConstInfo q+      (argTypes0, resType) <- hsTelApproximation $ defType def+      let pars = case theDef def of+                   Function{ funProjection = Right Projection{ projIndex = i } } | i > 0 -> i - 1+                   _ -> 0+          argTypes  = drop pars argTypes0+          argTypesS = filterUsed used argTypes++      (e, useFloat) <- if dostrip then closedTerm (stripUnusedArguments used treeless)+                                  else closedTerm treeless+      let (ps, b) = lamView e+          lamView e =+            case e of+              HS.Lambda ps b -> (ps, b)+              b              -> ([], b)++          tydecl  f ts t = HS.TypeSig [f] (foldr HS.TyFun t ts)+          funbind f ps b = HS.FunBind [HS.Match f ps (HS.UnGuardedRhs b) emptyBinds]+          tyfunbind f ts t ps b =+            let ts' = ts ++ (replicate (length ps - length ts) mazAnyType)+            in [tydecl f ts' t, funbind f ps b]++      -- The definition of the non-stripped function+      (ps0, _) <- lamView <$> closedTerm_ (foldr ($) T.TErased $ replicate (length used) T.TLam)+      let b0 = foldl HS.App (hsVarUQ $ duname q) [ hsVarUQ x | (~(HS.PVar x), ArgUsed) <- zip ps0 used ]+          ps0' = zipWith (\p u -> case u of+                                    ArgUsed   -> p+                                    ArgUnused -> HS.PIrrPat p)+                   ps0 used++      return (useFloat,+              if dostrip+                then tyfunbind (dname q) argTypes resType ps0' b0 +++                     tyfunbind (duname q) argTypesS resType ps b+                else tyfunbind (dname q) argTypes resType ps b)++  fbWithType :: HS.Type -> HS.Exp -> [HS.Decl]+  fbWithType ty e =+    HS.TypeSig [dname q] ty : fb e++  fb :: HS.Exp -> [HS.Decl]+  fb e  = [HS.FunBind [HS.Match (dname q) []+                                (HS.UnGuardedRhs e) emptyBinds]]++  axiomErr :: HS.Exp+  axiomErr = rtmError $ Text.pack $ "postulate evaluated: " ++ prettyShow q++constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> HsCompileM [HS.Decl]+constructorCoverageCode q np cs hsTy hsCons = do+  -- 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+    return $ ccs ++ cov++-- | Environment for naming of local variables.+--   Invariant: @reverse ccCxt ++ ccNameSupply@+data CCEnv = CCEnv+  { _ccNameSupply :: NameSupply  -- ^ Supply of fresh names+  , _ccContext    :: CCContext   -- ^ Names currently in scope+  }++type NameSupply = [HS.Name]+type CCContext  = [HS.Name]++ccNameSupply :: Lens' CCEnv NameSupply+ccNameSupply f e =  (\ ns' -> e { _ccNameSupply = ns' }) <$> f (_ccNameSupply e)++ccContext :: Lens' CCEnv CCContext+ccContext f e = (\ cxt -> e { _ccContext = cxt }) <$> f (_ccContext e)++-- | Initial environment for expression generation.+initCCEnv :: CCEnv+initCCEnv = CCEnv+  { _ccNameSupply = map (ihname V) [0..]  -- DON'T CHANGE THESE NAMES!+  , _ccContext    = []+  }++-- | Term variables are de Bruijn indices.+lookupIndex :: Int -> CCContext -> HS.Name+lookupIndex i xs = fromMaybe __IMPOSSIBLE__ $ xs !!! i++-- | Constructor coverage monad transformer+type CCT m = ReaderT CCEnv (WriterT UsesFloat (HsCompileT m))++-- | Constructor coverage monad+type CC = CCT TCM++liftCC :: Monad m => HsCompileT m a -> CCT m a+liftCC = lift . lift++freshNames :: Monad m => Int -> ([HS.Name] -> CCT m a) -> CCT m a+freshNames n _ | n < 0 = __IMPOSSIBLE__+freshNames n cont = do+  (xs, rest) <- splitAt n <$> view ccNameSupply+  local (over ccNameSupply (const rest)) $ cont xs++-- | Introduce n variables into the context.+intros :: Monad m => Int -> ([HS.Name] -> CCT m a) -> CCT m a+intros n cont = freshNames n $ \xs ->+  local (over ccContext (reverse xs ++)) $ cont xs++checkConstructorType :: QName -> HaskellCode -> HsCompileM [HS.Decl]+checkConstructorType q hs = do+  ty <- haskellType q+  return [ HS.TypeSig [unqhname CheckK q] ty+         , HS.FunBind [HS.Match (unqhname CheckK q) []+                                (HS.UnGuardedRhs $ fakeExp hs) emptyBinds]+         ]++checkCover :: HasConstInfo m => QName -> HaskellType -> Nat -> [QName] -> [HaskellCode] -> m [HS.Decl]+checkCover q ty n cs hsCons = do+  let tvs = [ "a" ++ show i | i <- [1..n] ]+      makeClause c hsc = do+        a <- erasedArity c+        let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ replicate a HS.PWildCard+        return $ HS.Alt pat (HS.UnGuardedRhs $ HS.unit_con) emptyBinds++  cs <- zipWithM makeClause cs hsCons+  let rhs = HS.Case (HS.Var $ HS.UnQual $ HS.Ident "x") cs++  return [ HS.TypeSig [unqhname CoverK q] $ fakeType $ unwords (ty : tvs) ++ " -> ()"+         , HS.FunBind [HS.Match (unqhname CoverK q) [HS.PVar $ HS.Ident "x"]+                                (HS.UnGuardedRhs rhs) emptyBinds]+         ]++closedTerm_ :: T.TTerm -> HsCompileM HS.Exp+closedTerm_ t = fst <$> closedTerm t++closedTerm :: T.TTerm -> HsCompileM (HS.Exp, UsesFloat)+closedTerm v = do+  v <- liftTCM $ addCoercions v+  runWriterT (term v `runReaderT` initCCEnv)++-- Translate case on bool to if+mkIf :: T.TTerm -> CC T.TTerm+mkIf t@(TCase e _ d [TACon c1 0 b1, TACon c2 0 b2]) | T.isUnreachable d = do+  env <- liftCC askGHCEnv+  let isTrue  c = Just c == ghcEnvTrue  env+      isFalse c = Just c == ghcEnvFalse env+  if | isTrue c1, isFalse c2 -> return $ T.tIfThenElse (TCoerce $ TVar e) b1 b2+     | isTrue c2, isFalse c1 -> return $ T.tIfThenElse (TCoerce $ TVar e) b2 b1+     | otherwise             -> return t+mkIf t = return t++-- | Extract Agda term to Haskell expression.+--   Erased arguments are extracted as @()@.+--   Types are extracted as @()@.+term :: T.TTerm -> CC HS.Exp+term tm0 = mkIf tm0 >>= \ tm0 -> do+  let ((hasCoerce, t), ts) = coerceAppView tm0+  -- let (t0, ts)       = tAppView tm0+  -- let (hasCoerce, t) = coerceView t0+  let coe            = applyWhen hasCoerce hsCoerce+  case (t, ts) of+    (T.TPrim T.PIf, [c, x, y]) -> coe <$> do HS.If <$> term c <*> term x <*> term y++    (T.TDef f, ts) -> do+      used <- liftCC $ fromMaybe [] <$> getCompiledArgUse f+      -- #2248: no unused argument pruning for COMPILE'd functions+      isCompiled <- liftTCM $ isJust <$> getHaskellPragma f+      let given   = length ts+          needed  = length used+          missing = drop given used+      if not isCompiled && ArgUnused `elem` used+        then if ArgUnused `elem` missing then term (etaExpand (needed - given) tm0) else do+          f <- liftCC $ HS.Var <$> xhqn (FunK NoUnused) f+                                   -- use stripped function+          -- Andreas, 2019-11-07, issue #4169.+          -- Insert coercion unconditionally as erasure of arguments+          -- that are matched upon might remove the unfolding of codomain types.+          -- (Hard to explain, see test/Compiler/simple/Issue4169.)+          hsCoerce f `apps` filterUsed used ts+        else do+          f <- liftCC $ HS.Var <$> xhqn (FunK PossiblyUnused) f+                                   -- use original (non-stripped) function+          coe f `apps` ts++    (T.TCon c, ts) -> do+      erased  <- liftCC $ getErasedConArgs c+      let missing = drop (length ts) erased+          notErased = not+      if all notErased missing+        then do+                f <- liftCC $ HS.Con <$> conhqn c+                hsCoerce f `apps` [ t | (t, False) <- zip ts erased ]+        else do+                let n = length missing+                unless (n >= 1) __IMPOSSIBLE__  -- We will add at least on TLam, not getting a busy loop here.+                term $ etaExpand (length missing) tm0++    -- Other kind of application: fall back to apps.+    (t, ts) -> noApplication t >>= \ t' -> coe t' `apps` ts+  where+  apps = foldM (\ h a -> HS.App h <$> term a)+  etaExpand n t = mkTLam n $ raise n t `T.mkTApp` map T.TVar (downFrom n)++-- | Translate a non-application, non-coercion, non-constructor, non-definition term.+noApplication :: T.TTerm -> CC HS.Exp+noApplication = \case+  T.TApp{}    -> __IMPOSSIBLE__+  T.TCoerce{} -> __IMPOSSIBLE__+  T.TCon{}    -> __IMPOSSIBLE__+  T.TDef{}    -> __IMPOSSIBLE__++  T.TVar i    -> hsVarUQ . lookupIndex i <$> view ccContext+  T.TLam t    -> intros 1 $ \ [x] -> hsLambda [HS.PVar x] <$> term t++  T.TLet t1 t2 -> do+    t1' <- term t1+    intros 1 $ \[x] -> do+      hsLet x t1' . hsCoerce <$> term t2++  T.TCase sc ct def alts -> do+    sc'   <- term $ T.TVar sc+    alts' <- traverse (alt sc) alts+    def'  <- term def+    let defAlt = HS.Alt HS.PWildCard (HS.UnGuardedRhs def') emptyBinds+    return $ HS.Case (hsCoerce sc') (alts' ++ [defAlt])++  T.TLit l    -> literal l+  T.TPrim p   -> return $ compilePrim p+  T.TUnit     -> return $ HS.unit_con+  T.TSort     -> return $ HS.unit_con+  T.TErased   -> return $ hsVarUQ $ HS.Ident mazErasedName+  T.TError e  -> return $ case e of+    T.TUnreachable -> rtmUnreachableError+    T.TMeta s      -> rtmHole s++hsCoerce :: HS.Exp -> HS.Exp+hsCoerce t = HS.App mazCoerce t++compilePrim :: T.TPrim -> HS.Exp+compilePrim s = HS.Var $ hsName $ treelessPrimName s++alt :: Int -> T.TAlt -> CC HS.Alt+alt sc a = do+  case a of+    T.TACon {T.aCon = c} -> do+      intros (T.aArity a) $ \ xs -> do+        erased <- liftCC $ getErasedConArgs c+        env    <- liftCC askGHCEnv+        hConNm <-+          if | Just c == ghcEnvNil env ->+               return $ HS.UnQual $ HS.Ident "[]"+             | Just c == ghcEnvCons env ->+               return $ HS.UnQual $ HS.Symbol ":"+             | otherwise -> liftCC $ conhqn c+        mkAlt (HS.PApp hConNm $ [HS.PVar x | (x, False) <- zip xs erased])+    T.TAGuard g b -> do+      g <- term g+      b <- term b+      return $ HS.Alt HS.PWildCard+                      (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+      mkGuarded (treelessPrimName T.PEqF) l b+    T.TALit { T.aLit = LitString s , T.aBody = b } -> mkGuarded "(==)" (litString s) b+    T.TALit {} -> mkAlt (HS.PLit $ hslit $ T.aLit a)+  where+    mkGuarded eq lit b = do+      b  <- term b+      let varName = HS.Ident "l" -- only used locally in the guard+          pv = HS.PVar varName+          v  = hsVarUQ varName+          guard =+            HS.Var (HS.UnQual (HS.Ident eq)) `HS.App`+              v `HS.App` lit+      return $ HS.Alt pv+                      (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier guard] b])+                      emptyBinds++    mkAlt :: HS.Pat -> CC HS.Alt+    mkAlt pat = do+        body' <- term $ T.aBody a+        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+  LitNat    _   -> return $ typed "Integer"+  LitWord64 _   -> return $ typed "MAlonzo.RTE.Word64"+  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+    typed = HS.ExpTypeSig l' . HS.TyCon . rtmQual++    -- ASR (2016-09-14): See Issue #2169.+    -- Ulf, 2016-09-28: and #2218.+    floatExp :: Double -> String -> CCT m HS.Exp+    floatExp x s+      | isPosInf  x = rte "positiveInfinity"+      | isNegInf  x = rte "negativeInfinity"+      | isNegZero x = rte "negativeZero"+      | isNaN     x = rte "nan"+      | otherwise   = return $ typed s+      where+        rte s = do tell YesFloat; return $ HS.Var $ HS.Qual mazRTEFloat $ HS.Ident s++hslit :: Literal -> HS.Literal+hslit = \case+  LitNat    x -> HS.Int    x+  LitWord64 x -> HS.Int    (fromIntegral x)+  LitFloat  x -> HS.Frac   (toRational x)+  LitChar   x -> HS.Char   x+  LitQName  x -> __IMPOSSIBLE__+  LitString _ -> __IMPOSSIBLE__+  LitMeta{}   -> __IMPOSSIBLE__++litString :: Text -> HS.Exp+litString s = HS.Ann (HS.Lit (HS.String s))+                     (HS.TyCon (HS.Qual (HS.ModuleName "Data.Text") (HS.Ident "Text")))++litqname :: QName -> HS.Exp+litqname x =+  rteCon "QName" `apps`+  [ hsTypedInt n+  , hsTypedInt m+  , HS.Lit $ HS.String $ Text.pack $ prettyShow x+  , rteCon "Fixity" `apps`+    [ litAssoc (fixityAssoc fx)+    , litPrec  (fixityLevel fx)+    ]+  ]+  where+    apps = foldl HS.App+    rteCon name = HS.Con $ HS.Qual mazRTE $ HS.Ident name+    NameId n (ModuleNameHash m) = nameId $ qnameName x+    fx = theFixity $ nameFixity $ qnameName x++    litAssoc NonAssoc   = rteCon "NonAssoc"+    litAssoc LeftAssoc  = rteCon "LeftAssoc"+    litAssoc RightAssoc = rteCon "RightAssoc"++    litPrec Unrelated   = rteCon "Unrelated"+    litPrec (Related l) = rteCon "Related" `HS.App` hsTypedDouble l++litqnamepat :: QName -> HS.Pat+litqnamepat x =+  HS.PApp (HS.Qual mazRTE $ HS.Ident "QName")+          [ HS.PLit (HS.Int $ fromIntegral n)+          , HS.PLit (HS.Int $ fromIntegral m)+          , HS.PWildCard, HS.PWildCard ]+  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, conSrcCon, conErased = erased } = theDef def+  (argTypes0, _) <- hsTelApproximation (defType def)+  let strict     = if conInductive conSrcCon == Inductive &&+                      optGhcStrictData opts+                   then HS.Strict+                   else HS.Lazy+      argTypes   = [ (Just strict, t)+                   | (t, False) <- zip (drop np argTypes0)+                                       (fromMaybe [] erased ++ repeat False)+                   ]+  return $ HS.ConDecl (unqhname ConK q) argTypes++compiledcondecl+  :: Maybe Nat  -- ^ The constructor's arity (after erasure).+  -> QName -> HsCompileM HS.Decl+compiledcondecl mar q = do+  ar <- case mar of+    Nothing -> liftTCM $ erasedArity q+    Just ar -> return ar+  hsCon <- fromMaybe __IMPOSSIBLE__ <$> getHaskellConstructor q+  let patVars = map (HS.PVar . ihname A) [0 .. ar - 1]+  return $ HS.PatSyn (HS.PApp (HS.UnQual $ unqhname ConK q) patVars)+             (HS.PApp (hsName hsCon) patVars)++compiledTypeSynonym :: QName -> String -> Nat -> HS.Decl+compiledTypeSynonym q hsT arity =+  HS.TypeDecl (unqhname TypeK q) (map HS.UnkindedVar vs)+              (foldl HS.TyApp (HS.FakeType hsT) $ map HS.TyVar vs)+  where+    vs = [ ihname A i | i <- [0 .. arity - 1]]++tvaldecl :: QName+         -> Induction+            -- ^ Is the type inductive or coinductive?+         -> Nat -> [HS.ConDecl] -> Maybe Clause -> [HS.Decl]+tvaldecl q ind npar cds cl =+  HS.FunBind [HS.Match vn pvs (HS.UnGuardedRhs HS.unit_con) emptyBinds] :+  maybe [HS.DataDecl kind tn [] cds' []]+        (const []) cl+  where+  (tn, vn) = (unqhname TypeK q, dname q)+  pvs = [ HS.PVar $ ihname A i | i <- [0 .. npar - 1]]++  -- Inductive data types consisting of a single constructor with a+  -- single argument are translated into newtypes.+  (kind, cds') = case (ind, cds) of+    (Inductive, [HS.ConDecl c [(_, t)]]) ->+      (HS.NewType, [HS.ConDecl c [(Nothing, t)]])+      -- The strictness annotations are removed for newtype+      -- constructors.+    _ -> (HS.DataType, cds)++infodecl :: QName -> [HS.Decl] -> [HS.Decl]+infodecl _ [] = []+infodecl q ds = HS.Comment (prettyShow q) : ds++--------------------------------------------------+-- Writing out a haskell module+--------------------------------------------------++type MonadGHCIO m = (MonadIO m, ReadGHCOpts m)++copyRTEModules :: MonadGHCIO m => m ()+copyRTEModules = do+  dataDir <- liftIO getDataDir+  let srcDir = dataDir </> "MAlonzo" </> "src"+  dstDir <- optGhcCompileDir <$> askGhcOpts+  liftIO $ copyDirContent srcDir dstDir++writeModule :: MonadGHCIO m => HS.Module -> m ()+writeModule (HS.Module m ps imp ds) = do+  -- Note that GHC assumes that sources use ASCII or UTF-8.+  out <- snd <$> outFileAndDir m+  strict <- optGhcStrict <$> askGhcOpts+  let languagePragmas =+        List.map (HS.LanguagePragma . singleton . HS.Ident) $+          List.sort $+            [ "QualifiedDo" | strict ] +++                -- If --ghc-strict is used, then the language extension+                -- QualifiedDo is activated. At the time of writing no+                -- code is generated that depends on this extension+                -- (except for the pragmas), but --ghc-strict is broken+                -- with at least some versions of GHC prior to version 9,+                -- and QualifiedDo was introduced with GHC 9.+            [ "BangPatterns"+            , "EmptyDataDecls"+            , "EmptyCase"+            , "ExistentialQuantification"+            , "ScopedTypeVariables"+            , "NoMonomorphismRestriction"+            , "RankNTypes"+            , "PatternSynonyms"+            , "OverloadedStrings"+            ]+  let ghcOptions =+        List.map HS.OtherPragma+          [ ""  -- to separate from LANGUAGE pragmas+          , "{-# OPTIONS_GHC -Wno-overlapping-patterns #-}"+              -- Andreas, 2022-01-26, issue #5758:+              -- Place this in generated file rather than+              -- passing it only when calling GHC from within Agda.+              -- This will silence the warning for the Agda-generated .hs+              -- files while it can be on for other .hs files in the same+              -- project.  (E.g., when using cabal/stack to compile.)+          ]+  liftIO $ UTF8.writeFile out $ (++ "\n") $ prettyPrint $+    -- TODO: It might make sense to skip bang patterns for the unused+    -- arguments of the "non-stripped" functions.+    applyWhen strict makeStrict $+    HS.Module m (concat [languagePragmas, ghcOptions, ps]) imp ds++outFileAndDir :: MonadGHCIO m => HS.ModuleName -> m (FilePath, FilePath)+outFileAndDir m = do+  mdir <- optGhcCompileDir <$> askGhcOpts+  let (fdir, fn) = splitFileName $ repldot pathSeparator $+                   prettyPrint m+  let dir = mdir </> fdir+      fp  = dir </> replaceExtension fn "hs"+  liftIO $ createDirectoryIfMissing True dir+  return (mdir, fp)+  where+  repldot c = List.map $ \ c' -> if c' == '.' then c else c'++curOutFileAndDir :: (MonadGHCIO m, ReadGHCModuleEnv m) => m (FilePath, FilePath)+curOutFileAndDir = outFileAndDir =<< curHsMod++curOutFile :: (MonadGHCIO m, ReadGHCModuleEnv m) => m FilePath+curOutFile = snd <$> curOutFileAndDir++callGHC :: ReaderT GHCModule TCM ()+callGHC = do+  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++  modIsMain <- curIsMainModule+  modHasMainFunc <- asks (not . null . ghcModMainFuncs)+  let isMain = modIsMain && modHasMainFunc  -- both need to be IsMain++  -- Warn if no main function and not --no-main+  when (modIsMain /= isMain) $ warning $ NoMain agdaMod++  let overridableArgs =+        [ "-O"] +++        (if isMain then ["-o", mdir </> outputName] else []) +++        [ "-Werror"]+      otherArgs       =+        [ "-i" ++ mdir] +++        (if isMain then ["-main-is", hsmod] else []) +++        [ fp+        , "--make"+        , "-fwarn-incomplete-patterns"+        ]+      args     = overridableArgs ++ ghcopts ++ otherArgs++  let ghcBin = optGhcBin opts++  -- Make GHC use UTF-8 when writing to stdout and stderr.+  liftIO $ setEnv "GHC_CHARENC" "UTF-8"+  -- Note: Some versions of GHC use stderr for progress reports. For+  -- those versions of GHC we don't print any progress information+  -- unless an error is encountered.+  let doCall = optGhcCallGhc opts+      cwd    = if optGHCiInteraction agdaOpts ||+                  optJSONInteraction agdaOpts+               then Just mdir+               else Nothing+  liftTCM $ callCompiler doCall ghcBin args cwd (Just utf8)
− src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot 
@@ -1,8 +0,0 @@-module Agda.Compiler.MAlonzo.Compiler where--import qualified Agda.Utils.Haskell.Syntax as HS--import Agda.Syntax.Treeless (TTerm)-import Agda.TypeChecking.Monad (TCM)--closedTerm :: TTerm -> TCM HS.Exp
src/full/Agda/Compiler/MAlonzo/Encode.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- Module name encoding ------------------------------------------------------------------------@@ -7,8 +9,7 @@   ) where  import Data.Char-import Data.Function-import Data.List+import qualified Data.List as List import qualified Agda.Utils.Haskell.Syntax as HS  import Agda.Compiler.MAlonzo.Misc@@ -26,7 +27,7 @@ -- @.@s may be adjacent.  encodeModuleName :: HS.ModuleName -> HS.ModuleName-encodeModuleName (HS.ModuleName s) = HS.ModuleName $ case stripPrefix mazstr s of+encodeModuleName (HS.ModuleName s) = HS.ModuleName $ case List.stripPrefix mazstr s of   Just s' -> mazstr ++ foldr encNamePart "" (splitUp' s')   Nothing -> s   where@@ -66,4 +67,3 @@    enc c r | isOK c    = c : r           | otherwise = escapeChar : shows (fromEnum c) (escapeChar : r)-
+ src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs view
@@ -0,0 +1,236 @@++-- | Translating Agda types to Haskell types. Used to ensure that imported+--   Haskell functions have the right type.++module Agda.Compiler.MAlonzo.HaskellTypes+  ( haskellType+  , hsTelApproximation, hsTelApproximation'+  ) where++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)++import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Free+import Agda.TypeChecking.Telescope++import Agda.Compiler.MAlonzo.Pragmas+import Agda.Compiler.MAlonzo.Misc+import Agda.Compiler.MAlonzo.Pretty () --instance only++import qualified Agda.Utils.Haskell.Syntax as HS+import Agda.Utils.List+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty (prettyShow)++import Agda.Utils.Impossible++hsQCon :: String -> String -> HS.Type+hsQCon m f = HS.TyCon $ HS.Qual (HS.ModuleName m) (HS.Ident f)++hsCon :: String -> HS.Type+hsCon = HS.TyCon . HS.UnQual . HS.Ident++hsUnit :: HS.Type+hsUnit = hsCon "()"++hsVar :: HS.Name -> HS.Type+hsVar = HS.TyVar++hsApp :: HS.Type -> [HS.Type] -> HS.Type+hsApp d ds = foldl HS.TyApp d ds++hsForall :: HS.Name -> HS.Type -> HS.Type+hsForall x = HS.TyForall [HS.UnkindedVar x]++-- Issue #5207: From ghc-9.0 we have to be careful with nested foralls.+hsFun :: HS.Type -> HS.Type -> HS.Type+hsFun a (HS.TyForall vs b) = HS.TyForall vs $ hsFun a b+hsFun a b = HS.TyFun a b++type ToHs = ExceptT WhyNotAHaskellType HsCompileM++runToHs :: Term -> ToHs a -> HsCompileM a+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))++-- Only used in hsTypeApproximation below, and in that case we catch the error.+getHsType' :: QName -> HsCompileM HS.Type+getHsType' q = runToHs (Def q []) (getHsType q)++getHsType :: QName -> ToHs HS.Type+getHsType x = do+  unlessM (isCompiled x) $ throwError $ NotCompiled x++  d   <- liftTCM $ getHaskellPragma x+  env <- askGHCEnv+  let is t p = Just t == p env++      namedType = do+        -- For these builtin types, the type name (xhqn ...) refers to the+        -- generated, but unused, datatype and not the primitive type.+        if  | x `is` ghcEnvNat ||+              x `is` ghcEnvInteger -> return $ hsCon "Integer"+            | x `is` ghcEnvBool    -> return $ hsCon "Bool"+            | otherwise            ->+              lift $ hsCon . prettyShow <$> xhqn TypeK x+  mapExceptT (setCurrentRange d) $ case d of+    _ | x `is` ghcEnvList ->+        lift $ hsCon . prettyShow <$> xhqn TypeK x+        -- we ignore Haskell pragmas for List+    _ | x `is` ghcEnvMaybe ->+        lift $ hsCon . prettyShow <$> xhqn TypeK x+        -- we ignore Haskell pragmas for Maybe+    _ | x `is` ghcEnvInf ->+        return $ hsQCon "MAlonzo.RTE" "Infinity"+    Just HsDefn{}      -> throwError $ WrongPragmaFor (getRange d) x+    Just HsType{}      -> namedType+    Just HsData{}      -> namedType+    _                  -> throwError $ NoPragmaFor x++-- | Is the given thing compiled?++isCompiled :: HasConstInfo m => QName -> m Bool+isCompiled q = usableModality <$> getConstInfo q++-- | Does the name stand for a data or record type?++isData :: HasConstInfo m => QName -> m Bool+isData q = do+  def <- theDef <$> getConstInfo q+  return $ case def of+    Datatype{} -> True+    Record{}   -> True+    _          -> False++getHsVar :: (MonadDebug tcm, MonadTCM tcm) => Nat -> tcm HS.Name+getHsVar i =+  HS.Ident . encodeString (VarK X) . prettyShow <$> nameOfBV i++haskellType' :: Type -> HsCompileM HS.Type+haskellType' t = runToHs (unEl t) (fromType t)+  where+    fromArgs = mapM (fromTerm . unArg)+    fromType = fromTerm . unEl+    fromTerm v = do+      v   <- liftTCM $ unSpine <$> reduce 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+          let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          hsApp . hsVar <$> getHsVar x <*> fromArgs args+        Def d es -> do+          let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          hsApp <$> getHsType d <*> fromArgs args+        Pi a b ->+          if isBinderUsed b  -- Andreas, 2012-04-03.  Q: could we rely on Abs/NoAbs instead of again checking freeness of variable?+          then do+            hsA <- fromType (unDom a)+            liftE1' (underAbstraction a b) $ \ b ->+              hsForall <$> getHsVar 0 <*> (hsFun hsA <$> fromType b)+          else hsFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)+        Con c ci es -> do+          let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          hsApp <$> getHsType (conName c) <*> fromArgs args+        Lam{}      -> throwError (BadLambda v)+        Level{}    -> return hsUnit+        Lit{}      -> return hsUnit+        Sort{}     -> return hsUnit+        MetaV{}    -> throwError (BadMeta v)+        DontCare{} -> throwError (BadDontCare v)+        Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++haskellType :: QName -> HsCompileM HS.Type+haskellType q = do+  def <- getConstInfo q+  let (np, erased) =+        case theDef def of+          Constructor{ conPars, conErased }+            -> (conPars, fromMaybe [] conErased ++ repeat False)+          _ -> (0, repeat False)+      stripErased (True  : es) (HS.TyFun _ t)     = stripErased es t+      stripErased (False : es) (HS.TyFun s t)     = HS.TyFun s $ stripErased es t+      stripErased es           (HS.TyForall xs t) = HS.TyForall xs $ stripErased es t+      stripErased _            t                  = t+      underPars 0 a = stripErased erased <$> haskellType' a+      underPars n a = do+        a <- reduce a+        case unEl a of+          Pi a (NoAbs _ b) -> underPars (n - 1) b+          Pi a b  -> underAbstraction a b $ \b -> hsForall <$> getHsVar 0 <*> underPars (n - 1) b+          _       -> __IMPOSSIBLE__+  ty <- underPars np $ defType def+  reportSDoc "tc.pragma.compile" 10 $ (("Haskell type for" <+> prettyTCM q) <> ":") <?> pretty ty+  return ty++-- Type approximations ----------------------------------------------------++data PolyApprox = PolyApprox | NoPolyApprox+  deriving (Eq)++hsTypeApproximation :: PolyApprox -> Int -> Type -> HsCompileM HS.Type+hsTypeApproximation poly fv t = do+  env <- askGHCEnv+  let is q b = Just q == b env+      tyCon  = HS.TyCon . HS.UnQual . HS.Ident+      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+          Pi a b -> hsFun <$> go n (unEl $ unDom a) <*> go (n + k) (unEl $ unAbs b)+            where k = case b of Abs{} -> 1; NoAbs{} -> 0+          Def q els+            | q `is` ghcEnvList+            , Just k <- ghcEnvListArity env+            , [Apply t] <- drop (k-1) els ->+              HS.TyApp (tyCon "[]") <$> go n (unArg t)+            | q `is` ghcEnvMaybe+            , 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"+            | q `is` ghcEnvNat     -> return $ tyCon "Integer"+            | q `is` ghcEnvWord64  -> return $ rteCon "Word64"+            | otherwise -> do+                let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims els+                foldl HS.TyApp <$> getHsType' q <*> mapM (go n . unArg) args+              `catchError` \ _ -> -- Not a Haskell type+                ifM (and2M (isCompiled q) (isData q))+                  (HS.TyCon <$> xhqn TypeK q)+                  (return mazAnyType)+          Sort{} -> return $ HS.FakeType "()"+          _ -> return mazAnyType+  go fv (unEl t)++-- Approximating polymorphic types is not actually a good idea unless we+-- actually keep track of type applications in recursive functions, and+-- generate parameterised datatypes. Otherwise we'll just coerce all type+-- variables to `Any` at the first `unsafeCoerce`.+hsTelApproximation :: Type -> HsCompileM ([HS.Type], HS.Type)+hsTelApproximation = hsTelApproximation' NoPolyApprox++hsTelApproximation' :: PolyApprox -> Type -> HsCompileM ([HS.Type], HS.Type)+hsTelApproximation' poly t = do+  TelV tel res <- telViewPath t+  let args = map (snd . unDom) (telToList tel)+  (,) <$> zipWithM (hsTypeApproximation poly) [0..] args <*> hsTypeApproximation poly (length args) res
src/full/Agda/Compiler/MAlonzo/Misc.hs view
@@ -1,105 +1,279 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.MAlonzo.Misc where -import Control.Monad.State (gets)+import Control.Monad.Reader ( ask )+import Control.Monad.State ( modify )+import Control.Monad.Trans ( MonadTrans(lift) )+import Control.Monad.Trans.Except ( ExceptT )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Reader ( ReaderT(runReaderT) )+import Control.Monad.Trans.State ( StateT(runStateT) )+ import Data.Char-import Data.List as List-import Data.Map as Map-import Data.Set as Set-import Data.Function+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T  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.TypeChecking.Monad.Builtin -import Agda.Utils.Lens-import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty -#include "undefined.h"+import Agda.Utils.CallStack ( HasCallStack ) import Agda.Utils.Impossible  -------------------------------------------------- -- Setting up Interface before compile -------------------------------------------------- -curHsMod :: TCM HS.ModuleName-curHsMod = mazMod <$> curMName+data HsModuleEnv = HsModuleEnv+  { mazModuleName :: TopLevelModuleName+    -- ^ The name of the Agda module+  , mazIsMainModule :: Bool+  -- ^ Whether this is the compilation root and therefore should have the `main` function.+  --   This corresponds to the @IsMain@ flag provided to the backend,+  --   not necessarily whether the GHC module has a `main` function defined.+  } +-- | The options derived from+-- 'Agda.Compiler.MAlonzo.Compiler.GHCFlags' and other shared options.++data GHCOptions = GHCOptions+  { optGhcCallGhc    :: Bool+  , optGhcBin        :: FilePath+    -- ^ Use the compiler at PATH instead of "ghc"+  , optGhcFlags      :: [String]+  , optGhcCompileDir :: FilePath+  , optGhcStrictData :: Bool+    -- ^ Make inductive constructors strict?+  , optGhcStrict :: Bool+    -- ^ Make functions strict?+  }++-- | A static part of the GHC backend's environment that does not+-- change from module to module.++data GHCEnv = GHCEnv+  { ghcEnvOpts :: GHCOptions+  , ghcEnvBool+  , ghcEnvTrue+  , ghcEnvFalse+  , ghcEnvMaybe+  , ghcEnvNothing+  , ghcEnvJust+  , ghcEnvList+  , ghcEnvNil+  , ghcEnvCons+  , ghcEnvNat+  , ghcEnvInteger+  , ghcEnvWord64+  , ghcEnvInf+  , ghcEnvSharp+  , ghcEnvFlat+  , ghcEnvInterval+  , ghcEnvIZero+  , ghcEnvIOne+  , ghcEnvIsOne+  , ghcEnvItIsOne+  , ghcEnvIsOne1+  , ghcEnvIsOne2+  , ghcEnvIsOneEmpty+  , ghcEnvPathP+  , ghcEnvSub+  , ghcEnvSubIn+    :: Maybe QName+    -- Various (possibly) builtin names.+  , ghcEnvIsTCBuiltin :: QName -> Bool+  , ghcEnvListArity   :: Maybe Int+  , ghcEnvMaybeArity  :: Maybe Int+  }++-- | Module compilation environment, bundling the overall+--   backend session options along with the module's basic+--   readable properties.+data GHCModuleEnv = GHCModuleEnv+  { ghcModEnv         :: GHCEnv+  , ghcModHsModuleEnv :: HsModuleEnv+  }++-- | Monads that can produce a 'GHCModuleEnv'.+class Monad m => ReadGHCModuleEnv m where+  askGHCModuleEnv :: m GHCModuleEnv++  default askGHCModuleEnv+    :: (MonadTrans t, Monad n, m ~ (t n), ReadGHCModuleEnv n)+    => m GHCModuleEnv+  askGHCModuleEnv = lift askGHCModuleEnv++  askHsModuleEnv :: m HsModuleEnv+  askHsModuleEnv = ghcModHsModuleEnv <$> askGHCModuleEnv++  askGHCEnv :: m GHCEnv+  askGHCEnv = ghcModEnv <$> askGHCModuleEnv++instance Monad m => ReadGHCModuleEnv (ReaderT GHCModuleEnv m) where+  askGHCModuleEnv = ask++instance ReadGHCModuleEnv m => ReadGHCModuleEnv (ExceptT e m)+instance ReadGHCModuleEnv m => ReadGHCModuleEnv (IdentityT m)+instance ReadGHCModuleEnv m => ReadGHCModuleEnv (MaybeT m)+instance ReadGHCModuleEnv m => ReadGHCModuleEnv (StateT s m)++newtype HsCompileState = HsCompileState+  { mazAccumlatedImports :: Set TopLevelModuleName+  } deriving (Eq, Semigroup, Monoid)++-- | Transformer adding read-only module info and a writable set of imported modules+type HsCompileT m = ReaderT GHCModuleEnv (StateT HsCompileState m)++-- | The default compilation monad is the entire TCM (☹️) enriched with our state and module info+type HsCompileM = HsCompileT TCM++runHsCompileT' :: HsCompileT m a -> GHCModuleEnv -> HsCompileState -> m (a, HsCompileState)+runHsCompileT' t e s = (flip runStateT s) . (flip runReaderT e) $ t++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 -------------------------------------------------- --- The following naming scheme seems to be used:------ * Types coming from Agda are named "T\<number\>".------ * Other definitions coming from Agda are named "d\<number\>".---   Exception: the main function is named "main".+-- | Whether the current module is expected to have the `main` function.+--   This corresponds to the @IsMain@ flag provided to the backend,+--   not necessarily whether the GHC module actually has a `main` function defined.+curIsMainModule :: ReadGHCModuleEnv m => m Bool+curIsMainModule = mazIsMainModule <$> askHsModuleEnv++-- | 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 TopLevelModuleName+curAgdaMod = mazModuleName <$> askHsModuleEnv++-- | Get the Haskell module name of the currently-focused Agda module+curHsMod :: ReadGHCModuleEnv m => m HS.ModuleName+curHsMod = mazMod <$> curAgdaMod++-- | There are two kinds of functions: those definitely without unused+-- arguments, and those that might have unused arguments.++data FunctionKind = NoUnused | PossiblyUnused++-- | Different kinds of variables: those starting with @a@, those+-- starting with @v@, and those starting with @x@.++data VariableKind = A | V | X++-- | Different kinds of names.++data NameKind+  = TypeK+    -- ^ Types.+  | ConK+    -- ^ Constructors.+  | VarK VariableKind+    -- ^ Variables.+  | CoverK+    -- ^ Used for coverage checking.+  | CheckK+    -- ^ Used for constructor type checking.+  | FunK FunctionKind+    -- ^ Other functions.++-- | Turns strings into valid Haskell identifiers. ----- * Names coming from Haskell must always be used qualified.---   Exception: names from the Prelude.+-- In order to avoid clashes with names of regular Haskell definitions+-- (those not generated from Agda definitions), make sure that the+-- Haskell names are always used qualified, with the exception of+-- names from the prelude. -ihname :: String -> Nat -> HS.Name-ihname s i = HS.Ident $ s ++ show i+encodeString :: NameKind -> String -> String+encodeString k s = prefix ++ concatMap encode s+  where+  encode '\'' = "''"+  encode c+    | isLower c || isUpper c || c == '_' ||+      generalCategory c == DecimalNumber =+      [c]+    | otherwise =+      "'" ++ show (fromEnum c) ++ "'" -unqhname :: String -> QName -> HS.Name-{- NOT A GOOD IDEA, see Issue 728-unqhname s q | ("d", "main") == (s, show(qnameName q)) = HS.Ident "main"-             | otherwise = ihname s (idnum $ nameId $ qnameName $ q)--}-unqhname s q = ihname s (idnum $ nameId $ qnameName $ q)-   where idnum (NameId x _) = fromIntegral x+  prefix = case k of+    TypeK               -> "T"+    ConK                -> "C"+    VarK A              -> "a"+    VarK V              -> "v"+    VarK X              -> "x"+    CoverK              -> "cover"+    CheckK              -> "check"+    FunK NoUnused       -> "du"+    FunK PossiblyUnused -> "d" +ihname :: VariableKind -> Nat -> HS.Name+ihname k i = HS.Ident $ encodeString (VarK k) (show i)++unqhname :: NameKind -> QName -> HS.Name+unqhname k q =+  HS.Ident $ encodeString k $+    "_" ++ prettyShow (nameCanonical n) ++ "_" ++ idnum (nameId n)+  where+  n = qnameName q++  idnum (NameId x _) = show (fromIntegral x)+ -- the toplevel module containing the given one-tlmodOf :: ModuleName -> TCM HS.ModuleName-tlmodOf = fmap mazMod . topLevelModuleName+tlmodOf :: ReadTCState m => ModuleName -> m HS.ModuleName+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 -> TCM HS.QName-xqual q n = do m1 <- topLevelModuleName (qnameModule q)-               m2 <- curMName-               if m1 == m2 then return (HS.UnQual n)-                  else addImport m1 >> return (HS.Qual (mazMod m1) n)+xqual :: QName -> HS.Name -> HsCompileM HS.QName+xqual q n = do+  m1 <- CC.topLevelModuleName (qnameModule q)+  m2 <- curAgdaMod+  if m1 == m2+    then return (HS.UnQual n)+    else do+      modify (HsCompileState . Set.insert m1 . mazAccumlatedImports)+      return (HS.Qual (mazMod m1) n) -xhqn :: String -> QName -> TCM HS.QName-xhqn s q = xqual q (unqhname s q)+xhqn :: NameKind -> QName -> HsCompileM HS.QName+xhqn k q = xqual q (unqhname k q)  hsName :: String -> HS.QName hsName s = HS.UnQual (HS.Ident s)  -- always use the original name for a constructor even when it's redefined.-conhqn :: QName -> TCM HS.QName-conhqn q = do-    cq  <- canonicalName q-    def <- getConstInfo cq-    cname <- xhqn "C" cq  -- Do this even if it has custom compiledHaskell code-                          -- to make sure we get the import.-    case (compiledHaskell (defCompiledRep def), theDef def) of-      (Just (HsDefn _ hs), Constructor{}) -> return $ hsName hs-      _                                   -> return cname+conhqn :: QName -> HsCompileM HS.QName+conhqn q = xhqn ConK =<< canonicalName q  -- qualify name s by the module of builtin b-bltQual :: String -> String -> TCM HS.QName+bltQual :: BuiltinId -> String -> HsCompileM HS.QName bltQual b s = do-  Def q _ <- ignoreSharing <$> getBuiltin b+  Def q _ <- getBuiltin b   xqual q (HS.Ident s)  dname :: QName -> HS.Name-dname q = unqhname "d" q+dname q = unqhname (FunK PossiblyUnused) q  -- | Name for definition stripped of unused arguments duname :: QName -> HS.Name-duname q = unqhname "du" q+duname q = unqhname (FunK NoUnused) q  hsPrimOp :: String -> HS.QOp hsPrimOp s = HS.QVarOp $ HS.UnQual $ HS.Symbol s@@ -113,9 +287,12 @@ hsTypedInt :: Integral a => a -> HS.Exp hsTypedInt n = HS.ExpTypeSig (HS.Lit (HS.Int $ fromIntegral n)) (HS.TyCon (hsName "Integer")) +hsTypedDouble :: Real a => a -> HS.Exp+hsTypedDouble n = HS.ExpTypeSig (HS.Lit (HS.Frac $ toRational n)) (HS.TyCon (hsName "Double"))+ hsLet :: HS.Name -> HS.Exp -> HS.Exp -> HS.Exp hsLet x e b =-  HS.Let (HS.BDecls [HS.FunBind [HS.Match x [] (HS.UnGuardedRhs e) emptyBinds]]) b+  HS.Let (HS.BDecls [HS.LocalBind HS.Lazy x (HS.UnGuardedRhs e)]) b  hsVarUQ :: HS.Name -> HS.Exp hsVarUQ = HS.Var . HS.UnQual@@ -154,48 +331,53 @@ mazMod' :: String -> HS.ModuleName mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s -mazMod :: ModuleName -> HS.ModuleName+mazMod :: TopLevelModuleName -> HS.ModuleName mazMod = mazMod' . prettyShow -mazerror :: String -> a-mazerror msg = error $ mazstr ++ ": " ++ msg- mazCoerceName :: String mazCoerceName = "coe"  mazErasedName :: String mazErasedName = "erased" +mazAnyTypeName :: String+mazAnyTypeName = "AgdaAny"+ mazCoerce :: HS.Exp -- mazCoerce = HS.Var $ HS.Qual unsafeCoerceMod (HS.Ident "unsafeCoerce") -- mazCoerce = HS.Var $ HS.Qual mazRTE $ HS.Ident mazCoerceName mazCoerce = HS.Var $ HS.UnQual $ HS.Ident mazCoerceName --- Andreas, 2011-11-16: error incomplete match now RTE-call-mazIncompleteMatch :: HS.Exp-mazIncompleteMatch = HS.Var $ HS.Qual mazRTE $ HS.Ident "mazIncompleteMatch"--rtmIncompleteMatch :: QName -> HS.Exp-rtmIncompleteMatch q = mazIncompleteMatch `HS.App` hsVarUQ (unqhname "name" q)- mazUnreachableError :: HS.Exp mazUnreachableError = HS.Var $ HS.Qual mazRTE $ HS.Ident "mazUnreachableError"  rtmUnreachableError :: HS.Exp rtmUnreachableError = mazUnreachableError +mazHole :: HS.Exp+mazHole = HS.Var $ HS.Qual mazRTE $ HS.Ident "mazHole"++rtmHole :: String -> HS.Exp+rtmHole s = mazHole `HS.App` HS.Lit (HS.String $ T.pack s)++mazAnyType :: HS.Type+mazAnyType = HS.TyCon (hsName mazAnyTypeName)+ mazRTE :: HS.ModuleName mazRTE = HS.ModuleName "MAlonzo.RTE" +mazRTEFloat :: HS.ModuleName+mazRTEFloat = HS.ModuleName "MAlonzo.RTE.Float"+ rtmQual :: String -> HS.QName rtmQual = HS.UnQual . HS.Ident  rtmVar :: String -> HS.Exp rtmVar  = HS.Var . rtmQual -rtmError :: String -> HS.Exp+rtmError :: Text -> HS.Exp rtmError s = rtmVar "error" `HS.App`-             (HS.Lit $ HS.String $ "MAlonzo Runtime Error: " ++ s)+             HS.Lit (HS.String $ T.append "MAlonzo Runtime Error: " s)  unsafeCoerceMod :: HS.ModuleName unsafeCoerceMod = HS.ModuleName "Unsafe.Coerce"@@ -211,7 +393,7 @@ fakeDS = fakeD . HS.Ident  fakeDQ :: QName -> String -> HS.Decl-fakeDQ = fakeD . unqhname "d"+fakeDQ = fakeD . dname  fakeType :: String -> HS.Type fakeType = HS.FakeType
+ src/full/Agda/Compiler/MAlonzo/Pragmas.hs view
@@ -0,0 +1,255 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Compiler.MAlonzo.Pragmas where++import Control.Monad.Trans.Maybe++import Data.Maybe+import Data.Char+import qualified Data.List as List+import qualified Data.Map as Map+import Text.ParserCombinators.ReadP++import Agda.Syntax.Position+import Agda.Syntax.Abstract.Name+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Warnings+import Agda.TypeChecking.Primitive++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.Utils.Impossible++type HaskellCode = String+type HaskellType = String++-- | GHC backend translation pragmas.+data HaskellPragma+  = HsDefn Range HaskellCode+      --  ^ @COMPILE GHC x = <code>@+  | HsType Range HaskellType+      --  ^ @COMPILE GHC X = type <type>@+  | HsData Range HaskellType [HaskellCode]+      -- ^ @COMPILE GHC X = data D (c₁ | ... | cₙ)+  | HsExport Range HaskellCode+      -- ^ @COMPILE GHC x as f@+  deriving (Show, Eq)++instance HasRange HaskellPragma where+  getRange (HsDefn   r _)   = r+  getRange (HsType   r _)   = r+  getRange (HsData   r _ _) = r+  getRange (HsExport r _)   = r++instance Pretty HaskellPragma where+  pretty = \case+    HsDefn   _r hsCode        -> equals <+> text hsCode+    HsType   _r hsType        -> equals <+> text hsType+    HsData   _r hsType hsCons -> hsep $+      [ equals, "data", text hsType+      , parens $ hsep $ map text $ List.intersperse "|" hsCons+      ]+    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 -> Maybe HaskellPragma+parsePragma (CompilerPragma r s) =+  case [ p | (p, "") <- readP_to_S pragmaP s ] of+    []  -> 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 ]++    whitespace = many1 (satisfy isSpace)++    wordsP []     = return ()+    wordsP (w:ws) = skipSpaces *> string w *> wordsP ws++    barP = skipSpaces *> char '|'++    -- quite liberal+    isIdent c = isAlphaNum c || elem c ("_.':[]" :: String)+    isOp c    = not $ isSpace c || elem c ("()" :: String)+    hsIdent = fst <$> gather (choice+                [ string "()"+                , many1 (satisfy isIdent)+                , between (char '(') (char ')') (many1 (satisfy isOp))+                ])+    hsCode  = many1 get -- very liberal++    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 (`isPrefixSpaceOf` s) ["type", "data"]++    exportP = HsExport r <$ wordsP ["as"]        <* whitespace <*> hsIdent <* skipSpaces+    typeP   = HsType   r <$ wordsP ["=", "type"] <* whitespace <*> hsCode+    dataP   = HsData   r <$ wordsP ["=", "data"] <* whitespace <*> hsIdent <*>+                                                    paren (sepBy (skipSpaces *> hsIdent) barP) <* skipSpaces+    defnP   = HsDefn   r <$ wordsP ["="]         <* whitespace <*  notTypeOrData <*> hsCode++parseHaskellPragma :: CompilerPragma -> TCM (Maybe HaskellPragma)+parseHaskellPragma p@(CompilerPragma _ s) = do+  let p' = parsePragma p+  () <- whenNothing p' $ warning $ PragmaCompileUnparsable s+  return p'++-- | 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++    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)+getHaskellConstructor c = do+  c    <- canonicalName c+  cDef <- theDef <$> getConstInfo c+  env  <- askGHCEnv+  let is c p = Just c == p env+  case cDef of+    _ | c `is` ghcEnvTrue    -> return $ Just "True"+      | c `is` ghcEnvFalse   -> return $ Just "False"+      | c `is` ghcEnvNil     -> return $ Just "[]"+      | c `is` ghcEnvCons    -> return $ Just "(:)"+      | c `is` ghcEnvNothing -> return $ Just "Nothing"+      | c `is` ghcEnvJust    -> return $ Just "Just"+      | c `is` ghcEnvSharp   -> return $ Just "MAlonzo.RTE.Sharp"+      | c `is` ghcEnvIZero   -> return $ Just "False"+      | c `is` ghcEnvIOne    -> return $ Just "True"+    Constructor{conData = d} -> do+      mp <- liftTCM $ getHaskellPragma d+      case mp of+        Just (HsData _ _ hsCons) -> do+          cons <- defConstructors . theDef <$> getConstInfo d+          return $ Just $ fromMaybe __IMPOSSIBLE__ $ lookup c $ zip cons hsCons+        _ -> return Nothing+    _ -> return Nothing++-- | Get content of @FOREIGN GHC@ pragmas, sorted by 'KindOfForeignCode':+--   file header pragmas, import statements, rest.+foreignHaskell :: Interface -> ([String], [String], [String])+foreignHaskell = partitionByKindOfForeignCode classifyForeign+    . map getCode . maybe [] (reverse . getForeignCodeStack) . Map.lookup ghcBackendName . iForeignCode+  where getCode (ForeignCode _ code) = code++-- | Classify @FOREIGN@ Haskell code.+data KindOfForeignCode+  = ForeignFileHeaderPragma+      -- ^ A pragma that must appear before the module header.+  | ForeignImport+      -- ^ An import statement.  Must appear right after the module header.+  | ForeignOther+      -- ^ The rest.  To appear after the import statements.++-- | Classify a @FOREIGN GHC@ declaration.+classifyForeign :: String -> KindOfForeignCode+classifyForeign s0 = case ltrim s0 of+  s | "import " `List.isPrefixOf` s -> ForeignImport+  s | "{-#" `List.isPrefixOf` s -> classifyPragma $ drop 3 s+  _ -> ForeignOther++-- | Classify a Haskell pragma into whether it is a file header pragma or not.+classifyPragma :: String -> KindOfForeignCode+classifyPragma s0 = case ltrim s0 of+  s | any (`List.isPrefixOf` s) fileHeaderPragmas -> ForeignFileHeaderPragma+  _ -> ForeignOther+  where+  fileHeaderPragmas =+    [ "LANGUAGE"+    , "OPTIONS_GHC"+    , "INCLUDE"+    ]++-- | Partition a list by 'KindOfForeignCode' attribute.+partitionByKindOfForeignCode :: (a -> KindOfForeignCode) -> [a] -> ([a], [a], [a])+partitionByKindOfForeignCode f = partition3 $ toThree . f+  where+  toThree = \case+    ForeignFileHeaderPragma -> One+    ForeignImport           -> Two+    ForeignOther            -> Three
src/full/Agda/Compiler/MAlonzo/Pretty.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- Pretty-printing of Haskell modules@@ -6,70 +6,86 @@  module Agda.Compiler.MAlonzo.Pretty where -import Data.Generics.Geniplate import qualified Agda.Utils.Haskell.Syntax as HS-import Text.PrettyPrint (empty)  import Agda.Compiler.MAlonzo.Encode-import Agda.Utils.Pretty-import Agda.Utils.Impossible+import Agda.Syntax.Common.Pretty -#include "undefined.h"+import Agda.Utils.Null (empty)+import Agda.Utils.Function (applyWhen) + prettyPrint :: Pretty a => a -> String prettyPrint = show . pretty  instance Pretty HS.Module where   pretty (HS.Module m pragmas imps decls) =-    vcat [ vcat $ map pretty pragmas-         , text "module" <+> pretty m <+> text "where"-         , text ""-         , vcat $ map pretty imps-         , text ""-         , vcat $ map pretty decls ]+    vcat $ concat+      [ map pretty pragmas+      , [ "" | not $ null pragmas ]+      , [ "module" <+> pretty m <+> "where" ]+      , [ "" ]+      , map pretty imps+      , [ "" ]+      , map pretty decls+      ]  instance Pretty HS.ModulePragma where   pretty (HS.LanguagePragma ps) =-    text "{-#" <+> text "LANGUAGE" <+> fsep (punctuate comma $ map pretty ps) <+> text "#-}"+    "{-#" <+> "LANGUAGE" <+> fsep (punctuate comma $ map pretty ps) <+> "#-}"+  pretty (HS.OtherPragma p) =+    text p  instance Pretty HS.ImportDecl where   pretty HS.ImportDecl{ HS.importModule    = m                       , HS.importQualified = q                       , HS.importSpecs     = specs } =-      hsep [ text "import"-           , if q then text "qualified" else empty+      hsep [ "import"+           , if q then "qualified" else empty            , pretty m            , maybe empty prSpecs specs ]     where prSpecs (hide, specs) =-            hsep [ if hide then text "hiding" else empty+            hsep [ if hide then "hiding" else empty                  , parens $ fsep $ punctuate comma $ map pretty specs ]  instance Pretty HS.ImportSpec where   pretty (HS.IVar x) = pretty x  instance Pretty HS.Decl where-  pretty d = case d of+  pretty = \case     HS.TypeDecl f xs t ->-      sep [ text "type" <+> pretty f <+> fsep (map pretty xs) <+> text "="+      sep [ "type" <+> pretty f <+> fsep (map pretty xs) <+> "="           , nest 2 $ pretty t ]     HS.DataDecl newt d xs cons derv ->       sep [ pretty newt <+> pretty d <+> fsep (map pretty xs)           , nest 2 $ if null cons then empty-                     else text "=" <+> fsep (punctuate (text " |") $ map pretty cons)+                     else "=" <+> fsep (punctuate " |" $ map pretty cons)           , nest 2 $ prDeriving derv ]       where         prDeriving [] = empty-        prDeriving ds = text "deriving" <+> parens (fsep $ punctuate comma $ map prDer ds)+        prDeriving ds = "deriving" <+> parens (fsep $ punctuate comma $ map prDer ds)         prDer (d, ts) = pretty (foldl HS.TyApp (HS.TyCon d) ts)     HS.TypeSig fs t ->-      sep [ hsep (punctuate comma (map pretty fs)) <+> text "::"+      sep [ hsep (punctuate comma (map pretty fs)) <+> "::"           , nest 2 $ pretty t ]     HS.FunBind ms -> vcat $ map pretty ms+    HS.LocalBind s f rhs ->+      sep [ pretty s <> pretty f+          , nest 2 $ prettyRhs "=" rhs+          ]+    HS.PatSyn p1 p2 -> sep [ "pattern" <+> pretty p1 <+> "=" <+> pretty p2 ]     HS.FakeDecl s -> text s+    HS.Comment s -> vcat $ map (("--" <+>) . text) (lines s)  instance Pretty HS.ConDecl where-  pretty (HS.ConDecl c ts) = pretty c <+> fsep (map (prettyPrec 10) ts)+  pretty (HS.ConDecl c sts) =+    pretty c <+>+    fsep (map (\(s, t) -> maybe empty pretty s <> prettyPrec 10 t) sts) +instance Pretty HS.Strictness where+  pretty HS.Strict = "!"+  pretty HS.Lazy   = empty+ instance Pretty HS.Match where   pretty (HS.Match f ps rhs wh) =     prettyWhere wh $@@ -79,19 +95,19 @@ prettyWhere :: Maybe HS.Binds -> Doc -> Doc prettyWhere Nothing  doc = doc prettyWhere (Just b) doc =-  vcat [ doc, nest 2 $ sep [ text "where", nest 2 $ pretty b ] ]+  vcat [ doc, nest 2 $ sep [ "where", nest 2 $ pretty b ] ]  instance Pretty HS.Pat where   prettyPrec pr pat =     case pat of       HS.PVar x         -> pretty x-      HS.PLit l         -> pretty l-      HS.PAsPat x p     -> mparens (pr > 10) $ pretty x <> text "@" <> prettyPrec 11 p-      HS.PWildCard      -> text "_"-      HS.PBangPat p     -> text "!" <> prettyPrec 11 p+      HS.PLit l         -> prettyPrec pr l+      HS.PAsPat x p     -> mparens (pr > 10) $ pretty x <> "@" <> prettyPrec 11 p+      HS.PWildCard      -> "_"+      HS.PBangPat p     -> "!" <> prettyPrec 11 p       HS.PApp c ps      -> mparens (pr > 9) $ pretty c <+> hsep (map (prettyPrec 10) ps)-      HS.PatTypeSig p t -> mparens (pr > 0) $ sep [ pretty p <+> text "::", nest 2 $ pretty t ]-      HS.PIrrPat p      -> mparens (pr > 10) $ text "~" <> prettyPrec 11 p+      HS.PatTypeSig p t -> mparens (pr > 0) $ sep [ pretty p <+> "::", nest 2 $ pretty t ]+      HS.PIrrPat p      -> mparens (pr > 10) $ "~" <> prettyPrec 11 p  prettyRhs :: String -> HS.Rhs -> Doc prettyRhs eq (HS.UnGuardedRhs e)   = text eq <+> pretty e@@ -99,15 +115,15 @@  prettyGuardedRhs :: String -> HS.GuardedRhs -> Doc prettyGuardedRhs eq (HS.GuardedRhs ss e) =-    sep [ text "|" <+> sep (punctuate comma $ map pretty ss) <+> text eq+    sep [ "|" <+> sep (punctuate comma $ map pretty ss) <+> text eq         , nest 2 $ pretty e ]  instance Pretty HS.Binds where   pretty (HS.BDecls ds) = vcat $ map pretty ds  instance Pretty HS.DataOrNew where-  pretty HS.DataType = text "data"-  pretty HS.NewType  = text "newtype"+  pretty HS.DataType = "data"+  pretty HS.NewType  = "newtype"  instance Pretty HS.TyVarBind where   pretty (HS.UnkindedVar x) = pretty x@@ -117,14 +133,17 @@     case t of       HS.TyForall xs t ->         mparens (pr > 0) $-          sep [ text "forall" <+> fsep (map pretty xs) <> text "."+          sep [ ("forall" <+> fsep (map pretty xs)) <> "."               , nest 2 $ pretty t ]       HS.TyFun a b ->         mparens (pr > 4) $-          sep [ prettyPrec 5 a <+> text "->", prettyPrec 4 b ]+          sep [ prettyPrec 5 a <+> "->", prettyPrec 4 b ]       HS.TyCon c -> pretty c       HS.TyVar x -> pretty x+      HS.TyApp (HS.TyCon (HS.UnQual (HS.Ident "[]"))) t ->+        brackets $ pretty t       t@HS.TyApp{} ->+        mparens (pr > 9) $           sep [ prettyPrec 9 f               , nest 2 $ fsep $ map (prettyPrec 10) ts ]         where@@ -135,13 +154,19 @@  instance Pretty HS.Stmt where   pretty (HS.Qualifier e) = pretty e-  pretty (HS.Generator p e) = sep [ pretty p <+> text "<-", nest 2 $ pretty e ]+  pretty (HS.Generator p e) = sep [ pretty p <+> "<-", nest 2 $ pretty e ]  instance Pretty HS.Literal where-  pretty (HS.Int n)    = integer n-  pretty (HS.Frac x)   = double (fromRational x)-  pretty (HS.Char c)   = text (show c)-  pretty (HS.String s) = text (show s)+  prettyPrec pr = \case+    HS.Int n    -> parensIfNeg n $ integer n+    HS.Frac x   -> parensIfNeg d $ double d+                   where+                   d = fromRational x+    HS.Char c   -> text (show c)+    HS.String s -> text (show s)+    where+    parensIfNeg :: (Ord n, Num n) => n -> Doc -> Doc+    parensIfNeg x = applyWhen (x < 0) $ mparens (pr > 10)  instance Pretty HS.Exp where   prettyPrec pr e =@@ -152,6 +177,11 @@       HS.InfixApp a qop b -> mparens (pr > 0) $         sep [ prettyPrec 1 a             , pretty qop <+> prettyPrec 1 b ]+      HS.Ann e ty -> mparens (pr > 0) $+        sep [ prettyPrec 1 e+            , "::"+            , prettyPrec 1 ty+            ]       HS.App{} -> mparens (pr > 9) $         sep [ prettyPrec 9 f             , nest 2 $ fsep $ map (prettyPrec 10) es ]@@ -160,22 +190,22 @@           appView (HS.App f e) es = appView f (e : es)           appView f es = f : es       HS.Lambda ps e -> mparens (pr > 0) $-        sep [ text "\\" <+> fsep (map (prettyPrec 10) ps) <+> text "->"+        sep [ "\\" <+> fsep (map (prettyPrec 10) ps) <+> "->"             , nest 2 $ pretty e ]       HS.Let bs e -> mparens (pr > 0) $-        sep [ text "let" <+> pretty bs <+> text "in"+        sep [ "let" <+> pretty bs <+> "in"             , pretty e ]       HS.If a b c -> mparens (pr > 0) $-        sep [ text "if" <+> pretty a-            , nest 2 $ text "then" <+> pretty b-            , nest 2 $ text "else" <+> prettyPrec 1 c ]+        sep [ "if" <+> pretty a+            , nest 2 $ "then" <+> pretty b+            , nest 2 $ "else" <+> prettyPrec 1 c ]       HS.Case e bs -> mparens (pr > 0) $-        vcat [ text "case" <+> pretty e <+> text "of"+        vcat [ "case" <+> pretty e <+> "of"              , nest 2 $ vcat $ map pretty bs ]       HS.ExpTypeSig e t -> mparens (pr > 0) $-        sep [ pretty e <+> text "::"+        sep [ pretty e <+> "::"             , nest 2 $ pretty t ]-      HS.NegApp exp -> parens $ text "-" <> pretty exp+      HS.NegApp exp -> parens $ "-" <> pretty exp       HS.FakeExp s -> text s  instance Pretty HS.Alt where@@ -197,7 +227,7 @@ instance Pretty HS.QOp where   pretty (HS.QVarOp x)     | isOperator x = prettyQName x-    | otherwise    = text "`" <> prettyQName x <> text "`"+    | otherwise    = "`" <> prettyQName x <> "`"  isOperator :: HS.QName -> Bool isOperator q =@@ -209,6 +239,5 @@     isOp HS.Ident{}  = False  prettyQName :: HS.QName -> Doc-prettyQName (HS.Qual m x)           = pretty m <> text "." <> pretty x+prettyQName (HS.Qual m x)           = pretty m <> "." <> pretty x prettyQName (HS.UnQual x)           = pretty x-
src/full/Agda/Compiler/MAlonzo/Primitives.hs view
@@ -1,232 +1,303 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.MAlonzo.Primitives where -import Control.Monad.State-import Data.Char-import Data.List as L-import Data.Map as M-import qualified Agda.Utils.Haskell.Syntax as HS+import Control.Arrow ( second )+import Control.Monad.Trans.Maybe ( MaybeT(MaybeT, runMaybeT) ) +import qualified Data.List as List+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap+import Data.Maybe+ import Agda.Compiler.Common-import Agda.Compiler.ToTreeless-import {-# SOURCE #-} Agda.Compiler.MAlonzo.Compiler (closedTerm) 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.Monad.Builtin import Agda.TypeChecking.Primitive import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty-import Agda.Utils.Monad-import Agda.Utils.Except-import qualified Agda.Utils.HashMap as HMap -#include "undefined.h"+import Agda.Utils.Either+import Agda.Utils.Lens+import Agda.Utils.List   (hasElem)+import qualified Agda.Utils.Haskell.Syntax as HS+ import Agda.Utils.Impossible -{- OLD--- | Check that the main function has type IO a, for some a.-checkTypeOfMain :: QName -> Type -> TCM ()-checkTypeOfMain q ty-  | show (qnameName q) /= "main" = return ()-  | otherwise = do-    Def io _ <- ignoreSharing <$> primIO-    ty <- normalise ty-    case ignoreSharing $ unEl ty of-      Def d _ | d == io -> return ()-      _                 -> 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--}+newtype MainFunctionDef = MainFunctionDef Definition +data CheckedMainFunctionDef = CheckedMainFunctionDef+  { checkedMainDef :: MainFunctionDef+  , checkedMainDecl :: HS.Decl+  }++-- Andreas, 2019-04-29, issue #3731: exclude certain kinds of names, like constructors.+-- 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 = 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+          | otherwise   = no+  no                    = Nothing++mainFunctionDefs :: Interface -> [MainFunctionDef]+mainFunctionDefs i = catMaybes $ asMainFunctionDef <$> defs+  where+    defs = HMap.elems $ iSignature i ^. sigDefinitions+ -- | Check that the main function has type IO a, for some a.-checkTypeOfMain :: QName -> Type -> TCM [HS.Decl] -> TCM [HS.Decl]-checkTypeOfMain q ty ret-  | show (nameConcrete $ qnameName q) /= "main" = ret-  | otherwise = do-    Def io _ <- ignoreSharing <$> primIO-    ty <- normalise ty-    case ignoreSharing $ unEl ty of-      Def d _ | d == io -> (mainAlias :) <$> ret-      _                 -> 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+checkTypeOfMain :: Definition -> HsCompileM (Maybe CheckedMainFunctionDef)+checkTypeOfMain def = runMaybeT $ do+  -- Only indicate main functions in the main module.+  isMainModule <- curIsMainModule+  mainDef <- MaybeT $ pure $ if isMainModule then asMainFunctionDef def else Nothing+  liftTCM $ checkTypeOfMain' mainDef++checkTypeOfMain' :: MainFunctionDef -> TCM CheckedMainFunctionDef+checkTypeOfMain' m@(MainFunctionDef def) = CheckedMainFunctionDef m <$> do+    Def io _ <- primIO+    ty <- reduce $ defType def+    case unEl ty of+      Def d _ | d == io -> return mainAlias+      _ -> ghcBackendError $ WrongTypeOfMain io ty   where     mainAlias = HS.FunBind [HS.Match mainLHS [] mainRHS emptyBinds ]     mainLHS   = HS.Ident "main"-    mainRHS   = HS.UnGuardedRhs $ HS.Var $ HS.UnQual $ unqhname "d" q+    mainRHS   = HS.UnGuardedRhs $ HS.App mazCoerce (HS.Var $ HS.UnQual $ dname $ defName def)  treelessPrimName :: TPrim -> String treelessPrimName p =   case p of-    PQuot -> "quotInt"-    PRem  -> "remInt"-    PSub  -> "subInt"-    PAdd  -> "addInt"-    PMul  -> "mulInt"-    PGeq  -> "geqInt"-    PLt   -> "ltInt"-    PEqI  -> "eqInt"-    PEqF  -> "eqFloat"+    PQuot   -> "quotInt"+    PRem    -> "remInt"+    PSub    -> "subInt"+    PAdd    -> "addInt"+    PMul    -> "mulInt"+    PGeq    -> "geqInt"+    PLt     -> "ltInt"+    PEqI    -> "eqInt"+    PQuot64 -> "quot64"+    PRem64  -> "rem64"+    PSub64  -> "sub64"+    PAdd64  -> "add64"+    PMul64  -> "mul64"+    PLt64   -> "lt64"+    PEq64   -> "eq64"+    PITo64  -> "word64FromNat"+    P64ToI  -> "word64ToNat"+    PEqF    -> "MAlonzo.RTE.Float.doubleDenotEq"     -- MAlonzo uses literal patterns, so we don't need equality for the other primitive types-    PEqC  -> __IMPOSSIBLE__-    PEqS  -> __IMPOSSIBLE__-    PEqQ  -> __IMPOSSIBLE__-    PSeq  -> "seq"+    PEqC    -> __IMPOSSIBLE__+    PEqS    -> __IMPOSSIBLE__+    PEqQ    -> __IMPOSSIBLE__+    PSeq    -> "seq"     -- primitives only used by GuardsToPrims transformation, which MAlonzo doesn't use-    PIf   -> __IMPOSSIBLE__+    PIf     -> __IMPOSSIBLE__ --- Haskell modules to be imported for BUILT-INs-importsForPrim :: TCM [HS.ModuleName]-importsForPrim =-  fmap (++ [HS.ModuleName "Data.Text"]) $-  xForPrim $-  L.map (\(s, ms) -> (s, return (L.map HS.ModuleName ms))) $-  [ "CHAR"              |-> ["Data.Char"]-  , "primIsAlpha"       |-> ["Data.Char"]-  , "primIsAscii"       |-> ["Data.Char"]-  , "primIsDigit"       |-> ["Data.Char"]-  , "primIsHexDigit"    |-> ["Data.Char"]-  , "primIsLatin1"      |-> ["Data.Char"]-  , "primIsLower"       |-> ["Data.Char"]-  , "primIsPrint"       |-> ["Data.Char"]-  , "primIsSpace"       |-> ["Data.Char"]-  , "primToLower"       |-> ["Data.Char"]-  , "primToUpper"       |-> ["Data.Char"]-  ]-  where (|->) = (,)+-- | Haskell modules to be imported for BUILT-INs+importsForPrim :: BuiltinThings -> [Definition] -> [HS.ModuleName]+importsForPrim builtinThings defs = xForPrim table builtinThings defs ++ [HS.ModuleName "Data.Text"]+  where+  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 :: [(String, TCM [a])] -> TCM [a]-xForPrim table = do-  qs <- HMap.keys <$> curDefs-  bs <- toList <$> gets stBuiltinThings-  let getName (Builtin (Def q _))    = q-      getName (Builtin (Con q _ _))  = conName q-      getName (Builtin (Shared p))   = getName (Builtin $ derefPtr p)-      getName (Builtin (Lam _ b))    = getName (Builtin $ unAbs b)-      getName (Builtin _)            = __IMPOSSIBLE__-      getName (Prim (PrimFun q _ _)) = q-  concat <$> sequence [ maybe (return []) id $ L.lookup s table-                        | (s, def) <- bs, getName def `elem` qs ]+xForPrim :: Map SomeBuiltin a -> BuiltinThings -> [Definition] -> [a]+xForPrim table builtinThings defs = catMaybes+    [ Map.lookup s table+    | (s, def) <- Map.toList builtinThings+    , maybe False elemDefs $ getName def+    ]+  where+  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 :: String -> TCM HS.Exp-primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $-             L.lookup s $+-- | Definition bodies for primitive functions+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 "(\\ _ _ -> ())"+  , 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 "(<)"+  , 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+   -- Floating point functions-  , "primNatToFloat"        |-> return "(fromIntegral :: Integer -> Double)"-  , "primFloatPlus"         |-> return "((+)          :: Double -> Double -> Double)"-  , "primFloatMinus"        |-> return "((-)          :: Double -> Double -> Double)"-  , "primFloatTimes"        |-> return "((*)          :: Double -> Double -> Double)"-  , "primFloatNegate"       |-> return "(negate       :: Double -> Double)"-  , "primFloatDiv"          |-> return "((/)          :: Double -> Double -> Double)"-  -- ASR (2016-09-14). We use bitwise equality for comparing Double-  -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove-  -- a contradiction (see Issue #2169).-  , "primFloatEquality"     |-> return "MAlonzo.RTE.eqFloat"-  , "primFloatNumericalEquality" |-> return "MAlonzo.RTE.eqNumFloat"-  , "primFloatNumericalLess" |-> return "MAlonzo.RTE.ltNumFloat"-  , "primFloatSqrt"         |-> return "(sqrt :: Double -> Double)"-  , "primRound"             |-> return "(round :: Double -> Integer)"-  , "primFloor"             |-> return "(floor :: Double -> Integer)"-  , "primCeiling"           |-> return "(ceiling :: Double -> Integer)"-  , "primExp"               |-> return "(exp :: Double -> Double)"-  , "primLog"               |-> return "(log :: Double -> Double)"-  , "primSin"               |-> return "(sin :: Double -> Double)"-  , "primCos"               |-> return "(cos :: Double -> Double)"-  , "primTan"               |-> return "(tan :: Double -> Double)"-  , "primASin"              |-> return "(asin :: Double -> Double)"-  , "primACos"              |-> return "(acos :: Double -> Double)"-  , "primATan"              |-> return "(atan :: Double -> Double)"-  , "primATan2"             |-> return "(atan2 :: Double -> Double -> Double)"-  , "primShowFloat"         |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"+  , 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 "(toEnum . fromIntegral :: Integer -> Char)"-  , "primShowChar"  |-> return "(Data.Text.pack . show :: Char -> Data.Text.Text)"+  , 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-  , "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 "id"+  , 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"-  , "primMetaEquality"    |-> rel "(==)" "Integer"-  , "primMetaLess"        |-> rel "(<)" "Integer"-  , "primShowMeta"        |-> return "\\ x -> Data.Text.pack (\"_\" ++ show (x :: Integer))"+  , 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 "erased"+  , PrimForce        |-> return "\\ _ _ _ _ x f -> f $! x"+  , PrimForceLemma   |-> return mazErasedName -  -- Trust me-  , ("primTrustMe"       , Right <$> do-       refl <- primRefl-       closedTerm =<< (closedTermToTreeless $ lam "a" (lam "A" (lam "x" (lam "y" refl)))))+  -- Lock universe+  , PrimLockUniv |-> return "()"++  -- Erase+  , PrimEraseEquality |-> return mazErasedName++  -- Cubical+  , 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"   ]   where   x |-> s = (x, Left <$> s)-  bin blt op ty from to = do-    from' <- bltQual' blt from-    to'   <- bltQual' blt to-    return $ repl [op, opty ty, from', to'] $-               "\\ x y -> <<3>> ((<<0>> :: <<1>>) (<<2>> x) (<<2>> y))"   binNat  op = return $ repl [op] "(<<0>> :: Integer -> Integer -> Integer)"   binNat4 op = return $ repl [op] "(<<0>> :: Integer -> Integer -> Integer -> Integer -> Integer)"   binAsis op ty = return $ repl [op, opty ty] $ "((<<0>>) :: <<1>>)"@@ -238,21 +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) -  lam x t = Lam (setHiding Hidden defaultArgInfo) (Abs x t)+  hLam x t = Lam (setHiding Hidden defaultArgInfo) (Abs x t)+  nLam x t = Lam (setHiding NotHidden defaultArgInfo) (Abs x t) -noCheckCover :: QName -> TCM Bool+noCheckCover :: (HasBuiltins m, MonadReduce m) => QName -> m Bool noCheckCover q = (||) <$> isBuiltin q builtinNat <*> isBuiltin q builtinInteger---------------------------pconName :: String -> TCM String-pconName s = toS . ignoreSharing =<< getBuiltin s where-  toS (Con q _ _) = prettyPrint <$> conhqn (conName q)-  toS (Lam _ t) = toS (unAbs t)-  toS _ = mazerror $ "pconName" ++ s--bltQual' :: String -> String -> TCM String-bltQual' b s = prettyPrint <$> bltQual b s
+ src/full/Agda/Compiler/MAlonzo/Strict.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_GHC -Wunused-imports #-}++------------------------------------------------------------------------+-- | Strictification of Haskell code+------------------------------------------------------------------------++module Agda.Compiler.MAlonzo.Strict where++import Agda.Utils.Haskell.Syntax++-- | The function 'makeStrict' makes every function argument, case and+-- generator pattern, and 'LocalBind' binding strict (except for those+-- patterns that are marked as irrefutable, and anything in a+-- 'FakeDecl' or 'FakeExp'). Note that only the outermost patterns are+-- made strict.++class MakeStrict a where+  makeStrict :: a -> a++instance MakeStrict a => MakeStrict [a] where+  makeStrict = map makeStrict++instance MakeStrict a => MakeStrict (Maybe a) where+  makeStrict = fmap makeStrict++instance MakeStrict Module where+  makeStrict (Module m pragmas imps decls) =+    Module m pragmas imps (makeStrict decls)++instance MakeStrict Decl where+  makeStrict = \case+    d@TypeDecl{}      -> d+    d@DataDecl{}      -> d+    d@TypeSig{}       -> d+    FunBind ms        -> FunBind (makeStrict ms)+    LocalBind s f rhs -> LocalBind Strict f (makeStrict rhs)+    d@PatSyn{}        -> d+    d@FakeDecl{}      -> d+    d@Comment{}       -> d++instance MakeStrict Match where+  makeStrict (Match f ps rhs wh) =+    Match f (makeStrict ps) (makeStrict rhs) (makeStrict wh)++instance MakeStrict Pat where+  makeStrict = \case+    p@PVar{}       -> PBangPat p+    p@PLit{}       -> PBangPat p+    PAsPat x p     -> PAsPat x (makeStrict p)+    p@PWildCard{}  -> PBangPat p+    p@PBangPat{}   -> p+    p@PApp{}       -> PBangPat p+    PatTypeSig p t -> PatTypeSig (makeStrict p) t+    p@PIrrPat{}    -> p++instance MakeStrict Binds where+  makeStrict (BDecls ds) = BDecls (makeStrict ds)++instance MakeStrict Rhs where+  makeStrict (UnGuardedRhs e) = UnGuardedRhs (makeStrict e)+  makeStrict (GuardedRhss rs) = GuardedRhss (makeStrict rs)++instance MakeStrict GuardedRhs where+  makeStrict (GuardedRhs ss e) =+    GuardedRhs (makeStrict ss) (makeStrict e)++instance MakeStrict Stmt where+  makeStrict = \case+    Qualifier e   -> Qualifier (makeStrict e)+    Generator p e -> Generator (makeStrict p) (makeStrict e)++instance MakeStrict Exp where+  makeStrict e =+    case e of+      Var{}           -> e+      Con{}           -> e+      Lit{}           -> e+      InfixApp a op b -> InfixApp (makeStrict a) op (makeStrict b)+      Ann e ty        -> Ann (makeStrict e) ty+      App a b         -> App (makeStrict a) (makeStrict b)+      Lambda ps e     -> Lambda (makeStrict ps) (makeStrict e)+      Let bs e        -> Let (makeStrict bs) (makeStrict e)+      If a b c        -> If (makeStrict a) (makeStrict b) (makeStrict c)+      Case e bs       -> Case (makeStrict e) (makeStrict bs)+      ExpTypeSig e t  -> ExpTypeSig (makeStrict e) t+      NegApp e        -> NegApp (makeStrict e)+      FakeExp s       -> FakeExp s++instance MakeStrict Alt where+  makeStrict (Alt pat rhs wh) =+    Alt (makeStrict pat) (makeStrict rhs) (makeStrict wh)
src/full/Agda/Compiler/ToTreeless.hs view
@@ -1,149 +1,236 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.ToTreeless   ( toTreeless+  , toTreelessWith   , closedTermToTreeless+  , Pipeline(..)+  , CompilerPass(..)+  , compilerPass+  , compilerPipeline+  , CCConfig+  , CCSubst(..)   ) where -import Control.Applicative-import Control.Monad.Reader-import Control.Monad.State+import Prelude hiding ((!!))++import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )+ import Data.Maybe import Data.Map (Map)-import qualified Data.Map as Map-import Data.Traversable (traverse)+import qualified Data.Map  as Map+import qualified Data.List as List  import Agda.Syntax.Common-import Agda.Syntax.Internal (QName)-import qualified Agda.Syntax.Treeless as C-import qualified Agda.Syntax.Internal as I+import Agda.Syntax.Internal as I import Agda.Syntax.Literal-import qualified Agda.TypeChecking.CompiledClause as CC-import Agda.TypeChecking.Records (getRecordConstructor)+import qualified Agda.Syntax.Treeless as C+import Agda.Syntax.Treeless (TTerm, EvaluationStrategy, ArgUsage(..))++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-import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Records (getRecordConstructor)+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute +import Agda.Compiler.Treeless.AsPatterns import Agda.Compiler.Treeless.Builtin-import Agda.Compiler.Treeless.Simplify import Agda.Compiler.Treeless.Erase+import Agda.Compiler.Treeless.Identity+import Agda.Compiler.Treeless.Simplify import Agda.Compiler.Treeless.Uncase-import Agda.Compiler.Treeless.Pretty import Agda.Compiler.Treeless.Unused-import Agda.Compiler.Treeless.AsPatterns-import Agda.Compiler.Treeless.Identity -import Agda.Syntax.Common-import Agda.TypeChecking.Monad as TCM-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-+import Agda.Utils.Function import Agda.Utils.Functor-import qualified Agda.Utils.HashMap as HMap+import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Lens-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 -#include "undefined.h" import Agda.Utils.Impossible  prettyPure :: P.Pretty a => a -> TCM Doc prettyPure = return . P.pretty +-- | Recompile clauses with forcing translation turned on.+getCompiledClauses :: QName -> TCM CC.CompiledClauses+getCompiledClauses q = do+  def <- getConstInfo q+  let cs = defClauses def+      isProj | Function{ funProjection = Right x } <- theDef def = isJust (projProper x)+             | otherwise = False+      translate | isProj    = CC.DontRunRecordPatternTranslation+                | otherwise = CC.RunRecordPatternTranslation+  reportSDoc "treeless.convert" 40 $ "-- before clause compiler" $$ (pretty q <+> "=") <?> vcat (map pretty cs)+  let mst = funSplitTree $ theDef def+  reportSDoc "treeless.convert" 70 $+    caseMaybe mst "-- not using split tree" $ \st ->+      "-- using split tree" $$ pretty st+  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.-toTreeless :: QName -> TCM (Maybe C.TTerm)-toTreeless q = ifM (alwaysInline q) (pure Nothing) $ Just <$> toTreeless' q+toTreelessWith :: BuildPipeline -> CCConfig -> QName -> TCM (Maybe C.TTerm)+toTreelessWith pl cfg q+  = ifM (alwaysInline q) (pure Nothing)+  $ Just <$> toTreelessWith' pl cfg q -toTreeless' :: QName -> TCM C.TTerm-toTreeless' q =-  flip fromMaybeM (getTreeless q) $ verboseBracket "treeless.convert" 20 ("compiling " ++ show q) $ do-    Just cc <- defCompiled <$> getConstInfo q+toTreeless :: EvaluationStrategy -> QName -> TCM (Maybe C.TTerm)+toTreeless eval = toTreelessWith compilerPipeline (eval, EraseUnused)++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 q cc+    ccToTreelessWith pl cfg q cc --- | Does not require the name to refer to a function.-cacheTreeless :: QName -> TCM ()-cacheTreeless q = do-  def <- theDef <$> getConstInfo q-  case def of-    Function{} -> () <$ toTreeless' q-    _          -> return ()+toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm+toTreeless' eval = toTreelessWith' compilerPipeline (eval, EraseUnused) -ccToTreeless :: QName -> CC.CompiledClauses -> TCM C.TTerm-ccToTreeless 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 (show q ++ suf) <+> text "=", nest 2 $ prettyPure 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) $ text "-- compiled clauses of" <+> prettyTCM q $$ nest 2 (prettyPure cc)-  body <- casetreeTop cc-  reportSDoc "treeless.opt.converted" (30 + v) $ text "-- converted" $$ pbody body-  body <- simplifyTTerm body-  reportSDoc "treeless.opt.simpl" (35 + v) $ text "-- after first simplification"  $$ pbody body-  body <- translateBuiltins body-  reportSDoc "treeless.opt.builtin" (30 + v) $ text "-- after builtin translation" $$ pbody body-  body <- simplifyTTerm body-  reportSDoc "treeless.opt.simpl" (30 + v) $ text "-- after second simplification"  $$ pbody body-  body <- eraseTerms q body-  reportSDoc "treeless.opt.erase" (30 + v) $ text "-- after erasure"  $$ pbody body-  body <- caseToSeq body-  reportSDoc "treeless.opt.uncase" (30 + v) $ text "-- after uncase"  $$ pbody body-  body <- recoverAsPatterns body-  reportSDoc "treeless.opt.aspat" (30 + v) $ text "-- after @-pattern recovery"  $$ pbody body-  body <- detectIdentityFunctions q body-  reportSDoc "treeless.opt.id" (30 + v) $ text "-- after identity function detection"  $$ pbody body-  body <- simplifyTTerm body-  reportSDoc "treeless.opt.simpl" (30 + v) $ text "-- after third simplification"  $$ pbody body-  body <- eraseTerms q body-  reportSDoc "treeless.opt.erase" (30 + v) $ text "-- after second erasure"  $$ pbody body+  reportSDoc "treeless.convert" (30 + v) $ "-- compiled clauses of" <+> prettyTCM q $$ nest 2 (prettyPure cc)+  body <- casetreeTop cfg cc+  reportSDoc "treeless.opt.converted" (30 + v) $ "-- converted" $$ pbody body+  body <- runPipeline eval q (pl v q) body   used <- usedArguments q body-  when (any not used) $+  when (su == EraseUnused && ArgUnused `elem` used) $     reportSDoc "treeless.opt.unused" (30 + v) $-      text "-- used args:" <+> hsep [ if u then text [x] else text "_" | (x, u) <- zip ['a'..] used ] $$+      "-- used args:" <+> hsep [ if u == ArgUsed then text [x] else "_" | (x, u) <- zip ['a'..] used ] $$       pbody' "[stripped]" (stripUnusedArguments used body)   reportSDoc "treeless.opt.final" (20 + v) $ pbody body   setTreeless q body   setCompiledArgUse q used   return body -closedTermToTreeless :: I.Term -> TCM C.TTerm-closedTermToTreeless t = do-  substTerm t `runReaderT` initCCEnv+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 :: BuildPipeline+compilerPipeline v q =+  Sequential+    -- Issue #4967: No simplification step before builtin translation! Simplification relies+    --              on either all or no builtins being translated. Since we might have inlined+    --              functions that have had the builtin translation applied, we need to apply it+    --              first.+    -- [ compilerPass "simpl"   (35 + v) "simplification"      $ const simplifyTTerm+    [ compilerPass "builtin" (30 + v) "builtin translation" $ const translateBuiltins+    , FixedPoint 5 $ Sequential+      [ compilerPass "simpl"  (30 + v) "simplification"     $ const simplifyTTerm+      , compilerPass "erase"  (30 + v) "erasure"            $ eraseTerms q+      , compilerPass "uncase" (30 + v) "uncase"             $ const caseToSeq+      , compilerPass "aspat"  (30 + v) "@-pattern recovery" $ const recoverAsPatterns+      ]+    , compilerPass "id" (30 + v) "identity function detection" $ const (detectIdentityFunctions q)+    ]++runPipeline :: EvaluationStrategy -> QName -> Pipeline -> TTerm -> TCM TTerm+runPipeline eval q pipeline t = case pipeline of+  SinglePass p   -> runCompilerPass eval q p t+  Sequential ps  -> foldM (flip $ runPipeline eval q) t ps+  FixedPoint n p -> runFixedPoint n eval q p t++runCompilerPass :: EvaluationStrategy -> QName -> CompilerPass -> TTerm -> TCM TTerm+runCompilerPass eval q p t = do+  t' <- passCode p eval t+  let dbg f   = reportSDoc ("treeless.opt." ++ passTag p) (passVerbosity p) $ f $ text ("-- " ++ passName p)+      pbody b = sep [ text (prettyShow q) <+> "=", nest 2 $ prettyPure b ]+  dbg $ if | t == t'   -> (<+> "(No effect)")+           | otherwise -> ($$ pbody t')+  return t'++runFixedPoint :: Int -> EvaluationStrategy -> QName -> Pipeline -> TTerm -> TCM TTerm+runFixedPoint n eval q pipeline = go 1+  where+    go i t | i > n = do+      reportSLn "treeless.opt.loop" 20 $ "++ Optimisation loop reached maximum iterations (" ++ show n ++ ")"+      return t+    go i t = do+      reportSLn "treeless.opt.loop" 30 $ "++ Optimisation loop iteration " ++ show i+      t' <- runPipeline eval q pipeline t+      if | t == t'   -> do+            reportSLn "treeless.opt.loop" 30 $ "++ Optimisation loop terminating after " ++ show i ++ " iterations"+            return t'+         | otherwise -> go (i + 1) t'++closedTermToTreeless :: CCConfig -> I.Term -> TCM C.TTerm+closedTermToTreeless cfg t = do+  substTerm t `runReaderT` initCCEnv cfg+ alwaysInline :: QName -> TCM Bool alwaysInline q = do   def <- theDef <$> getConstInfo q   pure $ case def of  -- always inline with functions and pattern lambdas-    Function{} -> isJust (funExtLam def) || isJust (funWith def)+    Function{funClauses = cs} -> (isJust (funExtLam def) && not recursive) || isJust (funWith def)+            where+              recursive = any (fromMaybe True . clauseRecursive) cs     _ -> False --- | Initial environment for expression generation.-initCCEnv :: CCEnv-initCCEnv = CCEnv-  { ccCxt        = []-  , ccCatchAll   = Nothing-  }---- | 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.-  }--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.@@ -158,8 +245,8 @@ lookupLevel l xs = fromMaybe __IMPOSSIBLE__ $ xs !!! (length xs - 1 - l)  -- | Compile a case tree into nested case and record expressions.-casetreeTop :: CC.CompiledClauses -> TCM C.TTerm-casetreeTop cc = flip runReaderT initCCEnv $ 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@@ -167,44 +254,66 @@ casetree :: CC.CompiledClauses -> CC C.TTerm casetree cc = do   case cc of-    CC.Fail -> return C.tUnreachable-    CC.Done xs v -> lambdasUpTo (length xs) $ do-        v <- lift $ putAllowedReductions [ProjectionReductions, CopatternReductions] $ normalise v-        substTerm 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-      --     text "Not yet implemented: compilation of copattern matching with catch-all clause"-    CC.Case (Arg _ n) (CC.Branches True conBrs _ Nothing) -> lambdasUpTo n $ do+    CC.Fail xs -> withContextSize (length xs) $ return C.tUnreachable+    CC.Done xs v -> withContextSize (length xs) $ do+      -- Issue 2469: Body context size (`length xs`) may be smaller than current context size+      -- if some arguments are not used in the body.+      v <- lift (putAllowedReductions (SmallSet.fromList [ProjectionReductions, CopatternReductions]) $ normalise v)+      cxt <- asks ccCxt+      v' <- substTerm v+      reportS "treeless.convert.casetree" 40 $+        [ "-- casetree, calling substTerm:"+        , "--   cxt =" <+> prettyPure cxt+        , "--   v   =" <+> prettyPure v+        , "--   v'  =" <+> prettyPure v'+        ]+      return v'+    CC.Case _ (CC.Branches True _ _ _ Just{} _ _) -> __IMPOSSIBLE__+    CC.Case (Arg _ n) (CC.Branches True conBrs _ _ Nothing _ _) -> lambdasUpTo n $ do       mkRecord =<< traverse casetree (CC.content <$> conBrs)-    CC.Case (Arg _ n) (CC.Branches False conBrs litBrs catchAll) -> lambdasUpTo (n + 1) $ do-      if Map.null conBrs && Map.null litBrs then 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-        fromCatchAll+        updateCatchall catchall fromCatchall       else do-        caseTy <- case (Map.keys conBrs, Map.keys litBrs) of-              ((c:_), []) -> do-                c' <- lift (canonicalName c)-                dtNm <- conData . theDef <$> lift (getConstInfo c')-                return $ C.CTData dtNm-              ([], (LitChar _ _):_)  -> return C.CTChar-              ([], (LitString _ _):_) -> return C.CTString-              ([], (LitFloat _ _):_) -> return C.CTFloat-              ([], (LitQName _ _):_) -> return C.CTQName-              _ -> __IMPOSSIBLE__-        updateCatchAll catchAll $ do-          x <- lookupLevel n <$> asks ccCxt-          def <- fromCatchAll-          C.TCase x caseTy def <$> do-            br1 <- conAlts n conBrs+        -- Get the type of the scrutinee.+        caseTy <-+          case (Map.keys conBrs', Map.keys litBrs) of+            (cs, []) -> lift $ go cs+              where+              go (c:cs) = canonicalName c >>= getConstInfo <&> theDef >>= \case+                Constructor{conData} ->+                  return $ C.CTData conData+                _ -> go cs+              go [] = __IMPOSSIBLE__+            ([], LitChar   _ : _) -> return C.CTChar+            ([], LitString _ : _) -> return C.CTString+            ([], LitFloat  _ : _) -> return C.CTFloat+            ([], LitQName  _ : _) -> return C.CTQName+            _ -> __IMPOSSIBLE__++        updateCatchall catchall $ do+          x <- asks (lookupLevel n . ccCxt)+          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             return (br1 ++ br2)   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 = maybe C.tUnreachable C.TVar <$> asks ccCatchAll+    fromCatchall :: CC C.TTerm+    fromCatchall = asks (maybe C.tUnreachable C.TVar . ccCatchall)  commonArity :: CC.CompiledClauses -> Int commonArity cc =@@ -212,50 +321,142 @@     [] -> 0     as -> minimum as   where-    arities cxt (Case (Arg _ x) (Branches False cons lits def)) =+    arities cxt (Case (Arg _ x) (Branches False cons eta lits def _ _)) =       concatMap (wArities cxt') (Map.elems cons) +++      concatMap ((wArities cxt') . snd) (maybeToList eta) ++       concatMap (wArities cxt' . WithArity 0) (Map.elems lits) ++       concat [ arities cxt' c | Just c <- [def] ] -- ??       where cxt' = max (x + 1) cxt-    arities cxt (Case _ (Branches True _ _ _)) = [cxt]+    arities cxt (Case _ Branches{projPatterns = True}) = [cxt]     arities cxt (Done xs _) = [max cxt (length xs)]-    arities _   Fail        = []+    arities cxt (Fail xs)   = [max cxt (length xs)]       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-  local (\e -> e { ccCatchAll = Just 0, ccCxt = shift 1 (ccCxt e) }) $ do+  cxt <- asks ccCxt+  reportS "treeless.convert.lambdas" 40 $+    [ "-- updateCatchall:"+    , "--   cxt =" <+> prettyPure cxt+    , "--   def =" <+> prettyPure def+    ]+  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+-- MUST NOT be used inside `cont`.+withContextSize :: Int -> CC C.TTerm -> CC C.TTerm+withContextSize n cont = do+  diff <- asks (((n -) . length) . ccCxt)+  if diff >= 1 then createLambdas diff cont else do+    let diff' = -diff+    cxt <- -- shift diff .+       -- Andreas, 2021-04-10, issue #5288+       -- The @shift diff@ is wrong, since we are returning to the original+       -- context from @cont@, and then we would have to reverse+       -- the effect of @shift diff@.+       -- We need to make sure that the result of @cont@ make sense+       -- in the **present** context, not the changed context+       -- where it is constructed.+       --+       -- Ulf, 2021-04-12, https://github.com/agda/agda/pull/5311/files#r611452551+       --+       -- This looks correct, but I can't quite follow the explanation. Here's my understanding:+       --+       -- We are building a `TTerm` case tree from `CompiledClauses`. In order+       -- to be able to match we bind all variables we'll need in a top-level+       -- lambda `λ a b c d → ..` (say). As we compute the `TTerm` we keep a+       -- context (list) of `TTerm` deBruijn indices for each `CompiledClause`+       -- variable. This is a renaming from the *source* context of the+       -- `CompiledClause` to the *target* context of the `TTerm`.+       --+       -- After some pattern matching we might have+       -- ```+       -- λ a b c d →+       --   case c of+       --     e :: f → {cxt = [d, f, e, b, a]}+       -- ```+       -- Now, what's causing the problems here is that `CompiledClauses` can be+       -- underapplied, so you might have matched on a variable only to find+       -- that in the catch-all the variable you matched on is bound in a lambda+       -- in the right-hand side! Extending the example, we might have+       -- `CompiledClauses` looking like this:+       -- ```+       -- case 2 of+       --   _::_ → done[d, f, e, b, a] ...+       --   _    → done[b, a] (λ c d → ...)+       -- ```+       -- When we get to the catch-all, the context will be `[d, c, b, a]` but+       -- the right-hand side is only expecting `a` and `b` to be bound. What we+       -- need to do is compile the right-hand side and then apply it to the+       -- variables `c` and `d` that we already bound. This is what+       -- `withContextSize` does.+       --+       -- Crucially (and this is where the bug was), we are not changing the+       -- target context, only the source context (we want a `TTerm` that makes+       -- sense at this point). This means that the correct move is to drop the+       -- entries for the additional source variables, but not change what+       -- target variables the remaining source variables map to. Hence, `drop`+       -- but no `shift`.+       --+       drop diff' <$> asks ccCxt+    local (\ e -> e { ccCxt = cxt }) $ do+      reportS "treeless.convert.lambdas" 40 $+        [ "-- withContextSize:"+        , "--   n   =" <+> prettyPure n+        , "--   diff=" <+> prettyPure diff+        , "--   cxt =" <+> prettyPure cxt+        ]+      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).+createLambdas :: Int -> CC C.TTerm -> CC C.TTerm+createLambdas diff cont = do+  unless (diff >= 1) __IMPOSSIBLE__+  cxt <- ([0 .. diff-1] ++) . shift diff <$> asks ccCxt+  local (\ e -> e { ccCxt = cxt }) $ do+    reportS "treeless.convert.lambdas" 40 $+      [ "-- createLambdas:"+      , "--   diff =" <+> prettyPure diff+      , "--   cxt  =" <+> prettyPure cxt+      ]+    -- Prepend diff lambdas+    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. lambdasUpTo :: Int -> CC C.TTerm -> CC C.TTerm lambdasUpTo n cont = do-  diff <- (n -) . length <$> asks ccCxt+  diff <- asks (((n -) . length) . ccCxt)    if diff <= 0 then cont -- no new lambdas needed   else do-    catchAll <- asks ccCatchAll--    local (\e -> e { ccCxt = [0..(diff - 1)] ++ shift diff (ccCxt e)}) $ do-      createLambdas diff <$> do-        case catchAll of-          Just catchAll' -> do-            -- 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-                           , ccCxt = shift 1 (ccCxt e)}) $ do-              let catchAllArgs = map C.TVar $ reverse [0..(diff - 1)]-              C.mkLet (C.mkTApp (C.TVar $ catchAll' + diff) catchAllArgs)-                <$> cont-          Nothing -> cont-  where createLambdas :: Int -> C.TTerm -> C.TTerm-        createLambdas 0 cont' = cont'-        createLambdas i cont' | i > 0 = C.TLam (createLambdas (i - 1) cont')-        createLambdas _ _ = __IMPOSSIBLE__+    createLambdas diff $ 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+            , "  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+                         , ccCxt = shift 1 cxt }) $ do+            let catchallArgs = map C.TVar $ downFrom diff+            C.mkLet (C.mkTApp (C.TVar $ catchall + diff) catchallArgs)+              <$> cont+        Nothing -> cont  conAlts :: Int -> Map QName (CC.WithArity CC.CompiledClauses) -> CC [C.TAlt] conAlts x br = forM (Map.toList br) $ \ (c, CC.WithArity n cc) -> do@@ -270,8 +471,7 @@     branch (C.TALit l ) cc  branch :: (C.TTerm -> C.TAlt) -> CC.CompiledClauses -> CC C.TAlt-branch alt cc = do-  alt <$> casetree cc+branch alt cc = alt <$> casetree cc  -- | Replace de Bruijn Level @x@ by @n@ new variables. replaceVar :: Int -> Int -> CC a -> CC a@@ -284,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  @@ -292,17 +492,22 @@ mkRecord :: Map QName C.TTerm -> CC C.TTerm mkRecord fs = lift $ do   -- Get the name of the first field-  let p1 = fst $ fromMaybe __IMPOSSIBLE__ $ headMaybe $ Map.toList fs+  let p1 = fst $ headWithDefault __IMPOSSIBLE__ $ Map.toList fs   -- Use the field name to get the record constructor and the field names.-  I.ConHead c _ind xs <- conSrcCon . theDef <$> (getConstInfo =<< canonicalName . I.conName =<< recConFromProj p1)+  I.ConHead c IsRecord{} _ind xs <- conSrcCon . theDef <$> (getConstInfo =<< canonicalName . I.conName =<< recConFromProj p1)+  reportSDoc "treeless.convert.mkRecord" 60 $ vcat+    [ text "record constructor fields: xs      = " <+> (text . show) xs+    , text "to be filled with content: keys fs = " <+> (text . show) (Map.keys fs)+    ]   -- Convert the constructor-  let (args :: [C.TTerm]) = for xs $ \ x -> fromMaybe __IMPOSSIBLE__ $ Map.lookup x fs+  let (args :: [C.TTerm]) = for xs $ \ x -> Map.findWithDefault __IMPOSSIBLE__ (unArg x) fs   return $ C.mkTApp (C.TCon c) args   recConFromProj :: QName -> TCM I.ConHead recConFromProj q = do   caseMaybeM (isProjection q) __IMPOSSIBLE__ $ \ proj -> do+    -- Get the record type name @d@ from the projection.     let d = unArg $ projFromType proj     getRecordConstructor d @@ -314,64 +519,120 @@ --   indices in the environment as well. substTerm :: I.Term -> CC C.TTerm substTerm term = normaliseStatic term >>= \ term ->-  case I.ignoreSharing $ I.unSpine term of+  case I.unSpine $ etaContractErased term of     I.Var ind es -> do-      ind' <- lookupIndex ind <$> asks ccCxt+      ind' <- asks (lookupIndex ind . ccCxt)       let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es       C.mkTApp (C.TVar ind') <$> substArgs args     I.Lam _ ab ->       C.TLam <$>-        local (\e -> e { ccCxt = 0 : (shift 1 $ ccCxt e) })+        local (\e -> e { ccCxt = 0 : shift 1 (ccCxt e) })           (substTerm $ I.unAbs ab)     I.Lit l -> return $ C.TLit l     I.Level _ -> return C.TUnit     I.Def q es -> do       let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es       maybeInlineDef q args-    I.Con c ci args -> do+    I.Con c ci es -> do+        let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es         c' <- lift $ canonicalName $ I.conName c         C.mkTApp (C.TCon c') <$> substArgs args-    I.Shared _ -> __IMPOSSIBLE__ -- the ignoreSharing fun should already take care of this     I.Pi _ _ -> return C.TUnit     I.Sort _  -> return C.TSort-    I.MetaV _ _ -> __IMPOSSIBLE__   -- we don't compiled if unsolved metas+    I.MetaV x _ -> return $ C.TError $ C.TMeta $ prettyShow x     I.DontCare _ -> return C.TErased+    I.Dummy{} -> __IMPOSSIBLE__ +-- Andreas, 2019-07-10, issue #3792+-- | Eta-contract erased lambdas.+--+-- Should also be fine for strict backends:+--+--   * eta-contraction is semantics-preserving for total, effect-free languages.+--   * should a user rely on thunking, better not used an erased abstraction!+--+-- A live-or-death issue for the GHC 8.0 backend.  Consider:+-- @+--   foldl : ∀ {A} (B : Nat → Set)+--         → (f : ∀ {@0 n} → B n → A → B (suc n))+--         → (z : B 0)+--         → ∀ {@0 n} → Vec A n → B n+--   foldl B f z (x ∷ xs) = foldl (λ n → B (suc n)) (λ{@0 x} → f {suc x}) (f z x) xs+--   foldl B f z [] = z+-- @+-- The hidden composition of @f@ with @suc@, term @(λ{@0 x} → f {suc x})@,+-- can be eta-contracted to just @f@ by the compiler, since the first argument+-- of @f@ is erased.+--+-- GHC >= 8.2 seems to be able to do the optimization himself, but not 8.0.+--+etaContractErased :: I.Term -> I.Term+etaContractErased = trampoline etaErasedOnce+  where+  etaErasedOnce :: I.Term -> Either I.Term I.Term  -- Left = done, Right = jump again+  etaErasedOnce t =+    case t of++      -- If the abstraction is void, we don't have to strengthen.+      I.Lam _ (NoAbs _ v) ->+        case binAppView v of+          -- If the body is an application ending with an erased argument, eta-reduce!+          App u arg | not (usableModality arg) -> Right u+          _ -> done++      -- If the abstraction is non-void, only eta-contract if erased.+      I.Lam ai (Abs _ v) | not (usableModality ai) ->+        case binAppView v of+          -- If the body is an application ending with an erased argument, eta-reduce!+          -- We need to strengthen the function part then.+          App u arg | not (usableModality arg) -> Right $ subst 0 (DontCare __DUMMY_TERM__) u+          _ -> done++      _ -> done+    where+    done = Left t+ normaliseStatic :: I.Term -> CC I.Term normaliseStatic v@(I.Def f es) = lift $ do   static <- isStaticFun . theDef <$> getConstInfo f   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 =-  ifM (lift $ alwaysInline q) doinline $ do-    lift $ cacheTreeless q+maybeInlineDef q vs = do+  eval <- asks ccEvaluation+  ifM (lift $ alwaysInline q) (doinline eval) $ do+    lift $ cacheTreeless eval q     def <- lift $ getConstInfo q     case theDef def of       fun@Function{}-        | fun ^. funInline -> doinline+        | fun ^. funInline -> doinline eval         | otherwise -> do-        used <- lift $ getCompiledArgUse q-        let substUsed False _   = pure C.TErased-            substUsed True  arg = substArg arg-        C.mkTApp (C.TDef q) <$> sequence [ substUsed u arg | (arg, u) <- zip vs $ used ++ repeat True ]+        -- If ArgUsage hasn't been computed yet, we assume all arguments are used.+        used <- lift $ fromMaybe [] <$> getCompiledArgUse q+        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-    doinline = C.mkTApp <$> inline q <*> substArgs vs-    inline q = lift $ toTreeless' q+    doinline eval = C.mkTApp <$> inline eval q <*> substArgs vs+    inline eval q = lift $ toTreeless' eval q  substArgs :: [Arg I.Term] -> CC [C.TTerm] substArgs = traverse substArg  substArg :: Arg I.Term -> CC C.TTerm-substArg x | erasable x = return C.TErased-           | otherwise  = substTerm (unArg x)-  where-    erasable x =-      case getRelevance x of-        Irrelevant -> True-        NonStrict  -> True-        UnusedArg  -> True-        Forced{}   -> False -- TODO: would like this to be True-        Relevant   -> False+substArg x | usableModality x = substTerm (unArg x)+           | otherwise = return C.TErased
src/full/Agda/Compiler/Treeless/AsPatterns.hs view
@@ -1,19 +1,11 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.AsPatterns (recoverAsPatterns) where -import Control.Applicative import Control.Monad.Reader-import Data.Monoid  import Agda.Syntax.Treeless-import Agda.Syntax.Literal-import Agda.TypeChecking.Substitute-import Agda.Compiler.Treeless.Subst-import Agda.Compiler.Treeless.Compare -import Agda.Utils.Impossible-#include "undefined.h"- data AsPat = AsPat Int QName [Int]  -- x@(c ys)   deriving (Show) @@ -61,6 +53,7 @@     TCon{} -> tApp t []   -- need to recover nullary constructors as well (to make deep @-patterns work)     TLet v b -> TLet <$> recover v <*> underBinds 1 (recover b)     TCase x ct d bs -> TCase x ct <$> recover d <*> mapM (recoverAlt x) bs+    TCoerce t -> TCoerce <$> recover t     TLit{}    -> pure t     TVar{}    -> pure t     TPrim{}   -> pure t
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:@@ -14,28 +16,18 @@ -- optimisations that analyse case tree, like impossible case elimination. -- -- Ulf, 2015-10-30: Guards are actually a better primitive. Fixed that.-{-# LANGUAGE CPP #-} module Agda.Compiler.Treeless.Builtin (translateBuiltins) where -import Control.Applicative- import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Abstract.Name (QName)-import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal  import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin -import Agda.Compiler.Treeless.Subst--import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Maybe+import Agda.Compiler.Treeless.Subst () --instance only import Agda.Utils.Impossible -#include "undefined.h"  data BuiltinKit = BuiltinKit   { isZero   :: QName -> Bool@@ -47,6 +39,8 @@   , isLess   :: QName -> Bool   , isEqual  :: QName -> Bool   , isForce  :: QName -> Bool+  , isWord64FromNat :: QName -> Bool+  , isWord64ToNat   :: QName -> Bool   }  builtinKit :: TCM BuiltinKit@@ -59,7 +53,9 @@              <*> isB def builtinNatTimes              <*> isB def builtinNatLess              <*> isB def builtinNatEquals-             <*> isP pf  "primForce"+             <*> isP pf  PrimForce+             <*> isP pf  PrimWord64FromNat+             <*> isP pf  PrimWord64ToNat   where     con (I.Con c _ _) = pure $ I.conName c     con _           = Nothing@@ -80,7 +76,7 @@ transform :: BuiltinKit -> TTerm -> TTerm transform BuiltinKit{..} = tr   where-    tr t = case t of+    tr = \case        TCon c | isZero c   -> tInt 0              | isSuc c    -> TLam (tPlusK 1 (TVar 0))@@ -91,16 +87,24 @@              | isTimes f  -> TPrim PMul              | isLess f   -> TPrim PLt              | isEqual f  -> TPrim PEqI+             | isWord64ToNat f   -> TPrim P64ToI+             | isWord64FromNat f -> TPrim PITo64         -- Note: Don't do this for builtinNatMinus! PSub is integer minus and         --       builtin minus is monus. The simplifier will do it if it can see         --       that it won't underflow. -      TApp (TDef q) [_, _, _, _, e, f]-        | isForce q -> tr $ TLet e $ tOp PSeq (TVar 0) $ mkTApp (raise 1 f) [TVar 0]+      -- 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]) $ raise 1 es        TApp (TCon s) [e] | isSuc s ->         case tr e of-          TLit (LitNat r n) -> tInt (n + 1)+          TLit (LitNat n) -> tInt (n + 1)           e | Just (i, e) <- plusKView e -> tPlusK (i + 1) e           e                 -> tPlusK 1 e @@ -108,21 +112,21 @@         | isPos c    -> tr e         | isNegSuc c ->         case tr e of-          TLit (LitNat _ n) -> tInt (-n - 1)+          TLit (LitNat n) -> tInt (-n - 1)           e | Just (i, e) <- plusKView e -> tNegPlusK (i + 1) e           e -> tNegPlusK 1 e -      TCase e t d bs -> TCase e (caseType t bs) (tr d) $ concatMap trAlt bs+      TCase e t d bs -> TCase e (inferCaseType t bs) (tr d) $ concatMap trAlt bs         where-          trAlt b = case b of-            TACon c 0 b | isZero c -> [TALit (LitNat noRange 0) (tr b)]+          trAlt = \case+            TACon c 0 b | isZero c -> [TALit (LitNat 0) (tr b)]             TACon c 1 b | isSuc c  ->               case tr b of                 -- Collapse nested n+k patterns                 TCase 0 _ d bs' -> map sucBranch bs' ++ [nPlusKAlt 1 d]                 b -> [nPlusKAlt 1 b]               where-                sucBranch (TALit (LitNat r i) b) = TALit (LitNat r (i + 1)) $ TLet (tInt i) b+                sucBranch (TALit (LitNat i) b) = TALit (LitNat (i + 1)) $ TLet (tInt i) b                 sucBranch alt | Just (k, b) <- nPlusKView alt =                   nPlusKAlt (k + 1) $ TLet (tOp PAdd (TVar 0) (tInt 1)) $                     applySubst ([TVar 1, TVar 0] ++# wkS 2 idS) b@@ -130,9 +134,6 @@                  nPlusKAlt k b = TAGuard (tOp PGeq (TVar e) (tInt k)) $                                 TLet (tOp PSub (TVar e) (tInt k)) b--                str err = compactS err [Nothing]-             TACon c 1 b | isPos c ->               case tr b of                 -- collapse nested nat patterns@@ -140,7 +141,7 @@                 b -> [posAlt  b]               where                 -- subst scrutinee for the pos argument-                sub :: Subst TTerm a => a -> a+                sub :: SubstWith TTerm a => a -> a                 sub = applySubst (TVar e :# IdS)                  posAlt b = TAGuard (tOp PGeq (TVar e) (tInt 0)) $ sub b@@ -154,39 +155,40 @@                 body b   = TLet (tNegPlusK 1 (TVar e)) b                 negAlt b = TAGuard (tOp PLt (TVar e) (tInt 0)) $ body b -                negsucBranch (TALit (LitNat r i) b) = TALit (LitNat r (-i - 1)) $ body b+                negsucBranch (TALit (LitNat i) b) = TALit (LitNat (-i - 1)) $ body b                 negsucBranch alt | Just (k, b) <- nPlusKView alt =                   TAGuard (tOp PLt (TVar e) (tInt (-k))) $                   body $ TLet (tNegPlusK (k + 1) (TVar $ e + 1)) b                 negsucBranch _ = __IMPOSSIBLE__ -             TACon c a b -> [TACon c a (tr b)]             TALit l b   -> [TALit l (tr b)]             TAGuard g b -> [TAGuard (tr g) (tr b)] -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t +      TCoerce a -> TCoerce (tr a)+       TLam b                  -> TLam (tr b)       TApp a bs               -> TApp (tr a) (map tr bs)       TLet e b                -> TLet (tr e) (tr b) -    caseType t (TACon c _ _ : _)-      | isZero c   = CTNat-      | isSuc c    = CTNat-      | isPos c    = CTInt-      | isNegSuc c = CTInt-    caseType t _ = t+    inferCaseType t (TACon c _ _ : _)+      | isZero c   = t { caseType = CTNat }+      | isSuc c    = t { caseType = CTNat }+      | isPos c    = t { caseType = CTInt }+      | isNegSuc c = t { caseType = CTInt }+    inferCaseType t _ = t -    nPlusKView (TAGuard (TApp (TPrim PGeq) [TVar 0, (TLit (LitNat _ k))])-                        (TLet (TApp (TPrim PSub) [TVar 0, (TLit (LitNat _ j))]) b))+    nPlusKView (TAGuard (TApp (TPrim PGeq) [TVar 0, (TLit (LitNat k))])+                        (TLet (TApp (TPrim PSub) [TVar 0, (TLit (LitNat j))]) b))       | k == j = Just (k, b)     nPlusKView _ = Nothing
src/full/Agda/Compiler/Treeless/Compare.hs view
@@ -1,8 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Compare (equalTerms) where  import Agda.Syntax.Treeless import Agda.TypeChecking.Substitute-import Agda.Compiler.Treeless.Subst+import Agda.Compiler.Treeless.Subst () --instance only  equalTerms :: TTerm -> TTerm -> Bool equalTerms u v =@@ -52,4 +54,13 @@ applyPrim PEqQ _ _ = Nothing applyPrim PIf  _ _ = Nothing applyPrim PSeq _ _ = Nothing+applyPrim PAdd64 _ _ = Nothing+applyPrim PSub64 _ _ = Nothing+applyPrim PMul64 _ _ = Nothing+applyPrim PQuot64 _ _ = Nothing+applyPrim PRem64 _ _ = Nothing+applyPrim PLt64  _ _ = Nothing+applyPrim PEq64 _ _ = Nothing+applyPrim PITo64 _ _ = Nothing+applyPrim P64ToI _ _ = Nothing 
− src/full/Agda/Compiler/Treeless/DelayCoinduction.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE CPP #-}--- | Inserts an additional lambda into all coinductive auxiliary definitions (== target type Inf XX). E.g.:------   f : A -> B -> C -> Inf A---   f = \a b c -> body--- is converted to---   f = \a b c _ -> body------ Assumes that flat/sharp are implemented as follows:------ flat = \x -> x--- sharp = \x -> x ()--module Agda.Compiler.Treeless.DelayCoinduction where--import Control.Applicative--import Agda.Syntax.Internal (Type)-import Agda.Syntax.Abstract.Name (QName)-import Agda.Syntax.Treeless--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Reduce ( instantiateFull, normalise )-import Agda.TypeChecking.Substitute hiding (underLambdas)-import Agda.TypeChecking.Telescope--import Agda.Compiler.Treeless.Subst--import Agda.Utils.Impossible--#include "undefined.h"--delayCoinduction :: TTerm -> Type -> TCM TTerm-delayCoinduction t ty = do-  kit <- coinductionKit-  case kit of-    Just kit -> transform kit t ty-    Nothing -> return t---transform :: CoinductionKit -> TTerm -> Type -> TCM TTerm-transform kit t ty = do-  isInf <- outputIsInf (Just kit) ty-  if isInf then do-      ty <- normalise ty-      TelV tel _ <- telView ty-      -- insert additional lambda-      return $ underLambdas (length $ telToList tel) (TLam . raise 1) t-    else-      return t---outputIsInf :: Maybe CoinductionKit -> Type -> TCM Bool-outputIsInf kit ty = do-  ty <- normalise ty-  tn <- getOutputTypeName ty-  case tn of-    OutputTypeName tn -> return $ Just tn == (nameOfInf <$> kit)-    _ -> return False---underLambdas :: Int -> (TTerm -> TTerm) -> TTerm -> TTerm-underLambdas n cont v = loop n v where-  loop 0 v = cont v-  loop n v = case v of-    TLam b -> TLam $ loop (n-1) b-    _       -> __IMPOSSIBLE__
+ src/full/Agda/Compiler/Treeless/EliminateDefaults.hs view
@@ -0,0 +1,55 @@+{-# 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++import Control.Monad+import qualified Data.List as List++import Agda.Syntax.Treeless++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Substitute++import Agda.Compiler.Treeless.Subst () --instance only++eliminateCaseDefaults :: TTerm -> TCM TTerm+eliminateCaseDefaults = tr+  where+    tr :: TTerm -> TCM TTerm+    tr = \case+      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+        def <- tr def+        newAlts <- forM missingCons $ \con -> do+          Constructor {conArity = ar} <- theDef <$> getConstInfo con+          return $ TACon con ar (TVar ar)++        alts' <- (++ newAlts) <$> mapM (trAlt . raise 1) alts++        return $ TLet def $ TCase (sc + 1) ct tUnreachable alts'+      TCase sc ct def alts -> TCase sc ct <$> tr def <*> mapM trAlt alts++      t@TVar{}    -> return t+      t@TDef{}    -> return t+      t@TCon{}    -> return t+      t@TPrim{}   -> return t+      t@TLit{}    -> return t+      t@TUnit{}   -> return t+      t@TSort{}   -> return t+      t@TErased{} -> return t+      t@TError{}  -> return t++      TCoerce a               -> TCoerce <$> tr a+      TLam b                  -> TLam <$> tr b+      TApp a bs               -> TApp <$> tr a <*> mapM tr bs+      TLet e b                -> TLet <$> tr e <*> tr b++    trAlt :: TAlt -> TCM TAlt+    trAlt = \case+      TAGuard g b -> TAGuard <$> tr g <*> tr b+      TACon q a b -> TACon q a <$> tr b+      TALit l b   -> TALit l <$> tr b
src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs view
@@ -1,26 +1,18 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Converts case matches on literals to if cascades with equality comparisons. module Agda.Compiler.Treeless.EliminateLiteralPatterns where -import Control.Applicative-import Data.List import Data.Maybe -import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Treeless import Agda.Syntax.Literal-import qualified Agda.Syntax.Internal as I  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Substitute -import Agda.Compiler.Treeless.Subst- import Agda.Utils.Impossible -#include "undefined.h"  eliminateLiteralPatterns :: TTerm -> TCM TTerm eliminateLiteralPatterns t = do@@ -36,8 +28,8 @@ transform kit = tr   where     tr :: TTerm -> TTerm-    tr t = case t of-      TCase sc t def alts | t `elem` [CTChar, CTString, CTQName, CTNat, CTInt, CTFloat] ->+    tr = \case+      TCase sc t def alts | caseType t `elem` [CTChar, CTString, CTQName, CTNat, CTInt, CTFloat] ->         foldr litAlt (tr def) alts         where           litAlt :: TAlt -> TTerm -> TTerm@@ -47,33 +39,39 @@               (tr body)               cont           litAlt _ _ = __IMPOSSIBLE__-      TCase sc t@(CTData dt) def alts -> TCase sc t (tr def) (map trAlt alts)+      TCase sc t@CaseInfo{caseType = CTData dt} def alts ->+        TCase sc t (tr def) (map trAlt alts)         where-          trAlt a = a { aBody = tr (aBody a) }+          trAlt = \case+            TAGuard g b -> TAGuard (tr g) (tr b)+            TACon q a b -> TACon q a (tr b)+            TALit l b   -> TALit l (tr b)       TCase _ _ _ _ -> __IMPOSSIBLE__ -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t +      TCoerce a               -> TCoerce (tr a)       TLam b                  -> TLam (tr b)       TApp a bs               -> TApp (tr a) (map tr bs)       TLet e b                -> TLet (tr e) (tr b) -    isCaseOn (CTData dt) xs = dt `elem` catMaybes (map ($ kit) xs)+    -- TODO:: Defined but not used+    isCaseOn (CTData dt) xs = dt `elem` mapMaybe ($ kit) xs     isCaseOn _ _ = False      eqFromLit :: Literal -> TPrim-    eqFromLit x = case x of-      LitNat _ _     -> PEqI-      LitFloat _ _   -> PEqF-      LitString _ _  -> PEqS-      LitChar _ _    -> PEqC-      LitQName _ _   -> PEqQ-      _              -> __IMPOSSIBLE__+    eqFromLit = \case+      LitNat _     -> PEqI+      LitFloat _   -> PEqF+      LitString _  -> PEqS+      LitChar _    -> PEqC+      LitQName _   -> PEqQ+      _ -> __IMPOSSIBLE__
src/full/Agda/Compiler/Treeless/Erase.hs view
@@ -1,51 +1,60 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Compiler.Treeless.Erase (eraseTerms, computeErasedConstructorArgs) where+{-# LANGUAGE PatternSynonyms #-} -import Control.Arrow ((&&&), (***), first, second)-import Control.Applicative-import Control.Monad-import Control.Monad.State+module Agda.Compiler.Treeless.Erase+       ( eraseTerms+       , computeErasedConstructorArgs+       , isErasable+       ) where++import Control.Arrow       ( first, second )+import Control.Monad.State ( StateT, evalStateT )+ import Data.Map (Map) import qualified Data.Map as Map  import Agda.Syntax.Common import Agda.Syntax.Internal as I-import Agda.Syntax.Abstract.Name (QName)-import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal  import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad as I-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Reduce import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive  import Agda.Compiler.Treeless.Subst-import Agda.Compiler.Treeless.Pretty+import Agda.Compiler.Treeless.Unused -import Agda.Utils.Maybe-import Agda.Utils.Impossible-import Agda.Utils.Monad import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.Maybe import Agda.Utils.Memo-import qualified Agda.Utils.Pretty as P+import Agda.Utils.Monad+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.IntSet.Infinite (IntSet)+import qualified Agda.Utils.IntSet.Infinite as IntSet -#include "undefined.h"+import Agda.Utils.Impossible -data ESt = ESt { _funMap  :: Map QName FunInfo-               , _typeMap :: Map QName TypeInfo }+-- | State of the eraser.+data ESt = ESt+  { _funMap  :: Map QName FunInfo+      -- ^ Memoize computed `FunInfo` for functions/constructors/... `QName`.+  , _typeMap :: Map QName TypeInfo+      -- ^ 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. type E = StateT ESt TCM  runE :: E a -> TCM a@@ -54,11 +63,11 @@ -- | Takes the name of the data/record type. computeErasedConstructorArgs :: QName -> TCM () computeErasedConstructorArgs d = do-  cs <- getConstructors d+  cs <- getNotErasedConstructors d   runE $ mapM_ getFunInfo cs -eraseTerms :: QName -> TTerm -> TCM TTerm-eraseTerms q = runE . eraseTop q+eraseTerms :: QName -> EvaluationStrategy -> TTerm -> TCM TTerm+eraseTerms q eval t = usedArguments q t *> runE (eraseTop q t)   where     eraseTop q t = do       (_, h) <- getFunInfo q@@ -69,7 +78,7 @@      erase t = case tAppView t of -      TCon c : vs -> do+      (TCon c, vs) -> do         (rs, h) <- getFunInfo c         when (length rs < length vs) __IMPOSSIBLE__         case h of@@ -77,12 +86,12 @@           Empty    -> pure TErased           _        -> tApp (TCon c) <$> zipWithM eraseRel rs vs -      TDef f : vs -> do+      (TDef f, vs) -> do         (rs, h) <- getFunInfo f         case h of           Erasable -> pure TErased           Empty    -> pure TErased-          _        -> tApp (TDef f) <$> zipWithM eraseRel (rs ++ repeat Relevant) vs+          _        -> tApp (TDef f) <$> zipWithM eraseRel (rs ++ repeat NotErasable) vs        _ -> case t of         TVar{}         -> pure t@@ -100,62 +109,156 @@                    _             -> erase $ subst 0 TErased b             else tLet e <$> erase b         TCase x t d bs -> do-          d  <- ifM (isComplete t bs) (pure tUnreachable) (erase d)-          bs <- mapM eraseAlt bs+          (d, bs) <- pruneUnreachable x (caseErased t) (caseType t) d bs+          d       <- erase d+          bs      <- mapM eraseAlt bs           tCase x t d bs          TUnit          -> pure t         TSort          -> pure t         TErased        -> pure t         TError{}       -> pure t+        TCoerce e      -> TCoerce <$> erase e -    tLam TErased = TErased-    tLam t       = TLam t+    -- #3380: this is not safe for strict backends+    tLam TErased | eval == LazyEvaluation = TErased+    tLam t                                = TLam t      tLet e b       | freeIn 0 b = TLet e b-      | otherwise  = strengthen __IMPOSSIBLE__ b+      | otherwise  = strengthen impossible b      tApp f []                  = f     tApp TErased _             = TErased     tApp f _ | isUnreachable f = tUnreachable-    tApp f es                  = TApp f es+    tApp f es                  = mkTApp f es      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 | erasableR r = pure TErased-                 | otherwise   = erase t+    eraseRel r t | erasable r = pure TErased+                 | otherwise  = erase t -    eraseAlt a = case a of+    eraseAlt = \case       TALit l b   -> TALit l   <$> erase b       TACon c a b -> do-        rs <- map erasableR . fst <$> getFunInfo c+        rs <- map erasable . fst <$> getFunInfo c         let sub = foldr (\ e -> if e then (TErased :#) . wkS 1 else liftS 1) idS $ reverse rs         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.-isComplete :: CaseType -> [TAlt] -> E Bool-isComplete (CTData d) bs = do-  cs <- lift $ getConstructors d-  return $ length cs == length [ b | b@TACon{} <- bs ]-isComplete _ _ = pure False+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 isErased erased+        then getConstructors q+        else getNotErasedConstructors q+  let bs | isErased erased = bs'+         | otherwise       =+           flip filter bs' $ \case+             a@TACon{} -> (aCon a) `elem` cs+             TAGuard{} -> True+             TALit{}   -> True+  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) +-- These are the guards we generate for Int/Nat pattern matching+pattern Below :: Int -> Integer -> TTerm+pattern Below x n = TApp (TPrim PLt)  [TVar x, TLit (LitNat n)]++pattern Above :: Int -> Integer -> TTerm+pattern Above x n = TApp (TPrim PGeq) [TVar x, TLit (LitNat n)]++-- | Strip unreachable clauses (replace by tUnreachable for the default).+--   Fourth argument is the set of ints covered so far.+pruneIntCase :: Int -> TTerm -> [TAlt] -> IntSet -> (TTerm, [TAlt])+pruneIntCase x d bs cover = go bs cover+  where+    go [] cover+      | cover == IntSet.full = (tUnreachable, [])+      | otherwise            = (d, [])+    go (b : bs) cover =+      case b of+        TAGuard (Below y n) _ | x == y -> rec (IntSet.below n)+        TAGuard (Above y n) _ | x == y -> rec (IntSet.above n)+        TALit (LitNat n) _             -> rec (IntSet.singleton n)+        _                                -> second (b :) $ go bs cover+      where+        rec this = second addAlt $ go bs cover'+          where+            this'  = IntSet.difference this cover+            cover' = this' <> cover+            addAlt = case IntSet.toFiniteList this' of+                       Just []  -> id                                     -- unreachable case+                       Just [n] -> (TALit (LitNat n) (aBody b) :) -- possibly refined case+                       _        -> (b :)                                  -- unchanged case+ data TypeInfo = Empty | Erasable | NotErasable   deriving (Eq, Show) @@ -168,50 +271,51 @@     plus r           Erasable    = r     plus NotErasable NotErasable = NotErasable -erasableR :: Relevance -> Bool-erasableR Relevant   = False-erasableR Forced{}   = False    -- TODO: should be True but need to transform clauses-erasableR NonStrict  = True-erasableR Irrelevant = True-erasableR UnusedArg  = True- erasable :: TypeInfo -> Bool erasable Erasable    = True erasable Empty       = True erasable NotErasable = False -type FunInfo = ([Relevance], TypeInfo)+type FunInfo = ([TypeInfo], TypeInfo)  getFunInfo :: QName -> E FunInfo getFunInfo q = memo (funMap . key q) $ getInfo q   where+    getInfo :: QName -> E FunInfo     getInfo q = do       (rs, t) <- do         (tel, t) <- lift $ typeWithoutParams q-        is <- mapM (getTypeInfo . snd . dget) tel-        return (zipWith (mkR . getRelevance) tel is, t)+        is     <- mapM (getTypeInfo . snd . dget) tel+        used   <- lift $ (++ repeat ArgUsed) . fromMaybe [] <$> getCompiledArgUse q+        forced <- lift $ (++ repeat NotForced) <$> getForcedArgs q+        return (zipWith3 (uncurry . mkR . getModality) tel (zip forced used) is, t)       h <- if isAbsurdLambdaName q then pure Erasable else getTypeInfo t-      lift $ reportSLn "treeless.opt.erase.info" 50 $ "type info for " ++ show q ++ ": " ++ show rs ++ " -> " ++ show h-      lift $ setErasedConArgs q $ map erasableR rs+      lift $ reportSLn "treeless.opt.erase.info" 50 $ "type info for " ++ prettyShow q ++ ": " ++ show rs ++ " -> " ++ show h+      lift $ setErasedConArgs q $ map erasable rs       return (rs, h) -    -- Treat empty or erasable arguments as NonStrict (and thus erasable)-    mkR :: Relevance -> TypeInfo -> Relevance-    mkR Irrelevant _ = Irrelevant-    mkR r NotErasable = r-    mkR _ Empty       = NonStrict-    mkR _ Erasable    = NonStrict+    -- Treat empty, erasable, or unused arguments as Erasable+    mkR :: Modality -> IsForced -> ArgUsage -> TypeInfo -> TypeInfo+    mkR m f u i+      | not (usableModality m) = Erasable+      | ArgUnused <- u         = Erasable+      | Forced <- f            = Erasable+      | otherwise              = i +isErasable :: QName -> TCM Bool+isErasable qn =+  erasable . snd <$> runE (getFunInfo qn)+ telListView :: Type -> TCM (ListTel, Type) telListView t = do-  TelV tel t <- telView t+  TelV tel t <- telViewPath t   return (telToList tel, t)  typeWithoutParams :: QName -> TCM (ListTel, Type) 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)@@ -219,37 +323,49 @@ getTypeInfo :: Type -> E TypeInfo getTypeInfo t0 = do   (tel, t) <- lift $ telListView t0-  et <- case ignoreSharing $ I.unEl t of-    I.Def d _ -> typeInfo d+  et <- case I.unEl t of+    I.Def d _ -> do+      -- #2916: Only update the memo table for d. Results for other types are+      -- under the assumption that d is erasable!+      oldMap <- use typeMap+      dInfo <- typeInfo d+      typeMap .= Map.insert d dInfo oldMap+      return dInfo     Sort{}    -> return Erasable     _         -> return NotErasable   is <- mapM (getTypeInfo . snd . dget) tel-  let e | any (== Empty) is = Erasable-        | null is           = et        -- TODO: guard should really be "all inhabited is"-        | et == Empty       = Erasable-        | otherwise         = et+  let e | Empty `elem` is = Erasable+        | null is         = et        -- TODO: guard should really be "all inhabited is"+        | et == Empty     = Erasable+        | otherwise       = et   lift $ reportSDoc "treeless.opt.erase.type" 50 $ prettyTCM t0 <+> text ("is " ++ show e)   return e   where-    typeInfo :: QName -> E TypeInfo-    typeInfo q = memoRec (typeMap . key q) Erasable $ do  -- assume recursive occurrences are erasable-      def <- lift $ getConstInfo q-      mcs <- return $ case I.theDef def of-        I.Datatype{ dataCons = cs } -> Just cs-        I.Record{ recConHead = c }  -> Just [conName c]-        _                           -> Nothing+  typeInfo :: QName -> E TypeInfo+  typeInfo q = ifM (erasureForbidden q) (return NotErasable) $ {-else-} do+    memoRec (typeMap . key q) Erasable $ do  -- assume recursive occurrences are erasable+      msizes <- lift $ mapM getBuiltinName+                         [builtinSize, builtinSizeLt]+      def    <- lift $ getConstInfo q+      let mcs = case I.theDef def of+                  I.Datatype{ dataCons = cs } -> Just cs+                  I.Record{ recConHead = c }  -> Just [conName c]+                  _                           -> Nothing       case mcs of+        _ | Just q `elem` msizes -> return Erasable         Just [c] -> do           (ts, _) <- lift $ typeWithoutParams c-          let rs = map getRelevance ts+          let rs = map getModality ts           is <- mapM (getTypeInfo . snd . dget) ts-          let er = and [ erasable i || erasableR r | (i, r) <- zip is rs ]+          let er = and [ erasable i || not (usableModality r) | (i, r) <- zip is rs ]           return $ if er then Erasable else NotErasable         Just []      -> return Empty         Just (_:_:_) -> return NotErasable         Nothing ->           case I.theDef def of             I.Function{ funClauses = cs } ->-              sumTypeInfo <$> mapM (maybe (return Empty) (getTypeInfo . El Prop) . clauseBody) cs+              sumTypeInfo <$> mapM (maybe (return Empty) (getTypeInfo . El __DUMMY_SORT__) . clauseBody) cs             _ -> return NotErasable-+  -- The backend also has a say whether a type is eraseable or not.+  erasureForbidden :: QName -> E Bool+  erasureForbidden q = lift $ not <$> activeBackendMayEraseType q
+ src/full/Agda/Compiler/Treeless/Erase.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Compiler.Treeless.Erase where++import Agda.TypeChecking.Monad.Base (TCM)+import Agda.Syntax.Abstract.Name (QName)++isErasable :: QName -> TCM Bool
src/full/Agda/Compiler/Treeless/GuardsToPrims.hs view
@@ -1,30 +1,21 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Translates guard alternatives to if-then-else cascades. -- -- The builtin translation must be run before this transformation.-{-# LANGUAGE CPP #-} module Agda.Compiler.Treeless.GuardsToPrims ( convertGuards ) where -import Data.List-+import qualified Data.List as List -import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Treeless-import Agda.Syntax.Literal -import Agda.TypeChecking.Substitute--import Agda.Compiler.Treeless.Subst- import Agda.Utils.Impossible -#include "undefined.h" -- convertGuards :: TTerm -> TTerm convertGuards = tr   where-    tr t = case t of+    tr = \case       TCase sc t def alts ->         if null otherAlts           then@@ -43,22 +34,23 @@           trAlt (TAGuard{}) = __IMPOSSIBLE__           trAlt a = a { aBody = tr (aBody a) } -      TVar{}    -> t-      TDef{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TLit{}    -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+      t@TVar{}    -> t+      t@TDef{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TLit{}    -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t +      TCoerce a               -> TCoerce (tr a)       TLam b                  -> TLam (tr b)       TApp a bs               -> TApp (tr a) (map tr bs)       TLet e b                -> TLet (tr e) (tr b)  -- | Split alts into TAGuard alts and other alts. splitAlts :: [TAlt] -> ([TAlt], [TAlt])-splitAlts = partition isGuardAlt+splitAlts = List.partition isGuardAlt   where isGuardAlt (TAGuard _ _) = True         isGuardAlt _ = False
src/full/Agda/Compiler/Treeless/Identity.hs view
@@ -1,29 +1,33 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.Treeless.Identity   ( detectIdentityFunctions ) where -import Control.Applicative-import Data.Foldable (foldMap)+import Prelude hiding ((!!))  -- don't use partial functions++import Control.Applicative ( Alternative((<|>), empty) ) import Data.Semigroup-import Data.List.NonEmpty (NonEmpty(..))-import Data.List+import qualified Data.List as List  import Agda.Syntax.Treeless-import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad-import Agda.Utils.Lens +import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|))++import Agda.Utils.Impossible+ detectIdentityFunctions :: QName -> TTerm -> TCM TTerm detectIdentityFunctions q t =   case isIdentity q t of     Nothing     -> return t     Just (n, k) -> do-      markInline q+      markInline True q       def <- theDef <$> getConstInfo q       return $ mkTLam n $ TVar k  -- If isIdentity f t = Just (n, k) then--- f = t is equivalent to f = λ xₙ₋₁ .. x₀ → xk+-- f = t is equivalent to f = λ xn₋₁ .. x₀ → xk isIdentity :: QName -> TTerm -> Maybe (Int, Int) isIdentity q t =   trivialIdentity q t <|> recursiveIdentity q t@@ -49,7 +53,7 @@         identityArgs a args =           length args == a && and (zipWith match (reverse args) [0..]) -        proj x args = reverse args !! x+        proj x args = indexWithDefault __IMPOSSIBLE__ (reverse args) x          match TErased              _  = True         match (TVar z)             y = z == y@@ -62,7 +66,7 @@ notId = IdIn []  instance Semigroup IdentityIn where-  IdIn xs <> IdIn ys = IdIn $ intersect xs ys+  IdIn xs <> IdIn ys = IdIn $ List.intersect xs ys  -- Does the function always return one of its arguments unchanged (possibly -- through recursive calls).@@ -84,6 +88,7 @@         TCase _ _ d bs     -> sconcat (go k d :| map (goAlt k) bs)         TApp (TDef f) args           | f == q         -> IdIn [ y | (TVar x, y) <- zip (reverse args) [0..], y + k == x ]+        TCoerce v          -> go k v         TApp{}             -> notId         TLam{}             -> notId         TLit{}             -> notId@@ -99,4 +104,3 @@     goAlt k (TALit _ b)   = go k b     goAlt k (TAGuard _ b) = go k b     goAlt k (TACon _ n b) = go (k + n) b-
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. --@@ -11,38 +13,31 @@ -- concrete name. -- -- This transfomation should be run as the last transformation.-{-# LANGUAGE CPP #-} module Agda.Compiler.Treeless.NormalizeNames ( normalizeNames ) where -import Control.Applicative- import Agda.TypeChecking.Monad import Agda.Syntax.Treeless  normalizeNames :: TTerm -> TCM TTerm normalizeNames = tr   where-    tr t = case t of-      TDef q -> do-        q' <- defName <$> getConstInfo q-        return $ TDef q'-      TVar{}    -> done-      TCon{}    -> done-      TPrim{}   -> done-      TLit{}    -> done-      TUnit{}   -> done-      TSort{}   -> done-      TErased{} -> done-      TError{}  -> done-      TLam b                  -> TLam <$> tr b-      TApp a bs               -> TApp <$> tr a <*> mapM tr bs-      TLet e b                -> TLet <$> tr e <*> tr b-      TCase sc t def alts     -> TCase sc t <$> tr def <*> mapM trAlt alts-      where-        done :: TCM TTerm-        done = return t+    tr = \case+      TDef q              -> TDef . defName <$> getConstInfo q+      t@TVar{}            -> return t+      t@TCon{}            -> return t+      t@TPrim{}           -> return t+      t@TLit{}            -> return t+      t@TUnit{}           -> return t+      t@TSort{}           -> return t+      t@TErased{}         -> return t+      t@TError{}          -> return t+      TLam b              -> TLam <$> tr b+      TApp a bs           -> TApp <$> tr a <*> mapM tr bs+      TLet e b            -> TLet <$> tr e <*> tr b+      TCase sc t def alts -> TCase sc t <$> tr def <*> mapM trAlt alts+      TCoerce a           -> TCoerce <$> tr a -    trAlt a = case a of+    trAlt = \case       TAGuard g b -> TAGuard <$> tr g <*> tr b       TACon q a b -> TACon q a <$> tr b       TALit l b   -> TALit l <$> tr b
src/full/Agda/Compiler/Treeless/Pretty.hs view
@@ -1,30 +1,60 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.Compiler.Treeless.Pretty () where -import Control.Arrow ((&&&), (***), first, second)-import Control.Applicative+import Prelude hiding ((!!)) -- don't use partial functions!++import Control.Arrow (first) import Control.Monad.Reader import Data.Maybe+import qualified Data.IntMap as IntMap  import Agda.Syntax.Treeless-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty +import Agda.Compiler.Treeless.Subst++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] }  type P = Reader PEnv -withName :: (String -> P a) -> P a-withName k = withNames 1 $ \[x] -> k x+--UNUSED Liang-Ting Chen 2019-07-16+--withName :: (String -> P a) -> P a+--withName k = withNames 1 $ \[x] -> k x  withNames :: Int -> ([String] -> P a) -> P a withNames n k = do   (xs, ys) <- asks $ splitAt n . pFresh   local (\ e -> e { pFresh = ys }) (k xs) +-- | Don't generate fresh names for unused variables.+withNames' :: HasFree a => Int -> a -> ([String] -> P b) -> P b+withNames' n tm k = withNames n' $ k . insBlanks+  where+    fv = freeVars tm+    n'  = length $ filter (< n) $ IntMap.keys fv+    insBlanks = go n+      where+        go 0 _ = []+        go i xs0@(~(x : xs))+          | IntMap.member (i - 1) fv = x   : go (i - 1) xs+          | otherwise             = "_" : go (i - 1) xs0+ bindName :: String -> P a -> P a bindName x = local $ \ e -> e { pBound = x : pBound e } @@ -34,13 +64,16 @@ 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 }  name :: Int -> P String-name x = asks $ (!! x) . (++ map (("^" ++) . show) [1..]) . pBound+name x = asks+  $ (\ xs -> indexWithDefault __IMPOSSIBLE__ xs x)+  . (++ map (("^" ++) . show) [1..])+  . pBound  runP :: P a -> a runP p = runReader p PEnv{ pPrec = 0, pFresh = names, pBound = [] }@@ -59,13 +92,23 @@ opName PGeq = ">=" opName PLt  = "<" opName PEqI = "==I"+opName PAdd64 = "+64"+opName PSub64 = "-64"+opName PMul64 = "*64"+opName PQuot64 = "quot64"+opName PRem64 = "rem64"+opName PLt64  = "<64"+opName PEq64 = "==64" opName PEqF = "==F" opName PEqS = "==S" opName PEqC = "==C" opName PEqQ = "==Q" opName PIf  = "if_then_else_" opName PSeq = "seq"+opName PITo64 = "toWord64"+opName P64ToI = "fromWord64" + isInfix :: TPrim -> Maybe (Int, Int, Int) isInfix op =   case op of@@ -74,32 +117,36 @@     PSub -> l 6     PGeq -> non 4     PLt  -> non 4+    PMul64 -> l 7+    PAdd64 -> l 6+    PSub64 -> l 6+    PLt64  -> non 4     p | isPrimEq p -> non 4     _    -> Nothing   where     l n   = Just (n, n, n + 1)-    r n   = Just (n, n + 1, n)+    r n   = Just (n, n + 1, n) -- NB:: Defined but not used     non n = Just (n, n + 1, n + 1)  pTerm' :: Int -> TTerm -> P Doc pTerm' p = prec p . pTerm  pTerm :: TTerm -> P Doc-pTerm t = case t of+pTerm = \case   TVar x -> text <$> name x   TApp (TPrim op) [a, b] | Just (c, l, r) <- isInfix op ->     paren c $ sep <$> sequence [ pTerm' l a                                , pure $ text $ opName op                                , pTerm' r b ]   TApp (TPrim PIf) [a, b, c] ->-    paren 0 $ (\ a b c -> sep [ text "if" <+> a-                              , nest 2 $ text "then" <+> b-                              , nest 2 $ text "else" <+> c ])+    paren 0 $ (\ a b c -> sep [ "if" <+> a+                              , nest 2 $ "then" <+> b+                              , nest 2 $ "else" <+> c ])               <$> pTerm' 0 a               <*> pTerm' 0 b               <*> pTerm c-  TDef f -> pure $ text (show f)-  TCon c -> pure $ text (show c)+  TDef f -> pure $ pretty f+  TCon c -> pure $ pretty c   TLit l -> pure $ pretty l   TPrim op | isJust (isInfix op) -> pure $ text ("_" ++ opName op ++ "_")            | otherwise -> pure $ text (opName op)@@ -107,22 +154,18 @@     paren 9 $ (\a bs -> sep [a, nest 2 $ fsep bs])               <$> pTerm' 9 f               <*> mapM (pTerm' 10) es-  TLam _ -> paren 0 $ withNames n $ \xs -> bindNames xs $+  t@TLam{} -> paren 0 $ withNames' n b $ \ xs -> bindNames xs $     (\b -> sep [ text ("λ " ++ unwords xs ++ " →")                , nest 2 b ]) <$> pTerm' 0 b     where-      (n, b) = lamV t-      lamV (TLam b) = first succ $ lamV b-      lamV t        = (0, t)-  TLet{} -> paren 0 $ withNames (length es) $ \ xs ->-    (\ (binds, b) -> sep [ text "let" <+> vcat [ sep [ text x <+> text "="-                                                     , nest 2 e ] | (x, e) <- binds ]-                              <+> text "in", b ])+      (n, b) = tLamView t+  t@TLet{} -> paren 0 $ withNames (length es) $ \ xs ->+    (\ (binds, b) -> sep [ "let" <+> vcat [ sep [ text x <+> "="+                                                , nest 2 e ] | (x, e) <- binds ]+                              <+> "in", b ])       <$> pLets (zip xs es) b     where-      (es, b) = letV t-      letV (TLet e b) = first (e :) $ letV b-      letV t          = ([], t)+      (es, b) = tLetView t        pLets [] b = ([],) <$> pTerm' 0 b       pLets ((x, e) : bs) b = do@@ -131,24 +174,24 @@    TCase x _ def alts -> paren 0 $     (\ sc alts defd ->-      sep [ text "case" <+> sc <+> text "of"-          , nest 2 $ vcat (alts ++ [ text "_ →" <+> defd | null alts || def /= TError TUnreachable ]) ]+      sep [ "case" <+> sc <+> "of"+          , nest 2 $ vcat (alts ++ [ "_ →" <+> defd | null alts || def /= TError TUnreachable ]) ]     ) <$> pTerm' 0 (TVar x)       <*> mapM pAlt alts       <*> pTerm' 0 def     where       pAlt (TALit l b) = pAlt' <$> pTerm' 0 (TLit l) <*> pTerm' 0 b       pAlt (TAGuard g b) =-        pAlt' <$> ((text "_" <+> text "|" <+>) <$> pTerm' 0 g)+        pAlt' <$> (("_" <+> "|" <+>) <$> pTerm' 0 g)               <*> (pTerm' 0 b)       pAlt (TACon c a b) =-        withNames a $ \ xs -> bindNames xs $+        withNames' a b $ \ xs -> bindNames xs $         pAlt' <$> pTerm' 0 (TApp (TCon c) [TVar i | i <- reverse [0..a - 1]])               <*> pTerm' 0 b-      pAlt' p b = sep [p <+> text "→", nest 2 b]--  TUnit -> pure $ text "()"-  TSort -> pure $ text "Set"-  TErased -> pure $ text "_"-  TError err -> paren 9 $ pure $ text "error" <+> text (show (show err))+      pAlt' p b = sep [p <+> "→", nest 2 b] +  TUnit -> pure "()"+  TSort -> pure "Set"+  TErased -> pure "_"+  TError err -> paren 9 $ pure $ "error" <+> text (show (show err))+  TCoerce t -> paren 9 $ ("coe" <+>) <$> pTerm' 10 t
+ 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,29 +1,25 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Simplify (simplifyTTerm) where -import Control.Arrow (first, second, (***))-import Control.Applicative-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Traversable (traverse)-import Data.List+import Control.Arrow        ( (***), second )+import Control.Monad        ( (>=>), guard )+import Control.Monad.Reader ( MonadReader(..), asks, Reader, runReader )+import qualified Data.List as List  import Agda.Syntax.Treeless-import Agda.Syntax.Internal (Substitution'(..)) import Agda.Syntax.Literal+ import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Primitive import Agda.TypeChecking.Substitute-import Agda.Utils.Maybe -import Agda.Compiler.Treeless.Subst-import Agda.Compiler.Treeless.Pretty import Agda.Compiler.Treeless.Compare-import Agda.Utils.Pretty +import Agda.Utils.List+import Agda.Utils.Maybe+ import Agda.Utils.Impossible-#include "undefined.h"  data SEnv = SEnv   { envSubst   :: Substitution' TTerm@@ -55,6 +51,9 @@ underLet :: TTerm -> S a -> S a underLet u = onRewrite (raiseS 1) . onSubst (\rho -> wkS 1 $ u :# rho) +bindVar :: Int -> TTerm -> S a -> S a+bindVar x u = onSubst (inplaceS x u `composeS`)+ rewrite :: TTerm -> S TTerm rewrite t = do   rules <- asks envRewrite@@ -77,36 +76,52 @@ simplify :: FunctionKit -> TTerm -> S TTerm simplify FunctionKit{..} = simpl   where-    simpl = rewrite' >=> unchainCase >=> \ t -> case t of--      TDef{}         -> pure t-      TPrim{}        -> pure t+    simpl = rewrite' >=> unchainCase >=> \case -      TVar x  -> do-        v <- lookupVar x-        pure $ if isAtomic v then v else t+      t@TDef{}  -> pure t+      t@TPrim{} -> pure t+      t@TVar{}  -> pure t -      TApp (TDef f) [TLit (LitNat _ 0), m, n, m']+      TApp (TDef f) [TLit (LitNat 0), m, n, m']         -- div/mod are equivalent to quot/rem on natural numbers.         | m == m', Just f == divAux -> simpl $ tOp PQuot n (tPlusK 1 m)         | m == m', Just f == modAux -> simpl $ tOp PRem n (tPlusK 1 m) -      TApp (TPrim _) _ -> pure t  -- taken care of by rewrite'+      -- Word64 primitives -- +      --  toWord (a ∙ b) == toWord a ∙64 toWord b+      TPFn PITo64 (TPOp op a b)+        | Just op64 <- opTo64 op -> simpl $ tOp op64 (TPFn PITo64 a) (TPFn PITo64 b)+        where+          opTo64 op = lookup op [(PAdd, PAdd64), (PSub, PSub64), (PMul, PMul64),+                                 (PQuot, PQuot64), (PRem, PRem64)]++      t@(TApp (TPrim _) _) -> pure t  -- taken care of by rewrite'++      TCoerce t -> TCoerce <$> simpl t+       TApp f es -> do         f  <- simpl f         es <- traverse simpl es         maybeMinusToPrim f es-      TLam b         -> TLam <$> underLam (simpl b)-      TLit{}         -> pure t-      TCon{}         -> pure t-      TLet e b       -> do-        e <- simpl e-        tLet e <$> underLet e (simpl b)+      TLam b    -> TLam <$> underLam (simpl b)+      t@TLit{}  -> pure t+      t@TCon{}  -> pure t+      TLet e b  -> do+        simpl e >>= \case+          TPFn P64ToI a -> do+            -- Inline calls to P64ToI since these trigger optimisations.+            -- Ideally, the optimisations would trigger anyway, but at the+            -- moment they only do if inlining the entire let looks like a+            -- good idea.+            let rho = inplaceS 0 (TPFn P64ToI (TVar 0))+            tLet a <$> underLet a (simpl (applySubst rho b))+          e -> tLet e <$> underLet e (simpl b)        TCase x t d bs -> do         v <- lookupVar x         let (lets, u) = tLetView v+        (d, bs) <- pruneBoolGuards d <$> traverse (simplAlt x) bs         case u of                          -- TODO: also for literals           _ | Just (c, as)     <- conView u   -> simpl $ matchCon lets c as d bs             | Just (k, TVar y) <- plusKView u -> simpl . mkLets lets . TCase y t d =<< mapM (matchPlusK y x k) bs@@ -128,18 +143,17 @@               distrCase v (TAGuard g b) = TAGuard g $ TLet b v            _ -> do-            d  <- simpl d-            bs <- traverse (simplAlt x) bs+            d <- simpl d             tCase x t d bs -      TUnit          -> pure t-      TSort          -> pure t-      TErased        -> pure t-      TError{}       -> pure t+      t@TUnit    -> pure t+      t@TSort    -> pure t+      t@TErased  -> pure t+      t@TError{} -> pure t -    conView (TCon c)           = Just (c, [])-    conView (TApp (TCon c) as) = Just (c, as)-    conView e                  = Nothing+    conView (TCon c)    = Just (c, [])+    conView (TApp f as) = second (++ as) <$> conView f+    conView e           = Nothing      -- Collapse chained cases (case x of bs -> vs; _ -> case x of bs' -> vs'  ==>     --                         case x of bs -> vs; bs' -> vs')@@ -149,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 @@ -169,7 +183,7 @@     -- Simplify let y = x + k in case y of j     -> u; _ | g[y]     -> v     -- to       let y = x + k in case x of j - k -> u; _ | g[x + k] -> v     matchPlusK :: Int -> Int -> Integer -> TAlt -> S TAlt-    matchPlusK x y k (TALit (LitNat r j) b) = return $ TALit (LitNat r (j - k)) b+    matchPlusK x y k (TALit (LitNat j) b) = return $ TALit (LitNat (j - k)) b     matchPlusK x y k (TAGuard g b) = flip TAGuard b <$> simpl (applySubst (inplaceS y (tPlusK k (TVar x))) g)     matchPlusK x y k TACon{} = __IMPOSSIBLE__     matchPlusK x y k TALit{} = __IMPOSSIBLE__@@ -191,33 +205,80 @@     simplPrim t = pure t      simplPrim' :: TTerm -> TTerm+    simplPrim' (TApp (TPrim PSeq) (u : v : vs))+      | u == v             = mkTApp v vs+      | TApp TCon{} _ <- u = mkTApp v vs+      | TApp TLit{} _ <- u = mkTApp v vs     simplPrim' (TApp (TPrim PLt) [u, v])       | Just (PAdd, k, u) <- constArithView u,         Just (PAdd, j, v) <- constArithView v,         k == j = tOp PLt u v+      | Just (PSub, k, u) <- constArithView u,+        Just (PSub, j, v) <- constArithView v,+        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+      | Just k <- intView u+      , Just j <- intView v+      , Just trueCon <- true+      , Just falseCon <- false = if k < j then TCon trueCon else TCon falseCon+    simplPrim' (TApp (TPrim PGeq) [u, v])+      | Just (PAdd, k, u) <- constArithView u,+        Just (PAdd, j, v) <- constArithView v,+        k == j = tOp PGeq u v+      | Just (PSub, k, u) <- constArithView u,+        Just (PSub, j, v) <- constArithView v,+        k == j = tOp PGeq v u+      | Just k <- intView u+      , Just j <- intView v+      , Just trueCon <- true+      , Just falseCon <- false = if k >= j then TCon trueCon else TCon falseCon     simplPrim' (TApp (TPrim op) [u, v])-      | elem op [PGeq, PLt, PEqI]+      | op `elem` [PGeq, PLt, PEqI]       , Just (PAdd, k, u) <- constArithView u       , Just j <- intView v = TApp (TPrim op) [u, tInt (j - k)]     simplPrim' (TApp (TPrim PEqI) [u, v])       | Just (op1, k, u) <- constArithView u,         Just (op2, j, v) <- constArithView v,         op1 == op2, k == j,-        elem op1 [PAdd, PSub] = tOp PEqI u v-    simplPrim' (TApp (TPrim PMul) [u, v])-      | Just 0 <- intView u = tInt 0-      | Just 0 <- intView v = tInt 0+        op1 `elem` [PAdd, PSub] = tOp PEqI u v+    simplPrim' (TPOp op u v)+      | zeroL, isMul || isDiv = tInt 0+      | zeroL, isAdd          = v+      | zeroR, isMul          = tInt 0+      | zeroR, isAdd || isSub = u+      where zeroL = Just 0 == intView u || Just 0 == word64View u+            zeroR = Just 0 == intView v || Just 0 == word64View v+            isAdd = op `elem` [PAdd, PAdd64]+            isSub = op `elem` [PSub, PSub64]+            isMul = op `elem` [PMul, PMul64]+            isDiv = op `elem` [PQuot, PQuot64, PRem, PRem64]     simplPrim' (TApp (TPrim op) [u, v])       | Just u <- negView u,         Just v <- negView v,-        elem op [PMul, PQuot] = tOp op u v+        op `elem` [PMul, PQuot] = tOp op u v       | Just u <- negView u,-        elem op [PMul, PQuot] = simplArith $ tOp PSub (tInt 0) (tOp op u v)+        op `elem` [PMul, PQuot] = simplArith $ tOp PSub (tInt 0) (tOp op u v)       | Just v <- negView v,-        elem op [PMul, PQuot] = simplArith $ tOp PSub (tInt 0) (tOp op u v)+        op `elem` [PMul, PQuot] = simplArith $ tOp PSub (tInt 0) (tOp op u v)     simplPrim' (TApp (TPrim PRem) [u, v])       | Just u <- negView u  = simplArith $ tOp PSub (tInt 0) (tOp PRem u (unNeg v))       | Just v <- negView v  = tOp PRem u v++      -- (fromWord a == fromWord b) = (a ==64 b)+    simplPrim' (TPOp op (TPFn P64ToI a) (TPFn P64ToI b))+        | Just op64 <- opTo64 op = tOp op64 a b+        where+          opTo64 op = lookup op [(PEqI, PEq64), (PLt, PLt64)]++      -- toWord/fromWord k == fromIntegral k+    simplPrim' (TPFn PITo64 (TLit (LitNat n)))    = TLit (LitWord64 (fromIntegral n))+    simplPrim' (TPFn P64ToI (TLit (LitWord64 n))) = TLit (LitNat    (fromIntegral n))++      -- toWord (fromWord a) == a+    simplPrim' (TPFn PITo64 (TPFn P64ToI a)) = a+     simplPrim' (TApp f@(TPrim op) [u, v]) = simplArith $ TApp f [simplPrim' u, simplPrim' v]     simplPrim' u = u @@ -232,29 +293,38 @@     betterThan u v = operations u <= operations v       where         operations (TApp (TPrim _) [a, b]) = 1 + operations a + operations b+        operations (TApp (TPrim PSeq) (a : _))+          | notVar a                       = 1000000  -- only seq on variables!+        operations (TApp (TPrim _) [a])    = 1 + operations a         operations TVar{}                  = 0         operations TLit{}                  = 0+        operations TCon{}                  = 0+        operations TDef{}                  = 0         operations _                       = 1000 +        notVar TVar{} = False+        notVar _      = True+     rewrite' t = rewrite =<< simplPrim t      constArithView :: TTerm -> Maybe (TPrim, Integer, TTerm)-    constArithView (TApp (TPrim op) [TLit (LitNat _ k), u])-      | elem op [PAdd, PSub] = Just (op, k, u)-    constArithView (TApp (TPrim op) [u, TLit (LitNat _ k)])+    constArithView (TApp (TPrim op) [TLit (LitNat k), u])+      | op `elem` [PAdd, PSub] = Just (op, k, u)+    constArithView (TApp (TPrim op) [u, TLit (LitNat k)])       | op == PAdd = Just (op, k, u)       | op == PSub = Just (PAdd, -k, u)     constArithView _ = Nothing      simplAlt x (TACon c a b) = TACon c a <$> underLams a (maybeAddRewrite (x + a) conTerm $ simpl b)-      where conTerm = mkTApp (TCon c) [TVar i | i <- reverse $ take a [0..]]+      where conTerm = mkTApp (TCon c) $ map TVar $ downFrom a     simplAlt x (TALit l b)   = TALit l   <$> maybeAddRewrite x (TLit l) (simpl b)     simplAlt x (TAGuard g b) = TAGuard   <$> simpl g <*> simpl b +    -- If x is already bound we add a rewrite, otherwise we bind x to rhs.     maybeAddRewrite x rhs cont = do       v <- lookupVar x       case v of-        TVar y | x == y -> cont+        TVar y | x == y -> bindVar x rhs $ cont         _ -> addRewrite v rhs cont      isTrue (TCon c) = Just c == true@@ -265,12 +335,9 @@      maybeMinusToPrim f@(TDef minus) es@[a, b]       | Just minus == natMinus = do-      b_a  <- rewrite' (tOp PLt b a)-      b_sa <- rewrite' (tOp PLt b (tOp PAdd (tInt 1) a))-      a_b  <- rewrite' (tOp PLt a b)-      if isTrue b_a || isTrue b_sa || isFalse b_a && isFalse a_b-        then pure $ tOp PSub a b-        else tApp f es+      leq  <- checkLeq b a+      if leq then pure $ tOp PSub a b+             else tApp f es      maybeMinusToPrim f es = tApp f es @@ -278,7 +345,7 @@     tLet e (TVar 0) = e     tLet e b        = TLet e b -    tCase :: Int -> CaseType -> TTerm -> [TAlt] -> S TTerm+    tCase :: Int -> CaseInfo -> TTerm -> [TAlt] -> S TTerm     tCase x t d [] = pure d     tCase x t d bs       | isUnreachable d =@@ -291,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@@ -299,28 +366,40 @@         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 -    -- | Drop unreachable cases for Nat and Int cases.-    pruneLitCases :: Int -> CaseType -> TTerm -> [TAlt] -> S TTerm-    pruneLitCases x CTNat d 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 =       case complete bs [] Nothing of-        Just bs' -> tCase x CTNat tUnreachable bs'-        Nothing  -> return $ TCase x CTNat d bs+        Just bs' -> tCase x t tUnreachable bs'+        Nothing  -> return $ TCase x t d bs       where         complete bs small (Just upper)-          | null $ [0..upper - 1] \\ small = Just []-        complete (b@(TALit (LitNat _ n) _) : bs) small upper =+          | null $ [0..upper - 1] List.\\ small = Just []+        complete (b@(TALit (LitNat n) _) : bs) small upper =           (b :) <$> complete bs (n : small) upper-        complete (b@(TAGuard (TApp (TPrim PGeq) [TVar y, TLit (LitNat _ j)]) _) : bs) small upper | x == y =+        complete (b@(TAGuard (TApp (TPrim PGeq) [TVar y, TLit (LitNat j)]) _) : bs) small upper | x == y =           (b :) <$> complete bs small (Just $ maybe j (min j) upper)         complete _ _ _ = Nothing-    pruneLitCases x CTInt d bs = return $ TCase x CTInt d bs -- TODO-    pruneLitCases x t d bs = return $ TCase x t d bs +    pruneLitCases x t d bs+      | CTInt == caseType t = return $ TCase x t d bs -- TODO+      | otherwise           = return $ TCase x t d bs++    -- Drop 'false' branches and drop everything after 'true' branches (including the default+    -- branch)+    pruneBoolGuards d [] = (d, [])+    pruneBoolGuards d (b@(TAGuard (TCon c) _) : bs)+      | Just c == true  = (tUnreachable, [b])+      | Just c == false = pruneBoolGuards d bs+    pruneBoolGuards d (b : bs) =+      second (b :) $ pruneBoolGuards d bs+     tCase' x t d [] = return d     tCase' x t d bs = pruneLitCases x t d bs @@ -345,7 +424,7 @@     tAppAlt (TALit l b) es   = TALit l   <$> tApp b es     tAppAlt (TAGuard g b) es = TAGuard g <$> tApp b es -    isAtomic v = case v of+    isAtomic = \case       TVar{}    -> True       TCon{}    -> True       TPrim{}   -> True@@ -356,6 +435,46 @@       TError{}  -> True       _         -> False +    checkLeq a b = do+      rho  <- asks envSubst+      rwr  <- asks envRewrite+      let nf = toArith . applySubst rho+          less = [ (nf a, nf b) | (TPOp PLt a b, rhs) <- rwr, isTrue  rhs ]+          leq  = [ (nf b, nf a) | (TPOp PLt a b, rhs) <- rwr, isFalse rhs ]++          match (j, as) (k, bs)+            | as == bs  = Just (j - k)+            | otherwise = Nothing++          -- Do we have x ≤ y given x' < y' + d ?+          matchEqn d x y (x', y') = isJust $ do+            k <- match x x'     -- x = x' + k+            j <- match y y'     -- y = y' + j+            guard (k <= j + d)  -- x ≤ y if k ≤ j + d++          matchLess = matchEqn 1+          matchLeq  = matchEqn 0++          literal (j, []) (k, []) = j <= k+          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 _ _ = False++          -- x ≤ k + fromWord y  if  x ≤ k+          wordLowerBound a (k, [Pos (TApp (TPrim P64ToI) _)]) = go a (k, [])+          wordLowerBound _ _ = False++          go x y = or+            [ literal x y+            , wordUpperBound x y+            , wordLowerBound x y+            , any (matchLess x y) less+            , any (matchLeq x y) leq ]++      return $ go (nf a) (nf b)+ type Arith = (Integer, [Atom])  data Atom = Pos TTerm | Neg TTerm@@ -367,12 +486,12 @@  aCancel :: [Atom] -> [Atom] aCancel (a : as)-  | elem (aNeg a) as = aCancel (delete (aNeg a) as)-  | otherwise        = a : aCancel as+  | (aNeg a) `elem` as = aCancel (List.delete (aNeg a) as)+  | otherwise          = a : aCancel as aCancel [] = []  sortR :: Ord a => [a] -> [a]-sortR = sortBy (flip compare)+sortR = List.sortBy (flip compare)  aAdd :: Arith -> Arith -> Arith aAdd (a, xs) (b, ys) = (a + b, aCancel $ sortR $ xs ++ ys)@@ -405,4 +524,3 @@  simplArith :: TTerm -> TTerm simplArith = fromArith . toArith-
src/full/Agda/Compiler/Treeless/Subst.hs view
@@ -1,34 +1,35 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}  module Agda.Compiler.Treeless.Subst where -import Control.Applicative-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, All(..), Any(..))+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap) import Data.Maybe+import Data.Semigroup ( Semigroup, (<>), All(..), Any(..) )  import Agda.Syntax.Treeless-import Agda.Syntax.Internal (Substitution'(..)) import Agda.TypeChecking.Substitute +import Agda.Utils.Impossible+ instance DeBruijn TTerm where   deBruijnVar = TVar   deBruijnView (TVar i) = Just i   deBruijnView _ = Nothing -instance Subst TTerm TTerm where-  applySubst IdS t = t-  applySubst rho t = case t of-      TDef{}    -> t-      TLit{}    -> t-      TCon{}    -> t-      TPrim{}   -> t-      TUnit{}   -> t-      TSort{}   -> t-      TErased{} -> t-      TError{}  -> t+instance Subst TTerm where+  type SubstArg TTerm = TTerm++  applySubst IdS = id+  applySubst rho = \case+      t@TDef{}    -> t+      t@TLit{}    -> t+      t@TCon{}    -> t+      t@TPrim{}   -> t+      t@TUnit{}   -> t+      t@TSort{}   -> t+      t@TErased{} -> t+      t@TError{}  -> t       TVar i         -> lookupS rho i       TApp f ts      -> tApp (applySubst rho f) (applySubst rho ts)       TLam b         -> TLam (applySubst (liftS 1 rho) b)@@ -38,11 +39,13 @@           TVar j  -> TCase j t (applySubst rho d) (applySubst rho bs)           e       -> TLet e $ TCase 0 t (applySubst rho' d) (applySubst rho' bs)             where rho' = wkS 1 rho+      TCoerce e -> TCoerce (applySubst rho e)     where       tApp (TPrim PSeq) [TErased, b] = b       tApp f ts = TApp f ts -instance Subst TTerm TAlt where+instance Subst TAlt where+  type SubstArg TAlt = TTerm   applySubst rho (TACon c i b) = TACon c i (applySubst (liftS i rho) b)   applySubst rho (TALit l b)   = TALit l (applySubst rho b)   applySubst rho (TAGuard g b) = TAGuard (applySubst rho g) (applySubst rho b)@@ -69,32 +72,40 @@   Occurs a k s <> Occurs b l t = Occurs (a + b) (k <> l) (s <> t)  instance Monoid Occurs where-  mempty = Occurs 0 mempty mempty+  mempty  = Occurs 0 mempty mempty   mappend = (<>) ++-- Andreas, 2019-07-10: this free variable computation should be rewritten+-- in the style of TypeChecking.Free.Lazy.+-- 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 @@ -102,24 +113,32 @@   freeVars (InSeq x) = inSeq <$> freeVars x  instance HasFree TTerm where-  freeVars t = case t of-    TDef{}    -> Map.empty-    TLit{}    -> Map.empty-    TCon{}    -> Map.empty-    TPrim{}   -> Map.empty-    TUnit{}   -> Map.empty-    TSort{}   -> Map.empty-    TErased{} -> Map.empty-    TError{}  -> Map.empty+  freeVars = \case+    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)     TLam b         -> underLambda <$> freeVars (Binder 1 b)     TLet e b       -> freeVars (e, Binder 1 b)     TCase i _ d bs -> freeVars (i, (d, bs))+    TCoerce t      -> freeVars t  instance HasFree TAlt where-  freeVars a = case a of+  freeVars = \case     TACon _ i b -> freeVars (Binder i b)     TALit _ b   -> freeVars b     TAGuard g b -> freeVars (g, b)++-- | Strenghtening.+tryStrengthen :: (HasFree a, Subst a) => Int -> a -> Maybe a+tryStrengthen n t =+  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,17 +1,15 @@-{-# LANGUAGE CPP #-}-module Agda.Compiler.Treeless.Uncase (caseToSeq) where+{-# OPTIONS_GHC -Wunused-imports #-} -import Control.Applicative-import Data.Monoid+module Agda.Compiler.Treeless.Uncase (caseToSeq) where  import Agda.Syntax.Treeless-import Agda.Syntax.Literal import Agda.TypeChecking.Substitute import Agda.Compiler.Treeless.Subst import Agda.Compiler.Treeless.Compare +import Agda.Utils.List+ import Agda.Utils.Impossible-#include "undefined.h"  caseToSeq :: Monad m => TTerm -> m TTerm caseToSeq t = return $ uncase t@@ -31,36 +29,40 @@   TSort{}   -> t   TErased{} -> t   TError{}  -> t+  TCoerce t -> TCoerce (uncase t)   where     uncaseAlt (TACon c a b) = TACon c a $ uncase b     uncaseAlt (TALit l b)   = TALit l $ uncase b     uncaseAlt (TAGuard g b) = TAGuard (uncase g) (uncase b)      doCase x t d bs-      | fv > 0               = fallback   -- can't do it for constructors with arguments-      | all (equalTo x u) bs = tApp (TPrim PSeq) [TVar x, u]+      | Just u <- mu,+        all (equalTo x u) bs = maybeSeq u       | otherwise            = fallback       where+        maybeSeq u | caseLazy t = u+                   | otherwise  = tApp (TPrim PSeq) [TVar x, u]         fallback = TCase x t d bs-        (fv, u)+        (fv, mu)           | isUnreachable d =-            case last bs of-              TACon _ a b -> (a, b)-              TALit l b   -> (0, b)-              TAGuard _ b -> (0, b)-          | otherwise = (0, d)+            case lastWithDefault __IMPOSSIBLE__ bs of+              TACon _ a b -> (a, tryStrengthen a b)+              TALit l b   -> (0, Just b)+              TAGuard _ b -> (0, Just b)+          | otherwise = (0, Just d)      equalTo :: Int -> TTerm -> TAlt -> Bool-    equalTo x t (TACon c a b) = a == 0 && equalTerms (subst x (TCon c) t) (subst x (TCon c) b)+    equalTo x t (TACon c a b)+      | Just b' <- tryStrengthen a b = equalTerms (subst x v t) (subst x v b')+      | otherwise                    = False+      where v = mkTApp (TCon c) (replicate a TErased)     equalTo x t (TALit l b)   = equalTerms (subst x (TLit l) t) (subst x (TLit l) b)     equalTo x t (TAGuard _ b) = equalTerms t b -    -- There's no sense binding an expression just to seq on it.     tLet e b =       case occursIn 0 b of-        Occurs 0 _ _                   -> strengthen __IMPOSSIBLE__ b-        Occurs _ _ (SeqArg (All True)) -> subst 0 TErased b -- this will get rid of the seq-        _                              -> TLet e b+        Occurs 0 _ _ -> strengthen impossible b+        _            -> TLet e b      -- Primitive operations are already strict     tApp (TPrim PSeq) [_, b@(TApp (TPrim op) _)]
src/full/Agda/Compiler/Treeless/Unused.hs view
@@ -1,71 +1,96 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.Treeless.Unused   ( usedArguments   , stripUnusedArguments   ) where -import Control.Arrow (first)-import Control.Applicative-import qualified Data.Set as Set import Data.Maybe +import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty   ( prettyShow ) import Agda.Syntax.Treeless import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute -import Agda.Compiler.Treeless.Subst-import Agda.Compiler.Treeless.Pretty+import Agda.Compiler.Treeless.Pretty () -- instance only -usedArguments :: QName -> TTerm -> TCM [Bool]-usedArguments q t = computeUnused q b (replicate n False)+import Agda.Utils.Function ( iterateUntilM )+import Agda.Utils.List     ( downFrom )+import qualified Agda.Utils.VarSet as VarSet++usedArguments :: QName -> TTerm -> TCM [ArgUsage]+usedArguments q t = computeUnused q b (replicate n ArgUnused)   where (n, b) = tLamView t -computeUnused :: QName -> TTerm -> [Bool] -> TCM [Bool]-computeUnused q t used = do-  reportSLn "treeless.opt.unused" 50 $ "Unused approximation for " ++ show q ++ ": " ++-                                       unwords [ if u then [x] else "_" | (x, u) <- zip ['a'..] used ]+-- | Saturation algorithm, starting with all unused arguments+--   and adding usages until fixed-point has been reached.++computeUnused :: QName -> TTerm -> [ArgUsage] -> TCM [ArgUsage]+computeUnused q t = iterateUntilM (==) $ \ used -> do++  reportSLn "treeless.opt.unused" 50 $ concat+    [ "Unused approximation for ", prettyShow q, ": "+    , unwords [ if u == ArgUsed then [x] else "_" | (x, u) <- zip ['a'..] used ]+    ]+  -- Update usage information q to so far "best" value.   setCompiledArgUse q used++  -- The new usage information is the free variables of @t@,+  -- computed under the current usage assumptions of the functions it calls.   fv <- go t-  let used' = [ Set.member i fv | (i, _) <- reverse $ zip [0..] used ]-  if used == used' then return used'-                   else computeUnused q t used'+  return $ [ if VarSet.member i fv then ArgUsed else ArgUnused+           | i <- downFrom (length used)+           ]   where-    go t = case t of-      TVar x    -> pure $ Set.singleton x-      TPrim{}   -> pure Set.empty-      TDef{}    -> pure Set.empty-      TLit{}    -> pure Set.empty-      TCon{}    -> pure Set.empty+    go = \case+      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 <- getCompiledArgUse f-        Set.unions <$> sequence [ go t | (t, True) <- zip ts $ used ++ repeat True ]+        used <- fromMaybe [] <$> getCompiledArgUse f+        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  -> Set.union <$> go e <*> (underBinder <$> go b)-      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+      TLet e b  -> do+        uses <- go b+        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 :: [Bool] -> TTerm -> TTerm+stripUnusedArguments :: [ArgUsage] -> TTerm -> TTerm stripUnusedArguments used t = mkTLam m $ applySubst rho b   where     (n, b) = tLamView t-    m      = length $ filter id used'-    used'  = reverse $ take n $ used ++ repeat True+    m      = length $ filter (== ArgUsed) used'+    used'  = reverse $ take n $ used ++ repeat ArgUsed     rho = computeSubst used'-    computeSubst (False : bs) = TErased :# computeSubst bs-    computeSubst (True  : bs) = liftS 1 $ computeSubst bs-    computeSubst []           = idS-+    computeSubst (ArgUnused : bs) = TErased :# computeSubst bs+    computeSubst (ArgUsed   : bs) = liftS 1 $ computeSubst bs+    computeSubst []               = idS
− src/full/Agda/Compiler/UHC/Bridge.hs 
@@ -1,292 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Exports the UHC API, and provides dummy--- definitions if the backend is disabled.-module Agda.Compiler.UHC.Bridge-  ( uhcBackendEnabled--  -- UHC.Util.Pretty-  , PP_Doc-  , putPPFile-  , disp-  , pp--  -- UHC.Util.Serialize-  , Serialize-  , putSerializeFile-  , serialize-  , unserialize--  -- UHC.Light.Compiler.Base.API-  , EHCOpts-  , defaultEHCOpts-  , HsName-  , CTag-  , mkHsName-  , mkHsName1-  , mkUniqueHsName--  -- UHC.Light.Compiler.Core.API-  , CModule-  , CImport-  , CExport-  , CDeclMeta-  , CDataCon-  , CExpr-  , CBind-  , CAlt-  , CPat-  , CPatFld---  , CPatRest--  , mkUnit-  , mkInt-  , mkInteger-  , mkChar-  , mkString-  , mkError-  , mkUndefined-  , mkVar-  , mkLet1Plain-  , mkLet1Strict-  , mkLetRec-  , mkLam-  , mkApp-  , mkBind1-  , mkBind1Nm1-  , mkCTag-  , destructCTag-  , ctagUnit-  , ctagTrue-  , ctagFalse-  , ctagCons-  , ctagNil-  , mkCase-  , mkAlt-  , mkPatCon-  , mkPatRestEmpty-  , mkPatFldBind-  , mkTagTup-  , mkModule-  , mkImport-  , mkExport-  , mkMetaData-  , mkMetaDataCon-  , mkMetaDataConFromCTag-  , mkMain-  , parseExpr-  , printModule-  ) where--#include "undefined.h"-import Agda.Utils.Impossible--import Data.Binary.Put-import Data.Binary.Get-import Data.Typeable--#if defined(UHC_BACKEND)-import UHC.Util.Pretty-import UHC.Util.Serialize-import UHC.Util.ParseUtils-import UHC.Util.ScanUtils-import UU.Scanner.Position--import UHC.Light.Compiler.Core.API-import UHC.Light.Compiler.Base.API-#else---- UHC.Util.Pretty-type PP_Doc = String--class Show a => PP a where-  pp :: a -> PP_Doc--instance PP CExpr where-  pp CExpr_DUMMY = "DUMMY - UHC backend is disabled"--putPPFile :: String -> PP_Doc -> Int -> IO ()-putPPFile = __IMPOSSIBLE__--disp :: PP_Doc -> Int -> ShowS-disp s _ = (s ++)---- UHC.Util.Serialize-class Serialize a where--putSerializeFile :: FilePath -> a -> IO ()-putSerializeFile = __IMPOSSIBLE__--serialize :: x -> Put-serialize = __IMPOSSIBLE__--unserialize :: Get x-unserialize = __IMPOSSIBLE__---- UHC.Light.Compiler.Base.API--data EHCOpts-defaultEHCOpts :: EHCOpts-defaultEHCOpts = __IMPOSSIBLE__--data HsName deriving (Typeable)-deriving instance Eq HsName-deriving instance Ord HsName-deriving instance Show HsName-instance Serialize HsName where--data CTag deriving (Typeable)-deriving instance Eq CTag-deriving instance Ord CTag-deriving instance Show CTag-instance Serialize CTag where--mkHsName :: [String] -> String -> HsName-mkHsName = __IMPOSSIBLE__--mkHsName1 :: String -> HsName-mkHsName1 = __IMPOSSIBLE__--mkUniqueHsName :: String -> [String] -> String -> HsName-mkUniqueHsName = __IMPOSSIBLE__---- UHC.Light.Compiler.Core.API-data CModule-instance Serialize CModule-data CImport-data CExport-data CDeclMeta-data CDataCon--- dummy to use as parse result for core pragmas-data CExpr = CExpr_DUMMY deriving (Eq, Ord, Show, Typeable)-instance Serialize CExpr where-data CBind-data CAlt-data CPat-data CPatFld-data CPatRest--mkUnit :: EHCOpts -> CExpr-mkUnit = __IMPOSSIBLE__--mkInt :: EHCOpts -> Int -> CExpr-mkInt = __IMPOSSIBLE__--mkInteger :: EHCOpts -> Integer -> CExpr-mkInteger = __IMPOSSIBLE__--mkChar :: Char -> CExpr-mkChar = __IMPOSSIBLE__--mkString :: EHCOpts -> String -> CExpr-mkString = __IMPOSSIBLE__--mkError :: EHCOpts -> String -> CExpr-mkError = __IMPOSSIBLE__--mkUndefined :: EHCOpts -> CExpr-mkUndefined = __IMPOSSIBLE__--mkVar :: HsName -> CExpr-mkVar = __IMPOSSIBLE__--mkLet1Plain :: HsName -> CExpr -> CExpr -> CExpr-mkLet1Plain = __IMPOSSIBLE__--mkLet1Strict :: HsName -> CExpr -> CExpr -> CExpr-mkLet1Strict = __IMPOSSIBLE__--mkLetRec :: [CBind] -> CExpr -> CExpr-mkLetRec = __IMPOSSIBLE__--mkLam :: [HsName] -> CExpr -> CExpr-mkLam = __IMPOSSIBLE__--mkApp :: CExpr -> [CExpr] -> CExpr-mkApp = __IMPOSSIBLE__--mkBind1 :: HsName -> CExpr -> CBind-mkBind1 = __IMPOSSIBLE__--mkBind1Nm1 :: HsName -> CBind-mkBind1Nm1 = __IMPOSSIBLE__--mkCTag :: HsName -> HsName -> Int -> Int -> CTag-mkCTag = __IMPOSSIBLE__--destructCTag :: a -> (HsName -> HsName -> Int -> Int -> a) -> CTag -> a-destructCTag = __IMPOSSIBLE__--ctagUnit :: CTag-ctagUnit = __IMPOSSIBLE__--ctagTrue :: EHCOpts -> CTag-ctagTrue = __IMPOSSIBLE__--ctagFalse :: EHCOpts -> CTag-ctagFalse = __IMPOSSIBLE__--ctagCons :: EHCOpts -> CTag-ctagCons = __IMPOSSIBLE__--ctagNil :: EHCOpts -> CTag-ctagNil = __IMPOSSIBLE__--mkCase :: CExpr -> [CAlt] -> CExpr-mkCase = __IMPOSSIBLE__--mkAlt :: CPat -> CExpr -> CAlt-mkAlt = __IMPOSSIBLE__--mkPatCon :: CTag -> CPatRest -> [CPatFld] -> CPat-mkPatCon = __IMPOSSIBLE__--mkPatRestEmpty :: CPatRest-mkPatRestEmpty = __IMPOSSIBLE__--mkPatFldBind :: (HsName, CExpr) -> CBind -> CPatFld-mkPatFldBind = __IMPOSSIBLE__--mkTagTup :: CTag -> [CExpr] -> CExpr-mkTagTup = __IMPOSSIBLE__--mkModule :: HsName -> [CExport] -> [CImport] -> [CDeclMeta] -> CExpr -> CModule-mkModule = __IMPOSSIBLE__--mkImport :: HsName -> CImport-mkImport = __IMPOSSIBLE__--mkExport :: HsName -> CExport-mkExport = __IMPOSSIBLE__--mkMetaData :: HsName -> [CDataCon] -> CDeclMeta-mkMetaData = __IMPOSSIBLE__--mkMetaDataCon :: HsName -> Int -> Int -> CDataCon-mkMetaDataCon = __IMPOSSIBLE__--mkMetaDataConFromCTag :: CTag -> Maybe CDataCon-mkMetaDataConFromCTag = __IMPOSSIBLE__--mkMain :: HsName -> CExpr-mkMain = __IMPOSSIBLE__--parseExpr :: EHCOpts -> String -> Either [String] CExpr--- just always succeed, as we don't want to fail on UHC pragmas--- if the backend is disabled-parseExpr _ _ = Right CExpr_DUMMY--printModule :: EHCOpts -> CModule -> PP_Doc-printModule = __IMPOSSIBLE__--#endif----uhcBackendEnabled :: Bool-#if defined(UHC_BACKEND)-uhcBackendEnabled = True-#else-uhcBackendEnabled = False-#endif
− src/full/Agda/Compiler/UHC/CompileState.hs 
@@ -1,248 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances       #-}---- | Contains the state monad that the compiler works in and some functions---   for tampering with the state.-module Agda.Compiler.UHC.CompileState-  ( CompileT-  , Compile-  , runCompileT-  , CoreMeta--  , addExports-  , addMetaCon-  , addMetaData-  , getExports-  , getDeclMetas--  , getCoreName-  , getCoreName1-  , getConstrCTag-  , getConstrFun-  , moduleNameToCoreName-  , moduleNameToCoreNameParts-  , freshLocalName--  , conArityAndPars-  , dataRecCons-  )-where--import Control.Monad.State-import Control.Monad.Reader.Class-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Char--#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-#endif-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)--import Agda.Compiler.UHC.MagicTypes-import Agda.Syntax.Internal-import Agda.Syntax.Common-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Monad.Builtin hiding (coinductionKit')-import qualified Agda.TypeChecking.Monad as TM-import Agda.Compiler.UHC.Bridge-import Agda.Compiler.UHC.Pragmas.Base-import Agda.Compiler.Common--import Agda.Utils.Lens--#include "undefined.h"-import Agda.Utils.Impossible--import Data.Time.Clock.POSIX--getTime :: IO Integer-getTime = round <$> getPOSIXTime--data CoreMeta = CoreMeta-  { coreMetaData :: Map.Map QName ( [CDataCon] -> CDeclMeta )-  , coreMetaCon :: Map.Map QName [CDataCon] -- map data name to constructors-  , coreExports :: [CExport] -- ^ UHC core exports-  }--instance Semigroup CoreMeta where-  CoreMeta a b c <> CoreMeta r s t =-    CoreMeta (Map.union a r) (Map.unionWith (++) b s) (c ++ t)--instance Monoid CoreMeta where-  mempty = CoreMeta mempty mempty []-  mappend = (<>)---- | Stuff we need in our compiler-data CompileState = CompileState-  { coreMeta :: CoreMeta-  , nameSupply :: Integer-  }---- | Compiler monad-newtype CompileT m a = CompileT { unCompileT :: StateT CompileState m a }-  deriving (Monad, MonadIO, MonadTrans, Applicative, Functor)--type Compile = CompileT TCM---- | Used to run the Agda-to-UHC Core transformation.--- During this transformation,-runCompileT :: MonadIO m =>-       ModuleName   -- ^ The module to compile.-    -> CompileT m a-    -> m a-runCompileT amod comp = do-  (result, state') <- runStateT (unCompileT comp) initial--  return result-  where initial = CompileState-            { coreMeta = mempty-            , nameSupply = 0-            }--appendCoreMeta :: Monad m => CoreMeta -> CompileT m ()-appendCoreMeta cm =-  CompileT $ modify (\s -> s { coreMeta = cm `mappend` coreMeta s })--addExports :: Monad m => [HsName] -> CompileT m ()-addExports = addExports' . map mkExport--addExports' :: Monad m => [CExport] -> CompileT m ()-addExports' nms = appendCoreMeta (mempty { coreExports = nms })--addMetaCon :: QName -> CDataCon -> Compile ()-addMetaCon q c = do-  dtNm <- conData . theDef <$> lift (getConstInfo q)-  appendCoreMeta (mempty { coreMetaCon = Map.singleton dtNm [c] })--addMetaData :: QName -> ([CDataCon] -> CDeclMeta) -> Compile ()-addMetaData q d =-  appendCoreMeta (mempty { coreMetaData = Map.singleton q d })--getExports :: Compile [CExport]-getExports = CompileT $ gets (coreExports . coreMeta)--getDeclMetas :: Compile [CDeclMeta]-getDeclMetas = CompileT $ do-  cons <- gets (coreMetaCon . coreMeta)-  dts <- gets (coreMetaData . coreMeta)-  return $ map (\(dtNm, f) -> f (Map.findWithDefault [] dtNm cons)) (Map.toList dts)--freshLocalName :: Monad m => CompileT m HsName-freshLocalName = CompileT $ do-    i <- gets nameSupply-    modify (\s -> s { nameSupply = i + 1 } )-    return $ mkUniqueHsName "nl.uu.agda.fresh-local-name" [] ("x" ++ show i)---------------------- Constructors----------------------- | Returns the CTag for a constructor. Not defined--- for Sharp and magic __UNIT__ constructor.-getConstrCTag :: QName -> Compile CTag-getConstrCTag q = do-  def <- lift $ getConstInfo q-  (arity, _) <- lift $ conArityAndPars q-  case compiledCore $ defCompiledRep def of-    Nothing -> do-      let dtQ = conData $ theDef def-      -- get tag, which is the index of current con in datatype con list-      tag <- fromJust . elemIndex q . dataRecCons . theDef <$> lift (getConstInfo dtQ)-      mkCTag <$> getCoreName dtQ <*> (getCoreName q) <*> pure tag <*> pure arity-    Just (CrConstr crCon) -> do-      return $ coreConstrToCTag crCon arity-    _ -> __IMPOSSIBLE__----- | Returns the expression to use to build a value of the given datatype/constructor.-getConstrFun :: QName -> Compile HsName-getConstrFun q = do-  def <- lift $ getConstInfo q-  case compiledCore $ defCompiledRep def of-    Nothing -> getCoreName q-    Just (CrConstr crCon) ->-      return $-        destructCTag builtinUnitCtor (\_ con _ _ -> con)-          (coreConstrToCTag crCon 0) -- Arity doesn't matter here, as we immediately destruct the ctag again!-    _ -> __IMPOSSIBLE__--dataRecCons :: Defn -> [QName]-dataRecCons r@(Record{}) = [recCon r]-dataRecCons d@(Datatype{}) = dataCons d-dataRecCons _ = __IMPOSSIBLE__----------------------- Names---------------------- All agda modules live in their own namespace in Agda.XXX, to avoid--- clashes with existing haskell modules. (e.g. Data.List) with confusing error messages.--- If we don't wan't this, we would have to avoid loading the HS base libraries--- or would need package-specific imports. As we don't have this in UHC right now,--- this is the best we can do.-moduleNameToCoreNameParts :: ModuleName -> [String]-moduleNameToCoreNameParts modNm = "Agda" : (map show $ mnameToList modNm)--moduleNameToCoreName :: ModuleName -> HsName-moduleNameToCoreName modNm = mkHsName (init nmParts) (last nmParts)-  where nmParts = moduleNameToCoreNameParts modNm--getCoreName :: QName -> Compile HsName-getCoreName qnm = CompileT $ do-  lift $ getCoreName1 qnm--getCoreName1 :: QName -> TCM HsName-getCoreName1 qnm = do--  modNm <- topLevelModuleName (qnameModule qnm)--  def <- theDef <$> getConstInfo qnm--  let locName = intercalate "_" $ map show $ either id id $ unqualifyQ modNm qnm-      modParts = moduleNameToCoreNameParts modNm-      identName = locName ++ "_" ++ show idnum-      identName' = case def of-        Datatype{} -> capitalize identName-        Record{} -> capitalize identName-        Constructor{} -> capitalize identName-        _ -> identName--  return $ mkUniqueHsName "nl.uu.agda.top-level-def" modParts identName-  where-    idnum = let (NameId x _) = nameId $ qnameName qnm in x-    -- we don't really care about the original name, we just keep it for easier debugging-    capitalize (x:xs) = (toUpper x):xs-    capitalize _      = __IMPOSSIBLE__---- | Returns the names inside a QName, with the module prefix stripped away.--- If the name is not module-qualified, returns the full name as left. (TODO investigate when this happens)-unqualifyQ :: ModuleName -> QName -> Either [Name] [Name]-unqualifyQ modNm qnm =-  case stripPrefix modNs qnms of-    -- not sure when the name doesn't have a module prefix... just force generation of a name for the time being-    Nothing -> Left qnms-    Just nm -> Right nm-  where-    modNs = mnameToList modNm-    qnms = qnameToList qnm-----instance MonadReader r m => MonadReader r (CompileT m) where-  ask = lift ask-  local f (CompileT x) = CompileT $ local f x--instance MonadState s m => MonadState s (CompileT m) where-  get = lift get-  put = lift . put--instance MonadTCM m => MonadTCM (CompileT m) where-  liftTCM = lift . TM.liftTCM
− src/full/Agda/Compiler/UHC/Compiler.hs 
@@ -1,216 +0,0 @@-{-# LANGUAGE CPP             #-}---- | UHC compiler backend, main entry point.---- In the long term, it would be nice if we could use e.g. shake to--- build individual Agda modules. The problem with that is that some--- parts need to be in the TCM Monad, which doesn't easily work in--- shake. We would need a way to extract the information out of the--- TCM monad, so that we can pass it to the compilation function--- without pulling in the TCM Monad. Another minor problem might be--- error reporting?--module Agda.Compiler.UHC.Compiler(compilerMain) where--#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-import Data.Monoid-#endif--import Control.Monad-import Control.Monad.Reader-import Control.Monad.State-import qualified Data.ByteString.Lazy as BS-import qualified Data.Map as M-import Data.Maybe--import System.Directory ( canonicalizePath, createDirectoryIfMissing-                        , setCurrentDirectory-                        , doesDirectoryExist-                        , getDirectoryContents, copyFile-                        )-import Data.List as L-import System.Exit-import System.FilePath hiding (normalise)--import Paths_Agda-import Agda.Compiler.CallCompiler-import Agda.Interaction.FindFile-import Agda.Interaction.Options-import Agda.Interaction.Imports-import qualified Agda.Syntax.Concrete.Name as CN-import Agda.Syntax.Internal hiding (Term(..))-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Serialise-import Agda.Utils.FileName-import Agda.Utils.Pretty-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.IO.Directory-import Agda.Utils.Lens--import Agda.Compiler.UHC.CompileState-import Agda.Compiler.UHC.Bridge as UB-import qualified Agda.Compiler.UHC.FromAgda     as FAgda-import Agda.Compiler.Common--#include "undefined.h"-import Agda.Utils.Impossible---- for the time being, we just copy the base library into the generated code.--- We don't install it into the user db anymore, as that gets complicated when--- multiple Agda instances run concurrently.--- Just copying it is safe for the time being, as we only have full-program--- compilation at the moment.-copyUHCAgdaBase :: FilePath -> TCM ()-copyUHCAgdaBase outDir = do-    dataDir <- liftIO getDataDir-    let srcDir = dataDir </> "uhc-agda-base" </> "src" </> "UHC"--    liftIO $ copyDirContent srcDir (outDir </> "UHC")----- | Compile an interface into an executable using UHC-compilerMain :: IsMain -> Interface -> TCM ()-compilerMain isMain i = inCompilerEnv i $ do-    when (not uhcBackendEnabled) $ typeError $ GenericError "Agda has been built without UHC support. To use the UHC compiler you need to reinstall Agda with 'cabal install Agda -f uhc'."-    -- TODO we should do a version check here at some point.-    let uhc_exist = ExitSuccess-    case uhc_exist of-        ExitSuccess -> do--            copyUHCAgdaBase =<< compileDir--            doCompile isMain i $ \_ -> compileModule--            case isMain of-              IsMain -> do-                main <- getMain i-                -- get core name from modInfo-                crMain <- getCoreName1 main-                runUHCMain $ Just (iModuleName i, crMain)-              NotMain -> runUHCMain Nothing--        ExitFailure _ -> internalError $ unlines-           [ "Agda cannot find the UHC compiler."-           ]----- | Compiles a module and it's imports. Returns the module info--- of this module, and the accumulating module interface.-compileModule :: Interface -> TCM ()-compileModule i = do-    -- look for the Agda.Primitive interface in visited modules.-    -- (It will not be in ImportedModules, if it has not been-    -- explicitly imported)-    -- TODO this should be done in a more clean way-    [agdaPrimInter] <- filter (("Agda.Primitive"==) . prettyShow . iModuleName)-      . map miInterface . M.elems-        <$> getVisitedModules-    -- we can't use the Core module name to get the name of the aui file,-    -- as we don't know the Core module name before we loaded/compiled the file.-    -- (well, we could just compute the module name and use that, that's-    -- probably better? )-    let modNm = iModuleName i-    let topModuleName = toTopLevelModuleName modNm-    -- check if this module has already been compiled-    imports <- map miInterface . catMaybes-      <$> (mapM (getVisitedModule . toTopLevelModuleName . fst)-            (iImportedModules i))--    let imports' = if prettyShow (iModuleName i) == "Agda.Primitive"-                     then imports-                     else agdaPrimInter : imports--    reportSLn "compile.uhc" 1 $-      "Compiling: " ++ show (iModuleName i)-    code <- compileDefns modNm (map iModuleName imports') i-    crFile <- corePath modNm-    _ <- writeCoreFile crFile code-    return ()---corePath :: ModuleName -> TCM FilePath-corePath mName = do-  mdir <- compileDir-  let fp = mdir </> replaceExtension fp' "bcr"-  liftIO $ createDirectoryIfMissing True (takeDirectory fp)-  return fp-   where-    fp' = foldl1 (</>) $ moduleNameToCoreNameParts mName----getMain :: MonadTCM m => Interface -> m QName-getMain iface = case concatMap f defs of-    [] -> typeError $ GenericError $ "Could not find main."-    [x] -> return x-    _   -> __IMPOSSIBLE__-  where defs = HMap.toList $ iSignature iface ^. sigDefinitions-        f (qn, def) = case theDef def of-            (Function{}) | "main" == show (qnameName qn) -> [qn]-            _   -> []---- | Perform the chain of compilation stages, from definitions to UHC Core code-compileDefns :: ModuleName-    -> [ModuleName] -- ^ top level imports-    -> Interface -> TCM UB.CModule-compileDefns modNm curModImps iface = do--    crMod <- FAgda.fromAgdaModule modNm curModImps iface--    reportSLn "compile.uhc" 10 $ "Done generating Core for \"" ++ show modNm ++ "\"."-    return crMod--writeCoreFile :: String -> UB.CModule -> TCM ()-writeCoreFile f cmod = do-  useTextual <- optUHCTextualCore <$> commandLineOptions--  -- dump textual core, useful for debugging.-  when useTextual (do-    let f' = replaceExtension f ".dbg.tcr"-    reportSLn "compile.uhc" 10 $ "Writing textual core to \"" ++ show f' ++ "\"."-    liftIO $ putPPFile f' (UB.printModule defaultEHCOpts cmod) 200-    )--  reportSLn "compile.uhc" 10 $ "Writing binary core to \"" ++ show f ++ "\"."-  liftIO $ putSerializeFile f cmod---- | Create the UHC Core main file, which calls the Agda main function-runUHCMain-    :: Maybe (ModuleName, HsName)  -- main module-    -> TCM ()-runUHCMain mainInfo = do-    otherFps <- mapM (corePath . iModuleName . miInterface) =<< (M.elems <$> getVisitedModules)-    allFps <--      case mainInfo of-            Nothing -> return otherFps-            Just (mainMod, mainName) -> do-                fp <- (</> "Main.bcr") <$> compileDir-                let mmod = FAgda.createMainModule mainMod mainName-                writeCoreFile fp mmod-                return ["Main.bcr"]--    let extraOpts = maybe-            ["--compile-only"]-            ((\x -> [x]) . ("--output="++) . prettyShow . last . mnameToList . fst)-            mainInfo--    liftIO . setCurrentDirectory =<< compileDir--    -- TODO drop the RTS args as soon as we don't need the additional-    -- memory anymore-    callUHC1 $  [ "--pkg-hide-all"-                , "--pkg-expose=uhcbase"-                , "--pkg-expose=base"-                , "UHC/Agda/double.c"-                ] ++ extraOpts ++ allFps ++ ["+RTS", "-K50m", "-RTS"]--callUHC1 :: [String] -> TCM ()-callUHC1 args = do-    uhcBin <- getUhcBin-    doCall <- optUHCCallUHC <$> commandLineOptions-    extraArgs <- optUHCFlags <$> commandLineOptions-    callCompiler doCall uhcBin (args ++ extraArgs)--getUhcBin :: TCM FilePath-getUhcBin = fromMaybe ("uhc") . optUHCBin <$> commandLineOptions
− src/full/Agda/Compiler/UHC/FromAgda.hs 
@@ -1,376 +0,0 @@-{-# LANGUAGE CPP             #-}---- | Convert from Agda's internal representation to UHC Core via Treeless.--------- The coinduction kit is translated the same way as in MAlonzo:--- flat = id--- sharp = id--- -> There is no runtime representation of Coinductive values.-module Agda.Compiler.UHC.FromAgda where--#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-import Data.Traversable (traverse)-#endif--import Control.Monad-import Control.Monad.State-import Control.Monad.Reader-import qualified Data.Map as M-import Data.Maybe-import Data.Either-import Data.List-import qualified Data.Set as Set--import Agda.Syntax.Internal hiding (Term(..))-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Literal  as TL-import Agda.Syntax.Treeless (TTerm (..), TAlt (..))-import qualified Agda.Syntax.Treeless as C-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty-import Agda.Utils.List-import qualified Agda.Utils.Pretty as P-import qualified Agda.Utils.HashMap as HMap-import Agda.Syntax.Abstract.Name-import Agda.Syntax.Common--import Agda.Compiler.Common-import Agda.Compiler.ToTreeless-import Agda.Compiler.Treeless.GuardsToPrims-import Agda.Compiler.Treeless.NormalizeNames-import Agda.Compiler.Treeless.Pretty-import Agda.Compiler.UHC.Pragmas.Base-import Agda.Compiler.UHC.Pragmas.Parse (coreExprToCExpr)-import Agda.Compiler.UHC.CompileState-import Agda.Compiler.UHC.Primitives-import Agda.Compiler.UHC.MagicTypes--import Agda.Compiler.UHC.Bridge as CA--import Agda.Utils.Maybe-import Agda.Utils.Except ( MonadError (catchError) )-import Agda.Utils.Lens--#include "undefined.h"-import Agda.Utils.Impossible--opts :: EHCOpts-opts = defaultEHCOpts---- | Convert from Agda's internal representation to our auxiliary AST.-fromAgdaModule :: ModuleName-    -> [ModuleName]      -- imported modules.-    -> Interface         -- interface to compile-    -> TCM CModule-fromAgdaModule modNm curModImps iface = do--  -- Set correct pragma options-  setCommandLineOptions =<< gets (stPersistentOptions . stPersistentState)-  mapM_ setOptionsFromPragma (iPragmaOptions iface)--  -- sort defs to ensure consistent order (see Issue 1900)-  let defs = sortDefs $ iSignature iface ^. sigDefinitions--  runCompileT modNm (do-    lift $ reportSLn "compile.uhc" 10 "Translate datatypes..."--    funs' <- concat <$> mapM translateDefn defs-    let funs = mkLetRec funs' (mkInt opts 0)----    additionalImports <- lift getHaskellImportsUHC-    let imps = map mkImport $ nub $-          [ mkHsName1 "UHC.Base"-          , mkHsName1 "UHC.Agda.Builtins" ]-          ++ map moduleNameToCoreName curModImps-          ++ map mkHsName1 (Set.toList additionalImports)--        crModNm = moduleNameToCoreName modNm--    mkModule crModNm-      <$> getExports <*> pure imps <*> getDeclMetas <*> pure funs-    )----- | Translate an Agda definition to an UHC Core function where applicable-translateDefn :: (QName, Definition) -> Compile [CBind]-translateDefn (n, defini) = do--  crName <- getCoreName n-  let crRep = compiledCore $ defCompiledRep defini-  kit <- lift coinductionKit-  case theDef defini of-    d@(Datatype {}) -> do--        unless (isJust crRep || Just n == (nameOfInf <$> kit)) $ do-          addMetaData n (mkMetaData crName)--        vars <- replicateM (dataPars d + dataIxs d) freshLocalName-        addExports [crName]-        return [mkBind1 crName (mkLam vars $ mkUnit opts)]-    (Function{}) | Just n == (nameOfFlat <$> kit) -> do-        addExports [crName]-        (\x -> [x]) <$> mkIdentityFun n "coind-flat" 0-    f@(Function{}) | otherwise -> do-        let ty    = (defType defini)-        lift $ reportSDoc "compile.uhc.fromagda" 5 $ text "compiling fun:" <+> prettyTCM n-        lift $ reportSDoc "compile.uhc.fromagda" 15 $ text "type:" <+> (text . show) ty--        caseMaybeM (lift $ toTreeless n) (pure []) $ \ treeless -> do-          funBody <- convertGuards <$> lift (normalizeNames treeless)-          lift $ reportSDoc "compile.uhc.fromagda" 30 $ text " compiled treeless fun:" <+> (text . show) funBody-          funBody' <- runTT $ compileTerm funBody-          lift $ reportSDoc "compile.uhc.fromagda" 30 $ text " compiled UHC Core fun:" <+> (text . show) funBody'--          addExports [crName]-          return [mkBind1 crName funBody']--    Constructor{} | Just n == (nameOfSharp <$> kit) -> do-        addExports [crName]-        (\x -> [x]) <$> mkIdentityFun n "coind-sharp" 0--    (Constructor{}) | Nothing <- crRep -> do -- become functions returning a constructor with their tag-      -- we have to ignore instantiated constructors here!-      n' <- lift $ canonicalName n-      if (n /= n')-        then return []-        else do-          addExports [crName]-          ctag <- getConstrCTag n--          addMetaCon n (fromJust $ mkMetaDataConFromCTag ctag)--          vars <- replicateM (getCTagArity ctag) freshLocalName-          let conWrapper = mkLam vars (mkTagTup ctag $ map mkVar vars)-          return [mkBind1 crName conWrapper]-    Constructor{} -> return []-    -- either foreign or builtin type. We can just assume existence of the wrapper functions then.--    r@(Record{}) -> do-        unless (isJust crRep) $ do-          addMetaData n (mkMetaData crName)--        vars <- replicateM (recPars r) freshLocalName-        addExports [crName]-        return [mkBind1 crName (mkLam vars $ mkUnit opts)]-    (Axiom{}) -> do -- Axioms get their code from COMPILED_UHC pragmas-        addExports [crName]-        case crRep of-            Nothing -> return [mkBind1 crName-                (coreError $ "Axiom " ++ show n ++ " used but has no computation.")]-            Just (CrDefn x) -> do-                        x' <- case coreExprToCExpr x of-                                -- This can only happen if an *.agdai file was generated by an Agda version-                                -- without UHC support enabled.-                                Left err -> internalError $ "Invalid COMPILED_UHC pragma value: " ++ err-                                Right y -> return y-                        return [mkBind1 crName x']-            _ -> __IMPOSSIBLE__--    p@(Primitive{}) -> do -- Primitives use primitive functions from UHC.Agda.Builtins of the same name.-      addExports [crName]--      case primName p `M.lookup` primFunctions of-        Nothing     -> internalError $ "Primitive " ++ show (primName p) ++ " declared, but no such primitive exists."-        (Just expr) -> do-                expr' <- expr-                return [mkBind1 crName expr']-    AbstractDefn -> __IMPOSSIBLE__-  where-    -- | Produces an identity function, optionally ignoring the first n arguments.-    mkIdentityFun :: QName-        -> String -- ^ comment-        -> Int      -- ^ How many arguments to ignore.-        -> Compile CBind-    mkIdentityFun nm comment ignArgs = do-        crName <- getCoreName nm-        xs <- replicateM (ignArgs + 1) freshLocalName-        return $ mkBind1 crName (mkLam xs (mkVar $ last xs))---runTT :: TT a -> Compile a-runTT r = do-  r `runReaderT` (TTEnv [])--data TTEnv = TTEnv-  { nmEnv :: [HsName] -- maps de-bruijn indices to names-  }--type TT = ReaderT TTEnv Compile---addToEnv :: [HsName] -> TT a -> TT a-addToEnv nms cont =-  local (\e -> e { nmEnv = nms ++ (nmEnv e) }) cont--data BuiltinKit = BuiltinKit-  { isNat :: QName -> Bool-  , isInt :: QName -> Bool-  }--builtinKit :: TCM BuiltinKit-builtinKit =-  BuiltinKit <$> is dat builtinNat-             <*> is dat builtinInteger-  where-    dat (I.Def d _) = pure d-    dat _           = Nothing--    is a b = maybe (const False) (==) . (a =<<) <$> getBuiltin' b---- | Translate the actual Agda terms, with an environment of all the bound variables---   from patternmatching. Agda terms are in de Bruijn so we just check the new---   names in the position.-compileTerm :: C.TTerm -> TT CExpr-compileTerm term = do-  builtinKit' <- lift $ lift builtinKit-  case term of-    C.TPrim t -> return $ compilePrim t-    C.TVar x -> do-      nm <- fromMaybe __IMPOSSIBLE__ . (!!! x) <$> asks nmEnv-      return $ mkVar nm-    C.TDef nm -> do-      nm' <- lift $ getCoreName nm-      return $ mkVar nm'-    C.TApp t xs -> do-      mkApp <$> compileTerm t <*> mapM compileTerm xs-    C.TLam t -> do-       name <- lift freshLocalName-       addToEnv [name] $ do-         mkLam [name] <$> compileTerm t-    C.TLit l -> return $ litToCore l-    C.TCon c -> do-        con <- lift $ getConstrFun c-        return $ mkVar con-    C.TLet x body -> do-        nm <- lift freshLocalName-        mkLet1Plain nm-          <$> compileTerm x-          <*> addToEnv [nm] (compileTerm body)-    C.TCase sc (C.CTData dt) def alts | not (isNat builtinKit' dt || isInt builtinKit' dt) -> do-      -- normal constructor case-      caseScr <- lift freshLocalName-      defVar <- lift freshLocalName-      def' <- compileTerm def--      branches <- traverse compileConAlt alts-      defBranches <- defaultBranches dt alts (mkVar defVar)-      let cas = mkCase (mkVar caseScr) (branches ++ defBranches)-      caseScr' <- compileTerm (C.TVar sc)--      return $ mkLet1Plain defVar def' (mkLet1Strict caseScr caseScr' cas)--    C.TCase sc ct def alts | otherwise -> do-      -- cases on literals-      sc <- compileTerm (C.TVar sc)-      var <- lift freshLocalName-      def <- compileTerm def--      css <- buildPrimCases eq (mkVar var) alts def-      return $ mkLet1Strict var sc css-      where-        eq :: CExpr-        eq = case ct of-          C.CTChar -> mkVar $ primFunNm "primCharEquality"-          C.CTString -> mkVar $ primFunNm "primStringEquality"-          C.CTQName -> mkVar $ primFunNm "primQNameEquality"-          C.CTFloat -> mkVar $ primFunNm "primFloatEquality"-          C.CTNat -> mkVar $ primFunNm "primIntegerEquality"-          C.CTInt -> mkVar $ primFunNm "primIntegerEquality"-          _ -> __IMPOSSIBLE__--    C.TUnit -> unit-    C.TSort -> unit-    C.TErased -> unit-    C.TError e -> return $ case e of-      C.TUnreachable -> coreError $ "Unreachable code reached. This should never happen! Crashing..."-  where unit = return $ mkUnit opts---buildPrimCases :: CExpr -- ^ equality function-    -> CExpr    -- ^ case scrutinee (in WHNF)-    -> [C.TAlt]-    -> CExpr    -- ^ default value-    -> TT CExpr-buildPrimCases _ _ [] def = return def-buildPrimCases eq scr (b:brs) def = do-    var <- lift     freshLocalName-    e' <- compileTerm (C.aBody b)-    rec' <- buildPrimCases eq scr brs def--    let lit = litToCore $ C.aLit b-        eqTest = mkApp eq [scr, lit]--    return $ mkLet1Strict var eqTest (mkIfThenElse (mkVar var) e' rec')---- move to UHC Core API-mkIfThenElse :: CExpr -> CExpr -> CExpr -> CExpr-mkIfThenElse c t e = mkCase c [b1, b2]-  where b1 = mkAlt (mkPatCon (ctagTrue opts) mkPatRestEmpty []) t-        b2 = mkAlt (mkPatCon (ctagFalse opts) mkPatRestEmpty []) e--compileConAlt :: C.TAlt -> TT CAlt-compileConAlt a =-  makeConAlt (C.aCon a)-    (\vars -> addToEnv (reverse vars) $ compileTerm (C.aBody a))--makeConAlt :: QName -> ([HsName] -> TT CExpr) -> TT CAlt-makeConAlt con mkBody = do-  ctag <- lift $ getConstrCTag con-  vars <- lift $ replicateM (getCTagArity ctag) freshLocalName-  body <- mkBody vars--  let patFlds = [mkPatFldBind (mkHsName [] "", mkInt opts i) (mkBind1Nm1 v) | (i, v) <- zip [0..] vars]-  return $ mkAlt (mkPatCon ctag mkPatRestEmpty patFlds) body---- | Constructs an alternative for all constructors not explicitly matched by a branch.-defaultBranches :: QName -> [C.TAlt] -> CExpr -> TT [CAlt]-defaultBranches dt alts def = do-  dtCons <- dataRecCons . theDef <$> (lift . lift) (getConstInfo dt)-  let altCons = map C.aCon alts-      missingCons = dtCons \\ altCons--  mapM (\a -> makeConAlt a (\_ -> return def)) missingCons--litToCore :: Literal -> CExpr-litToCore (LitNat _ i)   = mkApp (mkVar $ primFunNm "primIntegerToNat") [mkInteger opts i]-litToCore (LitString _ s) = mkString opts s-litToCore (LitChar _ c)  = mkChar c--- UHC and GHC handle trailing zeros slightly different. Work around to make sure--- we have the same semantics as MAlonzo.-litToCore (LitFloat _ f) = mkApp (mkVar $ primFunNm "primMkFloat") [mkString opts (show f)]-litToCore (LitQName _ q) = mkApp (mkVar $ primFunNm "primMkQName")-                             [mkInteger opts $ fromIntegral n, mkInteger opts $ fromIntegral m,-                              mkString opts $ P.prettyShow q]-  where NameId n m = nameId $ qnameName q-litToCore LitMeta{} = __IMPOSSIBLE__--getCTagArity :: CTag -> Int--- for records/datatypes, we can always extract the arity. If there is no arity,--- it is the unit constructor, so just return zero.-getCTagArity = destructCTag 0 (\_ _ _ ar -> ar)--coreError :: String -> CExpr-coreError msg = mkError opts $ "Fatal error: " ++ msg--compilePrim :: C.TPrim -> CExpr-compilePrim C.PQuot = mkVar $ primFunNm "primIntegerQuot"-compilePrim C.PRem = mkVar $ primFunNm "primIntegerRem"-compilePrim C.PSub = mkVar $ primFunNm "primIntegerMinus"-compilePrim C.PAdd = mkVar $ primFunNm "primIntegerPlus"-compilePrim C.PMul = mkVar $ primFunNm "primIntegerTimes"-compilePrim C.PIf  = mkVar $ primFunNm "primIfThenElse"-compilePrim C.PGeq = mkVar $ primFunNm "primIntegerGreaterOrEqual"-compilePrim C.PLt  = mkVar $ primFunNm "primIntegerLess"-compilePrim p | C.isPrimEq p = mkVar $ primFunNm "primIntegerEquality"-compilePrim C.PSeq = mkVar $ primFunNm "primSeq"-compilePrim _ = __IMPOSSIBLE__---createMainModule :: ModuleName -> HsName -> CModule-createMainModule mainMod main = mkModule (mkHsName [] "Main") [] [mkImport $ mkHsName1 "UHC.Run", mkImport mainModAux] [] (mkMain main)-  where mainModAux = moduleNameToCoreName mainMod
− src/full/Agda/Compiler/UHC/MagicTypes.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}--- | Defines some magic builtin datatypes.-module Agda.Compiler.UHC.MagicTypes-(   builtinUnitCtor-  , MagicName-  , getMagicTypes-  , MagicConstrInfo-  , MagicTypeInfo-  , HsDataType (..)-  )-where--import Data.List-import qualified Data.Map as M--import Agda.Compiler.UHC.Bridge----- | name of a magic, differently translated datatype/constructor-type MagicName = String--data HsDataType-  = HsDataType HsName-  | HsUnit--type MagicConstrInfo = M.Map MagicName CTag -- maps primitive names to constructor ctags-type MagicTypeInfo = M.Map MagicName (HsDataType, MagicConstrInfo) -- maps types to the UHC Core name--- (or nothing for unit) and to their constructors.--getMagicTypes :: MagicTypeInfo-getMagicTypes = M.fromList $ map f primCrTys1-  where f :: (MagicName, [(MagicName, CTag)]) -> (MagicName, (HsDataType, MagicConstrInfo))-        f (dtMgcNm, constrs) = let dtCrNm = ctagDataTyNm $ snd $ head constrs-                                in (dtMgcNm, (dtCrNm, M.fromList constrs))---- | Returns the name of the datatype or 'Nothing' for the unit datatype.-ctagDataTyNm :: CTag -> HsDataType-ctagDataTyNm = destructCTag HsUnit (\dt _ _ _ -> HsDataType dt)---primCrTys1 :: [(-      MagicName    -- the magic name of the dt in COMPILED_DATA_UHC pragmas-    , [(MagicName, CTag)] -- constructors. Maps magic name to constructor tags.-    )]-primCrTys1 =-          [( "BOOL",-                [ ("TRUE",   ctagTrue defaultEHCOpts)-                , ("FALSE",  ctagFalse defaultEHCOpts)-                ])-          , ("LIST",-                [ ("NIL",  ctagNil defaultEHCOpts)-                , ("CONS", ctagCons defaultEHCOpts)-                ])-          , ("UNIT",-                [("UNIT", ctagUnit)])-          ]--builtinUnitCtor :: HsName-builtinUnitCtor = mkHsName1 "UHC.Agda.Builtins.unit"
− src/full/Agda/Compiler/UHC/Pragmas/Base.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Defines UHC Core functions used in other parts of Agda.--- E.g. parsing Core pragmas uses the `parseCoreCode` function.-module Agda.Compiler.UHC.Pragmas.Base-  ( CoreExpr,-    CoreType (..),-    CoreConstr (..),-    coreConstrToCTag,-    setTag,-    HsName-  )-where---import Data.Typeable-import qualified Data.Map as M--import Agda.Compiler.UHC.Bridge as CA-import Agda.Compiler.UHC.MagicTypes--#include "undefined.h"-import Agda.Utils.Impossible----data CoreType-  = CTMagic MagicName -- ^ Magic name-  | CTNormal String -- Core Datatype name-  deriving (Eq, Show, Typeable)---- We store the COMPILED_UHC pragmas as string,--- as storing the UHC AST makes the serialization--- format dependent on uhc-light. This also makes it--- possible to just store COMPILED_UHC pragmas unchecked--- in the interface file, if the UHC backend is disabled.-type CoreExpr = String---- We need an explicit representation for constructors, as we need to serialise the CoreConstr--- to store it inside agdai files. Else we could just use a partially applied--- CTag constructor instead (we don't know the arity yet...).-data CoreConstr-  = CCMagic MagicName MagicName -- Magic type constructor with fixed arity; (datatype, ctor)-  | CCNormal HsName HsName Int -- Normall UHC Core Constructor; (datatype, constr, tag)-  deriving (Eq, Show, Typeable)---setTag :: CoreConstr -> Int -> CoreConstr-setTag (CCNormal a b _) t = CCNormal a b t-setTag _ _ = __IMPOSSIBLE__--coreConstrToCTag :: CoreConstr-    -> Int -- ^ Arity-    -> CTag-coreConstrToCTag (CCMagic dtMgcNm conMgcNm) _ = conMp M.! conMgcNm-  where (_, conMp) = getMagicTypes M.! dtMgcNm-coreConstrToCTag (CCNormal dt con tg) ar = mkCTag dt con tg ar
− src/full/Agda/Compiler/UHC/Pragmas/Parse.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Defines UHC Core functions used in other parts of Agda.--- E.g. parsing Core pragmas uses the `parseCoreCode` function.-module Agda.Compiler.UHC.Pragmas.Parse-  ( module Agda.Compiler.UHC.Pragmas.Base-  , parseCoreExpr-  , coreExprToCExpr-  , parseCoreData-  , parseCoreConstrs-  )--where---import Data.List-import qualified Data.Map as M--import Agda.TypeChecking.Monad-import Agda.Compiler.UHC.Pragmas.Base-import Agda.Compiler.UHC.MagicTypes--import Agda.Compiler.UHC.Bridge as CA--#include "undefined.h"-import Agda.Utils.Impossible---- | Parse a COMPILED_DATA_UHC specification.-parseCoreData :: MonadTCM m => String -> m CoreType-parseCoreData dt = do-  isDtMgc <- isMagicEntity getMagicTypes dt "datatype"-  return $ case isDtMgc of-    Nothing         -> CTNormal dt-    Just (dtMgc, _) -> CTMagic dtMgc--parseCoreConstrs :: MonadTCM m => CoreType -> [String] -> m [CoreConstr]-parseCoreConstrs (CTNormal dtCrNm) cs = do-  constrs <- mapM parseNormalConstr cs-  -- UHC assigns tags in lexographical order.-  -- Requires that the mapping is complete, else it will break.-  return $ zipWith setTag (sortBy ccOrd constrs) [0..]-    where-        parseNormalConstr :: MonadTCM m => String -> m CoreConstr-        parseNormalConstr c-            | isMagic c =  typeError $-                GenericError $ "Magic constructor " ++ (drop 2 $ init $ init c) ++ " can only be used for magic datatypes."-            | otherwise = let dtMod = dropWhileEnd (/='.') dtCrNm-                              conNm = dtMod ++ c-                           -- tag gets assigned after we have parsed all ctors-                           in return $ CCNormal (mkHsName1 dtCrNm) (mkHsName1 conNm) __IMPOSSIBLE__-        ccOrd :: CoreConstr -> CoreConstr -> Ordering-        ccOrd (CCNormal dtNm1 ctNm1 _) (CCNormal dtNm2 ctNm2 _) | dtNm1 == dtNm2 = compare ctNm1 ctNm2-        ccOrd _ _ = __IMPOSSIBLE__--parseCoreConstrs (CTMagic dtMgcNm) cs = do-  mapM parseMagicConstr cs-    where-        (_, conMp) = getMagicTypes M.! dtMgcNm-        parseMagicConstr :: MonadTCM m => String ->  m CoreConstr-        parseMagicConstr c-            | not (isMagic c) = typeError $-                GenericError $ "A magic datatype can only have magic constructors."-            | otherwise = do-                (Just (conMgcNm, _)) <- isMagicEntity conMp c "constructor"-                return $ CCMagic dtMgcNm conMgcNm----- | Parse a COMPILED_UHC expression.-parseCoreExpr :: String -> Either String CoreExpr-#if defined(UHC_BACKEND)-parseCoreExpr str = either Left (const $ Right str) (coreExprToCExpr str)-#else--- we don't have the uhc-light parser, so just succeed here.-parseCoreExpr str = Right str-#endif--coreExprToCExpr :: CoreExpr -> Either String CExpr-#if defined(UHC_BACKEND)-coreExprToCExpr str = case CA.parseExpr defaultEHCOpts str of-    (Left errs) -> Left $ intercalate "\n" errs-    (Right res) -> Right res-#else-coreExprToCExpr = __IMPOSSIBLE__-#endif---- | Check if the given name is a valid Magic entity.-isMagicEntity :: MonadTCM m-    => M.Map MagicName a    -- ^ lookup table-    -> String   -- ^ name to lookup.-    -> String   -- ^ type of the entity. Used for errors messages.-    -> m (Maybe (String, a))-isMagicEntity tbl xs ty | isMagic xs =-  case nm `M.lookup` tbl of-    Just x -> return $ Just (nm, x)-    Nothing -> typeError $ GenericError $ "No magic " ++ ty ++ " with the name " ++ nm ++ " exists."-  where nm = init $ init $ drop 2 xs-isMagicEntity _ _ _ | otherwise = return Nothing---- | Checks if the given name is syntactically a Magic name.--- A syntactally correct magic name is NOT necessarily a valid magic name.-isMagic :: String -> Bool-isMagic xs = "__" `isPrefixOf` xs && "__" `isSuffixOf` xs
− src/full/Agda/Compiler/UHC/Primitives.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE CPP #-}--- | Defines some primitive functions.-module Agda.Compiler.UHC.Primitives-  ( primFunNm-  , primFunctions-  )-where--import Agda.Compiler.UHC.CompileState-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import qualified Agda.Syntax.Internal as T-import Control.Monad.Trans--#include "undefined.h"-import Agda.Utils.Impossible--#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-#endif--import qualified Data.Map as M-import Data.Maybe--import Agda.Compiler.UHC.Bridge--primFunNm :: String -> HsName-primFunNm = mkHsName ["UHC", "Agda", "Builtins"]---- | Primitives defined for the UHC backend. Maps primitive names to the core expression to be used as function body.-primFunctions :: M.Map String ((CompileT TCM) CExpr)-primFunctions = M.fromList $-    [(n, return $ mkVar (primFunNm n)) | n <--        [-        -- Level-          "primLevelMax"-        , "primLevelZero"-        , "primLevelSuc"-        -- Integer-        , "primShowInteger"-        -- Nat-        , "primNatPlus"-        , "primNatTimes"-        , "primNatMinus"-        , "primNatDivSuc"-        , "primNatDivSucAux"-        , "primNatModSuc"-        , "primNatModSucAux"-        , "primNatToInteger"-        , "primNatEquality"-        , "primNatLess"-        , "primIntegerToNat"-        -- String-        , "primStringAppend"-        , "primStringEquality"-        , "primStringFromList"-        , "primStringToList"-        , "primShowString"-        -- Char-        , "primCharToNat"-        , "primCharEquality"-        , "primShowChar"-        , "primIsLower"-        , "primIsDigit"-        , "primIsAlpha"-        , "primIsSpace"-        , "primIsAscii"-        , "primIsLatin1"-        , "primIsPrint"-        , "primIsHexDigit"-        , "primToUpper"-        , "primToLower"-        , "primNatToChar"-        -- Float-        , "primShowFloat"-        , "primFloatEquality"-        , "primFloatNumericalEquality"-        , "primFloatNumericalLess"-        , "primNatToFloat"-        , "primFloatPlus"-        , "primFloatMinus"-        , "primFloatTimes"-        , "primFloatNegate"-        , "primFloatDiv"-        , "primFloatSqrt"-        , "primRound"-        , "primFloor"-        , "primCeiling"-        , "primExp"-        , "primLog"-        , "primSin"-        , "primCos"-        , "primTan"-        , "primASin"-        , "primACos"-        , "primATan"-        , "primATan"-        , "primATan2"-        -- Reflection-        , "primQNameEquality"-        , "primQNameLess"-        , "primShowQName"-        , "primQNameFixity"-        , "primMetaEquality"-        , "primMetaLess"-        , "primShowMeta"-        ]-    ] ++ [-        ("primTrustMe", mkTrustMe)-    ]-  where mkTrustMe = do-            -- lookup refl constructor-            bt <- fromMaybe __IMPOSSIBLE__ <$> (lift $ getBuiltin' builtinRefl)-            let reflNm = case T.ignoreSharing bt of-                    (T.Con conHd _ []) -> T.conName conHd-                    _                -> __IMPOSSIBLE__--            mkVar <$> getConstrFun reflNm
src/full/Agda/ImpossibleTest.hs view
@@ -1,9 +1,22 @@-{-# LANGUAGE CPP #-}+-- | Facility to test throwing internal errors.  module Agda.ImpossibleTest where -#include "undefined.h"-import Agda.Utils.Impossible+import Agda.TypeChecking.Monad.Base   ( TCM, ReduceM, runReduceM )+import Agda.TypeChecking.Monad.Debug  ( MonadDebug, __IMPOSSIBLE_VERBOSE__ )+import Agda.TypeChecking.Reduce.Monad () -impossibleTest :: a-impossibleTest = __IMPOSSIBLE__+import Agda.Utils.CallStack           ( HasCallStack )+import Agda.Utils.Impossible          ( __IMPOSSIBLE__ )++-- | If the given list of words is non-empty, print them as debug message+--   (using '__IMPOSSIBLE_VERBOSE__') before raising the internal error.+impossibleTest :: (MonadDebug m, HasCallStack) => [String] -> m a+impossibleTest = \case+  []   -> __IMPOSSIBLE__+  strs -> __IMPOSSIBLE_VERBOSE__ $ unwords strs++impossibleTestReduceM :: (HasCallStack) => [String] -> TCM a+impossibleTestReduceM = runReduceM . \case+  []   -> __IMPOSSIBLE__+  strs -> __IMPOSSIBLE_VERBOSE__ $ unwords strs
+ src/full/Agda/Interaction/AgdaTop.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.AgdaTop+    ( repl+    ) where++import Control.Monad                ( unless )+import Control.Monad.IO.Class       ( MonadIO(..) )+import Control.Monad.State          ( evalStateT, runStateT )+import Control.Monad.Trans          ( lift )++import Data.Char++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++----------------------------------++-- | 'repl' is a fake ghci interpreter for both the Emacs the JSON frontend+repl :: InteractionOutputCallback -> String -> TCM () -> TCM ()+repl callback prompt setup = do+    liftIO $ do+      hSetBuffering stdout LineBuffering+      hSetBuffering stdin  LineBuffering+      hSetEncoding  stdout utf8+      hSetEncoding  stdin  utf8++    setInteractionOutputCallback callback++    commands <- liftIO $ initialiseCommandQueue readCommand++    handleCommand_ (lift setup) `evalStateT` initCommandState commands++    opts <- commandLineOptions+    _ <- interact' `runStateT`+           (initCommandState commands)+             { optionsOnReload = opts{ optAbsoluteIncludePaths = [] } }+    return ()+  where+  interact' :: CommandM ()+  interact' = do+    Bench.reset+    done <- Bench.billTo [] $ do++      liftIO $ do+        putStr prompt+        hFlush stdout+      r <- maybeAbort runInteraction+      case r of+        Done      -> return True -- Done.+        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'++  -- Reads the next command from stdin.++  readCommand :: IO Command+  readCommand = do+    done <- isEOF+    if done then+      return Done+    else do+      r <- getLine+      _ <- return $! length r     -- force to read the full input line+      case dropWhile isSpace r of+        ""          -> readCommand+        ('-':'-':_) -> readCommand+        _           -> case parseIOTCM r of+          Right cmd -> return $ Command cmd+          Left err  -> return $ Error err
+ src/full/Agda/Interaction/Base.hs view
@@ -0,0 +1,505 @@+{-# OPTIONS_GHC -fno-cse #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++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+import           Control.Monad.State++import qualified Data.List                    as List+import           Data.Map                     (Map)+import qualified Data.Map                     as Map+import           Data.Maybe                   (listToMaybe)+import qualified Data.Text                    as T++import Agda.TypeChecking.Monad.Base.Types+  (HighlightingLevel, HighlightingMethod, Comparison, Polarity)++import           Agda.Syntax.Abstract         (QName)+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.Syntax.Common.Pretty            (Pretty(..), prettyShow, text)+import           Agda.Utils.Time              (ClockTime)++------------------------------------------------------------------------+-- The CommandM monad++-- | Auxiliary state of an interactive computation.++data CommandState = CommandState+  { theInteractionPoints :: [InteractionId]+    -- ^ The interaction points of the buffer, in the order in which+    --   they appear in the buffer. The interaction points are+    --   recorded in 'theTCState', but when new interaction points are+    --   added by give or refine Agda does not ensure that the ranges+    --   of later interaction points are updated.+  , theCurrentFile       :: Maybe CurrentFile+    -- ^ The file which the state applies to. Only stored if the+    -- module was successfully type checked (potentially with+    -- warnings).+  , optionsOnReload      :: CommandLineOptions+    -- ^ Reset the options on each reload to these.+  , oldInteractionScopes :: !OldInteractionScopes+    -- ^ We remember (the scope of) old interaction points to make it+    --   possible to parse and compute highlighting information for the+    --   expression that it got replaced by.+  , commandQueue         :: !CommandQueue+    -- ^ The command queue.+    --+    -- This queue should only be manipulated by+    -- 'initialiseCommandQueue' and 'maybeAbort'.+  }++type OldInteractionScopes = Map InteractionId ScopeInfo++-- | Initial auxiliary interaction state++initCommandState :: CommandQueue -> CommandState+initCommandState commandQueue =+  CommandState+    { theInteractionPoints = []+    , theCurrentFile       = Nothing+    , optionsOnReload      = defaultOptions+    , oldInteractionScopes = Map.empty+    , commandQueue         = commandQueue+    }++-- | 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++-- | A generalised command type.++data Command' a+  = Command !a+    -- ^ A command.+  | Done+    -- ^ Stop processing commands.+  | Error String+    -- ^ An error message for a command that could not be parsed.+  deriving Show++-- | IOTCM commands.++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+  { commands :: !(TChan (Integer, Command))+    -- ^ Commands that should be processed, in the order in which they+    -- should be processed. Each command is associated with a number,+    -- and the numbers are strictly increasing. Abort commands are not+    -- put on this queue.+  , abort    :: !(TVar (Maybe Integer))+    -- ^ When this variable is set to @Just n@ an attempt is made to+    -- abort all commands with a command number that is at most @n@.+  }+++----------------------------------------------------------------------------+-- | An interactive computation.++type Interaction = Interaction' Range++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_constraints++    -- | Show unsolved metas. If there are no unsolved metas but unsolved constraints+    -- 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++    -- | Shows all the top-level names in scope which mention all the given+    -- identifiers in their type.+  | Cmd_search_about_toplevel Rewrite String++    -- | Solve (all goals / the goal at point) whose values are determined by+    -- the constraints.+  | Cmd_solveAll Rewrite+  | Cmd_solveOne Rewrite InteractionId range String++    -- | 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++    -- | 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++    ------------------------------------------------------------------------+    -- 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+    -- information for the module in @source@, and asks Emacs to apply+    -- highlighting info from this file.+    --+    -- If the module does not exist, or its module name is malformed or+    -- cannot be determined, or the module has not already been visited,+    -- or the cached info is out of date, then no highlighting information+    -- is printed.+    --+    -- This command is used to load syntax highlighting information when a+    -- new file is opened, and it would probably be annoying if jumping to+    -- the definition of an identifier reset the proof state, so this+    -- command tries not to do that. One result of this is that the+    -- command uses the current include directories, whatever they happen+    -- to be.+  | Cmd_load_highlighting_info FilePath++    -- | Tells Agda to compute token-based highlighting information+    -- for the file.+    --+    -- This command works even if the file's module name does not+    -- match its location in the file system, or if the file is not+    -- scope-correct. Furthermore no file names are put in the+    -- generated output. Thus it is fine to put source code into a+    -- temporary file before calling this command. However, the file+    -- extension should be correct.+    --+    -- If the second argument is 'Remove', then the (presumably+    -- temporary) file is removed after it has been read.+  | Cmd_tokenHighlighting FilePath Remove++    -- | Tells Agda to compute highlighting information for the expression just+    --   spliced into an interaction point.+  | Cmd_highlight InteractionId range String++    ------------------------------------------------------------------------+    -- Implicit arguments++    -- | Tells Agda whether or not to show implicit arguments.+  | ShowImplicitArgs Bool-- Show them?+++    -- | Toggle display of implicit arguments.+  | ToggleImplicitArgs++    ------------------------------------------------------------------------+    -- Irrelevant arguments++    -- | Tells Agda whether or not to show irrelevant arguments.+  | ShowIrrelevantArgs Bool -- Show them?++    -- | Toggle display of irrelevant arguments.+  | ToggleIrrelevantArgs++    ------------------------------------------------------------------------+    -- | Goal commands+    --+    -- If the range is 'noRange', then the string comes from the+    -- minibuffer rather than the goal.++  | Cmd_give            UseForce InteractionId range String++  | Cmd_refine          InteractionId range String++  | Cmd_intro           Bool InteractionId range String++  | Cmd_refine_or_intro Bool InteractionId range String++  | Cmd_context         Rewrite InteractionId range String++  | Cmd_helper_function Rewrite InteractionId range String++  | Cmd_infer           Rewrite InteractionId range String++  | Cmd_goal_type       Rewrite InteractionId range String++  -- | Grabs the current goal's type and checks the expression in the hole+  -- against it. Returns the elaborated term.+  | Cmd_elaborate_give+                        Rewrite InteractionId range String++    -- | Displays the current goal and context.+  | Cmd_goal_type_context Rewrite InteractionId range String++    -- | Displays the current goal and context /and/ infers the type of an+    -- expression.+  | Cmd_goal_type_context_infer+                        Rewrite InteractionId range String++  -- | Grabs the current goal's type and checks the expression in the hole+  -- against it.+  | Cmd_goal_type_context_check+                        Rewrite InteractionId range String++    -- | Shows all the top-level names in the given module, along with+    -- their types. Uses the scope of the given goal.+  | Cmd_show_module_contents+                        Rewrite InteractionId range String++  | Cmd_make_case       InteractionId range String++  | Cmd_compute         ComputeMode+                        InteractionId range String++  | Cmd_why_in_scope    InteractionId range String+  | Cmd_why_in_scope_toplevel String+    -- | Displays version of the running Agda+  | Cmd_show_version+  | Cmd_abort+    -- ^ Abort the current computation.+    --+    -- Does nothing if no computation is in progress.+  | Cmd_exit+    -- ^ Exit the program.+        deriving (Show, Read, Functor, Foldable, Traversable)++data IOTCM' range+    = IOTCM+        FilePath+         -- -^ The current file. If this file does not match+         -- 'theCurrentFile, and the 'Interaction' is not+         -- \"independent\", then an error is raised.+        HighlightingLevel+        HighlightingMethod+        (Interaction' range)+         -- -^ What to do+            deriving (Show, Read, Functor, Foldable, Traversable)++-- | Used to indicate whether something should be removed or not.++data Remove+  = Remove+  | Keep+  deriving (Show, Read)+++++---------------------------------------------------------+-- 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.++type Parse a = ExceptT String (StateT String Identity) a++-- | Converter from the type of 'reads' to 'Parse'+--   The first paramter is part of the error message+--   in case the parse fails.++readsToParse :: String -> (String -> Maybe (a, String)) -> Parse a+readsToParse s f = do+  st <- lift get+  case f st of+    Nothing -> throwError s+    Just (a, st) -> do+        lift $ put st+        return a++parseToReadsPrec :: Parse a -> Int -> String -> [(a, String)]+parseToReadsPrec p i s = case runIdentity . flip runStateT s . runExceptT $ parens' p of+  (Right a, s) -> [(a,s)]+  _            -> []++-- | Demand an exact string.++exact :: String -> Parse ()+exact s = readsToParse (show s) $ fmap ((),) . List.stripPrefix s . dropWhile (== ' ')++readParse :: Read a => Parse a+readParse = readsToParse "read failed" $ listToMaybe . reads++parens' :: Parse a -> Parse a+parens' p = do+    exact "("+    x <- p+    exact ")"+    return x+  `mplus`+    p++instance Read InteractionId where+    readsPrec = parseToReadsPrec $+        fmap InteractionId readParse++-- | Note that the grammar implemented by this instance does not+-- necessarily match the current representation of ranges.++instance Read a => Read (Range' a) where+    readsPrec = parseToReadsPrec $+      (exact "intervalsToRange" >>+       liftM2 intervalsToRange readParse readParse)+        `mplus`+      (exact "noRange" >> return noRange)++instance Read a => Read (Interval' a) where+    readsPrec = parseToReadsPrec $ do+        exact "Interval"+        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"+        liftM4 Pn readParse readParse readParse readParse++---------------------------------------------------------+-- | Available backends.++data CompilerBackend = LaTeX | QuickLaTeX | OtherBackend BackendName+    deriving (Eq)++-- TODO 2021-08-25 get rid of custom Show instance+instance Show CompilerBackend where+  show = prettyShow++instance Pretty CompilerBackend where+  pretty = \case+    LaTeX          -> "LaTeX"+    QuickLaTeX     -> "QuickLaTeX"+    OtherBackend s -> pretty s++instance Read CompilerBackend where+  readsPrec _ s = do+    (t, s) <- lex s+    let b = case t of+              "LaTeX"      -> LaTeX+              "QuickLaTeX" -> QuickLaTeX+              _            -> OtherBackend $ T.pack t+    return (b, s)++-- | Ordered ascendingly by degree of normalization.+data Rewrite =  AsIs | Instantiated | HeadNormal | Simplified | Normalised+    deriving (Show, Read, Eq, Ord)++data ComputeMode = DefaultCompute | HeadCompute | IgnoreAbstract | UseShowInstance+  deriving (Show, Read, Eq)++data UseForce+  = WithForce     -- ^ Ignore additional checks, like termination/positivity...+  | WithoutForce  -- ^ Don't ignore any checks.+  deriving (Eq, Read, Show)++data OutputForm_boot tcErr a b = OutputForm Range [ProblemId] Blocker (OutputConstraint_boot tcErr a b)+  deriving (Functor)++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+                   | CmpLevels Comparison b b+                   | CmpTeles Comparison b b+      | JustSort b | CmpSorts Comparison b b+      | Assign b a | TypedAssign b a a | PostponedCheckArgs b [a] a a+      | IsEmptyType a+      | SizeLtSat a+      | FindInstanceOF b a [(a,a,a)]+      | ResolveInstanceOF QName+      | PTSInstance b b+      | PostponedCheckFunDef QName a tcErr+      | CheckLock b b+      | DataSort QName b+      | UsableAtMod Modality b+  deriving (Functor)++-- | A subset of 'OutputConstraint'.++data OutputConstraint' a b = OfType'+  { ofName :: b+  , ofExpr :: a+  }++data OutputContextEntry name ty val+  = ContextVar name ty+  | ContextLet name ty val
src/full/Agda/Interaction/BasicOps.hs view
@@ -1,952 +1,1455 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE UndecidableInstances  #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.Interaction.BasicOps where--import Prelude hiding (null)--import Control.Arrow ((***), first, second)-import Control.Applicative hiding (empty)-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Identity--import qualified Data.Map as Map-import Data.List hiding (null)-import Data.Maybe-import Data.Traversable hiding (mapM, forM, for)-import Data.Monoid--import qualified Agda.Syntax.Concrete as C -- ToDo: Remove with instance of ToConcrete-import Agda.Syntax.Position-import Agda.Syntax.Abstract as A hiding (Open, Apply, Assign)-import Agda.Syntax.Abstract.Views as A-import Agda.Syntax.Abstract.Pretty-import Agda.Syntax.Common-import Agda.Syntax.Info (ExprInfo(..),MetaInfo(..),emptyMetaInfo,exprNoRange)-import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Internal as I-import Agda.Syntax.Literal-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Translation.AbstractToConcrete-import Agda.Syntax.Translation.ConcreteToAbstract-import Agda.Syntax.Scope.Base-import Agda.Syntax.Scope.Monad-import Agda.Syntax.Fixity(Precedence(..))-import Agda.Syntax.Parser--import Agda.TheTypeChecker-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Monad as M hiding (MetaInfo)-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.With-import Agda.TypeChecking.Coverage-import Agda.TypeChecking.Records-import Agda.TypeChecking.Irrelevance (wakeIrrelevantVars)-import Agda.TypeChecking.Pretty (prettyTCM)-import Agda.TypeChecking.Free-import Agda.TypeChecking.CheckInternal-import Agda.TypeChecking.SizedTypes.Solve-import qualified Agda.TypeChecking.Pretty as TP--import Agda.Termination.TermCheck (termMutual)--import Agda.Utils.Except ( Error(strMsg), MonadError(catchError, throwError) )-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty-import Agda.Utils.Permutation-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible---- | Parses an expression.--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"-  return e-  where pos = fromMaybe (startPos Nothing) $ rStart rng--parseExprIn :: InteractionId -> Range -> String -> TCM Expr-parseExprIn ii rng s = do-    mId <- lookupInteractionId ii-    updateMetaVarRange mId rng-    mi  <- getMetaInfo <$> lookupMeta mId-    e   <- parseExpr rng s-    concreteToAbstract (clScope mi) e--giveExpr :: Maybe InteractionId -> MetaId -> Expr -> TCM ()--- When translator from internal to abstract is given, this function might return--- the expression returned by the type checker.-giveExpr mii mi e = do-    mv <- lookupMeta mi-    -- In the context (incl. signature) of the meta variable,-    -- type check expression and assign meta-    withMetaInfo (getMetaInfo mv) $ do-      metaTypeCheck mv (mvJudgement mv)-  where-    metaTypeCheck mv IsSort{}      = __IMPOSSIBLE__-    metaTypeCheck mv (HasType _ t) = disableDestructiveUpdate $ do-      reportSDoc "interaction.give" 20 $-        TP.text "give: meta type =" TP.<+> prettyTCM t-      -- Here, we must be in the same context where the meta was created.-      -- Thus, we can safely apply its type to the context variables.-      ctx <- getContextArgs-      t' <- t `piApplyM` permute (takeP (length ctx) $ mvPermutation mv) ctx-      traceCall (CheckExprCall e t') $ do-        reportSDoc "interaction.give" 20 $-          TP.text "give: instantiated meta type =" TP.<+> prettyTCM t'-        v <- checkExpr e t'-        case mvInstantiation mv of--          InstV xs v' -> unlessM ((Irrelevant ==) <$> asks envRelevance) $ do-            reportSDoc "interaction.give" 20 $ TP.sep-              [ TP.text "meta was already set to value v' = " TP.<+> prettyTCM v'-                TP.<+> TP.text " with free variables " TP.<+> return (fsep $ map pretty xs)-              , TP.text "now comparing it to given value v = " TP.<+> prettyTCM v-              , TP.text "in context " TP.<+> inTopContext (prettyTCM ctx)-              ]-            -- The number of free variables should be at least the size of the context-            -- (Ideally, if we implemented contextual type theory, it should be the same.)-            when (length xs < size ctx) __IMPOSSIBLE__-            -- if there are more free variables than the context has-            -- we need to abstract over the additional ones (xs2)-            let (_xs1, xs2) = splitAt (size ctx) xs-            v' <- return $ foldr (\ (Arg ai x) -> I.Lam ai . I.Abs x) v' xs2-            reportSDoc "interaction.give" 20 $ TP.sep-              [ TP.text "in meta context, v' = " TP.<+> prettyTCM v'-              ]-            equalTerm t' v v'  -- Note: v' now lives in context of meta--          _ -> do -- updateMeta mi v-            reportSLn "interaction.give" 20 "give: meta unassigned, assigning..."-            args <- getContextArgs-            nowSolvingConstraints $ assign DirEq mi args v--        reportSDoc "interaction.give" 20 $ TP.text "give: meta variable updated!"-        redoChecks mii-        wakeupConstraints mi-        solveSizeConstraints DontDefaultToInfty-        -- Double check.-        vfull <- instantiateFull v-        checkInternal vfull t'---- | After a give, redo termination etc. checks for function which was complemented.-redoChecks :: Maybe InteractionId -> TCM ()-redoChecks Nothing = return ()-redoChecks (Just ii) = do-  reportSLn "interaction.give" 20 $-    "give: redoing termination check for function surrounding " ++ show ii-  ip <- lookupInteractionPoint ii-  case ipClause ip of-    IPNoClause -> return ()-    IPClause f _ _ -> do-      mb <- mutualBlockOf f-      terErrs <- local (\ e -> e { envMutualBlock = Just mb }) $ termMutual []-      unless (null terErrs) $ typeError $ TerminationCheckFailed terErrs-  -- TODO redo positivity check!---- | Try to fill hole by expression.------   Returns the given expression unchanged---   (for convenient generalization to @'refine'@).-give-  :: InteractionId  -- ^ Hole.-  -> Maybe Range-  -> Expr           -- ^ The expression to give.-  -> TCM Expr       -- ^ If successful, the very expression is returned unchanged.-give ii mr e = liftTCM $ do-  -- if Range is given, update the range of the interaction meta-  mi  <- lookupInteractionId ii-  whenJust mr $ updateMetaVarRange mi-  reportSDoc "interaction.give" 10 $ TP.text "giving expression" TP.<+> prettyTCM e-  reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnscope e-  -- Try to give mi := e-  catchError (giveExpr (Just ii) mi e) $ \ err -> case err of-    -- Turn PatternErr into proper error:-    PatternErr{} -> typeError . GenericDocError =<< do-      withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e-    _ -> throwError err-  removeInteractionPoint ii-  return e----- | Try to refine hole by expression @e@.------   This amounts to successively try to give @e@, @e ?@, @e ? ?@, ...---   Returns the successfully given expression.-refine-  :: InteractionId  -- ^ Hole.-  -> Maybe Range-  -> Expr           -- ^ The expression to refine the hole with.-  -> TCM Expr       -- ^ The successfully given expression.-refine ii mr e = do-  mi <- lookupInteractionId ii-  mv <- lookupMeta mi-  let range = fromMaybe (getRange mv) mr-      scope = M.getMetaScope mv-  reportSDoc "interaction.refine" 10 $-    TP.text "refining with expression" TP.<+> prettyTCM e-  reportSDoc "interaction.refine" 50 $-    TP.text $ show $ deepUnscope e-  -- We try to append up to 10 meta variables-  tryRefine 10 range scope e-  where-    tryRefine :: Int -> Range -> ScopeInfo -> Expr -> TCM Expr-    tryRefine nrOfMetas r scope e = try nrOfMetas e-      where-        try :: Int -> Expr -> TCM Expr-        try 0 e = throwError $ strMsg "Cannot refine"-        try n e = give ii (Just r) e `catchError` (\_ -> try (n - 1) =<< appMeta e)--        -- Apply A.Expr to a new meta-        appMeta :: Expr -> TCM Expr-        appMeta e = do-          let rng = rightMargin r -- Andreas, 2013-05-01 conflate range to its right margin to ensure that appended metas are last in numbering.  This fixes issue 841.-          -- Make new interaction point-          ii <- registerInteractionPoint False rng Nothing-          let info = Info.MetaInfo-                { Info.metaRange = rng-                , Info.metaScope = scope { scopePrecedence = ArgumentCtx }-                , metaNumber = Nothing -- in order to print just as ?, not ?n-                , metaNameSuggestion = ""-                }-              metaVar = QuestionMark info ii--              count x e = getSum $ foldExpr isX e-                where isX (A.Var y) | x == y = Sum 1-                      isX _                  = mempty--              lamView (A.Lam _ (DomainFree _ x) e) = Just (x, e)-              lamView (A.Lam i (DomainFull (TypedBindings r (Arg ai (TBind br (x : xs) a)))) e)-                | null xs   = Just (dget x, e)-                | otherwise = Just (dget x, A.Lam i (DomainFull $ TypedBindings r $ Arg ai $ TBind br xs a) e)-              lamView _ = Nothing--              -- reduce beta-redexes where the argument is used at most once-              smartApp i e arg =-                case lamView $ unScope e of-                  Just (x, e) | count x e < 2 -> mapExpr subX e-                    where subX (A.Var y) | x == y = namedArg arg-                          subX e = e-                  _ -> App i e arg-          return $ smartApp (ExprRange r) e $ defaultNamedArg metaVar-          --ToDo: The position of metaVar is not correct-          --ToDo: The fixity of metavars is not correct -- fixed? MT--{-| Evaluate the given expression in the current environment -}-evalInCurrent :: Expr -> TCM Expr-evalInCurrent e =-    do  (v, t) <- inferExpr e-        v' <- {- etaContract =<< -} normalise v-        reify v'---evalInMeta :: InteractionId -> Expr -> TCM Expr-evalInMeta ii e =-   do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m-        withMetaInfo mi $-            evalInCurrent e---data Rewrite =  AsIs | Instantiated | HeadNormal | Simplified | Normalised-    deriving (Read)--normalForm :: (Reduce t, Simplify t, Normalise t) => Rewrite -> t -> TCM t-normalForm AsIs         t = return t-normalForm Instantiated t = return t   -- reify does instantiation-normalForm HeadNormal   t = {- etaContract =<< -} reduce t-normalForm Simplified   t = {- etaContract =<< -} simplify t-normalForm Normalised   t = {- etaContract =<< -} normalise t--data ComputeMode = DefaultCompute | IgnoreAbstract | UseShowInstance-  deriving (Read, Eq)--computeIgnoreAbstract :: ComputeMode -> Bool-computeIgnoreAbstract DefaultCompute  = False-computeIgnoreAbstract IgnoreAbstract  = True-computeIgnoreAbstract UseShowInstance = True-  -- UseShowInstance requires the result to be a string literal so respecting-  -- abstract can only ever break things.--computeWrapInput :: ComputeMode -> String -> String-computeWrapInput UseShowInstance s = "show (" ++ s ++ ")"-computeWrapInput _               s = s--showComputed :: ComputeMode -> Expr -> TCM Doc-showComputed UseShowInstance e =-  case e of-    A.Lit (LitString _ s) -> pure (text s)-    _                     -> (text "Not a string:" $$) <$> prettyATop e-showComputed _ e = prettyATop e--data OutputForm a b = OutputForm Range [ProblemId] (OutputConstraint a b)-  deriving (Functor)--data OutputConstraint a b-      = OfType b a | CmpInType Comparison a b b-                   | CmpElim [Polarity] a [b] [b]-      | JustType b | CmpTypes Comparison b b-                   | CmpLevels Comparison b b-                   | CmpTeles Comparison b b-      | JustSort b | CmpSorts Comparison b b-      | Guard (OutputConstraint a b) ProblemId-      | Assign b a | TypedAssign b a a | PostponedCheckArgs b [a] a a-      | IsEmptyType a-      | SizeLtSat a-      | FindInScopeOF b a [(a,a)]-  deriving (Functor)---- | A subset of 'OutputConstraint'.--data OutputConstraint' a b = OfType' { ofName :: b-                                     , ofExpr :: a-                                     }--outputFormId :: OutputForm a b -> b-outputFormId (OutputForm _ _ o) = out o-  where-    out o = case o of-      OfType i _                 -> i-      CmpInType _ _ i _          -> i-      CmpElim _ _ (i:_) _        -> i-      CmpElim _ _ [] _           -> __IMPOSSIBLE__-      JustType i                 -> i-      CmpLevels _ i _            -> i-      CmpTypes _ i _             -> i-      CmpTeles _ i _             -> i-      JustSort i                 -> i-      CmpSorts _ i _             -> i-      Guard o _                  -> out o-      Assign i _                 -> i-      TypedAssign i _ _          -> i-      PostponedCheckArgs i _ _ _ -> i-      IsEmptyType _              -> __IMPOSSIBLE__   -- Should never be used on IsEmpty constraints-      SizeLtSat{}                -> __IMPOSSIBLE__-      FindInScopeOF _ _ _        -> __IMPOSSIBLE__--instance Reify ProblemConstraint (Closure (OutputForm Expr Expr)) where-  reify (PConstr pids cl) = enterClosure cl $ \c -> buildClosure =<< (OutputForm (getRange c) pids <$> reify c)--reifyElimToExpr :: I.Elim -> TCM Expr-reifyElimToExpr e = case e of-    I.Apply v -> appl "apply" <$> reify v-    I.Proj _o f -> appl "proj" <$> reify ((defaultArg $ I.Def f []) :: Arg Term)-  where-    appl :: String -> Arg Expr -> Expr-    appl s v = A.App exprNoRange (A.Lit (LitString noRange s)) $ fmap unnamed v--instance Reify Constraint (OutputConstraint Expr Expr) where-    reify (ValueCmp cmp t u v)   = CmpInType cmp <$> reify t <*> reify u <*> reify v-    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 (TypeCmp cmp t t')     = CmpTypes cmp <$> reify t <*> reify t'-    reify (TelCmp a b cmp t t')  = CmpTeles cmp <$> (ETel <$> reify t) <*> (ETel <$> reify t')-    reify (SortCmp cmp s s')     = CmpSorts cmp <$> reify s <*> reify s'-    reify (Guarded c pid) = do-        o  <- reify c-        return $ Guard o pid-    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 $ \p -> case p of-            CheckExpr e a -> do-                a  <- reify a-                return $ TypedAssign m' e a-            CheckLambda (Arg ai (xs, mt)) body target -> do-              domType <- maybe (return underscore) reify mt-              target  <- reify target-              let bs = TypedBindings noRange $ Arg ai $-                       TBind noRange 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-            UnquoteTactic tac _ goal -> do-              tac <- A.App exprNoRange (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac-              OfType tac <$> reify goal-          Open{}  -> __IMPOSSIBLE__-          OpenIFS{}  -> __IMPOSSIBLE__-          InstV{} -> __IMPOSSIBLE__-    reify (FindInScope m _b mcands) = FindInScopeOF-      <$> (reify $ MetaV m [])-      <*> (reify =<< getMetaType m)-      <*> (forM (fromMaybe [] mcands) $ \ (Candidate tm ty eti _) -> do-            (,) <$> reify tm <*> reify ty)-    reify (IsEmpty r a) = IsEmptyType <$> reify a-    reify (CheckSizeLtSat a) = SizeLtSat  <$> reify a---- ASR TODO (28 December 2014): This function will be unnecessary when--- using a Pretty instance for OutputConstraint instead of the Show--- instance.-showComparison :: Comparison -> String-showComparison cmp = " " ++ prettyShow cmp ++ " "--instance (Show a,Show b) => Show (OutputForm a b) where-  show o =-    case o of-      OutputForm r []   c -> show c ++ range r-      OutputForm r pids c -> show pids ++ " " ++ show c ++ range r-    where-      range r | null s    = ""-              | otherwise = " [ at " ++ s ++ " ]"-        where s = show r--instance (Show a,Show b) => Show (OutputConstraint a b) where-    show (OfType e t)           = show e ++ " : " ++ show t-    show (JustType e)           = "Type " ++ show e-    show (JustSort e)           = "Sort " ++ show e-    show (CmpInType cmp t e e') = show e ++ showComparison cmp ++ show e' ++ " : " ++ show t-    show (CmpElim cmp t e e')   = show e ++ " == " ++ show e' ++ " : " ++ show t-    show (CmpTypes  cmp t t')   = show t ++ showComparison cmp ++ show t'-    show (CmpLevels cmp t t')   = show t ++ showComparison cmp ++ show t'-    show (CmpTeles  cmp t t')   = show t ++ showComparison cmp ++ show t'-    show (CmpSorts cmp s s')    = show s ++ showComparison cmp ++ show s'-    show (Guard o pid)          = show o ++ " [blocked by problem " ++ prettyShow pid ++ "]"-    show (Assign m e)           = show m ++ " := " ++ show e-    show (TypedAssign m e a)    = show m ++ " := " ++ show e ++ " :? " ++ show a-    show (PostponedCheckArgs m es t0 t1) = show m ++ " := (_ : " ++ show t0 ++ ") " ++ unwords (map (paren . show) es)-                                                  ++ " : " ++ show t1-      where paren s | elem ' ' s = "(" ++ s ++ ")"-                    | otherwise  = s-    show (IsEmptyType a)        = "Is empty: " ++ show a-    show (SizeLtSat a)          = "Not empty type of sizes: " ++ show a-    show (FindInScopeOF s t cs) = "Resolve instance argument " ++ showCand (s,t) ++ ".\n  Candidates:\n    [ " ++-                                    intercalate "\n    , " (map showCand cs) ++ " ]"-      where showCand (tm,ty) = indent 6 $ show tm ++ " : " ++ show ty-            indent n s = intercalate ("\n" ++ replicate n ' ') (l:ls)-              where l:ls = lines s--instance (ToConcrete a c, ToConcrete b d) =>-         ToConcrete (OutputForm a b) (OutputForm c d) where-    toConcrete (OutputForm r pid c) = OutputForm r pid <$> toConcrete c--instance (ToConcrete a c, ToConcrete b d) =>-         ToConcrete (OutputConstraint a b) (OutputConstraint c d) where-    toConcrete (OfType e t) = OfType <$> toConcrete e <*> toConcreteCtx TopCtx t-    toConcrete (JustType e) = JustType <$> toConcrete e-    toConcrete (JustSort e) = JustSort <$> toConcrete e-    toConcrete (CmpInType cmp t e e') =-      CmpInType cmp <$> toConcreteCtx TopCtx t <*> toConcreteCtx ArgumentCtx e-                                               <*> toConcreteCtx ArgumentCtx e'-    toConcrete (CmpElim cmp t e e') =-      CmpElim cmp <$> toConcreteCtx TopCtx t <*> toConcreteCtx TopCtx e <*> toConcreteCtx TopCtx e'-    toConcrete (CmpTypes cmp e e') = CmpTypes cmp <$> toConcreteCtx ArgumentCtx e-                                                  <*> toConcreteCtx ArgumentCtx e'-    toConcrete (CmpLevels cmp e e') = CmpLevels cmp <$> toConcreteCtx ArgumentCtx e-                                                    <*> toConcreteCtx ArgumentCtx e'-    toConcrete (CmpTeles cmp e e') = CmpTeles cmp <$> toConcrete e <*> toConcrete e'-    toConcrete (CmpSorts cmp e e') = CmpSorts cmp <$> toConcreteCtx ArgumentCtx e-                                                  <*> toConcreteCtx ArgumentCtx e'-    toConcrete (Guard o pid) = Guard <$> toConcrete o <*> pure pid-    toConcrete (Assign m e) = noTakenNames $ Assign <$> toConcrete m <*> toConcreteCtx TopCtx e-    toConcrete (TypedAssign m e a) = TypedAssign <$> toConcrete m <*> toConcreteCtx TopCtx e-                                                                  <*> toConcreteCtx TopCtx a-    toConcrete (PostponedCheckArgs m args t0 t1) =-      PostponedCheckArgs <$> toConcrete m <*> toConcrete args <*> toConcrete t0 <*> toConcrete t1-    toConcrete (IsEmptyType a) = IsEmptyType <$> toConcreteCtx TopCtx a-    toConcrete (SizeLtSat a) = SizeLtSat <$> toConcreteCtx TopCtx a-    toConcrete (FindInScopeOF s t cs) =-      FindInScopeOF <$> toConcrete s <*> toConcrete t-                    <*> mapM (\(tm,ty) -> (,) <$> toConcrete tm <*> toConcrete ty) cs--instance (Pretty a, Pretty b) => Pretty (OutputConstraint' a b) where-  pretty (OfType' e t) = pretty e <+> text ":" <+> pretty t--instance (ToConcrete a c, ToConcrete b d) =>-            ToConcrete (OutputConstraint' a b) (OutputConstraint' c d) where-  toConcrete (OfType' e t) = OfType' <$> toConcrete e <*> toConcreteCtx TopCtx t--getConstraints :: TCM [OutputForm C.Expr C.Expr]-getConstraints = liftTCM $ do-    cs <- M.getAllConstraints-    cs <- forM cs $ \c -> do-            cl <- reify c-            enterClosure cl abstractToConcrete_-    ss <- mapM toOutputForm =<< getSolvedInteractionPoints True AsIs -- get all-    return $ ss ++ cs-  where-    toOutputForm (ii, mi, e) = do-      mv <- getMetaInfo <$> lookupMeta mi-      withMetaInfo mv $ do-        let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii-        abstractToConcrete_ $ OutputForm noRange [] $ Assign m e---- | @getSolvedInteractionPoints True@ returns all solutions,---   even if just solved by another, non-interaction meta.------   @getSolvedInteractionPoints False@ only returns metas that---   are solved by a non-meta.--getSolvedInteractionPoints :: Bool -> Rewrite -> TCM [(InteractionId, MetaId, Expr)]-getSolvedInteractionPoints all norm = concat <$> do-  mapM solution =<< getInteractionIdsAndMetas-  where-    solution (i, m) = do-      mv <- lookupMeta m-      withMetaInfo (getMetaInfo mv) $ do-        args  <- getContextArgs-        scope <- getScope-        let sol v = do-              -- Andreas, 2014-02-17 exclude metas solved by metas-              v <- ignoreSharing <$> instantiate v-              let isMeta = case v of MetaV{} -> True; _ -> False-              if isMeta && not all then return [] else do-                e <- reify =<< normalForm norm v-                return [(i, m, ScopedExpr scope e)]-            unsol = return []-        case mvInstantiation mv of-          InstV{}                        -> sol (MetaV m $ map Apply args)-          Open{}                         -> unsol-          OpenIFS{}                      -> unsol-          BlockedConst{}                 -> unsol-          PostponedTypeCheckingProblem{} -> unsol--typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta)-typeOfMetaMI norm mi =-     do mv <- lookupMeta mi-        withMetaInfo (getMetaInfo mv) $-          rewriteJudg mv (mvJudgement mv)-   where-    rewriteJudg :: MetaVariable -> Judgement MetaId ->-                   TCM (OutputConstraint Expr NamedMeta)-    rewriteJudg mv (HasType i t) = do-      ms <- getMetaNameSuggestion i-      t <- normalForm norm t-      vs <- getContextArgs-      let x = NamedMeta ms i-      reportSDoc "interactive.meta" 10 $ TP.vcat-        [ TP.text $ unwords ["permuting", show i, "with", show $ mvPermutation mv]-        , TP.nest 2 $ TP.vcat-          [ TP.text "len  =" TP.<+> TP.text (show $ length vs)-          , TP.text "args =" TP.<+> prettyTCM vs-          , TP.text "t    =" TP.<+> prettyTCM t-          , TP.text "x    =" TP.<+> TP.pretty x-          ]-        ]-      reportSDoc "interactive.meta.scope" 20 $ TP.text $ show $ getMetaScope mv-      -- Andreas, 2016-01-19, issue #1783: need piApplyM instead of just piApply-      OfType x <$> do reify =<< t `piApplyM` permute (takeP (size vs) $ mvPermutation mv) vs-    rewriteJudg mv (IsSort i t) = do-      ms <- getMetaNameSuggestion i-      return $ JustSort $ NamedMeta ms i---typeOfMeta :: Rewrite -> InteractionId -> TCM (OutputConstraint Expr InteractionId)-typeOfMeta norm ii = typeOfMeta' norm . (ii,) =<< lookupInteractionId ii--typeOfMeta' :: Rewrite -> (InteractionId, MetaId) -> TCM (OutputConstraint Expr InteractionId)-typeOfMeta' norm (ii, mi) = fmap (\_ -> ii) <$> typeOfMetaMI norm mi--typesOfVisibleMetas :: Rewrite -> TCM [OutputConstraint Expr InteractionId]-typesOfVisibleMetas norm =-  liftTCM $ mapM (typeOfMeta' norm) =<< getInteractionIdsAndMetas--typesOfHiddenMetas :: Rewrite -> TCM [OutputConstraint Expr NamedMeta]-typesOfHiddenMetas norm = liftTCM $ do-  is    <- getInteractionMetas-  store <- Map.filterWithKey (openAndImplicit is) <$> getMetaStore-  mapM (typeOfMetaMI norm) $ Map.keys store-  where-  openAndImplicit is x m =-    case mvInstantiation m of-      M.InstV{} -> False-      M.Open    -> x `notElem` is-      M.OpenIFS -> x `notElem` is  -- OR: True !?-      M.BlockedConst{} -> True-      M.PostponedTypeCheckingProblem{} -> False--metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)-metaHelperType norm ii rng s = case words s of-  []    -> failure-  f : _ -> do-    ensureName f-    A.Application h args <- A.appView . getBody . deepUnscope <$> parseExprIn ii rng ("let " ++ f ++ " = _ in " ++ s)-    withInteractionId ii $ 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-      a        <- runIdentity . onNames unW . (`piApply` cxtArgs) <$> (getMetaType =<< lookupInteractionId ii)-      (vs, as) <- unzip <$> mapM (inferExpr . namedThing . unArg) args-      -- Remember the arity of a-      TelV atel _ <- telView a-      let arity = size atel-          (delta1, delta2, _, a', as', vs') = splitTelForWith tel a (map OtherType as) vs-      a <- local (\e -> e { envPrintDomainFreePi = True }) $ do-        reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vs' as' delta2 a'-      reportSDoc "interaction.helper" 10 $ TP.vcat-        [ TP.text "generating helper function"-        , TP.nest 2 $ TP.text "tel    = " TP.<+> inTopContext (prettyTCM tel)-        , TP.nest 2 $ TP.text "a      = " TP.<+> prettyTCM a-        , TP.nest 2 $ TP.text "vs     = " TP.<+> prettyTCM vs-        , TP.nest 2 $ TP.text "as     = " TP.<+> prettyTCM as-        , TP.nest 2 $ TP.text "delta1 = " TP.<+> inTopContext (prettyTCM delta1)-        , TP.nest 2 $ TP.text "delta2 = " TP.<+> inTopContext (addContext delta1 $ prettyTCM delta2)-        , TP.nest 2 $ TP.text "a'     = " TP.<+> inTopContext (addContext delta1 $ addContext delta2 $ prettyTCM a')-        , TP.nest 2 $ TP.text "as'    = " TP.<+> inTopContext (addContext delta1 $ prettyTCM as')-        , TP.nest 2 $ TP.text "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"-    ensureName f = do-      ce <- parseExpr rng f-      case ce of-        C.Ident{} -> return ()-        C.RawApp _ [C.Ident{}] -> return ()-        _ -> do-         reportSLn "interaction.helper" 10 $ "ce = " ++ show ce-         failure-    cleanupType arity args t = do-      -- Get the arity of t-      TelV ttel _ <- telView t-      -- Compute the number or pi-types subject to stripping.-      let n = size ttel - arity-      -- It cannot be negative, otherwise we would have performed a-      -- negative number of with-abstractions.-      unless (n >= 0) __IMPOSSIBLE__-      return $ evalState (renameVars $ hiding args $ stripUnused n t) args--    getBody (A.Let _ _ e)      = e-    getBody _                  = __IMPOSSIBLE__--    -- Strip the non-dependent abstractions from the first n abstractions.-    stripUnused n (El s v) = El s $ strip n v-    strip 0 v = v-    strip n v = case v of-      I.Pi a b -> case stripUnused (n-1) <$> b of-        b | absName b == "w"   -> I.Pi a b-        NoAbs _ b              -> unEl b-        Abs s b | 0 `freeIn` b -> I.Pi (hide a) (Abs s b)-                | otherwise    -> strengthen __IMPOSSIBLE__ (unEl b)-      _ -> v  -- todo: handle if goal type is a Pi--    -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)-    renameVars = onNames renameVar--    hiding args (El s v) = El s $ hidingTm args v-    hidingTm (arg:args) (I.Pi a b) | absName b == "w" =-      I.Pi (setHiding (getHiding arg) a) (hiding args <$> b)-    hidingTm args (I.Pi a b) = I.Pi a (hiding args <$> b)-    hidingTm _ a = a--    -- onNames :: Applicative m => (ArgName -> m ArgName) -> Type -> m Type-    onNames :: Applicative m => (String -> m String) -> Type -> m Type-    onNames f (El s v) = El s <$> onNamesTm f v--    -- onNamesTel :: Applicative f => (ArgName -> f ArgName) -> I.Telescope -> f I.Telescope-    onNamesTel :: Applicative f => (String -> f String) -> I.Telescope -> f I.Telescope-    onNamesTel f I.EmptyTel = pure I.EmptyTel-    onNamesTel f (I.ExtendTel a b) = I.ExtendTel <$> traverse (onNames f) a <*> onNamesAbs f onNamesTel b--    onNamesTm f v = case v of-      I.Var x es   -> I.Var x <$> onNamesElims f es-      I.Def q es   -> I.Def q <$> onNamesElims f es-      I.Con c ci args -> I.Con c ci <$> onNamesArgs f args-      I.Lam i b    -> I.Lam i <$> onNamesAbs f onNamesTm b-      I.Pi a b     -> I.Pi <$> traverse (onNames f) a <*> onNamesAbs f onNames b-      I.DontCare v -> I.DontCare <$> onNamesTm f v-      I.Lit{}      -> pure v-      I.Sort{}     -> pure v-      I.Level{}    -> pure v-      I.MetaV{}    -> pure v-      I.Shared{}   -> pure v-    onNamesElims f = traverse $ traverse $ onNamesTm f-    onNamesArgs f  = traverse $ traverse $ onNamesTm f-    onNamesAbs f   = onNamesAbs' f (stringToArgName <.> f . argNameToString)-    onNamesAbs' f f' nd (Abs   s x) = Abs   <$> f' s <*> nd f x-    onNamesAbs' f f' nd (NoAbs s x) = NoAbs <$> f' s <*> nd f x--    unW "w" = return ".w"-    unW s   = return s--    renameVar ('.':s) = pure s-    renameVar "w"     = betterName-    renameVar s       = pure s--    betterName = do-      arg : args <- get-      put args-      return $ case arg of-        Arg _ (Named _ (A.Var x)) -> show $ A.nameConcrete x-        Arg _ (Named (Just x) _)  -> argNameToString $ rangedThing x-        _                         -> "w"----- Gives a list of names and corresponding types.--contextOfMeta :: InteractionId -> Rewrite -> TCM [OutputConstraint' Expr Name]-contextOfMeta ii norm = do-  info <- getMetaInfo <$> (lookupMeta =<< lookupInteractionId ii)-  withMetaInfo info $ do-    cxt <- getContext-    let n         = length cxt-        localVars = zipWith raise [1..] cxt-        mkLet (x, lb) = do-          (tm, Dom c ty) <- getOpen lb-          return $ Dom c (x, ty)-    letVars <- mapM mkLet . Map.toDescList =<< asks envLetBindings-    gfilter visible . reverse <$> mapM out (letVars ++ localVars)-  where gfilter p = catMaybes . map p-        visible (OfType x y) | not (isNoName x) = Just (OfType' x y)-                             | otherwise        = Nothing-        visible _            = __IMPOSSIBLE__-        out (Dom _ (x, t)) = do-          t' <- reify =<< normalForm norm t-          return $ OfType x t'----- | Returns the type of the expression in the current environment---   We wake up irrelevant variables just in case the user want to---   invoke that command in an irrelevant context.-typeInCurrent :: Rewrite -> Expr -> TCM Expr-typeInCurrent norm e =-    do  (_,t) <- wakeIrrelevantVars $ inferExpr e-        v <- normalForm norm t-        reify v----typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr-typeInMeta ii norm e =-   do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m-        withMetaInfo mi $-            typeInCurrent norm e--withInteractionId :: InteractionId -> TCM a -> TCM a-withInteractionId i ret = do-  m <- lookupInteractionId i-  withMetaId m ret--withMetaId :: MetaId -> TCM a -> TCM a-withMetaId m ret = do-  mv <- lookupMeta m-  withMetaInfo' mv ret---- The intro tactic---- Returns the terms (as strings) that can be--- used to refine the goal. Uses the coverage checker--- to find out which constructors are possible.-introTactic :: Bool -> InteractionId -> TCM [String]-introTactic pmLambda ii = do-  mi <- lookupInteractionId ii-  mv <- lookupMeta mi-  withMetaInfo (getMetaInfo mv) $ case mvJudgement mv of-    HasType _ t -> do-        t <- reduce =<< piApplyM t =<< getContextArgs-        -- Andreas, 2013-03-05 Issue 810: skip hidden domains in introduction-        -- of constructor.-        TelV tel' t <- telViewUpTo' (-1) notVisible t-        -- if we cannot introduce a constructor, we try a lambda-        let fallback = do-              TelV tel _ <- telView t-              reportSDoc "interaction.intro" 20 $ TP.sep-                [ TP.text "introTactic/fallback"-                , TP.text "tel' = " TP.<+> prettyTCM tel'-                , TP.text "tel  = " TP.<+> prettyTCM tel-                ]-              case (tel', tel) of-                (EmptyTel, EmptyTel) -> return []-                _ -> introFun (telToList tel' ++ telToList tel)--        case ignoreSharing $ unEl t of-          I.Def d _ -> do-            def <- getConstInfo d-            case theDef def of-              Datatype{}    -> addContext tel' $ introData t-              Record{ recNamedCon = name }-                | name      -> addContext tel' $ introData t-                | otherwise -> addContext tel' $ introRec d-              _ -> fallback-          _ -> fallback-     `catchError` \_ -> return []-    _ -> __IMPOSSIBLE__-  where-    conName [p] = [ c | I.ConP c _ _ <- [namedArg p] ]-    conName _   = __IMPOSSIBLE__--    showTCM v = show <$> prettyTCM v--    introFun tel = addContext tel' $ do-        reportSDoc "interaction.intro" 10 $ do TP.text "introFun" TP.<+> prettyTCM (telFromList tel)-        imp <- showImplicitArguments-        let okHiding0 h = imp || h == NotHidden-            -- if none of the vars were displayed, we would get a parse error-            -- thus, we switch to displaying all-            allHidden   = null (filter okHiding0 hs)-            okHiding    = if allHidden then const True else okHiding0-        vars <- -- setShowImplicitArguments (imp || allHidden) $-                (if allHidden then withShowAllArguments else id) $-                  mapM showTCM [ setHiding h $ defaultArg $ var i :: Arg Term-                               | (h, i) <- zip hs $ downFrom n-                               , okHiding h-                               ]-        if pmLambda-           then return [ unwords $ ["λ", "{"] ++ vars ++ ["→", "?", "}"] ]-           else return [ unwords $ ["λ"]      ++ vars ++ ["→", "?"] ]-      where-        n = size tel-        hs   = map getHiding tel-        tel' = telFromList [ fmap makeName b | b <- tel ]-        makeName ("_", t) = ("x", t)-        makeName (x, t)   = (x, t)--    introData t = do-      let tel  = telFromList [defaultDom ("_", t)]-          pat  = [defaultArg $ unnamed $ debruijnNamedVar "c" 0]-      r <- splitLast CoInductive tel pat-      case r of-        Left err -> return []-        Right cov -> mapM showTCM $ concatMap (conName . scPats) $ splitClauses cov--    introRec :: QName -> TCM [String]-    introRec d = do-      hfs <- getRecordFieldNames d-      fs <- ifM showImplicitArguments-            (return $ map unArg hfs)-            (return [ unArg a | a <- hfs, getHiding a == NotHidden ])-      let e = C.Rec noRange $ for fs $ \ f ->-            Left $ C.FieldAssignment f $ C.QuestionMark noRange Nothing-      return [ prettyShow e ]---- | Runs the given computation as if in an anonymous goal at the end---   of the top-level module.------   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 (use stCurrentModule) err $ \ current -> do-    caseMaybeM (getVisitedModule $ toTopLevelModuleName current) __IMPOSSIBLE__ $ \ mi -> do-      let scope = iInsideScope $ miInterface mi-      tel <- lookupSection current-      -- Get the names of the local variables from @scope@-      -- and put them into the context.-      let names :: [A.Name]-          names = reverse $ map snd $ notShadowedLocals $ scopeLocals scope-          types :: [Dom I.Type]-          types = map (snd <$>) $ telToList tel-          gamma :: ListTel' A.Name-          gamma = zipWith' (\ x dom -> (x,) <$> dom) names types-      M.withCurrentModule current $-        withScope_ scope $-          addContext gamma $-            m---- | Parse a name.-parseName :: Range -> String -> TCM C.QName-parseName r s = do-  m <- parseExpr r s-  case m of-    C.Ident m              -> return m-    C.RawApp _ [C.Ident m] -> return m-    _                      -> typeError $-      GenericError $ "Not an identifier: " ++ show m ++ "."---- | Check whether an expression is a (qualified) identifier.-isQName :: C.Expr -> Maybe C.QName-isQName m = do-  case m of-    C.Ident m              -> return m-    C.RawApp _ [C.Ident m] -> return m-    _ -> Nothing---- | Returns the contents of the given module or record.--moduleContents-  :: Rewrite-     -- ^ How should the types be presented?-  -> Range-     -- ^ The range of the next argument.-  -> String-     -- ^ The module name.-  -> TCM ([C.Name], [(C.Name, Type)])-     -- ^ Module names, names paired up with corresponding types.--moduleContents norm rng s = traceCall ModuleContents $ do-  e <- parseExpr rng s-  case isQName e of-    -- If the expression is not a single identifier, it is not a module name-    -- and treated as a record expression.-    Nothing -> getRecordContents norm e-    -- Otherwise, if it is not in scope as a module name, it is treated-    -- as a record name.-    Just x  -> do-      ms :: [AbstractModule] <- scopeLookup x <$> getScope-      if null ms then getRecordContents norm e else getModuleContents norm x---- | Returns the contents of the given record identifier.--getRecordContents-  :: Rewrite  -- ^ Amount of normalization in types.-  -> C.Expr   -- ^ Expression presumably of record type.-  -> TCM ([C.Name], [(C.Name, Type)])-              -- ^ Module names, 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 = tel } -> do-      let xs   = map (nameConcrete . qnameName . unArg) fs-          doms = telToList $ apply tel vs-      ts <- mapM (normalForm norm) $ map (snd . unDom) doms-      return ([], zip xs ts)-    _ -> __IMPOSSIBLE__---- | Returns the contents of the given module.--getModuleContents-  :: Rewrite  -- ^ Amount of normalization in types.-  -> C.QName  -- ^ Module name.-  -> TCM ([C.Name], [(C.Name, Type)])-              -- ^ Module names, names paired up with corresponding types.-getModuleContents norm m = do-  modScope <- getNamedScope . amodName =<< resolveModule m-  let modules :: ThingsInScope AbstractModule-      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)-  return (Map.keys modules, types)---whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule])-whyInScope s = do-  x     <- parseName noRange s-  scope <- getScope-  return ( lookup x $ map (first C.QName) $ scopeLocals scope-         , scopeLookup x scope-         , scopeLookup x scope )+{-# LANGUAGE NondecreasingIndentation #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Agda.Interaction.BasicOps where++import Prelude hiding (null)++import Control.Arrow          ( first )+import Control.Monad.Except   ( MonadError(..) )+import Control.Monad.State    ( MonadState(..), evalState )+import Control.Monad.Identity ( runIdentity )+import Control.Monad.Trans.Maybe++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+import Data.Monoid+import Data.Function (on)+import Data.Text (Text)+import qualified Data.Text as T++import Agda.Interaction.Base+import Agda.Interaction.Output+import Agda.Interaction.Options+import Agda.Interaction.Response (Goals, ResponseContextEntry(..))++import qualified Agda.Syntax.Concrete as C -- ToDo: Remove with instance of ToConcrete+import Agda.Syntax.Position+import Agda.Syntax.Abstract as A hiding (Open, Apply, Assign)+import Agda.Syntax.Abstract.Views as A+import Agda.Syntax.Abstract.Pretty+import Agda.Syntax.Common+import Agda.Syntax.Info (MetaInfo(..),emptyMetaInfo,exprNoRange,defaultAppInfo_,defaultAppInfo)+import qualified Agda.Syntax.Info as Info+import Agda.Syntax.Internal as I+import Agda.Syntax.Literal+import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.Translation.AbstractToConcrete+import Agda.Syntax.Translation.ConcreteToAbstract+import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Monad+import Agda.Syntax.Fixity(Precedence(..), argumentCtx_)+import Agda.Syntax.Parser++import Agda.TheTypeChecker+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+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.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+  ( 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+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 as P+import Agda.Utils.Permutation+import Agda.Utils.Size+import Agda.Utils.String+import Agda.Utils.WithDefault ( WithDefault'(Value) )++import Agda.Utils.Impossible++-- | Parses an expression.++parseExpr :: Range -> String -> TCM C.Expr+parseExpr rng s = do+  (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++parseExprIn :: InteractionId -> Range -> String -> TCM Expr+parseExprIn ii rng s = do+    mId <- lookupInteractionId ii+    updateMetaVarRange mId rng+    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+    -- such that the scope checker can label the clause+    -- of a parsed extended lambda as IsAbstract if the+    -- interaction point was created in AbstractMode.+    withMetaInfo mi $+      concreteToAbstract (clScope mi) e++-- Type check the given expression and assign its value to the meta+-- 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 <- lookupLocalMeta mi+    let t = case mvJudgement mv of+              IsSort{}    -> __IMPOSSIBLE__+              HasType _ _ t -> t+    reportSDoc "interaction.give" 20 $+      "give: meta type =" TP.<+> prettyTCM t+    -- Here, we must be in the same context where the meta was created.+    -- Thus, we can safely apply its type to the context variables.+    ctx <- getContextArgs+    t' <- t `piApplyM` permute (takeP (length ctx) $ mvPermutation mv) ctx+    traceCall (CheckExprCall CmpLeq e t') $ do+      reportSDoc "interaction.give" 20 $ do+        a <- asksTC envAbstractMode+        TP.hsep+          [ TP.text ("give(" ++ show a ++ "): instantiated meta type =")+          , prettyTCM t'+          ]+      -- Andreas, 2020-05-27 AIM XXXII, issue #4679+      -- Clear envMutualBlock since cubical only executes+      -- certain checks (checkIApplyConfluence) for an extended lambda+      -- 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 (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'+            , "now comparing it to given value v = " TP.<+> prettyTCM v+            , "in context " TP.<+> inTopContext (prettyTCM ctx)+            ]+          equalTerm t' v v'++        _ -> do -- updateMeta mi v+          reportSLn "interaction.give" 20 "give: meta unassigned, assigning..."+          args <- getContextArgs+          nowSolvingConstraints $ assign DirEq mi args v (AsTermsOf t')++      reportSDoc "interaction.give" 20 $ "give: meta variable updated!"+      unless (force == WithForce) $ redoChecks mii+      wakeupConstraints mi+      solveSizeConstraints DontDefaultToInfty+      cubical <- isJust <$> cubicalOption+      -- don't double check with cubical, because it gets in the way too often.+      unless (cubical || force == WithForce) $ do+        -- Double check.+        reportSDoc "interaction.give" 20 $ "give: double checking"+        vfull <- instantiateFull v+        checkInternal vfull CmpLeq t'+      return v++-- | After a give, redo termination etc. checks for function which was complemented.+redoChecks :: Maybe InteractionId -> TCM ()+redoChecks Nothing = return ()+redoChecks (Just ii) = do+  reportSLn "interaction.give" 20 $+    "give: redoing termination check for function surrounding " ++ show ii+  ip <- lookupInteractionPoint ii+  case ipClause ip of+    IPNoClause -> return ()+    IPClause{ipcQName = f} -> do+      mb <- defMutual <$> getConstInfo f+      terErrs <- localTC (\ e -> e { envMutualBlock = Just mb }) $ termMutual []+      List1.unlessNull terErrs $ warning . TerminationIssue+  -- TODO redo positivity check!++-- | Auxiliary definition for 'give' and 'elaborate_give'.+give_ ::+     Bool           -- ^ Elaborating?+  -> UseForce       -- ^ Skip safety checks?+  -> InteractionId  -- ^ Hole.+  -> Maybe Range+  -> Expr           -- ^ The expression to give.+  -> 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.+    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++-- | Try to fill hole by elaborated expression.+elaborate_give+  :: Rewrite        -- ^ Normalise result?+  -> UseForce       -- ^ Skip safety checks?+  -> InteractionId  -- ^ Hole.+  -> Maybe Range+  -> Expr           -- ^ The expression to give.+  -> TCM Expr       -- ^ If successful, return the elaborated expression.+elaborate_give norm force ii mr e = withInteractionId ii $ do+  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@.+--+--   This amounts to successively try to give @e@, @e ?@, @e ? ?@, ...+--   Returns the successfully given expression.+refine+  :: UseForce       -- ^ Skip safety checks when giving?+  -> InteractionId  -- ^ Hole.+  -> Maybe Range+  -> Expr           -- ^ The expression to refine the hole with.+  -> TCM Expr       -- ^ The successfully given expression.+refine force ii mr e = do+  mi <- lookupInteractionId ii+  mv <- lookupLocalMeta mi+  let range = fromMaybe (getRange mv) mr+      scope = M.getMetaScope mv+  reportSDoc "interaction.refine" 10 $+    "refining with expression" TP.<+> prettyTCM e+  reportSDoc "interaction.refine" 50 $+    TP.text $ show $ deepUnscope e+  -- We try to append up to 10 meta variables+  tryRefine 10 range scope e+  where+    tryRefine :: Int -> Range -> ScopeInfo -> Expr -> TCM Expr+    tryRefine nrOfMetas r scope = try nrOfMetas Nothing+      where+        try :: Int -> Maybe TCErr -> Expr -> TCM Expr+        try 0 err e = interactionError $ CannotRefine $ case err of+           Just (TypeError _ _ cl) | UnequalTerms _ I.Pi{} _ _ <- clValue cl ->+             "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+        appMeta :: Expr -> TCM Expr+        appMeta e = do+          let rng = rightMargin r -- Andreas, 2013-05-01 conflate range to its right margin to ensure that appended metas are last in numbering.  This fixes issue 841.+          -- Make new interaction point+          ii <- registerInteractionPoint False rng Nothing+          let info = Info.MetaInfo+                { Info.metaRange = rng+                , Info.metaScope = set scopePrecedence [argumentCtx_] scope+                    -- Ulf, 2017-09-07: The `argumentCtx_` above is causing #737.+                    -- If we're building an operator application the precedence+                    -- should be something else.+                , metaNumber = Nothing -- in order to print just as ?, not ?n+                , metaNameSuggestion = ""+                , metaKind           = Info.UnificationMeta+                }+              metaVar = QuestionMark info ii++              count x e = getSum $ foldExpr isX e+                where isX (A.Var y) | x == y = Sum 1+                      isX _                  = mempty++              lamView (A.Lam _ (DomainFree _ x) e) = Just (namedArg x, e)+              lamView (A.Lam i (DomainFull (TBind r t (x :| xs) a)) e) =+                List1.ifNull xs {-then-} (Just (namedArg x, e)) {-else-} $ \ xs ->+                  Just (namedArg x, A.Lam i (DomainFull $ TBind r t xs a) e)+              lamView _ = Nothing++              -- reduce beta-redexes where the argument is used at most once+              smartApp i e arg =+                case fmap (first A.binderName) (lamView $ unScope e) of+                  Just (A.BindName{unBind = x}, e) | count x e < 2 -> mapExpr subX e+                    where subX (A.Var y) | x == y = namedArg arg+                          subX e = e+                  _ -> App i e arg+          return $ smartApp (defaultAppInfo r) e $ defaultNamedArg metaVar++{-| Evaluate the given expression in the current environment -}+evalInCurrent :: ComputeMode -> Expr -> TCM Expr+evalInCurrent cmode e = do+  (v, _t) <- inferExpr e+  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 <$> lookupLocalMeta m+        withMetaInfo mi $+            evalInCurrent cmode e++-- | Modifier for interactive commands,+--   specifying the amount of normalization in the output.+--+normalForm :: (Reduce t, Simplify t, Instantiate t, Normalise t) => Rewrite -> t -> TCM t+normalForm = \case+  AsIs         -> instantiate   -- #4975: reify will also instantiate by for goal-type-and-context-and-check+  Instantiated -> instantiate   --        we get a top-level fresh meta which has disappeared from state by the+  HeadNormal   -> reduce        --        time we get to reification. Hence instantiate here.+  Simplified   -> simplify+  Normalised   -> normalise++-- | Modifier for the interactive computation command,+--   specifying the mode of computation and result display.+--+computeIgnoreAbstract :: ComputeMode -> Bool+computeIgnoreAbstract DefaultCompute  = False+computeIgnoreAbstract HeadCompute     = False+computeIgnoreAbstract IgnoreAbstract  = True+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 ++ ")"+computeWrapInput _               s = s++showComputed :: ComputeMode -> Expr -> TCM Doc+showComputed UseShowInstance e =+  case e of+    A.Lit _ (LitString s) -> pure (text $ T.unpack s)+    _                     -> ("Expected applying `show` to the given value to produce a string literal, but got:" $$) <$> prettyATop e+showComputed _ e = prettyATop e++-- | Modifier for interactive commands,+--   specifying whether safety checks should be ignored.+outputFormId :: OutputForm a b -> b+outputFormId (OutputForm _ _ _ o) = out o+  where+    out = \case+      OfType i _                 -> i+      CmpInType _ _ i _          -> i+      CmpElim _ _ (i:_) _        -> i+      CmpElim _ _ [] _           -> __IMPOSSIBLE__+      JustType i                 -> i+      CmpLevels _ i _            -> i+      CmpTypes _ i _             -> i+      CmpTeles _ i _             -> i+      JustSort i                 -> i+      CmpSorts _ i _             -> i+      Assign i _                 -> i+      TypedAssign i _ _          -> i+      PostponedCheckArgs i _ _ _ -> i+      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++instance Reify ProblemConstraint where+  type ReifiesTo ProblemConstraint = Closure (OutputForm Expr Expr)+  reify (PConstr pids unblock cl) = withClosure cl $ \ c ->+    OutputForm (getRange c) (Set.toList pids) unblock <$> reify c++reifyElimToExpr :: MonadReify m => I.Elim -> m Expr+reifyElimToExpr = \case+    I.IApply _ _ v -> appl "iapply" <$> reify (defaultArg $ v) -- TODO Andrea: endpoints?+    I.Apply v -> appl "apply" <$> reify v+    I.Proj _o f -> appl "proj" <$> reify ((defaultArg $ I.Def f []) :: Arg Term)+  where+    appl :: Text -> Arg Expr -> Expr+    appl s v = A.App defaultAppInfo_ (A.Lit empty (LitString s)) $ fmap unnamed v++instance Reify Constraint where+  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 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 <?>+      sep [ prange r, parensNonEmpty (sep [blockedOn unblock, prPids pids]) ]+    where+      prPids []    = empty+      prPids [pid] = "belongs to problem" <+> pretty pid+      prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map pretty pids)++      comma | null pids = empty+            | otherwise = ","++      blockedOn (UnblockOnAll bs) | Set.null bs = empty+      blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" P.<> comma+      blockedOn u = "blocked on" <+> (pretty u P.<> comma)++      prange r | null s = empty+               | otherwise = text $ " [ at " ++ s ++ " ]"+        where s = prettyShow r++instance (Pretty a, Pretty b) => Pretty (OutputConstraint a b) where+  pretty oc =+    case oc of+      OfType e t           -> pretty e .: t+      JustType e           -> "Type" <+> pretty e+      JustSort e           -> "Sort" <+> pretty e+      CmpInType cmp t e e' -> pcmp cmp e e' .: t+      CmpElim cmp t e e'   -> pcmp cmp e e' .: t+      CmpTypes  cmp t t'   -> pcmp cmp t t'+      CmpLevels cmp t t'   -> pcmp cmp t t'+      CmpTeles  cmp t t'   -> pcmp cmp t t'+      CmpSorts cmp s s'    -> pcmp cmp s s'+      Assign m e           -> bin (pretty m) ":=" (pretty e)+      TypedAssign m e a    -> bin (pretty m) ":=" $ bin (pretty e) ":?" (pretty a)+      PostponedCheckArgs m es t0 t1 ->+        bin (pretty m) ":=" $ (parens ("_" .: t0) <+> fsep (map (paren . pretty) es)) .: t1+        where paren d = mparens (any (`elem` [' ', '\n']) $ show d) d+      IsEmptyType a        -> "Is empty:" <+> pretty a+      SizeLtSat a          -> "Not empty type of sizes:" <+> pretty a+      FindInstanceOF s t cs -> vcat+        [ "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" <+> 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)+      val .: ty = bin val ":" (pretty ty)+++instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputForm a b) where+    type ConOfAbs (OutputForm a b) = OutputForm (ConOfAbs a) (ConOfAbs b)+    toConcrete (OutputForm r pid u c) = OutputForm r pid u <$> toConcrete c++instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputConstraint a b) where+    type ConOfAbs (OutputConstraint a b) = OutputConstraint (ConOfAbs a) (ConOfAbs b)++    toConcrete (OfType e t) = OfType <$> toConcrete e <*> toConcreteCtx TopCtx t+    toConcrete (JustType e) = JustType <$> toConcrete e+    toConcrete (JustSort e) = JustSort <$> toConcrete e+    toConcrete (CmpInType cmp t e e') =+      CmpInType cmp <$> toConcreteCtx TopCtx t <*> toConcreteCtx TopCtx e+                                               <*> toConcreteCtx TopCtx e'+    toConcrete (CmpElim cmp t e e') =+      CmpElim cmp <$> toConcreteCtx TopCtx t <*> toConcreteCtx TopCtx e <*> toConcreteCtx TopCtx e'+    toConcrete (CmpTypes cmp e e') = CmpTypes cmp <$> toConcreteCtx TopCtx e+                                                  <*> toConcreteCtx TopCtx e'+    toConcrete (CmpLevels cmp e e') = CmpLevels cmp <$> toConcreteCtx TopCtx e+                                                    <*> toConcreteCtx TopCtx e'+    toConcrete (CmpTeles cmp e e') = CmpTeles cmp <$> toConcrete e <*> toConcrete e'+    toConcrete (CmpSorts cmp e e') = CmpSorts cmp <$> toConcreteCtx TopCtx e+                                                  <*> toConcreteCtx TopCtx e'+    toConcrete (Assign m e) = noTakenNames $ Assign <$> toConcrete m <*> toConcreteCtx TopCtx e+    toConcrete (TypedAssign m e a) = TypedAssign <$> toConcrete m <*> toConcreteCtx TopCtx e+                                                                  <*> toConcreteCtx TopCtx a+    toConcrete (PostponedCheckArgs m args t0 t1) =+      PostponedCheckArgs <$> toConcrete m <*> toConcrete args <*> toConcrete t0 <*> toConcrete t1+    toConcrete (IsEmptyType a) = IsEmptyType <$> toConcreteCtx TopCtx a+    toConcrete (SizeLtSat a) = SizeLtSat <$> toConcreteCtx TopCtx a+    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++instance (Pretty a, Pretty b) => Pretty (OutputConstraint' a b) where+  pretty (OfType' e t) = pretty e <+> ":" <+> pretty t++instance (ToConcrete a, ToConcrete b) => ToConcrete (OutputConstraint' a b) where+  type ConOfAbs (OutputConstraint' a b) = OutputConstraint' (ConOfAbs a) (ConOfAbs b)+  toConcrete (OfType' e t) = OfType' <$> toConcrete e <*> toConcreteCtx TopCtx t++instance Reify a => Reify (IPBoundary' a) where+  type ReifiesTo (IPBoundary' a) = IPBoundary' (ReifiesTo a)+  reify = traverse reify++instance ToConcrete a => ToConcrete (IPBoundary' a) where+  type ConOfAbs (IPBoundary' a) = IPBoundary' (ConOfAbs a)++  toConcrete = traverse (toConcreteCtx TopCtx)++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++prettyConstraints :: [Closure Constraint] -> TCM [OutputForm C.Expr C.Expr]+prettyConstraints cs = do+  forM cs $ \ c -> do+            cl <- reify (PConstr Set.empty alwaysUnblock c)+            enterClosure cl abstractToConcrete_++getConstraints :: TCM [OutputForm C.Expr C.Expr]+getConstraints = getConstraints' return $ const True++namedMetaOf :: OutputConstraint A.Expr a -> a+namedMetaOf (OfType i _) = i+namedMetaOf (JustType i) = i+namedMetaOf (JustSort i) = i+namedMetaOf (Assign i _) = i+namedMetaOf _ = __IMPOSSIBLE__++getConstraintsMentioning :: Rewrite -> MetaId -> TCM [OutputForm C.Expr C.Expr]+getConstraintsMentioning norm m = getConstrs instantiateBlockingFull (mentionsMeta m)+  -- could be optimized by not doing a full instantiation up front, with a more clever mentionsMeta.+  where+    instantiateBlockingFull p+      = 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+    -- the call to @unifyElimsMeta@ below.+    hasHeadMeta c =+      case c of+        ValueCmp _ _ u v           -> isMeta u `mplus` isMeta v+        ValueCmpOnFace cmp p t u v -> isMeta u `mplus` isMeta v+        -- TODO: extend to other comparisons?+        ElimCmp cmp fs t v as bs   -> Nothing+        LevelCmp cmp u v           -> Nothing+        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 _ ms _ t  -> caseMaybe ms (isMeta t) $ \ s -> isMetaS s `mplus` isMeta t++    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)+      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+        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.+            unifyElimsMeta m as_m c $ \ eqs c -> do+              flip enterClosure abstractToConcrete_ =<< reify . PConstr s ub =<< buildClosure c+          _ -> do+            cl <- reify $ PConstr s ub c+            enterClosure cl abstractToConcrete_++-- Copied from Agda.TypeChecking.Pretty.Warning.prettyConstraints+stripConstraintPids :: Constraints -> Constraints+stripConstraintPids cs = List.sortBy (compare `on` isBlocked) $ map stripPids cs+  where+    isBlocked = not . null . allBlockingProblems . constraintUnblocker+    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)+    cs <- forM cs $ \c -> do+            cl <- reify c+            enterClosure cl abstractToConcrete_+    ss <- mapM toOutputForm =<< getSolvedInteractionPoints True AsIs -- get all+    return $ ss ++ cs+  where+    toOutputForm (ii, mi, e) = do+      mv <- getMetaInfo <$> lookupLocalMeta mi+      withMetaInfo mv $ do+        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++  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+getGoals = getGoals' AsIs Simplified+  -- visible metas (as-is)+  -- hidden metas (unsolved implicit arguments simplified)++getGoals'+  :: Rewrite    -- ^ Degree of normalization of goals.+  -> Rewrite    -- ^ Degree of normalization of hidden goals.+  -> TCM Goals+getGoals' normVisible normHidden = do+  visibleMetas <- typesOfVisibleMetas normVisible+  hiddenMetas <- typesOfHiddenMetas normHidden+  return (visibleMetas, hiddenMetas)++-- | Print open metas nicely.+showGoals :: Goals -> TCM String+showGoals (ims, hms) = do+  di <- forM ims $ \ i ->+    withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock i) $+      prettyATop i+  dh <- mapM showA' hms+  return $ unlines $ map show di ++ dh+  where+    showA' :: OutputConstraint A.Expr NamedMeta -> TCM String+    showA' m = do+      let i = nmid $ namedMetaOf m+      r <- getMetaRange i+      d <- withMetaId i (prettyATop m)+      return $ show d ++ "  [ at " ++ prettyShow r ++ " ]"++getWarningsAndNonFatalErrors :: TCM WarningsAndNonFatalErrors+getWarningsAndNonFatalErrors = do+  mws <- getAllWarnings AllWarnings+  let notMetaWarnings = filter (not . isMetaTCWarning) $ Set.toList mws+  return $ case notMetaWarnings of+    ws@(_:_) -> classifyWarnings ws+    _ -> empty++-- | Collecting the context of the given meta-variable.+getResponseContext+  :: Rewrite      -- ^ Normalise?+  -> InteractionId+  -> TCM [ResponseContextEntry]+getResponseContext norm ii = contextOfMeta ii norm++-- | @getSolvedInteractionPoints True@ returns all solutions,+--   even if just solved by another, non-interaction meta.+--+--   @getSolvedInteractionPoints False@ only returns metas that+--   are solved by a non-meta.++getSolvedInteractionPoints :: Bool -> Rewrite -> TCM [(InteractionId, MetaId, Expr)]+getSolvedInteractionPoints all norm = concat <$> do+  mapM solution =<< getInteractionIdsAndMetas+  where+    solution (i, m) = do+      mv <- lookupLocalMeta m+      withMetaInfo (getMetaInfo mv) $ do+        args  <- getContextArgs+        scope <- getScope+        let sol v = do+              -- Andreas, 2014-02-17 exclude metas solved by metas+              v <- instantiate v+              let isMeta = case v of MetaV{} -> True; _ -> False+              if isMeta && not all then return [] else do+                e <- blankNotInScope =<< reify =<< normalForm norm v+                return [(i, m, ScopedExpr scope e)]+            unsol = return []+        case mvInstantiation mv of+          InstV{}                        -> sol (MetaV m $ map Apply args)+          OpenMeta{}                     -> unsol+          BlockedConst{}                 -> unsol+          PostponedTypeCheckingProblem{} -> unsol++typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta)+typeOfMetaMI norm mi =+     do mv <- lookupLocalMeta mi+        withMetaInfo (getMetaInfo mv) $+          rewriteJudg mv (mvJudgement mv)+   where+    rewriteJudg :: MetaVariable -> Judgement MetaId ->+                   TCM (OutputConstraint Expr NamedMeta)+    rewriteJudg mv (HasType i cmp t) = do+      ms <- getMetaNameSuggestion i+      -- Andreas, 2019-03-17, issue #3638:+      -- Need to put meta type into correct context _before_ normalizing,+      -- otherwise rewrite rules in parametrized modules will not fire.+      vs <- getContextArgs+      t <- t `piApplyM` permute (takeP (size vs) $ mvPermutation mv) vs+      t <- normalForm norm t+      let x = NamedMeta ms i+      reportSDoc "interactive.meta" 10 $ TP.vcat+        [ TP.text $ unwords ["permuting", show i, "with", show $ mvPermutation mv]+        , TP.nest 2 $ TP.vcat+          [ "len  =" TP.<+> TP.text (show $ length vs)+          , "args =" TP.<+> prettyTCM vs+          , "t    =" TP.<+> prettyTCM t+          , "x    =" TP.<+> TP.pretty x+          ]+        ]+      reportSDoc "interactive.meta.scope" 20 $ TP.text $ show $ getMetaScope mv+      -- Andreas, 2016-01-19, issue #1783: need piApplyM instead of just piApply+      OfType x <$> reifyUnblocked t+    rewriteJudg mv (IsSort i t) = do+      ms <- getMetaNameSuggestion i+      return $ JustSort $ NamedMeta ms i+++typeOfMeta :: Rewrite -> InteractionId -> TCM (OutputConstraint Expr InteractionId)+typeOfMeta norm ii = typeOfMeta' norm . (ii,) =<< lookupInteractionId ii++typeOfMeta' :: Rewrite -> (InteractionId, MetaId) -> TCM (OutputConstraint Expr InteractionId)+typeOfMeta' norm (ii, mi) = fmap (\_ -> ii) <$> typeOfMetaMI norm mi++typesOfVisibleMetas :: Rewrite -> TCM [OutputConstraint Expr InteractionId]+typesOfVisibleMetas norm =+  liftTCM $ mapM (typeOfMeta' norm) =<< getInteractionIdsAndMetas++typesOfHiddenMetas :: Rewrite -> TCM [OutputConstraint Expr NamedMeta]+typesOfHiddenMetas norm = liftTCM $ do+  is    <- getInteractionMetas+  store <- MapS.filterWithKey (implicit is) <$> useR stOpenMetaStore+  mapM (typeOfMetaMI norm) $ MapS.keys store+  where+  implicit is x m | isJust (mvTwin m) = False+  implicit is x m =+    case mvInstantiation m of+      M.InstV{} -> __IMPOSSIBLE__+      M.OpenMeta _ -> x `notElem` is  -- OR: True in case of InstanceMeta !?+      M.BlockedConst{} -> False+      M.PostponedTypeCheckingProblem{} -> False++-- | Create type of application of new helper function that would solve the goal.+metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)+metaHelperType norm ii rng s = case words s of+  []    -> failure+  f : _ -> withInteractionId ii $ do+    ensureName f+    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+     -- If all arguments are variables, there is no need to abstract.+     -- We simply make exactly the given arguments visible and all other hidden.+     Just xs -> do+      let inXs = hasElem xs+      let hideButXs ce = setHiding (if inXs (ctxEntryName ce) then NotHidden else Hidden) ce+      let tel = contextToTel . map hideButXs $ contextForAbstracting+      OfType' h <$> do+        runInPrintingEnvironment $ reify $ telePiVisible tel a0++     -- If some arguments are not variables (in this case, @args@ is not empty).+     Nothing -> do+      -- cleanupType relies on with arguments being named 'w',+      -- so we'd better rename any actual 'w's to avoid confusion.+      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) $+        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 <- 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 = interactionError ExpectedApplication+    ensureName f = do+      ce <- parseExpr rng f+      flip (caseMaybe $ isName ce) (\ _ -> return ()) $ do+         reportSLn "interaction.helper" 10 $ "ce = " ++ show ce+         failure+    isVar :: A.Expr -> Maybe A.Name+    isVar = \case+      A.Var x -> Just x+      _ -> Nothing+    cleanupType arity args t = do+      -- Get the arity of t+      TelV ttel _ <- telView t+      -- Compute the number of pi-types subject to stripping.+      let n = size ttel - arity+      -- It cannot be negative, otherwise we would have performed a+      -- negative number of with-abstractions.+      unless (n >= 0) __IMPOSSIBLE__+      return $ evalState (renameVars $ stripUnused n t) args++    getBody (A.Let _ _ e)      = e+    getBody _                  = __IMPOSSIBLE__++    -- Strip the non-dependent abstractions from the first n abstractions.+    stripUnused n (El s v) = El s $ strip n v+    strip 0 = id+    strip n = \case+      I.Pi a b -> case stripUnused (n-1) <$> b of+        b | absName b == "w"   -> I.Pi a b+        NoAbs _ b              -> unEl b+        Abs s b | 0 `freeIn` b -> I.Pi (hide a) (Abs s b)+                | otherwise    -> strengthen impossible (unEl b)+      v -> v  -- todo: handle if goal type is a Pi++    -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)+    renameVars = onNames renameVar++    -- 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+    onNamesTel :: Applicative f => (String -> f String) -> I.Telescope -> f I.Telescope+    onNamesTel f I.EmptyTel = pure I.EmptyTel+    onNamesTel f (I.ExtendTel a b) = I.ExtendTel <$> traverse (onNames f) a <*> onNamesAbs f onNamesTel b++    onNamesTm f = \case+      I.Var x es   -> I.Var x <$> onNamesElims f es+      I.Def q es   -> I.Def q <$> onNamesElims f es+      I.Con c ci args -> I.Con c ci <$> onNamesArgs f args+      I.Lam i b    -> I.Lam i <$> onNamesAbs f onNamesTm b+      I.Pi a b     -> I.Pi <$> traverse (onNames f) a <*> onNamesAbs f onNames b+      I.DontCare v -> I.DontCare <$> onNamesTm f v+      v@I.Lit{}    -> pure v+      v@I.Sort{}   -> pure v+      v@I.Level{}  -> pure v+      v@I.MetaV{}  -> pure v+      v@I.Dummy{}  -> pure v+    onNamesElims f = traverse $ traverse $ onNamesTm f+    onNamesArgs f  = traverse $ traverse $ onNamesTm f+    onNamesAbs f   = onNamesAbs' f (stringToArgName <.> f . argNameToString)+    onNamesAbs' f f' nd (Abs   s x) = Abs   <$> f' s <*> nd f x+    onNamesAbs' f f' nd (NoAbs s x) = NoAbs <$> f' s <*> nd f x++    unW "w" = return ".w"+    unW s   = return s++    renameVar "w" = betterName+    renameVar s   = pure s++    betterName = do+      xs <- get+      case xs of+        []         -> __IMPOSSIBLE__+        arg : args -> do+          put args+          return $ if+            | Arg _ (Named _ (A.Var x)) <- arg -> prettyShow $ A.nameConcrete x+            | Just x <- bareNameOf arg         -> argNameToString x+            | otherwise                        -> "w"+++-- | Gives a list of names and corresponding types.+--   This list includes not only the local variables in scope, but also the let-bindings.++contextOfMeta :: InteractionId -> Rewrite -> TCM [ResponseContextEntry]+contextOfMeta ii norm = withInteractionId ii $ do+  info <- getMetaInfo <$> (lookupLocalMeta =<< lookupInteractionId ii)+  withMetaInfo info $ do+    -- List of local variables.+    cxt <- getContext+    let localVars = zipWith raise [1..] cxt+    -- List of let-bindings.+    letVars <- Map.toAscList <$> asksTC envLetBindings+    -- Reify the types and filter out bindings without a name.+    (++) <$> forMaybeM (reverse localVars) mkVar+         <*> forMaybeM letVars mkLet++  where+    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+        let s = C.isInScope x+        ty <- reifyUnblocked =<< normalForm norm t+        return $ ResponseContextEntry n x (Arg ai ty) Nothing s++    mkLet :: (Name, Open M.LetBinding) -> TCM (Maybe ResponseContextEntry)+    mkLet (name, lb) = do+      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+              -- 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+    shouldHide ai n = not (isInstance ai) && (isNoName n || nameIsRecordName n)++-- | Returns the type of the expression in the current environment+--   We wake up irrelevant variables just in case the user want to+--   invoke that command in an irrelevant context.+typeInCurrent :: Rewrite -> Expr -> TCM Expr+typeInCurrent norm e =+    do  (_,t) <- wakeIrrelevantVars $ inferExpr e+        v <- normalForm norm t+        reifyUnblocked v++++typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr+typeInMeta ii norm e =+   do   m <- lookupInteractionId ii+        mi <- getMetaInfo <$> lookupLocalMeta m+        withMetaInfo mi $+            typeInCurrent norm e++-- | The intro tactic.+--+-- Returns the terms (as strings) that can be+-- used to refine the goal. Uses the coverage checker+-- to find out which constructors are possible.+--+introTactic :: Bool -> InteractionId -> TCM [String]+introTactic pmLambda ii = do+  mi <- lookupInteractionId ii+  mv <- lookupLocalMeta mi+  withMetaInfo (getMetaInfo mv) $ case mvJudgement mv of+    HasType _ _ t -> do+        t <- reduce =<< piApplyM t =<< getContextArgs+        -- Andreas, 2013-03-05 Issue 810: skip hidden domains in introduction+        -- of constructor.+        TelV tel' t <- telViewUpTo' (-1) notVisible t+        -- if we cannot introduce a constructor, we try a lambda+        let fallback = do+              cubical <- isJust <$> cubicalOption+              TelV tel _ <- (if cubical then telViewPath else telView) t+              reportSDoc "interaction.intro" 20 $ TP.sep+                [ "introTactic/fallback"+                , "tel' = " TP.<+> prettyTCM tel'+                , "tel  = " TP.<+> prettyTCM tel+                ]+              case (tel', tel) of+                (EmptyTel, EmptyTel) -> return []+                _ -> introFun (telToList tel' ++ telToList tel)++        case unEl t of+          I.Def d _ -> do+            def <- getConstInfo d+            case theDef def of+              Datatype{}    -> addContext tel' $ introData AmbiguousNothing t+              Record{ recNamedCon = name }+                | name      -> addContext tel' $ introData AmbiguousConProjs t+                | otherwise -> addContext tel' $ introRec d+              _ -> fallback+          _ -> fallback+     `catchError` \_ -> return []+    _ -> __IMPOSSIBLE__+  where+    conName :: [NamedArg SplitPattern] -> [I.ConHead]+    conName [p] = [ c | I.ConP c _ _ <- [namedArg p] ]+    conName _   = __IMPOSSIBLE__++    showUnambiguousConName :: AllowAmbiguousNames -> ConHead -> TCM String+    showUnambiguousConName amb c = render . pretty <$> do+      abstractToConcreteQName amb $ I.conName c++    showTCM :: PrettyTCM a => a -> TCM String+    showTCM = render <.> prettyTCM++    introFun :: ListTel -> TCM [String]+    introFun tel = addContext tel' $ do+        reportSDoc "interaction.intro" 10 $ do "introFun" TP.<+> prettyTCM (telFromList tel)+        imp <- showImplicitArguments+        let okHiding0 h = imp || h == NotHidden+            -- if none of the vars were displayed, we would get a parse error+            -- thus, we switch to displaying all+            allHidden   = not (any okHiding0 hs)+            okHiding    = if allHidden then const True else okHiding0+        vars <- -- setShowImplicitArguments (imp || allHidden) $+                applyWhen allHidden withShowAllArguments $+                  mapM showTCM [ setHiding h $ defaultArg $ var i :: Arg Term+                               | (h, i) <- zip hs $ downFrom n+                               , okHiding h+                               ]+        if pmLambda+           then return [ unwords $ ["λ", "{"] ++ vars ++ ["→", "?", "}"] ]+           else return [ unwords $ ["λ"]      ++ vars ++ ["→", "?"] ]+      where+        n = size tel+        hs   = map getHiding tel+        tel' = telFromList [ fmap makeName b | b <- tel ]+        makeName ("_", t) = ("x", t)+        makeName (x, t)   = (x, t)++    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]+      -- 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 amb) $ concatMap (conName . scPats) $ filter dimension $ splitClauses cov++    introRec :: QName -> TCM [String]+    introRec d = do+      hfs <- getRecordFieldNames d+      fs <- ifM showImplicitArguments+            (return $ map unDom hfs)+            (return [ unDom a | a <- hfs, visible a ])+      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:+      -- prettyShow is ok here since we are just printing something like+      -- record { f1 = ? ; ... ; fn = ?}+      -- which does not involve any qualified names, and the fi are C.Name.++-- | Runs the given computation as if in an anonymous goal at the end+--   of the top-level module.+--+--   Sets up current module, scope, and context.+atTopLevel :: TCM a -> TCM a+atTopLevel m = inConcreteMode $ 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@+      -- and put them into the context.+      --+      -- Andreas, 2017-04-24, issue #2552:+      --+      -- Delete the let-bound ones, since they are not represented+      -- in the module telescope.+      --+      -- This is a temporary fix until a better solution is available,+      -- e.g., when the module telescope represents let-bound variables.+      --+      -- Unfortunately, referring to let-bound variables+      -- from the top level module telescope will for now result in a not-in-scope error.+      let names :: [A.Name]+          names = map localVar $ filter ((LetBound /=) . localBindingSource)+                               $ map snd $ reverse $ scope ^. scopeLocals+      -- Andreas, 2016-12-31, issue #2371+      -- The following is an unnecessary complication, as shadowed locals+      -- are not in scope anyway (they are ambiguous).+      -- -- Replace the shadowed names by fresh names (such that they do not shadow imports)+      -- let mnames :: [Maybe A.Name]+      --     mnames = map (notShadowedLocal . snd) $ reverse $ scopeLocals scope+      -- names <- mapM (maybe freshNoName_ return) mnames+      let types :: [Dom I.Type]+          types = map (snd <$>) $ telToList tel+          gamma :: ListTel' A.Name+          gamma = fromMaybe __IMPOSSIBLE__ $+                    zipWith' (\ x dom -> (x,) <$> dom) names types+      reportSDoc "interaction.top" 20 $ TP.vcat+        [ "BasicOps.atTopLevel"+        , "  names = " TP.<+> TP.sep (map prettyA   names)+        , "  types = " TP.<+> TP.sep (map prettyTCM types)+        ]+      M.withCurrentModule current $+        withScope_ scope $+          addContext gamma $ do+            -- We're going inside the top-level module, so we have to set the+            -- checkpoint for it and all its submodules to the new checkpoint.+            cp <- viewTC eCurrentCheckpoint+            stModuleCheckpoints `modifyTCLens` fmap (const cp)+            m++-- | Parse a name.+parseName :: Range -> String -> TCM C.QName+parseName r s = do+  e <- parseExpr r s+  maybe (interactionError $ ExpectedIdentifier e) return $ isQName e++-- | Check whether an expression is a (qualified) identifier.+isQName :: C.Expr -> Maybe C.QName+isQName = \case+  C.Ident x                    -> return x+  _ -> Nothing++isName :: C.Expr -> Maybe C.Name+isName = isQName >=> \case+  C.QName x -> return x+  _ -> Nothing++-- | Returns the contents of the given module or record.++moduleContents+  :: Rewrite+     -- ^ How should the types be presented?+  -> Range+     -- ^ The range of the next argument.+  -> String+     -- ^ The module name.+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])+     -- ^ Module names,+     --   context extension needed to print types,+     --   names paired up with corresponding types.++moduleContents norm rng s = traceCall ModuleContents $ do+  if null (trim s) then getModuleContents norm Nothing else do+  e <- parseExpr rng s+  case isQName e of+    -- If the expression is not a single identifier, it is not a module name+    -- and treated as a record expression.+    Nothing -> getRecordContents norm e+    -- Otherwise, if it is not in scope as a module name, it is treated+    -- as a record name.+    Just x  -> do+      ms :: [AbstractModule] <- scopeLookup x <$> getScope+      if null ms then getRecordContents norm e else getModuleContents norm $ Just x++-- | Returns the contents of the given record identifier.++getRecordContents+  :: Rewrite  -- ^ Amount of normalization in types.+  -> C.Expr   -- ^ Expression presumably of record type.+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])+              -- ^ Module names,+              --   context extension,+              --   names paired up with corresponding types.+getRecordContents norm ce = 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+      -- Andreas, 2019-04-10, issue #3687: use flattenTel+      -- to bring types into correct scope.+      reportSDoc "interaction.contents.record" 20 $ TP.vcat+        [ "getRecordContents"+        , "  cxt  = " TP.<+> (prettyTCM =<< getContextTelescope)+        , "  tel  = " TP.<+> prettyTCM tel+        , "  doms = " TP.<+> prettyTCM doms+        , "  doms'= " TP.<+> addContext tel (prettyTCM doms)+        ]+      ts <- mapM (normalForm norm . unDom) doms+      return ([], tel, zip xs ts)++-- | Returns the contents of the given module.++getModuleContents+  :: Rewrite+       -- ^ Amount of normalization in types.+  -> Maybe C.QName+       -- ^ Module name, @Nothing@ if top-level module.+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])+       -- ^ Module names,+       --   context extension,+       --   names paired up with corresponding types.+getModuleContents norm mm = do+  modScope <- case mm of+    Nothing -> getCurrentScope+    Just m  -> getNamedScope . amodName =<< resolveModule m+  let modules :: ThingsInScope AbstractModule+      modules = exportedNamesInScope modScope+      names :: ThingsInScope AbstractName+      names = exportedNamesInScope modScope+      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 :: FilePath -> String -> TCM WhyInScopeData+whyInScope cwd s = do+  x     <- parseName noRange s+  scope <- getScope+  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
@@ -1,18 +1,28 @@-{-# LANGUAGE CPP #-} -module Agda.Interaction.CommandLine where+module Agda.Interaction.CommandLine+  ( runInteractionLoop+  ) where +import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.State import Control.Monad.Reader-import Control.Applicative -import Data.List as List+import qualified Data.List as List import Data.Maybe +import Text.Read (readMaybe)++import Agda.Interaction.Base hiding (Command) import Agda.Interaction.BasicOps as BasicOps hiding (parseExpr)+import Agda.Interaction.Imports ( CheckResult, crInterface ) import Agda.Interaction.Monad  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 import Agda.Syntax.Position@@ -20,9 +30,6 @@ import Agda.Syntax.Translation.ConcreteToAbstract import Agda.Syntax.Abstract.Pretty -import Text.PrettyPrint--import Agda.TheTypeChecker import Agda.TypeChecking.Constraints import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce@@ -30,69 +37,112 @@ import Agda.TypeChecking.Pretty ( PrettyTCM(prettyTCM) ) import Agda.TypeChecking.Substitute -import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Monad+import Agda.Utils.FileName (absolute, AbsolutePath)+import Agda.Utils.Maybe (caseMaybeM) -#include "undefined.h" import Agda.Utils.Impossible +data ReplEnv = ReplEnv+    { replSetupAction     :: TCM ()+    , replTypeCheckAction :: AbsolutePath -> TCM CheckResult+    }++data ReplState = ReplState+    { currentFile :: Maybe AbsolutePath+    }++newtype ReplM a = ReplM { unReplM :: ReaderT ReplEnv (StateT ReplState IM) a }+    deriving+    ( Functor, Applicative, Monad, MonadIO+    , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM+    , MonadError TCErr+    , MonadReader ReplEnv, MonadState ReplState+    , MonadFileId+    )++runReplM :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> ReplM () -> TCM ()+runReplM initialFile setup checkInterface+    = runIM+    . flip evalStateT (ReplState initialFile)+    . flip runReaderT replEnv+    . unReplM+  where+  replEnv = ReplEnv+    { replSetupAction     = setup+    , replTypeCheckAction = checkInterface+    }+ data ExitCode a = Continue | ContinueIn TCEnv | Return a -type Command a = (String, [String] -> TCM (ExitCode a))+type Command a = (String, [String] -> ReplM (ExitCode a)) -matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a))+matchCommand :: String -> [Command a] -> Either [String] ([String] -> ReplM (ExitCode a)) matchCommand x cmds =-    case List.filter (isPrefixOf x . fst) cmds of+    case List.filter (List.isPrefixOf x . fst) cmds of         [(_,m)] -> Right m         xs      -> Left $ List.map fst xs -interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a+interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> ReplM a interaction prompt cmds eval = loop     where         go (Return x)       = return x         go Continue         = loop-        go (ContinueIn env) = local (const env) loop+        go (ContinueIn env) = localTC (const env) loop          loop =-            do  ms <- readline prompt+            do  ms <- ReplM $ lift $ lift $ readline prompt                 case fmap words ms of                     Nothing               -> return $ error "** EOF **"                     Just []               -> loop                     Just ((':':cmd):args) ->                         do  case matchCommand cmd cmds of-                                Right c -> go =<< liftTCM (c args)+                                Right c -> go =<< (c args)                                 Left [] ->                                     do  liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'"                                         loop                                 Left xs ->-                                    do  liftIO $ putStrLn $ "More than one command match: " ++ concat (intersperse ", " xs)+                                    do  liftIO $ putStrLn $ "More than one command match: " +++                                                            List.intercalate ", " xs                                         loop                     Just _ ->                         do  go =<< liftTCM (eval $ fromJust ms)             `catchError` \e ->-                do  s <- liftTCM $ prettyError e+                do  s <- renderError e                     liftIO $ putStrLn s                     loop +runInteractionLoop :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()+runInteractionLoop initialFile setup check = runReplM initialFile setup check interactionLoop++replSetup :: ReplM ()+replSetup = do+    liftTCM =<< asks replSetupAction+    liftIO $ putStr splashScreen++checkCurrentFile :: ReplM (Maybe CheckResult)+checkCurrentFile = traverse checkFile =<< gets currentFile++checkFile :: AbsolutePath -> ReplM CheckResult+checkFile file = liftTCM . ($ file) =<< asks replTypeCheckAction+ -- | The interaction loop.-interactionLoop :: TCM (Maybe Interface) -> IM ()-interactionLoop doTypeCheck =-    do  liftTCM reload-        interaction "Main> " commands evalTerm+interactionLoop :: ReplM ()+interactionLoop = do+    -- Run the setup action+    replSetup+    reload+    interaction "Main> " commands evalTerm     where-        reload = do-            mi <- doTypeCheck-            -- Note that mi is Nothing if (1) there is no input file or-            -- (2) the file type checked with unsolved metas and-            -- --allow-unsolved-metas was used. In the latter case the-            -- behaviour of agda -I may be surprising. If agda -I ever-            -- becomes properly supported again, then this behaviour-            -- should perhaps be fixed.-            setScope $ case mi of-              Just i  -> iInsideScope i-              Nothing -> emptyScopeInfo+        reload :: ReplM () = do+            checked <- checkCurrentFile+            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." @@ -100,42 +150,44 @@             [ "quit"        |>  \_ -> return $ Return ()             , "?"           |>  \_ -> continueAfter $ liftIO $ help commands             , "reload"      |>  \_ -> do reload-                                         ContinueIn <$> ask-            , "constraints" |> \args -> continueAfter $ showConstraints args-            , "Context"     |> \args -> continueAfter $ showContext args-            , "give"        |> \args -> continueAfter $ giveMeta args-            , "Refine"      |> \args -> continueAfter $ refineMeta args-            , "metas"       |> \args -> continueAfter $ showMetas args+                                         ContinueIn <$> askTC+            , "constraints" |> \args -> continueAfter $ liftTCM $ showConstraints args+            , "Context"     |> \args -> continueAfter $ liftTCM $ showContext args+            , "give"        |> \args -> continueAfter $ liftTCM $ giveMeta args+            , "Refine"      |> \args -> continueAfter $ liftTCM $ refineMeta args+            , "metas"       |> \args -> continueAfter $ liftTCM $ showMetas args             , "load"        |> \args -> continueAfter $ loadFile reload args-            , "eval"        |> \args -> continueAfter $ evalIn args-            , "typeOf"      |> \args -> continueAfter $ typeOf args-            , "typeIn"      |> \args -> continueAfter $ typeIn args-            , "wakeup"      |> \_ -> continueAfter $ retryConstraints-            , "scope"       |> \_ -> continueAfter $ showScope+            , "eval"        |> \args -> continueAfter $ liftTCM $ evalIn args+            , "typeOf"      |> \args -> continueAfter $ liftTCM $ typeOf args+            , "typeIn"      |> \args -> continueAfter $ liftTCM $ typeIn args+            , "wakeup"      |> \_ -> continueAfter $ liftTCM $ retryConstraints+            , "scope"       |> \_ -> continueAfter $ liftTCM $ showScope             ]             where                 (|>) = (,) -continueAfter :: TCM a -> TCM (ExitCode b)+continueAfter :: ReplM a -> ReplM (ExitCode b) continueAfter m = withCurrentFile $ do   m >> return Continue --- | Set 'envCurrentPath' to 'optInputFile'.-withCurrentFile :: TCM a -> TCM a+-- | Set 'envCurrentPath' to the repl's current file+withCurrentFile :: ReplM a -> ReplM a withCurrentFile cont = do-  mpath <- getInputFile'-  local (\ e -> e { envCurrentPath = mpath }) cont+  mpath <- gets currentFile+  i <- traverse idFromFile mpath+  localTC (\ e -> e { envCurrentPath = i }) cont -loadFile :: TCM () -> [String] -> TCM ()+loadFile :: ReplM () -> [String] -> ReplM () loadFile reload [file] = do-  setInputFile file+  absPath <- liftIO $ absolute file+  modify (\(ReplState _prevFile) -> ReplState (Just absPath))   withCurrentFile reload loadFile _ _ = liftIO $ putStrLn ":load file"  showConstraints :: [String] -> TCM () showConstraints [] =     do  cs <- BasicOps.getConstraints-        liftIO $ putStrLn $ unlines (List.map show cs)+        liftIO $ putStrLn $ unlines (List.map prettyShow cs) showConstraints _ = liftIO $ putStrLn ":constraints [cid]"  @@ -145,22 +197,22 @@         withInteractionId i $ do           s <- typeOfMeta AsIs i           r <- getInteractionRange i-          d <- showA s-          liftIO $ putStrLn $ d ++ " " ++ show r+          d <- prettyA s+          liftIO $ putStrLn $ render d ++ " " ++ prettyShow r showMetas [m,"normal"] =     do  i <- InteractionId <$> readM m         withInteractionId i $ do-          s <- showA =<< typeOfMeta Normalised i+          s <- prettyA =<< typeOfMeta Normalised i           r <- getInteractionRange i-          liftIO $ putStrLn $ s ++ " " ++ show r+          liftIO $ putStrLn $ render s ++ " " ++ prettyShow r showMetas [] =     do  interactionMetas <- typesOfVisibleMetas AsIs         hiddenMetas      <- typesOfHiddenMetas  AsIs-        mapM_ (liftIO . putStrLn) =<< mapM showII interactionMetas+        mapM_ (liftIO . print) =<< mapM showII interactionMetas         mapM_ print' hiddenMetas     where-        showII o = withInteractionId (outputFormId $ OutputForm noRange [] o) $ showA o-        showM  o = withMetaId (nmid $ outputFormId $ OutputForm noRange [] o) $ showA o+        showII o = withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock o) $ prettyA o+        showM  o = withMetaId (nmid $ outputFormId $ OutputForm noRange [] alwaysUnblock o) $ prettyA o          metaId (OfType i _) = i         metaId (JustType i) = i@@ -170,25 +222,24 @@         print' x = do             r <- getMetaRange $ nmid $ metaId x             d <- showM x-            liftIO $ putStrLn $ d ++ "  [ at " ++ show r ++ " ]"+            liftIO $ putStrLn $ render d ++ "  [ at " ++ prettyShow r ++ " ]" showMetas _ = liftIO $ putStrLn $ ":meta [metaid]"   showScope :: TCM () showScope = do   scope <- getScope-  liftIO $ print scope+  liftIO $ putStrLn $ prettyShow scope  metaParseExpr ::  InteractionId -> String -> TCM A.Expr metaParseExpr ii s =     do  m <- lookupInteractionId ii-        scope <- getMetaScope <$> lookupMeta m-        r <- getRange <$> lookupMeta m-        --liftIO $ putStrLn $ show scope-        let pos = case rStart r of-                    Nothing  -> __IMPOSSIBLE__-                    Just pos -> pos-        e <- runPM $ parsePosString exprParser pos s+        scope <- getMetaScope <$> lookupLocalMeta m+        r <- getRange <$> lookupLocalMeta m+        -- liftIO $ putStrLn $ prettyShow scope+        let pos = fromMaybe __IMPOSSIBLE__ (rStart r)+        (e, attrs) <- runPM $ parsePosString exprParser pos s+        checkAttributes attrs         concreteToAbstract scope e  actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a@@ -202,7 +253,7 @@  giveMeta :: [String] -> TCM () giveMeta s | length s >= 2 = do-  _ <- actOnMeta s (\ii -> \e -> give ii Nothing e)+  _ <- actOnMeta s $ \ ii e -> give WithoutForce ii Nothing e   return () giveMeta _ = liftIO $ putStrLn $ ": give" ++ " metaid expr" @@ -210,62 +261,57 @@  refineMeta :: [String] -> TCM () refineMeta s | length s >= 2 = do-  _ <- actOnMeta s (\ii -> \e -> refine ii Nothing e)+  _ <- actOnMeta s $ \ ii e -> refine WithoutForce ii Nothing e   return () refineMeta _ = liftIO $ putStrLn $ ": refine" ++ " metaid expr"    retryConstraints :: TCM ()-retryConstraints = liftTCM wakeupConstraints_+retryConstraints = wakeupConstraints_   evalIn :: [String] -> TCM () evalIn s | length s >= 2 =-    do  d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e+    do  d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent DefaultCompute e         liftIO $ print d evalIn _ = liftIO $ putStrLn ":eval metaid expr"  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) evalTerm s =     do  e <- parseExpr s-        v <- evalInCurrent e+        v <- evalInCurrent DefaultCompute e         e <- prettyTCM v-        liftIO $ putStrLn $ show e+        liftIO $ print e         return Continue-    where-        evalInCurrent e = do-          (v,t) <- inferExpr e-          v'    <- normalise v-          return v' - typeOf :: [String] -> TCM () typeOf s =     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 unDom . telToList <$> getContextTelescope+      ctx <- List.map I.unDom . telToList <$> getContextTelescope       zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx     where         display (x, t) n = do@@ -273,7 +319,7 @@                     ["normal"] -> normalise $ raise n t                     _          -> return $ raise n t             d <- prettyTCM t-            liftIO $ print $ text (I.argNameToString x) <+> text ":" <+> d+            liftIO $ print $ text (argNameToString x) <+> ":" <+> d showContext _ = liftIO $ putStrLn ":Context meta"  -- | The logo that prints when Agda is started in interactive mode.@@ -289,7 +335,8 @@     , "        __/ /"     , "        \\__/"     , ""-    , "The interactive mode is no longer supported. Don't complain if it doesn't work."+    -- , "The interactive mode is no longer supported. Don't complain if it doesn't work."+    , "The interactive mode is no longer under active development. Use at your own risk."     ]  -- | The help message@@ -299,3 +346,10 @@     [ "<exp> Infer type of expression <exp> and evaluate it." ]     where         explain (x,_) = ":" ++ x++-- Read -------------------------------------------------------------------++readM :: Read a => String -> TCM a+readM s = maybe err return $ readMaybe s+  where+  err = throwError $ GenericException $ "Cannot parse: " ++ s
src/full/Agda/Interaction/EmacsCommand.hs view
@@ -8,15 +8,14 @@   , response   , putResponse   , display_info'-  , display_warning   , clearRunningInfo   , clearWarning   , 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.@@ -30,21 +29,22 @@     -- ^ List.   | Q (Lisp a)     -- Quoted expression.+  deriving Eq  instance Pretty a => Pretty (Lisp a) where   pretty (A a )     = pretty a-  pretty (Cons a b) = parens (pretty a <+> text "." <+> pretty b)+  pretty (Cons a b) = parens (pretty a <+> "." <+> pretty b)   pretty (L xs)     = parens (hsep (map pretty xs))-  pretty (Q x)      = text "'" <> pretty x+  pretty (Q x)      = "'" <> pretty x -instance Show (Lisp String) where-  showsPrec _ (A a)      = showString a-  showsPrec p (Cons a b) = showString "(" . showsPrec p a . showString " . " .-                                            showsPrec p b . showString ")"-  showsPrec p (L xs)     = showString "(" . foldr (.) (showString ")")-                                              (List.intersperse (showString " ")-                                                 (map (showsPrec p) xs))-  showsPrec p (Q x)      = showString "'" . showsPrec p x+-- instance Show (Lisp String) where+--   showsPrec _ (A a)      = showString a+--   showsPrec p (Cons a b) = showString "(" . showsPrec p a . showString " . " .+--                                             showsPrec p b . showString ")"+--   showsPrec p (L xs)     = showString "(" . foldr (.) (showString ")")+--                                               (List.intersperse (showString " ")+--                                                  (map (showsPrec p) xs))+--   showsPrec p (Q x)      = showString "'" . showsPrec p x  -- | Formats a response command. --@@ -76,9 +76,6 @@  display_info' :: Bool -> String -> String -> Lisp String display_info' = displayInBuffer "agda2-info-action"--display_warning :: String -> String -> Lisp String-display_warning = displayInBuffer "agda2-warning-action" False  ------------------------------------------------------------------------ -- Running info
src/full/Agda/Interaction/EmacsTop.hs view
@@ -1,32 +1,45 @@--- {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.EmacsTop     ( mimicGHCi+    , namedMetaOf+    , showGoals+    , showInfoError+    , explainWhyInScope+    , prettyResponseContext+    , prettyTypeOfMeta     ) where-import Control.Applicative-import Control.Monad.State -import Data.Char-import Data.List-import Data.Maybe--import System.IO+import Control.Monad+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.State    ( evalStateT )+import Control.Monad.Trans    ( lift ) -import Agda.Utils.Monad-import Agda.Utils.Pretty-import Agda.Utils.String+import qualified Data.List as List  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Abstract.Pretty (prettyATop)+import Agda.Syntax.Concrete as C +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) import Agda.TypeChecking.Monad-import qualified Agda.TypeChecking.Monad.Benchmark as Bench-+import Agda.Interaction.AgdaTop+import Agda.Interaction.Base+import Agda.Interaction.BasicOps as B import Agda.Interaction.Response as R-import Agda.Interaction.InteractionTop-import Agda.Interaction.EmacsCommand+import Agda.Interaction.EmacsCommand hiding (putResponse) import Agda.Interaction.Highlighting.Emacs-import Agda.Interaction.Options-+import Agda.Interaction.Highlighting.Precise (TokenBased(..))+import Agda.Interaction.Command (localStateCommandM)+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Null (empty)+import Agda.Utils.Maybe+import Agda.Utils.String+import Agda.Utils.Time (CPUTime) import Agda.VersionCommit  ----------------------------------@@ -36,120 +49,37 @@ -- --   'mimicGHCi' reads the Emacs frontend commands from stdin, --   interprets them and print the result into stdout.- mimicGHCi :: TCM () -> TCM ()-mimicGHCi setup = do-    liftIO $ do-      hSetBuffering stdout LineBuffering-      hSetBuffering stdin  LineBuffering-      hSetEncoding  stdout utf8-      hSetEncoding  stdin  utf8--    setInteractionOutputCallback $-        liftIO . mapM_ print <=< lispifyResponse--    handleCommand_ (lift setup) `evalStateT` initCommandState--    opts <- commandLineOptions-    _ <- interact' `runStateT` initCommandState { optionsOnReload = opts{ optAbsoluteIncludePaths = [] } }-    return ()-  where--    interact' :: CommandM ()-    interact' = do-      Bench.reset-      done <- Bench.billTo [] $ do--        liftIO $ do-          putStr "Agda2> "-          hFlush stdout-        done <- liftIO isEOF-        unless done $ do-            r <- liftIO getLine-            _ <- return $! length r     -- force to read the full input line-            case dropWhile isSpace r of-                ""  -> return ()-                ('-':'-':_) -> return ()-                _ -> case listToMaybe $ reads r of-                    Just (x, "")  -> runInteraction x-                    Just (_, rem) -> liftIO $ putStrLn $ "not consumed: " ++ rem-                    _ ->             liftIO $ putStrLn $ "cannot read: " ++ r-        return done--      lift Bench.print-      unless done interact'+mimicGHCi = repl (liftIO . mapM_ (putStrLn . prettyShow) <=< lispifyResponse) "Agda2> "  -- | Convert Response to an elisp value for the interactive emacs frontend.  lispifyResponse :: Response -> TCM [Lisp String]-lispifyResponse (Resp_HighlightingInfo info modFile) =-  (:[]) <$> lispifyHighlightingInfo info modFile-lispifyResponse (Resp_DisplayInfo info) = return $ case info of-    Info_CompilationOk -> f "The module was successfully compiled." "*Compilation result*"-    Info_Constraints s -> f s "*Constraints*"-    Info_AllGoalsWarnings g  w e -> f body ("*All" ++ title ++ "*")-      where-        isG = not $ null g-        isW = not $ null w-        isE = not $ null e-        title = intercalate "," $ catMaybes-                  [ " Goals"    <$ guard isG-                  , " Warnings" <$ guard isW-                  , " Errors"   <$ guard isE-                  , " Done"     <$ guard (not (isG || isW || isE))-                  ]-        delimiter s = concat [ replicate 4 '\x2014'-                             , " ", s, " "-                             , replicate (54 - length s) '\x2014'-                             ]--        body = intercalate "\n" $ catMaybes-                 [ g                    <$ guard isG-                 , delimiter "Warnings" <$ guard (isW && (isG || isE))-                 , w                    <$ guard isW-                 , delimiter "Errors"   <$ guard (isE && (isG || isW))-                 , e                    <$ guard isE-                 ]-    Info_Auto s -> f s "*Auto*"-    Info_Error s -> f s "*Error*"-    -- FNF: if Info_Warning comes back into use, the above should be-    -- clearWarning : f s "*Error*"-    --Info_Warning s -> [ display_warning "*Errors*" s ] -- FNF: currently unused-    Info_Time s -> f (render s) "*Time*"-    Info_NormalForm s -> f (render s) "*Normal Form*"   -- show?-    Info_InferredType s -> f (render s) "*Inferred Type*"-    Info_CurrentGoal s -> f (render s) "*Current Goal*"-    Info_GoalType s -> f (render s) "*Goal type etc.*"-    Info_ModuleContents s -> f (render s) "*Module contents*"-    Info_SearchAbout s -> f (render s) "*Search About*"-    Info_WhyInScope s -> f (render s) "*Scope Info*"-    Info_Context s -> f (render s) "*Context*"-    Info_HelperFunction s -> [ L [ A "agda2-info-action-and-copy"-                                 , A $ quote "*Helper function*"-                                 , A $ quote (render s ++ "\n")-                                 , A "nil"-                                 ]-                             ]-    Info_Intro s -> f (render s) "*Intro*"-    Info_Version -> f ("Agda version " ++ versionWithCommitInfo) "*Agda Version*"-  where f content bufname = [ display_info' False bufname content ]-lispifyResponse Resp_ClearHighlighting = return [ L [ A "agda2-highlight-clear" ] ]+lispifyResponse (Resp_HighlightingInfo info remove method modFile) =+  (:[]) <$> liftIO (lispifyHighlightingInfo info remove method modFile)+lispifyResponse (Resp_DisplayInfo info) = lispifyDisplayInfo info+lispifyResponse (Resp_ClearHighlighting tokenBased) =+  return [ L $ A "agda2-highlight-clear" :+               case tokenBased of+                 NotOnlyTokenBased -> []+                 TokenBased        ->+                   [ Q (lispifyTokenBased tokenBased) ]+         ]+lispifyResponse Resp_DoneAborting = return [ L [ A "agda2-abort-done" ] ]+lispifyResponse Resp_DoneExiting  = return [ L [ A "agda2-exit-done"  ] ] lispifyResponse Resp_ClearRunningInfo = return [ clearRunningInfo ]--- FNF: if Info_Warning comes back into use, the above should be--- return [ clearRunningInfo, clearWarning ] lispifyResponse (Resp_RunningInfo n s)   | n <= 1    = return [ displayRunningInfo s ]   | otherwise = return [ L [A "agda2-verbose", A (quote s)] ] lispifyResponse (Resp_Status s)     = return [ L [ A "agda2-status-action"-                 , A (quote $ intercalate "," $ catMaybes [checked, showImpl])+                 , A (quote $ List.intercalate "," $ catMaybes [checked, showImpl, showIrr])                  ]              ]   where-    boolToMaybe b x = if b then Just x else Nothing--    checked  = boolToMaybe (sChecked               s) "Checked"-    showImpl = boolToMaybe (sShowImplicitArguments s) "ShowImplicit"+    checked  = boolToMaybe (sChecked                 s) "Checked"+    showImpl = boolToMaybe (sShowImplicitArguments   s) "ShowImplicit"+    showIrr  = boolToMaybe (sShowIrrelevantArguments s) "ShowIrrelevant"  lispifyResponse (Resp_JumpToError f p) = return   [ lastTag 3 $@@ -166,7 +96,7 @@         Give_String str -> quote str         Give_Paren      -> "'paren"         Give_NoParen    -> "'no-paren"-lispifyResponse (Resp_MakeCase variant pcs) = return+lispifyResponse (Resp_MakeCase ii variant pcs) = return   [ lastTag 2 $ L [ A cmd, Q $ L $ map (A . quote) pcs ] ]   where   cmd = case variant of@@ -177,8 +107,163 @@       L [ A "agda2-solveAll-action", Q . L $ concatMap prn ps ]   ]   where-    prn (ii,e)= [showNumIId ii, A $ quote $ show e]+    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+    Info_CompilationOk backend ws -> do+      warnings <- prettyTCWarnings (tcWarnings ws)+      errors <- prettyTCWarnings (nonFatalErrors ws)+      let+        msg = concat+          [ "The module was successfully compiled with backend "+          , prettyShow backend+          , ".\n"+          ]+      -- abusing the goals field since we ignore the title+        (body, _) = formatWarningsAndErrors msg warnings errors+      format body "*Compilation result*"+    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)+      errors <- prettyTCWarnings (nonFatalErrors ws)+      let (body, title) = formatWarningsAndErrors goals warnings errors+      format body ("*All" ++ title ++ "*")+    Info_Auto s -> format s "*Auto*"+    Info_Error err -> do+      s <- showInfoError err+      format s "*Error*"+    Info_Time s -> format (render $ prettyTimed s) "*Time*"+    Info_NormalForm state cmode time expr -> do+      exprDoc <- evalStateT prettyExpr state+      let doc = maybe empty prettyTimed time $$ exprDoc+          lbl | cmode == HeadCompute = "*Head Normal Form*"+              | otherwise            = "*Normal Form*"+      format (render doc) lbl+      where+        prettyExpr = localStateCommandM+            $ lift+            $ B.atTopLevel+            $ allowNonTerminatingReductions+            $ (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)+            $ (B.showComputed cmode)+            $ expr+    Info_InferredType state time expr -> do+      exprDoc <- evalStateT prettyExpr state+      let doc = maybe empty prettyTimed time $$ exprDoc+      format (render doc) "*Inferred Type*"+      where+        prettyExpr = localStateCommandM+            $ lift+            $ B.atTopLevel+            $ TCP.prettyA+            $ expr+    Info_ModuleContents modules tel types -> do+      doc <- localTCState $ do+        typeDocs <- addContext tel $ forM types $ \ (x, t) -> do+          doc <- prettyTCM t+          return (prettyShow x, ":" <+> doc)+        return $ vcat+          [ "Modules"+          , nest 2 $ vcat $ map pretty modules+          , "Names"+          , nest 2 $ align 10 typeDocs+          ]+      format (render doc) "*Module contents*"+    Info_SearchAbout hits names -> do+      hitDocs <- forM hits $ \ (x, t) -> do+        doc <- prettyTCM t+        return (prettyShow x, ":" <+> doc)+      let doc = "Definitions about" <+>+                text (List.intercalate ", " $ words names) $$ nest 2 (align 10 hitDocs)+      format (render doc) "*Search About*"+    Info_WhyInScope why -> do+      doc <- explainWhyInScope why+      format (render doc) "*Scope Info*"+    Info_Context ii ctx -> do+      doc <- localTCState (prettyResponseContext ii False ctx)+      format (render doc) "*Context*"+    Info_Intro_NotFound -> format "No introduction forms found." "*Intro*"+    Info_Intro_ConstructorUnknown ss -> do+      let doc = sep [ "Don't know which constructor to introduce of"+                    , let mkOr []     = []+                          mkOr [x, y] = [text x <+> "or" <+> text y]+                          mkOr (x:xs) = text x : mkOr xs+                      in nest 2 $ fsep $ punctuate comma (mkOr ss)+                    ]+      format (render doc) "*Intro*"+    Info_Version -> format ("Agda version " ++ versionWithCommitInfo) "*Agda Version*"+    Info_GoalSpecific ii kind -> lispifyGoalSpecificDisplayInfo ii kind++lispifyGoalSpecificDisplayInfo :: InteractionId -> GoalDisplayInfo -> TCM [Lisp String]+lispifyGoalSpecificDisplayInfo ii kind = localTCState $ withInteractionId ii $+  case kind of+    Goal_HelperFunction helperType -> do+      doc <- inTopContext $ prettyATop helperType+      return [ L [ A "agda2-info-action-and-copy"+                 , A $ quote "*Helper function*"+                 , A $ quote (render doc ++ "\n")+                 , A "nil"+                 ]+             ]+    Goal_NormalForm cmode expr -> do+      doc <- showComputed cmode expr+      format (render doc) "*Normal Form*"   -- show?+    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 bndry -> do+              doc <- prettyATop expr+              return $ ("Have:" <+> doc) $$ vcat (boundaryDoc ("Boundary (actual)") bndry)+            GoalAndElaboration expr -> do+              doc <- prettyATop expr+              return $ "Elaborates to:" <+> doc+      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+      format (render doc) "*Current Goal*"+    Goal_InferredType expr -> do+      doc <- prettyATop expr+      format (render doc) "*Inferred Type*"++-- | Format responses of DisplayInfo++format :: String -> String -> TCM [Lisp String]+format content bufname = return [ display_info' False bufname content ]+ -- | Adds a \"last\" tag to a response.  lastTag :: Integer -> Lisp String -> Lisp String@@ -187,4 +272,116 @@ -- | Show an iteraction point identifier as an elisp expression.  showNumIId :: InteractionId -> Lisp String-showNumIId = A . tail . show+showNumIId = A . show . interactionId++--------------------------------------------------------------------------------++-- | Given strings of goals, warnings and errors, return a pair of the+--   body and the title for the info buffer+formatWarningsAndErrors :: String -> String -> String -> (String, String)+formatWarningsAndErrors g w e = (body, title)+  where+    isG = not $ null g+    isW = not $ null w+    isE = not $ null e+    title = List.intercalate "," $ catMaybes+              [ " Goals"    <$ guard isG+              , " Errors"   <$ guard isE+              , " Warnings" <$ guard isW+              , " Done"     <$ guard (not (isG || isW || isE))+              ]++    body = List.intercalate "\n" $ catMaybes+             [ g                    <$ guard isG+             , delimiter "Error"    <$ guard (isE && (isG || isW))+             , e                    <$ guard isE+             , delimiter "Warnings" <$ guard (isW && (isG || isE))+             , w                    <$ guard isW+             ]+++-- | Serializing Info_Error+showInfoError :: Info_Error -> TCM String+showInfoError (Info_GenericError err) = do+  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+    ]+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++-- | Pretty-prints the context of the given meta-variable.++prettyResponseContext+  :: InteractionId  -- ^ Context of this meta-variable.+  -> Bool           -- ^ Print the elements in reverse order?+  -> [ResponseContextEntry]+  -> TCM Doc+prettyResponseContext ii rev ctx = withInteractionId ii $ do+  mod <- currentModality+  align 10 . concat . applyWhen rev reverse <$> do+    forM ctx $ \ (ResponseContextEntry n x (Arg ai expr) letv nis) -> do+      let+        prettyCtxName :: String+        prettyCtxName+          | n == x                 = prettyShow x+          | isInScope n == InScope = prettyShow n ++ " = " ++ prettyShow x+          | otherwise              = prettyShow x++        -- Some attributes are useful to report whenever they are not+        -- in the default state.+        attribute :: String+        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 but goal is non-erased.+          , [ "erased"       | not $ getQuantity  ai `moreQuantity` getQuantity  mod ]+            -- 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+      maybeVal <- traverse prettyATop letv++      return $+        (attribute ++ prettyCtxName, ":" <+> ty <+> (parenSep extras)) :+        [ (prettyShow x, "=" <+> val) | val <- maybeToList maybeVal ]++  where+    parenSep :: [Doc] -> Doc+    parenSep docs+      | null docs = empty+      | otherwise = (" " <+>) $ parens $ fsep $ punctuate comma docs+++-- | Pretty-prints the type of the meta-variable.++prettyTypeOfMeta :: Rewrite -> InteractionId -> TCM Doc+prettyTypeOfMeta norm ii = do+  form <- B.typeOfMeta norm ii+  case form of+    OfType _ e -> prettyATop e+    _            -> prettyATop form++-- | Prefix prettified CPUTime with "Time:"+prettyTimed :: CPUTime -> Doc+prettyTimed time = "Time:" <+> pretty time
+ src/full/Agda/Interaction/ExitCode.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.ExitCode (+  AgdaError(..),+  agdaErrorToInt,+  agdaErrorFromInt,+  exitSuccess,+  exitAgdaWith)+  where++import System.Exit (exitSuccess, exitWith, ExitCode(ExitFailure))++data AgdaError = UnknownError      -- ^ 1+               | TCMError          -- ^ 42+               | OptionError       -- ^ 71+               | CommandError      -- ^ 113+               | ImpossibleError   -- ^ 154+               deriving (Show, Eq, Enum, Bounded)++agdaErrorToInt :: AgdaError -> Int+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+--   Agda process+agdaErrorFromInt :: Int -> Maybe AgdaError+agdaErrorFromInt = -- We implement this in a somewhat more inefficient+                   -- way for the sake of consistency+                   flip lookup [(agdaErrorToInt error, error)+                               | error  <- [minBound..maxBound]+                               ]++exitAgdaWith :: AgdaError -> IO a+exitAgdaWith = exitWith . ExitFailure . agdaErrorToInt
src/full/Agda/Interaction/FindFile.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ------------------------------------------------------------------------ -- | Functions which map between module names and file names. --@@ -8,51 +7,98 @@ ------------------------------------------------------------------------  module Agda.Interaction.FindFile-  ( toIFile+  ( SourceFile(..), InterfaceFile(intFilePath)+  , toIFile, mkInterfaceFile   , FindError(..), findErrorToTypeError-  , findFile, findFile', findFile''-  , findInterfaceFile+  , findFile, findFile', findFile'_, findFile''+  , findInterfaceFile', findInterfaceFile   , checkModuleName-  , moduleName', moduleName   , rootNameModule   , replaceModuleExtension+  , dropAgdaExtension, hasAgdaExtension, stripAgdaExtension   ) where  import Prelude hiding (null) -import Control.Applicative hiding (empty) import Control.Monad+import Control.Monad.Except+import Control.Monad.State import Control.Monad.Trans-import Data.List hiding (null)-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.Syntax.Common+import Agda.Interaction.Library ( findProjectRoot )+ import Agda.Syntax.Concrete import Agda.Syntax.Parser-import Agda.Syntax.Parser.Literate (literateExts, literateExtsShortList)+import Agda.Syntax.Parser.Literate (literateExtsShortList) import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Trace import Agda.TypeChecking.Monad.Benchmark (billTo) import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import {-# SOURCE #-} Agda.TypeChecking.Monad.Options (getIncludeDirs)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Options+  (getIncludeDirs, libToTCM)+import Agda.TypeChecking.Monad.State ( registerFileIdWithBuiltin, topLevelModuleName )+import Agda.TypeChecking.Monad.Trace (runPM, setCurrentRange) -import Agda.Utils.Except+import Agda.Version ( version )++import Agda.Utils.Applicative ( (?$>) )+import Agda.Utils.CallStack   ( HasCallStack )+import Agda.Utils.FileId import Agda.Utils.FileName-import Agda.Utils.Lens-import Agda.Utils.Null+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.Syntax.Common.Pretty ( Pretty(..), prettyShow )+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Singleton -#include "undefined.h" import Agda.Utils.Impossible +-- This instance isn't producing something pretty.+-- instance Pretty SourceFile where+--   pretty = pretty . srcFileId++-- | File must exist.+newtype InterfaceFile = InterfaceFile { intFilePath :: AbsolutePath }++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@.++mkInterfaceFile+  :: AbsolutePath             -- ^ Path to the candidate interface file+  -> IO (Maybe InterfaceFile) -- ^ Interface file iff it exists+mkInterfaceFile fp = do+  ex <- doesFileExistCaseSensitive $ filePath fp+  pure (ex ?$> InterfaceFile fp)+ -- | Converts an Agda file name to the corresponding interface file--- name.+--   name. Note that we do not guarantee that the file exists. -toIFile :: AbsolutePath -> AbsolutePath-toIFile = replaceModuleExtension ".agdai"+toIFile :: HasCallStack => SourceFile -> TCM AbsolutePath+toIFile (SourceFile fi) = do+  src <- fileFromId fi -- partial function, thus HasCallStack+  let fp = filePath src+  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 <- liftIO $ makeRelativeCanonical root (filePath localIFile)+      let separatedIFile = mkAbsolute $ buildDir </> fileName+      pure separatedIFile  replaceModuleExtension :: String -> AbsolutePath -> AbsolutePath replaceModuleExtension ext@('.':_) = mkAbsolute . (++ ext) .  dropAgdaExtension . filePath@@ -64,28 +110,31 @@  data FindError   = NotFound [AbsolutePath]-    -- ^ The file was not found. It should have had one of the given-    -- file names.-  | Ambiguous [AbsolutePath]-    -- ^ Several matching files were found.-    ---    -- Invariant: The list of matching files has at least two-    -- elements.+      -- ^ 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 files-findErrorToTypeError m (Ambiguous files) =-  AmbiguousTopLevelModuleName m 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. -- -- Raises an error if the file cannot be found. -findFile :: TopLevelModuleName -> TCM AbsolutePath+findFile :: TopLevelModuleName -> TCM SourceFile findFile m = do   mf <- findFile' m   case mf of@@ -96,138 +145,140 @@ --   module name. The returned paths are absolute. -- --   SIDE EFFECT:  Updates 'stModuleToSource'.-findFile' :: TopLevelModuleName -> TCM (Either FindError AbsolutePath)+findFile' :: TopLevelModuleName -> TCM (Either FindError SourceFile) findFile' m = do-    dirs         <- getIncludeDirs-    modFile      <- use stModuleToSource-    (r, modFile) <- liftIO $ findFile'' dirs m modFile-    stModuleToSource .= 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 AbsolutePath, ModuleToSource)-findFile'' dirs m modFile =-  case Map.lookup m modFile of-    Just f  -> return (Right 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 sourceFileExts-      filesShortList <- fileList sourceFileExtsShortList-      existingFiles <--        liftIO $ filterM (doesFileExistCaseSensitive . filePath) files-      return $ case nub existingFiles of-        []     -> (Left (NotFound filesShortList), modFile)-        [file] -> (Right file, Map.insert m 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 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 name. The returned paths are absolute.+-- module file. The returned paths are absolute. --+-- Raises 'Nothing' if the interface file cannot be found.++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.+-- -- Raises an error if the source file cannot be found, and returns -- 'Nothing' if the source file can be found but not the interface -- file. -findInterfaceFile :: TopLevelModuleName -> TCM (Maybe AbsolutePath)-findInterfaceFile m = do-  f  <- toIFile <$> findFile m-  ex <- liftIO $ doesFileExistCaseSensitive $ filePath f-  return $ if ex then Just f else Nothing+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.-  -> AbsolutePath-     -- ^ The file from which it was loaded.+checkModuleName ::+     TopLevelModuleName+       -- ^ The name of the module.+  -> SourceFile+       -- ^ 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 file mexpected = do+checkModuleName name src0 mexpected = do+  file <- srcFilePath src0   findFile' name >>= \case      Left (NotFound files)  -> typeError $       case mexpected of-        Nothing       -> ModuleNameDoesntMatchFileName name files+        Nothing -> ModuleNameDoesntMatchFileName name files         Just expected -> ModuleNameUnexpected name expected      Left (Ambiguous files) -> typeError $       AmbiguousTopLevelModuleName name files -    Right file' -> do-      file <- liftIO $ absolute (filePath file)-      if file === file' then-        return ()-       else+    Right src -> do+      file' <- srcFilePath src+      file  <- liftIO $ absolute $ filePath file+      unlessM (liftIO $ sameFile file file') $         typeError $ ModuleDefinedInOtherFile name file file' --- | Computes the module name of the top-level module in the given file.------   Warning! Parses the whole file to get the module name out.---   Use wisely!------   No side effects!  Only in 'TCM' to raise errors.+  -- Andreas, 2020-09-28, issue #4671:  In any case, make sure+  -- that we do not end up with a mismatch between expected+  -- and actual module name. -moduleName' :: AbsolutePath -> TCM (Ranged TopLevelModuleName)-moduleName' file = billTo [Bench.ModuleName] $ do-  q <- runPM (parseFile' moduleParser file)-  let name = topLevelModuleName q-  case name of-    TopLevelModuleName ["_"] -> do-      q <- runPM (parse moduleNameParser defaultName)-             `catchError` \_ ->-           typeError $-             GenericError $ "File name " ++ show file ++-               " is invalid as it does not correspond to a valid module name."-      return $ Ranged (getRange q) $ TopLevelModuleName [defaultName]-    _ -> return $ Ranged (getRange q) name-  where-    defaultName = rootNameModule file+  forM_ mexpected \ expected ->+    unless (name == expected) $+      typeError $ OverlappingProjects file name expected+      -- OverlappingProjects is the correct error for+      -- test/Fail/customized/NestedProjectRoots+      -- -- typeError $ ModuleNameUnexpected name expected -sourceFileExts :: [String]-sourceFileExts = [".agda"] ++ literateExts -sourceFileExtsShortList :: [String]-sourceFileExtsShortList = [".agda"] ++ literateExtsShortList+parseFileExtsShortList :: List2 String+parseFileExtsShortList = List2.cons ".agda" literateExtsShortList -dropAgdaExtension :: String -> String-dropAgdaExtension s = case catMaybes [ stripExtension ext s-                                     | ext <- sourceFileExts ] of-    [name] -> name-    _      -> __IMPOSSIBLE__-  where-    stripExtension :: String -> String -> Maybe String-    stripExtension e = fmap reverse . stripPrefix (reverse e) . reverse+-- | Remove an Agda file extension from a filepath, if possible.+stripAgdaExtension :: FilePath -> Maybe FilePath+stripAgdaExtension = stripAnyOfExtensions agdaFileExtensions -rootNameModule :: AbsolutePath -> String-rootNameModule = dropAgdaExtension . snd . splitFileName . filePath+-- | Check if a file path has an Agda extension.+hasAgdaExtension :: FilePath -> Bool+hasAgdaExtension = isJust . stripAgdaExtension --- | A variant of 'moduleName'' which raises an error if the file name--- does not match the module name.------ The file name is interpreted relative to the current working--- directory (unless it is absolute).+-- | Remove an existing Agda file extension from a file path.+dropAgdaExtension :: FilePath -> FilePath+dropAgdaExtension = fromMaybe __IMPOSSIBLE__ . stripAgdaExtension -moduleName :: AbsolutePath -> TCM TopLevelModuleName-moduleName file = do-  Ranged r m <- moduleName' file-  -- 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).-  (if null r then id else traceCall (SetRange r)) $-    checkModuleName m file Nothing-  return m++rootNameModule :: AbsolutePath -> String+rootNameModule = dropAgdaExtension . snd . splitFileName . filePath
− src/full/Agda/Interaction/FindFile.hs-boot 
@@ -1,10 +0,0 @@-module Agda.Interaction.FindFile where--import Agda.Syntax.Common (Ranged)-import Agda.Syntax.Concrete.Name (TopLevelModuleName)-import Agda.TypeChecking.Monad.Base (TCM)-import Agda.Utils.FileName (AbsolutePath)--moduleName :: AbsolutePath -> TCM TopLevelModuleName-moduleName' :: AbsolutePath -> TCM (Ranged TopLevelModuleName)-checkModuleName :: TopLevelModuleName -> AbsolutePath -> Maybe TopLevelModuleName -> TCM ()
+ src/full/Agda/Interaction/Highlighting/Common.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Common syntax highlighting functions for Emacs and JSON++module Agda.Interaction.Highlighting.Common+  ( toAtoms+  , chooseHighlightingMethod+  ) where++import Agda.Interaction.Highlighting.Precise+import Agda.Syntax.Common+import Agda.TypeChecking.Monad (HighlightingMethod(..))+import Data.Maybe (maybeToList)+import Data.Char (toLower)+import qualified Data.Set as Set++-- | Converts the 'aspect' and 'otherAspects' fields to strings that are+-- friendly to editors.+toAtoms :: Aspects -> [String]+toAtoms m = map toAtom (Set.toList $ otherAspects m)+         ++ toAtoms' (aspect m)+  where++  toAtom :: Show a => a -> String+  toAtom = map toLower . show++  kindToAtom (Constructor Inductive)   = "inductiveconstructor"+  kindToAtom (Constructor CoInductive) = "coinductiveconstructor"+  kindToAtom k                         = toAtom k++  toAtoms' Nothing               = []+  toAtoms' (Just (Name mKind op)) =+    map kindToAtom (maybeToList mKind) ++ opAtom+    where opAtom | op        = ["operator"]+                 | otherwise = []+  toAtoms' (Just a) = [toAtom a]++-- | Choose which method to use based on HighlightingInfo and HighlightingMethod+chooseHighlightingMethod+  :: HighlightingInfo+  -> HighlightingMethod+  -> HighlightingMethod+chooseHighlightingMethod info method = case toList info of+  _             | method == Direct -> Direct+  ((_, mi) : _) | check mi         -> Direct+  _                                -> Indirect++  where check mi = otherAspects mi == Set.singleton TypeChecks+                || mi == mempty
src/full/Agda/Interaction/Highlighting/Dot.hs view
@@ -1,100 +1,7 @@-{-# LANGUAGE CPP #-}---- | Generate an import dependency graph for a given module.--module Agda.Interaction.Highlighting.Dot where--import Control.Applicative-import Control.Monad.State--import qualified Data.Map as M-import Data.Map(Map)-import Data.Maybe-import Data.Monoid--import qualified Data.Set as S-import Data.Set (Set)--import Agda.Interaction.Options-import Agda.Syntax.Abstract-import Agda.TypeChecking.Monad--#include "undefined.h"-import Agda.Utils.Impossible---- | Internal module identifiers for construction of dependency graph.-type ModuleId = String--data DotState = DotState-  { dsModules    :: Map ModuleName ModuleId-    -- ^ Records already processed modules-    --   and maps them to an internal identifier.-  , dsNameSupply :: [ModuleId]-    -- ^ Supply of internal identifiers.-  , dsConnection :: Set (ModuleId, ModuleId)-    -- ^ Edges of dependency graph.-  }--initialDotState :: DotState-initialDotState = DotState-  { dsModules    = mempty-  , dsNameSupply = map (('m':) . show) [0..]-  , dsConnection = mempty-  }--type DotM = StateT DotState TCM---- | Translate a 'ModuleName' to an internal 'ModuleId'.---   Returns @True@ if the 'ModuleName' is new, i.e., has not been---   encountered before and is thus added to the map of processed modules.-addModule :: ModuleName -> DotM (ModuleId, Bool)-addModule m = do-    s <- get-    case M.lookup m (dsModules s) of-        Just r  -> return (r, False)-        Nothing -> do-            let newName:nameSupply = dsNameSupply s-            put s-              { dsModules = M.insert m newName (dsModules s)-              , dsNameSupply = nameSupply-              }-            return (newName, True)---- | Add an arc from importer to imported.-addConnection :: ModuleId -> ModuleId -> DotM ()-addConnection m1 m2 = modify $ \s -> s {dsConnection = S.insert (m1,m2) (dsConnection s)}+{-# OPTIONS_GHC -Wunused-imports #-} --- | Recursively build import graph, starting from given 'Interface'.---   Modifies the state in 'DotM' and returns the 'ModuleId' of the 'Interface'.-dottify :: Interface -> DotM ModuleId-dottify inter = do-    let curModule = iModuleName inter-    (name, continue) <- addModule curModule-    -- If we have not visited this interface yet,-    -- process its imports recursively and-    -- add them as connections to the graph.-    when continue $ do-        importsifs <- lift $ map miInterface . catMaybes <$>-          mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules inter)-        imports    <- mapM dottify importsifs-        mapM_ (addConnection name) imports-    return name+module Agda.Interaction.Highlighting.Dot+  ( dotBackend+  ) where --- | Generate a .dot file for the import graph starting with the---   given 'Interface' and write it to the file specified by the---   command line option.-generateDot :: Interface -> TCM ()-generateDot inter = do-    (top, state) <- flip runStateT initialDotState $ do-        dottify inter-    fp <- fromMaybe __IMPOSSIBLE__ . optDependencyGraph <$> commandLineOptions-    liftIO $ writeFile fp $ mkDot state-  where-    mkDot :: DotState -> String-    mkDot st = unlines $-        [ "digraph dependencies {"-        ] ++ ["   " ++ repr ++ "[label=\"" ++ show (mnameToConcrete modulename) ++ "\"];"-             | (modulename, repr) <- M.toList (dsModules st)]-          ++ ["   " ++ r1 ++ " -> " ++ r2 ++ ";"-             | (r1 , r2) <- S.toList (dsConnection st) ]-          ++ ["}"]+import Agda.Interaction.Highlighting.Dot.Backend ( dotBackend )
+ src/full/Agda/Interaction/Highlighting/Dot/Backend.hs view
@@ -0,0 +1,254 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.Highlighting.Dot.Backend+  ( dotBackend+  ) where++import Prelude hiding (null)++import Agda.Interaction.Highlighting.Dot.Base (renderDotToFile)++import Control.Monad.Except+  ( ExceptT+  , runExceptT+  , MonadError(throwError)+  )+import Control.Monad.IO.Class+  ( MonadIO(..)+  )+import Control.DeepSeq++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+import qualified Data.Text.Lazy as L++import GHC.Generics (Generic)++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.Common.Pretty ( prettyShow )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)++import Agda.TypeChecking.Monad+  ( Interface(iImportedModules)+  , MonadTCError+  , ReadTCState+  , MonadTCM(..)+  , internalError+  , reportSDoc+  , getAgdaLibFiles+  , srcFilePath+  )+import Agda.TypeChecking.Pretty++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++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+  , 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          :: TopLevelModuleName+  , dotModuleImportedNames :: Set TopLevelModuleName+  , dotModuleInclude       :: Bool+    -- ^ Include the module in the graph?+  }++-- | Currently unused+data DotDef = DotDef++dotBackend :: Backend+dotBackend = Backend dotBackend'++dotBackend' :: Backend' DotFlags DotCompileEnv DotModuleEnv DotModule DotDef+dotBackend' = Backend'+  { backendName           = "Dot"+  , backendVersion        = Nothing+  , options               = defaultDotFlags+  , commandLineFlags      = dotFlagsDescriptions+  , isEnabled             = isJust . dotFlagDestination+  , 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".+asInternalErrors :: (MonadTCError m) => ExceptT String m b -> m b+asInternalErrors t = either internalError return =<< runExceptT t++preCompileDot+  :: MonadError String m+  => DotFlags+  -> m DotCompileEnv+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+  -> TopLevelModuleName+  -> Maybe FilePath+  -> m (Recompile DotModuleEnv DotModule)+preModuleDot _cenv _main _moduleName _ifacePath = pure $ Recompile DotModuleEnv++compileDefDot+  :: Applicative m+  => DotCompileEnv+  -> DotModuleEnv+  -> IsMain+  -> Definition+  -> m DotDef+compileDefDot _cenv _menv _main _def = pure DotDef++postModuleDot+  :: (MonadTCM m, ReadTCState m)+  => DotCompileEnv+  -> DotModuleEnv+  -> IsMain+  -> TopLevelModuleName+  -> [DotDef]+  -> m DotModule+postModuleDot cenv DotModuleEnv _main m _defs = do+  i <- curIF+  let importedModuleNames = Set.fromList $ fst <$> (iImportedModules i)+  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 TopLevelModuleName DotModule+  -> m ()+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
@@ -0,0 +1,44 @@+-- | Generate an import dependency graph for a given module.++module Agda.Interaction.Highlighting.Dot.Base+  ( renderDotToFile+  , renderDot+  , DotGraph+  ) where++import Control.Monad.IO.Class++import qualified Data.Set as S++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Encoding as E+import qualified Data.ByteString.Lazy as BS++import Agda.Utils.Graph.AdjacencyMap.Unidirectional+  (Graph, WithUniqueInt)+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph++-- | Graph structure+type DotGraph = Graph (WithUniqueInt L.Text) ()++-- * Graph rendering++renderDot :: DotGraph -> L.Text+renderDot g = L.unlines $ concat+  [ [ "digraph dependencies {" ]+  , [ 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,55 +1,36 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Functions which give precise syntax highlighting info to Emacs.  module Agda.Interaction.Highlighting.Emacs   ( lispifyHighlightingInfo+  , lispifyTokenBased   ) where -import Agda.Interaction.Highlighting.Precise-import Agda.Interaction.Highlighting.Range-import Agda.Interaction.EmacsCommand-import Agda.Syntax.Common-import Agda.TypeChecking.Monad-  (TCM, envHighlightingMethod, HighlightingMethod(..), ModuleToSource)-import Agda.Utils.FileName-import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.String+import Prelude hiding (null) -import Control.Applicative-import qualified Control.Exception as E-import Control.Monad.Reader-import Data.Char-import qualified Data.Map as Map+import qualified Data.List as List import Data.Maybe-import Data.Monoid-import qualified System.Directory as D-import qualified System.IO as IO -#include "undefined.h"-import Agda.Utils.Impossible+import Agda.Syntax.Common.Pretty (prettyShow) ---------------------------------------------------------------------------- Read/show functions+import Agda.Interaction.Highlighting.Common+import Agda.Interaction.Highlighting.Precise+import Agda.Interaction.Highlighting.Range (Range(..))+import Agda.Interaction.EmacsCommand+import Agda.Interaction.Response --- | Converts the 'aspect' and 'otherAspects' fields to atoms readable--- by the Emacs interface.+import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource, topLevelModuleFilePath) -toAtoms :: Aspects -> [String]-toAtoms m = map toAtom (otherAspects m) ++ toAtoms' (aspect m)-  where-  toAtom x = map toLower (show x)+import Agda.Utils.CallStack    (HasCallStack)+import Agda.Utils.FileName     (AbsolutePath, filePath)+import Agda.Utils.IO.TempFile  (writeToTempFile)+import Agda.Utils.Null+import Agda.Utils.String       (quote) -  kindToAtom (Constructor Inductive)   = "inductiveconstructor"-  kindToAtom (Constructor CoInductive) = "coinductiveconstructor"-  kindToAtom k                         = toAtom k -  toAtoms' Nothing               = []-  toAtoms' (Just (Name mKind op)) =-    map kindToAtom (maybeToList mKind) ++ opAtom-    where opAtom | op        = ["operator"]-                 | otherwise = []-  toAtoms' (Just a) = [toAtom a]+------------------------------------------------------------------------+-- Read/show functions  -- | Shows meta information in such a way that it can easily be read -- by Emacs.@@ -58,21 +39,33 @@   :: ModuleToSource      -- ^ Must contain a mapping for the definition site's module, if any.   -> (Range, Aspects) -> Lisp String-showAspects modFile (r, m) =-    L $ ((map (A . show) [from r, to r])-           ++-         [L $ map A $ toAtoms m]-           ++-         (A $ maybe "nil" quote $ note m)-         :-          defSite)+showAspects modFile (r, m) = L $+    (map (A . show) [from r, to r])+      +++    [L $ map A $ toAtoms m]+      +++    dropNils (+      [lispifyTokenBased (tokenBased m)]+        +++      [A $ ifNull (note m) "nil" quote]+        +++      maybeToList (defSite <$> definitionSite m))   where-  defSite = case definitionSite m of-    Nothing     -> []-    Just (m, p) -> case Map.lookup m modFile of-      Nothing -> __IMPOSSIBLE__-      Just f  -> [Cons (A $ quote $ filePath f) (A $ show p)]+  defSite (DefinitionSite m p _ _) =+    Cons (A $ quote $ filePath f) (A $ show p)+    where+      f :: HasCallStack => AbsolutePath+      f = topLevelModuleFilePath modFile m  -- partial function, so use CallStack! +  dropNils = List.dropWhileEnd (== A "nil")++-- | Formats the 'TokenBased' tag for the Emacs backend. No quotes are+-- added.++lispifyTokenBased :: TokenBased -> Lisp String+lispifyTokenBased TokenBased        = A "t"+lispifyTokenBased NotOnlyTokenBased = A "nil"+ -- | Turns syntax highlighting information into a list of -- S-expressions. @@ -83,28 +76,29 @@  lispifyHighlightingInfo   :: HighlightingInfo+  -> RemoveTokenBasedHighlighting+  -> HighlightingMethod   -> ModuleToSource      -- ^ Must contain a mapping for every definition site's module.-  -> TCM (Lisp String)-lispifyHighlightingInfo h modFile = do-  method <- envHighlightingMethod <$> ask-  liftIO $ case ranges h of-    _             | method == Direct                   -> direct-    ((_, mi) : _) | otherAspects mi == [TypeChecks] ||-                    mi == mempty                       -> direct-    _                                                  -> indirect+  -> IO (Lisp String)+lispifyHighlightingInfo h remove method modFile =+  case chooseHighlightingMethod h method of+    Direct   -> direct+    Indirect -> indirect   where-  info     = map (showAspects modFile) (ranges h)+  info :: [Lisp String]+  info = (case remove of+                RemoveHighlighting -> A "remove"+                KeepHighlighting   -> A "nil") :+             map (showAspects modFile) (toList h) -  direct   = return $ L (A "agda2-highlight-add-annotations" :+  direct :: IO (Lisp String)+  direct = return $ L (A "agda2-highlight-add-annotations" :                          map Q info) +  indirect :: IO (Lisp String)   indirect = do-    dir <- D.getTemporaryDirectory-    f   <- E.bracket (IO.openTempFile dir "agda2-mode")-                     (IO.hClose . snd) $ \ (f, h) -> do-             UTF8.hPutStr h (show $ L info)-             return f+    filepath <- writeToTempFile (prettyShow $ L info)     return $ L [ A "agda2-highlight-load-and-delete-action"-               , A (quote f)+               , A (quote filepath)                ]
+ src/full/Agda/Interaction/Highlighting/FromAbstract.hs view
@@ -0,0 +1,712 @@+-- | Extract highlighting syntax from abstract syntax.+--+-- Implements one big fold over abstract syntax.++-- {-# OPTIONS_GHC -fwarn-unused-imports #-}  -- Data.Semigroup is redundant in later GHC versions+{-# OPTIONS_GHC -fwarn-unused-binds   #-}++module Agda.Interaction.Highlighting.FromAbstract+  ( runHighlighter+  , NameKinds+  ) where++import Prelude hiding (null)++import Control.Applicative+import Control.Monad.Reader  ( MonadReader(..), asks, Reader, runReader )++import qualified Data.Map      as Map+import           Data.Maybe+import           Data.Semigroup       ( Semigroup(..) )          -- for ghc 8.0+import           Data.Void            ( Void )++import           Agda.Interaction.Highlighting.Precise hiding ( singleton )+import qualified Agda.Interaction.Highlighting.Precise as H+import           Agda.Interaction.Highlighting.Range   ( rToR )  -- Range is ambiguous++import           Agda.Syntax.Abstract                ( IsProjP(..) )+import qualified Agda.Syntax.Abstract      as A+import           Agda.Syntax.Common        as Common+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.Function+import           Agda.Utils.Functor+import           Agda.Utils.List                     ( initLast1 )+import           Agda.Utils.List1                    ( List1 )+import qualified Agda.Utils.List1          as List1+import           Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict   as Strict+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+  => TopLevelModuleName+     -- ^ The current top-level module's name.+  -> NameKinds -> a -> HighlightingInfoBuilder+runHighlighter top kinds x =+  runReader (hilite x) $+  HiliteEnv+    { hleNameKinds         = kinds+    , hleCurrentModuleName = top+    }++-- | Environment of the highlighter.+data HiliteEnv = HiliteEnv+  { hleNameKinds :: NameKinds+      -- ^ Function mapping qualified names to their kind.+  , 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.+type NameKinds = A.QName -> Maybe NameKind++-- | Highlighting monad.+type HiliteM = Reader HiliteEnv++-- | Highlighter.++type Hiliter = HiliteM HighlightingInfoBuilder++instance Monoid Hiliter where+  mempty  = pure mempty+  mappend = (<>)++-- | Traversal to extract highlighting information.++class Hilite a where+  hilite :: a -> Hiliter++  default hilite :: (Foldable t, Hilite b, t b ~ a) => a -> Hiliter+  hilite = foldMap hilite++-- * Generic instances+---------------------------------------------------------------------------++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+  hilite _ = mempty++instance (Hilite a, Hilite b) => Hilite (Either a b) where+  hilite = either hilite hilite++instance (Hilite a, Hilite b) => Hilite (a, b) where+  hilite (a, b) = hilite a <> hilite b++-- * Major syntactic categories+---------------------------------------------------------------------------++-- | Reengineered from the old Geniplate-implemented highlighting extraction.+-- This was the old procedure:+--+-- Traversal over declaration in abstract syntax that collects the+-- following hiliting information:+--+-- [1. @constructorInfo@ (highest prio)]+-- 2. @theRest@ (medium prio)+-- 3. @nameInfo@ (lowest prio)+--+-- @nameInfo@:+--   "All names mentioned in the syntax tree (not bound variables)."+-- For each possibly ambiguous name (QName and AmbiguousQName)+-- that not isExtendedLambdaName,+-- do @hiliteAmbiguous@ (used to be called@generate@).+--+-- @constructorInfo@ (only when highlighting level == Full):+--   "After the code has been type checked more information may be+--   available for overloaded constructors, and+--   generateConstructorInfo takes advantage of this information.+--   Note, however, that highlighting for overloaded constructors is+--   included also in nameInfo."+-- This is not computed by recursion over the abstract syntax,+-- but gets the constructor names stDisambiguatedNames+-- that fall within the bounds of the current declaration.+--+-- @theRest@:+--   Bound variables, dotted patterns, record fields, module names,+--   the "as" and "to" symbols and some other things.+--+-- Here is a table what @theRest@ used to collect:+--+-- ---------------------------------------------------------------------+-- | A.Expr+-- ---------------------------------------------------------------------+-- | getVarAndField (Expr) | A.Var                       | bound+-- | getVarAndField        | A.Rec(Update)               | field+-- | getExpr        (Expr) | A.PatternSyn                | patsyn+-- | getExpr               | A.Macro                     | macro+-- ---------------------------------------------------------------------+-- | A.LetBinding+-- ---------------------------------------------------------------------+-- | getLet                | A.LetBind                   | bound+-- ---------------------------------------------------------------------+-- | A.LamBinding+-- ---------------------------------------------------------------------+-- | getLam                | A.Binder under A.DomainFree | bound+-- | getTyped              | A.Binder under A.TBind      | bound+-- ---------------------------------------------------------------------+-- | A.Pattern'+-- ---------------------------------------------------------------------+-- | getPattern(Syn)       | A.VarP                      | bound+-- | getPattern(Syn)       | A.AsP                       | bound+-- | getPattern(Syn)       | A.DotP (not isProjP)        | DottedPattern+-- | getPattern(Syn)       | A.RecP                      | field+-- | getPattern(Syn)       | A.PatternSynP               | patsyn+-- ---------------------------------------------------------------------+-- | A.Declaration+-- ---------------------------------------------------------------------+-- | getFieldDecl          | A.Field under A.RecDef      | field+-- | getPatSynArgs         | A.PatternSynDef             | bound+-- | getPragma             | A.BuiltinPragma...          | keyword+-- ---------------------------------------------------------------------+-- | A.NamedArg (polymorphism not supported in geniplate)+-- ---------------------------------------------------------------------+-- | getNamedArg           | NamedArg a                  | nameOf+-- | getNamedArgE          | NamedArg Exp                | nameOf+-- | getNamedArgP          | NamedArg Pattern            | nameOf+-- | getNamedArgB          | NamedArg BindName           | nameOf+-- | getNamedArgL          | NamedArg LHSCore            | nameOf+--+-- | getModuleName         | A.MName                     | mod+-- | getModuleInfo         | ModuleInfo                  | asName, (range of as,to)+-- | getQuantityAttr       | Common.Quantity             | Symbol (if range)++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+      A.Generalize _names _di ai x e         -> hl ai <> hl x <> hl e+      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 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 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 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.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+      A.Var x                       -> hl $ A.BindName x        -- bound variable like binder+      A.Def' q _                    -> hiliteQName Nothing q+      A.Proj _o qs                  -> hiliteAmbiguousQName Nothing qs  -- Issue #4604: not: hiliteProjection qs+                                         -- Names from @open R r@ should not be highlighted as projections+      A.Con qs                      -> hiliteAmbiguousQName Nothing qs  -- TODO? Con aspect+      A.PatternSyn qs               -> hilitePatternSynonym qs+      A.Macro q                     -> hiliteQName (Just Macro) q+      A.Lit _r l                    -> hl l+      A.QuestionMark _mi _ii        -> mempty+      A.Underscore _mi              -> mempty+      A.Dot _r e                    -> hl e                   -- TODO? Projection?+      A.App _r e es                 -> hl e <> hl es+      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 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.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+      A.Unquote _r                  -> mempty+      A.DontCare e                  -> hl e+    where+    hl a = hilite a++instance (Hilite a, IsProjP a) => Hilite (A.Pattern' a) where+  hilite = \case+      A.VarP x               -> hl x+      A.ConP _i qs es        -> hiliteInductiveConstructor qs <> hl es+        -- No matching on coinductive constructors, thus, can determine NameKind here.+      A.ProjP _r _o qs       -> hiliteProjection qs+      A.DefP _r qs es        -> hl qs <> hl es+      A.WildP _r             -> mempty+      A.AsP _r x p           -> hl x <> hl p+      A.DotP r e             -> case isProjP e of+                                  Nothing       -> singleOtherAspect DottedPattern r <> hl e+                                  Just (_o, qs) -> hiliteProjection qs+      A.AbsurdP _r           -> mempty+      A.LitP _r l            -> hl l+      A.PatternSynP _r qs es -> hilitePatternSynonym qs <> hl es+      A.RecP _kwr _r ps      -> hl ps+      A.EqualP _r ps         -> hl ps+      A.WithP _ p            -> hl p++    where+    hl a = hilite a++instance Hilite Literal where+  hilite = \case+    LitNat{}                 -> mempty+    LitWord64{}              -> mempty+    LitFloat{}               -> mempty+    LitString{}              -> mempty+    LitChar{}                -> mempty+    LitQName x               -> hilite x+    LitMeta _fileName _id    -> mempty++-- * Minor syntactic categories+---------------------------------------------------------------------------++instance Hilite A.LHS where+  hilite (A.LHS _r lhs) = hilite lhs++instance (Hilite a, IsProjP a) => Hilite (A.LHSCore' a) where+  hilite = \case+    A.LHSHead q ps       -> hilite q   <> hilite ps+    A.LHSProj q lhs ps   -> hilite lhs <> hilite q   <> hilite ps -- TODO? Projection?+    A.LHSWith lhs wps ps -> hilite lhs <> hilite wps <> hilite ps++instance Hilite A.RHS where+  hilite = \case+      A.RHS e _ce                          -> hl e+      A.AbsurdRHS                          -> mempty+      A.WithRHS _q es cs                   -> hl es  <> hl cs  -- No highlighting for with-function-name!+      A.RewriteRHS eqs strippedPats rhs wh -> hl eqs <> hl strippedPats <> hl rhs <> hl wh+    where+    hl a = hilite a++instance (HasRange n, Hilite p, Hilite e) => Hilite (RewriteEqn' x n p e) where+  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) =+    hilite lhs <> hilite strippedPats <> hilite rhs <> hilite wh++instance Hilite A.ProblemEq where+  hilite (A.ProblemEq p _t _dom) = hilite p++instance Hilite A.WhereDeclarations where+  hilite (A.WhereDecls m _ ds) = hilite m <> hilite ds++instance Hilite A.GeneralizeTelescope where+  hilite (A.GeneralizeTel _gen tel) = hilite tel++instance Hilite A.DataDefParams where+  hilite (A.DataDefParams _gen pars) = hilite pars++instance Hilite A.ModuleApplication where+  hilite = \case+    A.SectionApp tel x es    -> hilite tel <> hilite x <> hilite es+    A.RecordModuleInstance x -> hilite x++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 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+    A.TLet _r binds        -> hilite binds++instance Hilite A.LamBinding where+  hilite = \case+    A.DomainFree tac binds -> hilite tac <> hilite binds+    A.DomainFull bind      -> hilite bind++instance Hilite a => Hilite (A.Binder' a) where+  hilite (A.Binder p _ x) = hilite p <> hilite x++instance Hilite A.BindName where+  hilite (A.BindName x) = hiliteBound x++instance Hilite a => Hilite (FieldAssignment' a) where+  hilite (FieldAssignment x e) = hiliteField [] x Nothing <> hilite e++instance (Hilite a, HasRange n) => Hilite (Named n a) where+  hilite (Named mn e)+    =  maybe mempty (singleAspect $ Name (Just Argument) False) mn+    <> hilite e++instance Hilite a => Hilite (Arg a) where+  hilite (Arg ai e) = hilite ai <> hilite e++instance Hilite ArgInfo where+  hilite (ArgInfo _hiding modality _origin _fv _a) = hilite modality++instance Hilite Modality where+  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+    <> maybe mempty hiliteAsName asName+    -- <> hilite impDir                     -- Should be covered by A.ImportDirective+    where+    hiliteAsName :: C.Name -> Hiliter+    hiliteAsName n = hiliteCName [] n noRange Nothing $ nameAsp Module++instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (ImportDirective' m n) where+  hilite (ImportDirective _r using hiding renaming _ropen) =+    hilite using <> hilite hiding <> hilite renaming++instance (Hilite m, Hilite n) => Hilite (Using' m n) where+  hilite = \case+    UseEverything -> mempty+    Using using   -> hilite using++instance (Hilite m, Hilite n, Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (Renaming' m n) where+  hilite (Renaming from to _fixity rangeKwTo)+    =  hilite from+    <> singleAspect Symbol rangeKwTo+         -- Currently, the "to" is already highlited by rAsTo above.+         -- TODO: remove the "to" ranges from rAsTo.+    <> hilite (RenamingTo to)++instance (Hilite m, Hilite n) => Hilite (ImportedName' m n) where+  hilite = \case+    ImportedModule m -> hilite m+    ImportedName   n -> hilite n++-- * Highlighting of names+---------------------------------------------------------------------------++instance Hilite DisambiguatedName where+  hilite (DisambiguatedName k x) = hiliteQName (Just k) x++instance Hilite ResolvedName where+  hilite = \case+    VarName           x _bindSrc -> hiliteBound x+    DefinedName  _acc x _suffix  -> hilite $ anameName x+    FieldName         xs         -> hiliteProjection $ A.AmbQ $ fmap anameName xs+    ConstructorName i xs         -> hiliteAmbiguousQName k $ A.AmbQ $ fmap anameName xs+      where k = kindOfNameToNameKind <$> exactConName i+    PatternSynResName xs         -> hilitePatternSynonym $ A.AmbQ $ fmap anameName xs+    UnknownName                  -> mempty++instance Hilite A.QName where+  hilite = hiliteQName Nothing++instance Hilite A.AmbiguousQName where+  hilite = hiliteAmbiguousQName Nothing++instance Hilite A.ModuleName where+  hilite m@(A.MName xs) = hiliteModule (isTopLevelModule, m)+    where+    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.+newtype RenamingTo a = RenamingTo a++instance Hilite (RenamingTo A.QName) where+  -- Andreas, 2020-09-29, issue #4952.+  -- Do not include the bindingSite, because the HTML backed turns it into garbage.+  hilite (RenamingTo q) = do+    kind <- asks hleNameKinds <&> ($ q)+    hiliteAName q False $ nameAsp' kind++instance Hilite (RenamingTo A.ModuleName) where+  -- Andreas, 2020-09-29, issue #4952.+  -- Do not include the bindingSite, because the HTML backed turns it into garbage.+  hilite (RenamingTo (A.MName ns)) = flip foldMap ns $ \ n ->+    hiliteCName [] (A.nameConcrete n) noRange Nothing $ nameAsp Module++instance (Hilite (RenamingTo m), Hilite (RenamingTo n))+       => Hilite (RenamingTo (ImportedName' m n)) where+  hilite (RenamingTo x) = case x of+    ImportedModule m -> hilite (RenamingTo m)+    ImportedName   n -> hilite (RenamingTo n)++hiliteQName+  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?+  -> A.QName+  -> Hiliter+hiliteQName mkind q+  | isExtendedLambdaName q = mempty+  | isAbsurdLambdaName   q = mempty+  | otherwise = do+      kind <- ifJust mkind (pure . Just) {-else-} $ asks hleNameKinds <&> ($ q)+      hiliteAName q True $ nameAsp' kind++-- | Takes the first 'NameKind'.  Binding site only included if unique.+hiliteAmbiguousQName+  :: Maybe NameKind   -- ^ Is 'NameKind' already known from the context?+  -> A.AmbiguousQName+  -> Hiliter+hiliteAmbiguousQName mkind (A.AmbQ qs) = do+  kind <- ifJust mkind (pure . Just) {-else-} $ do+    kinds <- asks hleNameKinds+    pure $ listToMaybe $ List1.catMaybes $ fmap kinds qs+      -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather+      -- than doing no highlighting if there's an ambiguity between an+      -- inductive and coinductive constructor.+  flip foldMap qs $ \ q ->+    hiliteAName q include $ nameAsp' kind+  where+  include = List1.allEqual $ fmap bindingSite qs++hiliteBound :: A.Name -> Hiliter+hiliteBound x =+  hiliteCName [] (A.nameConcrete x) noRange (Just $ A.nameBindingSite x) $ nameAsp Bound++hiliteInductiveConstructor :: A.AmbiguousQName -> Hiliter+hiliteInductiveConstructor = hiliteAmbiguousQName $ Just $ Constructor Inductive++hilitePatternSynonym :: A.AmbiguousQName -> Hiliter+hilitePatternSynonym = hiliteInductiveConstructor  -- There are no coinductive pattern synonyms!?++hiliteProjection :: A.AmbiguousQName -> Hiliter+hiliteProjection = hiliteAmbiguousQName (Just Field)++hiliteField :: [C.Name] -> C.Name -> Maybe Range -> Hiliter+hiliteField xs x bindingR = hiliteCName xs x noRange bindingR $ nameAsp Field++-- For top level modules, we set the binding site to the beginning of the file+-- so that clicking on an imported module will jump to the beginning of the file+-- which defines this module.+hiliteModule :: (Bool, A.ModuleName) -> Hiliter+hiliteModule (isTopLevelModule, A.MName []) = mempty+hiliteModule (isTopLevelModule, A.MName (n:ns)) =+  hiliteCName+    (map A.nameConcrete ms)+    (A.nameConcrete m)+    noRange+    mR+    (nameAsp Module)+  where+  (ms, m) = initLast1 n ns+  mR = Just $+       applyWhen isTopLevelModule P.beginningOfFile $+       A.nameBindingSite m++-- This was Highlighting.Generate.nameToFile:+-- | Converts names to suitable 'File's.+hiliteCName+  :: [C.Name]+     -- ^ The name qualifier (may be empty).+  -> C.Name     -- ^ The base name.+  -> Range+     -- ^ The 'Range' of the name in its fixity declaration (if any).+  -> Maybe Range+     -- ^ The definition site of the name. The calculated+     --   meta information is extended with this information, if possible.+  -> (Bool -> Aspects)+     -- ^ Meta information to be associated with the name.+     --   The argument is 'True' iff the name is an operator.+  -> Hiliter+hiliteCName xs x fr mR asp = do+  env <- ask+  -- We don't care if we get any funny ranges.+  if all (== Just (hleCurrentModuleName env)) moduleNames+  then pure $+    frFile <>+    H.singleton (rToR rs) (aspects { definitionSite = mFilePos })+  else mempty+  where+  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 :: Maybe DefinitionSite+  mFilePos = do+    r <- mR+    P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r+    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 (size mod) xs+    -- For bound variables, we do not create symbolic anchors.+        local = maybe True isLocalAspect $ aspect aspects+    return $ DefinitionSite+      { defSiteModule = mod+      , defSitePos    = fromIntegral p+        -- Is our current position the definition site?+      , defSiteHere   = r == getRange x+        -- For bound variables etc. we do not create a symbolic anchor name.+        -- Also not for names that include anonymous modules,+        -- otherwise, we do not get unique anchors.+      , defSiteAnchor = if local || C.isNoName x || any Common.isUnderscore qualifiers+          then Nothing+          else Just $ prettyShow $ foldr C.Qual (C.QName x) qualifiers+      }++  -- Is the name a bound variable or similar? If in doubt, yes.+  isLocalAspect :: Aspect -> Bool+  isLocalAspect = \case+    Name (Just kind) _ -> isLocal kind+    _ -> True+  isLocal :: NameKind -> Bool+  isLocal = \case+    Bound         -> True+    Generalizable -> True+    Argument      -> True+    Constructor{} -> False+    Datatype      -> False+    Field         -> False+    Function      -> False+    Module        -> False+    Postulate     -> False+    Primitive     -> False+    Record        -> False+    Macro         -> False++-- This was Highlighting.Generate.nameToFileA:+-- | A variant of 'hiliteCName' for qualified abstract names.+hiliteAName+  :: A.QName+     -- ^ The name.+  -> Bool+     -- ^ Should the binding site be included in the file?+  -> (Bool -> Aspects)+     -- ^ Meta information to be associated with the name.+     -- ^ The argument is 'True' iff the name is an operator.+  -> Hiliter+hiliteAName x include asp = do+  currentModule <- asks hleCurrentModuleName+  hiliteCName (concreteQualifier x)+              (concreteBase x)+              (rangeOfFixityDeclaration currentModule)+              (if include then Just $ bindingSite x else Nothing)+              asp+    <> notationFile currentModule+  where+  -- TODO: Currently we highlight fixity and syntax declarations by+  -- producing highlighting something like once per occurrence of the+  -- related name(s) in the file of the declaration (and we explicitly+  -- avoid doing this for other files). Perhaps it would be better to+  -- only produce this highlighting once.++  rangeOfFixityDeclaration currentModule =+    if P.rangeModule r == Just currentModule+    then r else noRange+    where+    r = theNameRange $ A.nameFixity $ A.qnameName x++  notationFile currentModule = pure $+    if P.rangeModule (getRange notation) == Just currentModule+    then mconcat $ map genPartFile notation+    else mempty+    where+    notation = theNotation $ A.nameFixity $ A.qnameName x++    boundAspect = nameAsp Bound 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.+---------------------------------------------------------------------------++singleAspect :: HasRange a => Aspect -> a -> Hiliter+singleAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { aspect = Just a }++singleOtherAspect :: HasRange a => OtherAspect -> a -> Hiliter+singleOtherAspect a x = pure $ H.singleton (rToR $ getRange x) $ parserBased { otherAspects = singleton a }++nameAsp' :: Maybe NameKind -> Bool -> Aspects+nameAsp' k isOp = parserBased { aspect = Just $ Name k isOp }++nameAsp :: NameKind -> Bool -> Aspects+nameAsp = nameAsp' . Just++concreteBase :: A.QName -> C.Name+concreteBase = A.nameConcrete . A.qnameName++concreteQualifier :: A.QName -> [C.Name]+concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule++bindingSite :: A.QName -> Range+bindingSite = A.nameBindingSite . A.qnameName
src/full/Agda/Interaction/Highlighting/Generate.hs view
@@ -1,713 +1,780 @@-{-# LANGUAGE CPP              #-}---- | Generates data used for precise syntax highlighting.--module Agda.Interaction.Highlighting.Generate-  ( Level(..)-  , generateAndPrintSyntaxInfo-  , generateTokenInfo, generateTokenInfoFromString-  , printSyntaxInfo-  , printErrorInfo, errorHighlighting-  , printUnsolvedInfo-  , printHighlightingInfo-  , highlightAsTypeChecked-  , computeUnsolvedMetaWarnings-  , computeUnsolvedConstraints-  , storeDisambiguatedName-  ) where--import Prelude hiding (null)--import Control.Monad-import Control.Monad.Trans-import Control.Monad.Reader-import Control.Applicative-import Control.Arrow (second)--import Data.Monoid-import Data.Generics.Geniplate-import qualified Data.Map as Map-import Data.Maybe-import Data.List ((\\), isPrefixOf)-import qualified Data.Foldable as Fold (fold, foldMap)-import qualified Data.IntMap as IntMap-import Data.Void--import Agda.Interaction.Response (Response(Resp_HighlightingInfo))-import Agda.Interaction.Highlighting.Precise-import Agda.Interaction.Highlighting.Range--import qualified Agda.TypeChecking.Errors as E-import Agda.TypeChecking.MetaVars (isBlockedTerm)-import Agda.TypeChecking.Monad-  hiding (MetaInfo, Primitive, Constructor, Record, Function, Datatype)-import qualified Agda.TypeChecking.Monad as M-import Agda.TypeChecking.Positivity.Occurrence--import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Concrete (FieldAssignment'(..))-import qualified Agda.Syntax.Common as Common-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Fixity-import qualified Agda.Syntax.Info as SI-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.Utils.FileName-import Agda.Utils.Function-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Null-import Agda.Utils.HashMap (HashMap)-import qualified Agda.Utils.HashMap as HMap--#include "undefined.h"-import Agda.Utils.Impossible---- | @highlightAsTypeChecked rPre r m@ runs @m@ and returns its---   result. Additionally, some code may be highlighted:------ * If @r@ is non-empty and not a sub-range of @rPre@ (after---   'P.continuousPerLine' has been applied to both): @r@ is---   highlighted as being type-checked while @m@ is running (this---   highlighting is removed if @m@ completes /successfully/).------ * Otherwise: Highlighting is removed for @rPre - r@ before @m@---   runs, and if @m@ completes successfully, then @rPre - r@ is---   highlighted as being type-checked.--highlightAsTypeChecked-  :: MonadTCM tcm-  => P.Range-  -> P.Range-  -> tcm a-  -> tcm a-highlightAsTypeChecked rPre r m-  | r /= P.noRange && delta == rPre' = wrap r'    highlight clear-  | otherwise                        = wrap delta clear     highlight-  where-  rPre'     = rToR (P.continuousPerLine rPre)-  r'        = rToR (P.continuousPerLine r)-  delta     = rPre' `minus` r'-  clear     = mempty-  highlight = mempty { otherAspects = [TypeChecks] }--  wrap rs x y = do-    p rs x-    v <- m-    p rs y-    return v-    where-    p rs x = printHighlightingInfo (singletonC rs x)---- | Lispify and print the given highlighting information.--printHighlightingInfo :: MonadTCM tcm => HighlightingInfo -> tcm ()-printHighlightingInfo x = do-  modToSrc <- use stModuleToSource-  liftTCM $ reportSLn "highlighting" 50 $-    "Printing highlighting info:\n" ++ show x ++ "\n" ++-    "  modToSrc = " ++ show modToSrc-  unless (null $ ranges x) $ do-    liftTCM $ appInteractionOutputCallback $-        Resp_HighlightingInfo x modToSrc---- | Highlighting levels.--data Level-  = Full-    -- ^ Full highlighting. Should only be used after typechecking has-    --   completed successfully.-  | Partial-    -- ^ Highlighting without disambiguation of overloaded-    --   constructors.---- | Generate syntax highlighting information for the given--- declaration, and (if appropriate) print it. If the--- 'HighlightingLevel' is @'Full'@, then the state is--- additionally updated with the new highlighting info (in case of a--- conflict new info takes precedence over old info).------ The procedure makes use of some of the token highlighting info in--- 'stTokens' (that corresponding to the interval covered by the--- declaration). If the 'HighlightingLevel' is @'Full'@,--- then this token highlighting info is additionally removed from--- 'stTokens'.--generateAndPrintSyntaxInfo :: A.Declaration -> Level -> TCM ()-generateAndPrintSyntaxInfo decl _ | null $ P.getRange decl = return ()-generateAndPrintSyntaxInfo decl hlLevel = do-  file <- fromMaybe __IMPOSSIBLE__ <$> asks envCurrentPath--  reportSLn "import.iface.create" 15 $-      "Generating syntax info for " ++ filePath file ++ ' ' :-        case hlLevel of-            Full    {} -> "(final)"-            Partial {} -> "(first approximation)"-        ++ "."--  reportSLn "highlighting.names" 60 $ "highlighting names = " ++ show names--  M.ignoreAbstractMode $ do-    modMap <- sourceToModule-    kinds  <- nameKinds hlLevel decl--    let nameInfo = mconcat $ map (generate modMap file kinds) names--    -- Constructors are only highlighted after type checking, since they-    -- can be overloaded.-    constructorInfo <- case hlLevel of-      Full{} -> generateConstructorInfo modMap file kinds decl-      _      -> return mempty--    warnInfo <- Fold.fold . map (warningHighlighting . tcWarning) <$> use stTCWarnings--    let (from, to) = case P.rangeToInterval (P.getRange decl) of-          Nothing -> __IMPOSSIBLE__-          Just i  -> ( fromIntegral $ P.posPos $ P.iStart i-                     , fromIntegral $ P.posPos $ P.iEnd i)-    (prevTokens, (curTokens, postTokens)) <--      (second (splitAtC to)) . splitAtC from <$> use stTokens--    -- theRest needs to be placed before nameInfo here since record-    -- field declarations contain QNames. constructorInfo also needs-    -- to be placed before nameInfo since, when typechecking is done,-    -- constructors are included in both lists. Finally the token-    -- information is placed last since token highlighting is more-    -- crude than the others.-    let syntaxInfo = compress (mconcat [ constructorInfo-                                       , theRest modMap file-                                       , nameInfo-                                       , warnInfo-                                       ])-                       `mappend`-                     curTokens--    case hlLevel of-      Full{} -> do stSyntaxInfo %= mappend syntaxInfo-                   stTokens     .= prevTokens `mappend` postTokens-      _      -> return ()--    ifTopLevelAndHighlightingLevelIs NonInteractive $-      printHighlightingInfo syntaxInfo-  where-  -- All names mentioned in the syntax tree (not bound variables).-  names :: [A.AmbiguousQName]-  names =-    (map (A.AmbQ . (:[])) $-     filter (not . extendedLambda) $-     universeBi decl) ++-    universeBi decl-    where-    extendedLambda :: A.QName -> Bool-    extendedLambda = (extendedLambdaName `isPrefixOf`) . show . A.nameConcrete . A.qnameName--  -- Bound variables, dotted patterns, record fields, module names,-  -- the "as" and "to" symbols.-  theRest modMap file = mconcat-    [ Fold.foldMap getFieldDecl   $ universeBi decl-    , Fold.foldMap getVarAndField $ universeBi decl-    , Fold.foldMap getLet         $ universeBi decl-    , Fold.foldMap getLam         $ universeBi decl-    , Fold.foldMap getTyped       $ universeBi decl-    , Fold.foldMap getPattern     $ universeBi decl-    , Fold.foldMap getPatternSyn  $ universeBi decl-    , Fold.foldMap getExpr        $ universeBi decl-    , Fold.foldMap getPatSynArgs  $ universeBi decl-    , Fold.foldMap getModuleName  $ universeBi decl-    , Fold.foldMap getModuleInfo  $ universeBi decl-    , Fold.foldMap getNamedArg    $ universeBi decl-    ]-    where-    bound n = nameToFile modMap file [] (A.nameConcrete n) P.noRange-                         (\isOp -> mempty { aspect = Just $ Name (Just Bound) isOp })-                         (Just $ A.nameBindingSite n)--    patsyn n = nameToFileA modMap file n True $ \isOp ->-                  mempty { aspect = Just $ Name (Just $ Constructor Common.Inductive) isOp }--    macro n = nameToFileA modMap file n True $ \isOp ->-                  mempty { aspect = Just $ Name (Just Macro) isOp }--    field m n = nameToFile modMap file m n P.noRange-                           (\isOp -> mempty { aspect = Just $ Name (Just Field) isOp })-                           Nothing-    asName n = nameToFile modMap file []-                          n P.noRange-                          (\isOp -> mempty { aspect = Just $ Name (Just Module) isOp })-                          Nothing--    mod isTopLevelModule n =-      nameToFile modMap file []-                 (A.nameConcrete n) P.noRange-                 (\isOp -> mempty { aspect = Just $ Name (Just Module) isOp })-                 (Just $ (if isTopLevelModule then P.beginningOfFile else id)-                           (A.nameBindingSite n))--    getVarAndField :: A.Expr -> File-    getVarAndField (A.Var x)            = bound x-    getVarAndField (A.Rec       _ fs)   = mconcat [ field [] x | Left (FieldAssignment x _) <- fs ]-    getVarAndField (A.RecUpdate _ _ fs) = mconcat [ field [] x |      (FieldAssignment x _) <- fs ]-    getVarAndField _                    = mempty--    -- Ulf, 2014-04-09: It would be nicer to have it on Named_ a, but-    -- you can't have polymorphic functions in universeBi.-    getNamedArg :: Common.RString -> File-    getNamedArg x = singleton (rToR $ P.getRange x) mempty{ aspect = Just $ Name (Just Argument) False }--    getLet :: A.LetBinding -> File-    getLet (A.LetBind _ _ x _ _)     = bound x-    getLet A.LetPatBind{}            = mempty-    getLet A.LetApply{}              = mempty-    getLet A.LetOpen{}               = mempty-    getLet (A.LetDeclaredVariable x) = bound x--    getLam :: A.LamBinding -> File-    getLam (A.DomainFree _ x) = bound x-    getLam (A.DomainFull {})  = mempty--    getTyped :: A.TypedBinding -> File-    getTyped (A.TBind _ xs _) = mconcat $ map (bound . dget) xs-    getTyped A.TLet{}         = mempty--    getPatSynArgs :: A.Declaration -> File-    getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . Common.unArg) xs-    getPatSynArgs _                        = mempty--    getPattern' :: A.Pattern' e -> File-    getPattern' (A.VarP x)    = bound x-    getPattern' (A.AsP _ x _) = bound x-    getPattern' (A.DotP pi _ _) =-      singleton (rToR $ P.getRange pi)-                (mempty { otherAspects = [DottedPattern] })-    getPattern' (A.PatternSynP _ q _) = patsyn q-    getPattern' (A.RecP _ fs) = mconcat [ field [] x | FieldAssignment x _ <- fs ]-    getPattern' _             = mempty--    getPattern :: A.Pattern -> File-    getPattern = getPattern'--    getPatternSyn :: A.Pattern' Void -> File-    getPatternSyn = getPattern'--    getExpr :: A.Expr -> File-    getExpr (A.PatternSyn q) = patsyn q-    getExpr (A.Macro q)      = macro q-    getExpr _                = mempty--    getFieldDecl :: A.Declaration -> File-    getFieldDecl (A.RecDef _ _ _ _ _ _ _ fs) = Fold.foldMap extractField fs-      where-      extractField (A.ScopedDecl _ ds) = Fold.foldMap extractField ds-      extractField (A.Field _ x _)     = field (concreteQualifier x)-                                               (concreteBase x)-      extractField _                   = mempty-    getFieldDecl _                   = mempty--    getModuleName :: A.ModuleName -> File-    getModuleName m@(A.MName { A.mnameToList = xs }) =-      mconcat $ map (mod isTopLevelModule) xs-      where-      isTopLevelModule =-        case catMaybes $-             map (join .-                  fmap (Strict.toLazy . P.srcFile) .-                  P.rStart .-                  A.nameBindingSite) xs of-          f : _ -> Map.lookup f modMap ==-                   Just (C.toTopLevelModuleName $ A.mnameToConcrete m)-          []    -> False--    getModuleInfo :: SI.ModuleInfo -> File-    getModuleInfo (SI.ModuleInfo { SI.minfoAsTo   = asTo-                                 , SI.minfoAsName = name }) =-      singleton (rToR asTo) (mempty { aspect = Just Symbol })-        `mappend`-      maybe mempty asName name---- | Generate and return the syntax highlighting information for the--- tokens in the given file.--generateTokenInfo-  :: AbsolutePath          -- ^ The module to highlight.-  -> TCM CompressedFile-generateTokenInfo file =-  runPM $ tokenHighlighting <$> Pa.parseFile' Pa.tokensParser file---- | Same as 'generateTokenInfo' but takes a string instead of a filename.-generateTokenInfoFromString :: P.Range -> String -> TCM CompressedFile-generateTokenInfoFromString r _ | r == P.noRange = return mempty-generateTokenInfoFromString r s = do-  runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s-  where-    Just p = P.rStart r---- | Compute syntax highlighting for the given tokens.-tokenHighlighting :: [T.Token] -> CompressedFile-tokenHighlighting = merge . map tokenToCFile-  where-  -- Converts an aspect and a range to a file.-  aToF a r = singletonC (rToR r) (mempty { aspect = Just a })--  -- Merges /sorted, non-overlapping/ compressed files.-  merge = CompressedFile . concat . map ranges--  tokenToCFile :: T.Token -> CompressedFile-  tokenToCFile (T.TokSetN (i, _))               = aToF PrimitiveType (P.getRange i)-  tokenToCFile (T.TokKeyword T.KwSet  i)        = aToF PrimitiveType (P.getRange i)-  tokenToCFile (T.TokKeyword T.KwProp i)        = aToF PrimitiveType (P.getRange i)-  tokenToCFile (T.TokKeyword T.KwForall i)      = aToF Symbol (P.getRange i)-  tokenToCFile (T.TokKeyword _ i)               = aToF Keyword (P.getRange i)-  tokenToCFile (T.TokSymbol  _ i)               = aToF Symbol (P.getRange i)-  tokenToCFile (T.TokLiteral (L.LitNat    r _)) = aToF Number r-  tokenToCFile (T.TokLiteral (L.LitFloat  r _)) = aToF Number r-  tokenToCFile (T.TokLiteral (L.LitString r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitChar   r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitQName  r _)) = aToF String r-  tokenToCFile (T.TokLiteral (L.LitMeta r _ _)) = aToF String r-  tokenToCFile (T.TokComment (i, _))            = aToF Comment (P.getRange i)-  tokenToCFile (T.TokTeX (i, _))                = aToF Comment (P.getRange i)-  tokenToCFile (T.TokId {})                     = mempty-  tokenToCFile (T.TokQId {})                    = mempty-  tokenToCFile (T.TokString {})                 = mempty-  tokenToCFile (T.TokDummy {})                  = mempty-  tokenToCFile (T.TokEOF {})                    = mempty---- | A function mapping names to the kind of name they stand for.--type NameKinds = A.QName -> Maybe NameKind---- | Builds a 'NameKinds' function.--nameKinds :: Level-             -- ^ This should only be @'Full'@ if-             -- type-checking completed successfully (without any-             -- errors).-          -> A.Declaration-          -> TCM NameKinds-nameKinds hlLevel decl = do-  imported <- fix <$> use stImports-  local    <- case hlLevel of-    Full{} -> fix <$> use stSignature-    _      -> return HMap.empty-      -- Traverses the syntax tree and constructs a map from qualified-      -- names to name kinds. TODO: Handle open public.-  let syntax = foldr ($) HMap.empty $ map declToKind $ universeBi decl-  let merged = unions [local, imported, syntax]-  return (\n -> HMap.lookup n merged)-  where-  fix = HMap.map (defnToKind . theDef) . (^. sigDefinitions)--  -- | The 'M.Axiom' constructor is used to represent various things-  -- which are not really axioms, so when maps are merged 'Postulate's-  -- are thrown away whenever possible. The 'declToKind' function-  -- below can return several explanations for one qualified name; the-  -- 'Postulate's are bogus.-  merge Postulate k = k-  merge _     Macro = Macro  -- If the abstract syntax says macro, it's a macro.-  merge k         _ = k--  unions = foldr (HMap.unionWith merge) HMap.empty-  insert = HMap.insertWith merge--  defnToKind :: Defn -> NameKind-  defnToKind   M.Axiom{}                           = Postulate-  defnToKind d@M.Function{} | isProperProjection d = Field-                            | otherwise            = Function-  defnToKind   M.Datatype{}                        = Datatype-  defnToKind   M.Record{}                          = Record-  defnToKind   M.Constructor{ M.conInd = i }       = Constructor i-  defnToKind   M.Primitive{}                       = Primitive-  defnToKind   M.AbstractDefn                      = __IMPOSSIBLE__--  declToKind :: A.Declaration ->-                HashMap A.QName NameKind -> HashMap A.QName NameKind-  declToKind (A.Axiom _ i _ _ q _)-    | SI.defMacro i == Common.MacroDef = insert q Macro-    | otherwise                        = insert q Postulate-  declToKind (A.Field _ q _)        = insert q Field -- Function-    -- Note that the name q can be used both as a field name and as a-    -- projection function. Highlighting of field names is taken care-    -- of by "theRest" above, which does not use NameKinds.-  declToKind (A.Primitive _ q _)    = insert q Primitive-  declToKind (A.Mutual {})          = id-  declToKind (A.Section {})         = id-  declToKind (A.Apply {})           = id-  declToKind (A.Import {})          = id-  declToKind (A.Pragma {})          = id-  declToKind (A.ScopedDecl {})      = id-  declToKind (A.Open {})            = id-  declToKind (A.PatternSynDef q _ _) = insert q (Constructor Common.Inductive)-  declToKind (A.FunDef  _ q _ _)     = insert q Function-  declToKind (A.UnquoteDecl _ _ qs _) = foldr (\ q f -> insert q Function . f) id qs-  declToKind (A.UnquoteDef _ qs _)    = foldr (\ q f -> insert q Function . f) id qs-  declToKind (A.DataSig _ q _ _)    = insert q Datatype-  declToKind (A.DataDef _ q _ cs)   = \m ->-                                      insert q Datatype $-                                      foldr (\d -> insert (A.axiomName d)-                                                          (Constructor Common.Inductive))-                                            m cs-  declToKind (A.RecSig _ q _ _)     = insert q Record-  declToKind (A.RecDef _ q _ _ c _ _ _) = insert q Record .-                                      case c of-                                        Nothing -> id-                                        Just q  -> insert q (Constructor Common.Inductive)---- | Generates syntax highlighting information for all constructors--- occurring in patterns and expressions in the given declaration.------ This function should only be called after type checking.--- Constructors can be overloaded, and the overloading is resolved by--- the type checker.--generateConstructorInfo-  :: SourceToModule  -- ^ Maps source file paths to module names.-  -> AbsolutePath    -- ^ The module to highlight.-  -> NameKinds-  -> A.Declaration-  -> TCM File-generateConstructorInfo modMap file kinds decl = do--  -- Get boundaries of current declaration.-  -- @noRange@ should be impossible, but in case of @noRange@-  -- it makes sense to return the empty File.-  ifNull (P.rangeIntervals $ P.getRange decl)-         (return mempty) $ \is -> do-    let start = fromIntegral $ P.posPos $ P.iStart $ head is-        end   = fromIntegral $ P.posPos $ P.iEnd   $ last is--    -- Get all disambiguated names that fall within the range of decl.-    m0 <- use stDisambiguatedNames-    let (_, m1) = IntMap.split (pred start) m0-        (m2, _) = IntMap.split end m1-        constrs = IntMap.elems m2--    -- Return suitable syntax highlighting information.-    let files = for constrs $ \ q -> generate modMap file kinds $ A.AmbQ [q]-    return $ Fold.fold files--printSyntaxInfo :: P.Range -> TCM ()-printSyntaxInfo r = do-  syntaxInfo <- use stSyntaxInfo-  ifTopLevelAndHighlightingLevelIs NonInteractive $-      printHighlightingInfo (selectC r syntaxInfo)----- | Prints syntax highlighting info for an error.--printErrorInfo :: TCErr -> TCM ()-printErrorInfo e = printHighlightingInfo . compress =<< errorHighlighting e---- | Generate highlighting for error.---   Does something special for termination errors.--errorHighlighting :: TCErr -> TCM File--errorHighlighting (TypeError s cl@Closure{ clValue = TerminationCheckFailed termErrs }) =-  -- For termination errors, we keep the previous highlighting,-  -- just additionally mark the bad calls.-  return $ terminationErrorHighlighting termErrs--errorHighlighting e = do--  -- Erase previous highlighting.-  let r     = P.getRange e-      erase = singleton (rToR $ P.continuousPerLine r) mempty--  -- Print new highlighting.-  s <- E.prettyError e-  let error = singleton (rToR r)-         $ mempty { otherAspects = [Error]-                  , note         = Just s-                  }-  return $ mconcat [ erase, error ]---- | Generate syntax highlighting for warnings.--warningHighlighting :: Warning -> File-warningHighlighting w = case w of-  TerminationIssue terrs    -> terminationErrorHighlighting terrs-  NotStrictlyPositive d ocs -> positivityErrorHighlighting d ocs-  _ -> mempty----- | Generate syntax highlighting for termination errors.--terminationErrorHighlighting :: [TerminationError] -> File-terminationErrorHighlighting termErrs = functionDefs `mappend` callSites-  where-    m            = mempty { otherAspects = [TerminationProblem] }-    functionDefs = Fold.foldMap (\x -> singleton (rToR $ bindingSite x) m) $-                   concatMap M.termErrFunctions termErrs-    callSites    = Fold.foldMap (\r -> singleton (rToR r) m) $-                   concatMap (map M.callInfoRange . M.termErrCalls) termErrs---- | Generate syntax highlighting for not-strictly-positive inductive--- definitions.---- TODO: highlight also the problematic occurrences-positivityErrorHighlighting :: I.QName -> OccursWhere -> File-positivityErrorHighlighting q o = several (rToR <$> P.getRange q : rs) m-  where-    rs = case o of Unknown -> []; Known r _ -> [r]-    m  = mempty { otherAspects = [PositivityProblem] }----- | Generates and prints syntax highlighting information for unsolved--- meta-variables and certain unsolved constraints.--printUnsolvedInfo :: TCM ()-printUnsolvedInfo = do-  metaInfo       <- computeUnsolvedMetaWarnings-  constraintInfo <- computeUnsolvedConstraints--  printHighlightingInfo-    (compress $ metaInfo `mappend` constraintInfo)---- | Generates syntax highlighting information for unsolved meta--- variables.--computeUnsolvedMetaWarnings :: TCM File-computeUnsolvedMetaWarnings = do-  is <- getInteractionMetas--  -- We don't want to highlight blocked terms, since-  --   * there is always at least one proper meta responsible for the blocking-  --   * in many cases the blocked term covers the highlighting for this meta-  let notBlocked m = not <$> isBlockedTerm m-  ms <- filterM notBlocked =<< getOpenMetas--  rs <- mapM getMetaRange (ms \\ is)-  return $ several (map (rToR . P.continuousPerLine) rs)-                   (mempty { otherAspects = [UnsolvedMeta] })---- | Generates syntax highlighting information for unsolved constraints--- that are not connected to a meta variable.--computeUnsolvedConstraints :: TCM File-computeUnsolvedConstraints = do-  cs <- getAllConstraints-  -- get ranges of emptyness constraints-  let rs = [ r | PConstr{ theConstraint = Closure{ clValue = IsEmpty r t }} <- cs ]-  return $ several (map (rToR . P.continuousPerLine) rs)-                   (mempty { otherAspects = [UnsolvedConstraint] })---- | Generates a suitable file for a possibly ambiguous name.--generate :: SourceToModule-            -- ^ Maps source file paths to module names.-         -> AbsolutePath-            -- ^ The module to highlight.-         -> NameKinds-         -> A.AmbiguousQName-         -> File-generate modMap file kinds (A.AmbQ qs) =-  mconcat $ map (\q -> nameToFileA modMap file q include m) qs-  where-    ks   = map kinds qs-    -- Ulf, 2014-06-03: [issue1064] It's better to pick the first rather-    -- than doing no highlighting if there's an ambiguity between an-    -- inductive and coinductive constructor.-    kind = case [ k | Just k <- ks ] of-             k : _ -> Just k-             []    -> Nothing-    -- kind = case (allEqual ks, ks) of-    --          (True, Just k : _) -> Just k-    --          _                  -> Nothing-    -- Note that all names in an AmbiguousQName should have the same-    -- concrete name, so either they are all operators, or none of-    -- them are.-    m isOp  = mempty { aspect = Just $ Name kind isOp }-    include = allEqual (map bindingSite qs)---- | Converts names to suitable 'File's.--nameToFile :: SourceToModule-              -- ^ Maps source file paths to module names.-           -> AbsolutePath-              -- ^ The file name of the current module. Used for-              -- consistency checking.-           -> [C.Name]-              -- ^ The name qualifier (may be empty).-           -> C.Name-              -- ^ The base name.-           -> P.Range-              -- ^ The 'Range' of the name in its fixity declaration (if any).-           -> (Bool -> Aspects)-              -- ^ Meta information to be associated with the name.-              -- The argument is 'True' iff the name is an operator.-           -> Maybe P.Range-              -- ^ The definition site of the name. The calculated-              -- meta information is extended with this information,-              -- if possible.-           -> File-nameToFile modMap file xs x fr m mR =-  -- We don't care if we get any funny ranges.-  if all (== Strict.Just file) fileNames then-    several (map rToR rs)-            ((m $ C.isOperator x) { definitionSite = mFilePos })-   else-    mempty-  where-  fileNames  = catMaybes $ map (fmap P.srcFile . P.rStart . P.getRange) (x : xs)-  rs         = applyWhen (not $ null fr) (fr :) $ map P.getRange (x : xs)-  mFilePos   = do-    r <- mR-    P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r-    mod <- Map.lookup f modMap-    return (mod, fromIntegral p)---- | A variant of 'nameToFile' for qualified abstract names.--nameToFileA-  :: SourceToModule-     -- ^ Maps source file paths to module names.-  -> AbsolutePath-     -- ^ The file name of the current module. Used for-     -- consistency checking.-  -> A.QName-     -- ^ The name.-  -> Bool-     -- ^ Should the binding site be included in the file?-  -> (Bool -> Aspects)-     -- ^ Meta information to be associated with the name.-     -- ^ The argument is 'True' iff the name is an operator.-  -> File-nameToFileA modMap file x include m =-  nameToFile modMap-             file-             (concreteQualifier x)-             (concreteBase x)-             r-             m-             (if include then Just $ bindingSite x else Nothing)-  where-    -- Andreas, 2016-09-08, for issue #2140:-    -- Range of name from fixity declaration:-    fr = theNameRange $ A.nameFixity $ A.qnameName x-    -- Somehow we import fixity ranges from other files, we should ignore them.-    -- (I do not understand how we get them as they should not be serialized...)-    r = if P.rangeFile fr == Strict.Just file then fr else P.noRange--concreteBase :: I.QName -> C.Name-concreteBase = A.nameConcrete . A.qnameName--concreteQualifier :: I.QName -> [C.Name]-concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule--bindingSite :: I.QName -> P.Range-bindingSite = A.nameBindingSite . A.qnameName---- | Remember a name disambiguation (during type checking).---   To be used later during syntax highlighting.-storeDisambiguatedName :: A.QName -> TCM ()-storeDisambiguatedName q = whenJust (start $ P.getRange q) $ \ i ->-  stDisambiguatedNames %= IntMap.insert i q-  where-  start r = fromIntegral . P.posPos <$> P.rStart' r++-- | Generates data used for precise syntax highlighting.++-- {-# OPTIONS_GHC -fwarn-unused-imports #-}  -- Semigroup import obsolete in later ghcs+-- {-# OPTIONS_GHC -fwarn-unused-binds   #-}++module Agda.Interaction.Highlighting.Generate+  ( Level(..)+  , generateAndPrintSyntaxInfo+  , generateTokenInfo, generateTokenInfoFromSource+  , generateTokenInfoFromString+  , printSyntaxInfo+  , printErrorInfo, errorHighlighting+  , printUnsolvedInfo+  , printHighlightingInfo+  , highlightAsTypeChecked+  , highlightWarning, warningHighlighting+  , computeUnsolvedInfo+  , storeDisambiguatedConstructor, storeDisambiguatedProjection+  , disambiguateRecordFields+  ) where++import Prelude hiding (null)++import Control.Monad++import qualified Data.Foldable as Fold+import qualified Data.Map as Map+import Data.Maybe+import Data.List ((\\))+import qualified Data.List as List+import qualified Data.IntMap as IntMap+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.Semigroup (Semigroup(..))+import Data.Sequence (Seq)+import qualified Data.Set as Set+import qualified Data.Text.Lazy as Text++import Agda.Interaction.Response+  ( RemoveTokenBasedHighlighting( KeepHighlighting ) )+import Agda.Interaction.Highlighting.Precise as H+import Agda.Interaction.Highlighting.Range+  (rToR, rangeToRange, overlappings, Ranges)+import Agda.Interaction.Highlighting.FromAbstract++import qualified Agda.TypeChecking.Errors as TCM+import Agda.TypeChecking.MetaVars (isBlockedTerm, hasTwinMeta)+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 )++import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Concrete.Definitions as W ( DeclarationWarning(..), DeclarationWarning'(..) )+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+  (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, 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.Syntax.Common.Pretty+import Agda.Utils.Singleton++import Agda.Utils.Impossible++-- | Highlighting levels.++data Level+  = Full+    -- ^ Full highlighting. Should only be used after typechecking has+    --   completed successfully.+  | Partial+    -- ^ Highlighting without disambiguation of overloaded+    --   constructors.++-- | Highlight a warning.+--   We do not generate highlighting for unsolved metas and+--   constraints, as that gets handled in bulk after typechecking.+highlightWarning :: TCWarning -> TCM ()+highlightWarning tcwarn = do+  let h = convert $ warningHighlighting' False tcwarn+  -- Highlighting for warnings coming from the Happy parser is placed+  -- together with token highlighting.+  case tcWarning tcwarn of+    ParseWarning{} -> modifyTCLens stTokens     (h <>)+    _              -> modifyTCLens stSyntaxInfo (h <>)+  ifTopLevelAndHighlightingLevelIs NonInteractive $+    printHighlightingInfo KeepHighlighting h++-- | Generate syntax highlighting information for the given+-- declaration, and (if appropriate) print it. If the boolean is+-- 'True', then the state is additionally updated with the new+-- highlighting info (in case of a conflict new info takes precedence+-- over old info).+--+-- The procedure makes use of some of the highlighting info+-- corresponding to 'stTokens' (that corresponding to the interval+-- covered by the declaration). If the boolean is 'True', then this+-- highlighting info is additionally removed from the data structure+-- that 'stTokens' refers to.++generateAndPrintSyntaxInfo+  :: A.Declaration+       -- ^ Declaration to highlight.+  -> Level+       -- ^ Amount of highlighting.+  -> Bool+       -- ^ Update the state?+  -> TCM ()+generateAndPrintSyntaxInfo decl _ _ | null $ getRange decl = return ()+generateAndPrintSyntaxInfo decl hlLevel updateState = do+  top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule++  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+    kinds <- nameKinds hlLevel decl++    -- After the code has been type checked more information may be+    -- available for overloaded constructors, and+    -- @generateConstructorInfo@ takes advantage of this information.+    -- Note, however, that highlighting for overloaded constructors is+    -- included also in @nameInfo@.+    constructorInfo <- case hlLevel of+      Full{} -> generateConstructorInfo top kinds decl+      _      -> return mempty++    -- Main source of scope-checker generated highlighting:+    let nameInfo = runHighlighter top kinds decl++    reportSDoc "highlighting.warning" 60 $ TCM.hcat+      [ "current path = "+      , Strict.maybe "(nothing)" (return . pretty) =<< do+          P.rangeFile <$> viewTC eRange+      ]++    -- Highlighting from the lexer and Happy parser:+    (curTokens, otherTokens) <-+      insideAndOutside (rangeToRange (getRange decl)) <$> useTC stTokens++    -- @constructorInfo@ needs+    -- to be placed before @nameInfo@ since, when typechecking is done,+    -- constructors are included in both lists. Finally the token+    -- information is placed last since token highlighting is more+    -- crude than the others.+    let syntaxInfo = convert (constructorInfo <> nameInfo)+                       <>+                     curTokens++    when updateState $ do+      stSyntaxInfo `modifyTCLens` mappend syntaxInfo+      stTokens     `setTCLens`    otherTokens++    ifTopLevelAndHighlightingLevelIs NonInteractive $+      printHighlightingInfo KeepHighlighting syntaxInfo++-- | Generate and return the syntax highlighting information for the+-- tokens in the given file.++generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo+generateTokenInfo 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+  :: 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 . 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+-- given range.++generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo+generateTokenInfoFromString r _ | r == noRange = return mempty+generateTokenInfoFromString r s = do+  runPM $ tokenHighlighting . fst <$>+          Pa.parsePosString Pa.tokensParser p s+  where+    Just p = P.rStart r++-- | Compute syntax highlighting for the given tokens.+tokenHighlighting :: [T.Token] -> HighlightingInfo+tokenHighlighting = convert . mconcat . map tokenToHI+  where+  -- Converts an aspect and a range to a file.+  aToF a r = H.singleton (rToR r) (mempty { aspect = Just a })++  tokenToHI :: T.Token -> HighlightingInfoBuilder+  tokenToHI (T.TokKeyword T.KwForall i)  = aToF Symbol (getRange i)+  tokenToHI (T.TokKeyword T.KwREWRITE _) = mempty  -- #4361, REWRITE is not always a Keyword+  tokenToHI (T.TokKeyword _ i)           = aToF Keyword (getRange i)+  tokenToHI (T.TokSymbol T.SymQuestionMark i) = aToF Hole (getRange i)+  tokenToHI (T.TokSymbol  _ i)                = aToF Symbol (getRange i)+  tokenToHI (T.TokLiteral (Ranged r (L.LitNat    _))) = aToF Number r+  tokenToHI (T.TokLiteral (Ranged r (L.LitWord64 _))) = aToF Number r+  tokenToHI (T.TokLiteral (Ranged r (L.LitFloat  _))) = aToF Number r+  tokenToHI (T.TokLiteral (Ranged r (L.LitString _))) = aToF String r+  tokenToHI (T.TokLiteral (Ranged r (L.LitChar   _))) = aToF String r+  tokenToHI (T.TokLiteral (Ranged r (L.LitQName  _))) = aToF String r+  tokenToHI (T.TokLiteral (Ranged r (L.LitMeta _ _))) = aToF String r+  tokenToHI (T.TokComment (i, _))            = aToF Comment (getRange i)+  tokenToHI (T.TokTeX (i, _))                = aToF Background (getRange i)+  tokenToHI (T.TokMarkup (i, _))             = aToF Markup (getRange i)+  tokenToHI (T.TokId {})                     = mempty+  tokenToHI (T.TokQId {})                    = mempty+  tokenToHI (T.TokString (i,s))              = aToF Pragma (getRange i)+  tokenToHI (T.TokDummy {})                  = mempty+  tokenToHI (T.TokEOF {})                    = mempty++-- | Builds a 'NameKinds' function.++nameKinds :: Level+             -- ^ This should only be @'Full'@ if+             -- type-checking completed successfully (without any+             -- errors).+          -> A.Declaration+          -> TCM NameKinds+nameKinds hlLevel decl = do+  imported <- useTC $ stImports . sigDefinitions+  local    <- case hlLevel of+    Full{} -> useTC $ stSignature . sigDefinitions+    _      -> return HMap.empty+  impPatSyns <- useTC stPatternSynImports+  locPatSyns <- case hlLevel of+    Full{} -> useTC stPatternSyns+    _      -> return empty+      -- Traverses the syntax tree and constructs a map from qualified+      -- names to name kinds. TODO: Handle open public.+  let syntax :: NameKindMap+      syntax = runBuilder (declaredNames decl :: NameKindBuilder) HMap.empty+  return $ \ n -> unionsMaybeWith mergeNameKind+    [ defnToKind . theDef <$> HMap.lookup n local+    , con <$ Map.lookup n locPatSyns+    , defnToKind . theDef <$> HMap.lookup n imported+    , con <$ Map.lookup n impPatSyns+    , HMap.lookup n syntax+    ]+  where+  defnToKind :: TCM.Defn -> NameKind+  defnToKind   TCM.Axiom{}                           = Postulate+  defnToKind   TCM.DataOrRecSig{}                    = Postulate+  defnToKind   TCM.GeneralizableVar{}                = Generalizable+  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.conSrcCon = c }  = Constructor $ I.conInductive c+  defnToKind   TCM.Primitive{}                       = Primitive+  defnToKind   TCM.PrimitiveSort{}                   = Primitive+  defnToKind   TCM.AbstractDefn{}                    = __IMPOSSIBLE__++  con :: NameKind+  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+-- are thrown away whenever possible. The 'declaredNames' function+-- below can return several explanations for one qualified name; the+-- 'Postulate's are bogus.+mergeNameKind :: NameKind -> NameKind -> NameKind+mergeNameKind Postulate k = k+mergeNameKind _     Macro = Macro  -- If the abstract syntax says macro, it's a macro.+mergeNameKind k         _ = k++-- Auxiliary types for @nameKinds@ generation++type NameKindMap     = HashMap A.QName NameKind+data NameKindBuilder = NameKindBuilder+  { runBuilder :: NameKindMap -> NameKindMap+  }++instance Semigroup (NameKindBuilder) where+  NameKindBuilder f <> NameKindBuilder g = NameKindBuilder $ f . g++instance Monoid (NameKindBuilder) where+  mempty = NameKindBuilder id+  mappend = (<>)++instance Singleton KName NameKindBuilder where+  singleton (WithKind k q) = NameKindBuilder $+    HMap.insertWith mergeNameKind q $ kindOfNameToNameKind k++instance Collection KName NameKindBuilder++-- | Generates syntax highlighting information for all constructors+-- occurring in patterns and expressions in the given declaration.+--+-- This function should only be called after type checking.+-- Constructors can be overloaded, and the overloading is resolved by+-- the type checker.++generateConstructorInfo+  :: TopLevelModuleName+     -- ^ The module to highlight.+  -> NameKinds+  -> A.Declaration+  -> TCM HighlightingInfoBuilder+generateConstructorInfo top kinds decl = do++  -- Get boundaries of current declaration.+  -- @noRange@ should be impossible, but in case of @noRange@+  -- it makes sense to return mempty.+  caseList (P.rangeIntervals $ getRange decl)+           (return mempty) $ \ i is -> do+    let start = fromIntegral $ P.posPos $ P.iStart i+        end   = fromIntegral $ P.posPos $ P.iEnd $ last1 i is++    -- Get all disambiguated names that fall within the range of decl.+    m0 <- useTC stDisambiguatedNames+    let (_, m1) = IntMap.split (pred start) m0+        (m2, _) = IntMap.split end m1+        constrs = IntMap.elems m2++    -- Return suitable syntax highlighting information.+    return $ foldMap (runHighlighter top kinds) constrs++printSyntaxInfo :: Range -> TCM ()+printSyntaxInfo r = do+  syntaxInfo <- useTC stSyntaxInfo+  ifTopLevelAndHighlightingLevelIs NonInteractive $+    printHighlightingInfo KeepHighlighting+      (restrictTo (rangeToRange r) syntaxInfo)++-- | Prints syntax highlighting info for an error.++printErrorInfo :: TCErr -> TCM ()+printErrorInfo e =+  printHighlightingInfo KeepHighlighting . convert =<<+    errorHighlighting e++-- | Generate highlighting for error.++errorHighlighting :: TCErr -> TCM HighlightingInfoBuilder+errorHighlighting e = errorHighlighting' (getRange e) <$> TCM.renderError e++errorHighlighting'+  :: Range     -- ^ Error range.+  -> String    -- ^ Error message for tooltip.+  -> HighlightingInfoBuilder+errorHighlighting' r s = mconcat+  [ -- Erase previous highlighting.+    H.singleton (rToR $ P.continuousPerLine r) mempty+  , -- Print new highlighting.+    H.singleton (rToR r)+         $ parserBased { otherAspects = Set.singleton Error+                       , note         = s+                       }+  ]++-- | Highlighting for warnings that are considered fatal.++errorWarningHighlighting :: HasRange a => a -> HighlightingInfoBuilder+errorWarningHighlighting w =+  H.singleton (rToR $ P.continuousPerLine $ getRange w) $+    parserBased { otherAspects = Set.singleton ErrorWarning }+-- errorWarningHighlighting w = errorHighlighting' (getRange w) ""+  -- MonadPretty not available here, so, no tooltip.+  -- errorHighlighting' (getRange w) . render <$> TCM.prettyWarning (tcWarning w)++-- | Generate syntax highlighting for warnings.++warningHighlighting :: TCWarning -> HighlightingInfoBuilder+warningHighlighting = warningHighlighting' True++warningHighlighting' :: Bool -- ^ should we generate highlighting for unsolved metas and constrains?+                     -> TCWarning -> HighlightingInfoBuilder+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+  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+  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{}   -> instanceProblemHighlighting w+  InstanceWithExplicitArg{}    -> instanceProblemHighlighting w+  InstanceNoOutputTypeName{}   -> instanceProblemHighlighting w+  InstanceArgWithExplicitArg{} -> instanceProblemHighlighting w+  InversionDepthReached{}    -> mempty+  -- Andreas, 2020-03-21, issue #4456:+  -- Error warnings that do not have dedicated highlighting+  -- are highlighted as errors.+  InvalidCharacterLiteral{}             -> errorWarningHighlighting w+  SafeFlagPostulate{}                   -> errorWarningHighlighting w+  SafeFlagPragma{}                      -> errorWarningHighlighting w+  SafeFlagWithoutKFlagPrimEraseEquality -> 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+    -- can get.+    NotAllowedInMutual{}             -> deadcodeHighlighting w+    EmptyAbstract{}                  -> deadcodeHighlighting w+    EmptyConstructor{}               -> deadcodeHighlighting w+    EmptyInstance{}                  -> deadcodeHighlighting w+    EmptyMacro{}                     -> deadcodeHighlighting w+    EmptyMutual{}                    -> deadcodeHighlighting w+    EmptyPostulate{}                 -> deadcodeHighlighting w+    EmptyPrimitive{}                 -> deadcodeHighlighting w+    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+    InvalidConstructorBlock{}        -> 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+    MissingDataDeclaration{}         -> missingDefinitionHighlighting w+    MissingDefinitions{}             -> missingDefinitionHighlighting w+    -- TODO: explore highlighting opportunities here!+    PolarityPragmasButNotPostulates{} -> mempty+    PragmaNoTerminationCheck{}        -> mempty+    PragmaCompiled{}                  -> errorWarningHighlighting w+    UnknownFixityInMixfixDecl{}       -> mempty+    UnknownNamesInFixityDecl{}        -> mempty+    UnknownNamesInPolarityPragmas{}   -> mempty++  -- Backends+  CustomBackendWarning{} -> mempty++  -- Polarities+  TooManyPolarities _x occs -> deadcodeHighlighting occs+  TopLevelPolarity{} -> errorWarningHighlighting w++recordFieldWarningHighlighting ::+  RecordFieldWarning -> HighlightingInfoBuilder+recordFieldWarningHighlighting = \case+  W.DuplicateFields xrs      -> dead xrs+  W.TooManyFields _q _ys xrs -> dead xrs+  where+  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++-- | Generate syntax highlighting for termination errors.++terminationErrorHighlighting ::+  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 getRange . termErrCalls) termErrs+    bindingSite  = A.nameBindingSite . A.qnameName++-- | Generate syntax highlighting for not-strictly-positive inductive+-- definitions.++positivityErrorHighlighting ::+  I.QName -> Seq OccursWhere -> HighlightingInfoBuilder+positivityErrorHighlighting q os =+  several (rToR <$> getRange q : rs) m+  where+    rs = map (\(OccursWhere r _ _) -> r) (Fold.toList os)+    m  = parserBased { otherAspects = Set.singleton PositivityProblem }++deadcodeHighlighting :: HasRange a => a -> HighlightingInfoBuilder+deadcodeHighlighting a = H.singleton (rToR $ P.continuous $ getRange a) m+  where m = parserBased { otherAspects = Set.singleton Deadcode }++coverageErrorHighlighting :: Range -> HighlightingInfoBuilder+coverageErrorHighlighting r = H.singleton (rToR $ P.continuousPerLine r) m+  where m = parserBased { otherAspects = Set.singleton CoverageProblem }++shadowingTelHighlighting :: List2 Range -> HighlightingInfoBuilder+shadowingTelHighlighting =+  -- we do not want to highlight the one variable in scope so we take+  -- the @init@ segment of the ranges in question+  foldMap (\r -> H.singleton (rToR $ P.continuous r) m) . List2.init+  where+  m = parserBased { otherAspects =+                      Set.singleton H.ShadowingInTelescope }++catchallHighlighting :: Range -> HighlightingInfoBuilder+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 Aspect.MissingDefinition }++-- | Generates and prints syntax highlighting information for unsolved+-- meta-variables and certain unsolved constraints.++printUnsolvedInfo :: TCM ()+printUnsolvedInfo = do+  info <- computeUnsolvedInfo++  printHighlightingInfo KeepHighlighting (convert info)++computeUnsolvedInfo :: TCM HighlightingInfoBuilder+computeUnsolvedInfo = do+  (rs, metaInfo) <- computeUnsolvedMetaWarnings+  constraintInfo <- computeUnsolvedConstraints rs++  return $ metaInfo `mappend` constraintInfo++-- | Generates syntax highlighting information for unsolved meta+-- variables.+--   Also returns ranges of unsolved or interaction metas.+computeUnsolvedMetaWarnings :: TCM ([Ranges], HighlightingInfoBuilder)+computeUnsolvedMetaWarnings = do+  is <- getInteractionMetas++  -- We don't want to highlight blocked terms, since+  --   * there is always at least one proper meta responsible for the blocking+  --   * in many cases the blocked term covers the highlighting for this meta+  --   * for the same reason we skip metas with a twin, since the twin will be blocked.+  let notBlocked m = not <$> isBlockedTerm m+  let notHasTwin m = not <$> hasTwinMeta m+  ms <- filterM notHasTwin =<< filterM notBlocked =<< getOpenMetas++  let extend = map (rToR . P.continuousPerLine)++  rs <- extend <$> mapM getMetaRange (ms \\ is)++  rs' <- extend <$> mapM getMetaRange is+  return $ (rs ++ rs', metasHighlighting' rs)++metasHighlighting :: [Range] -> HighlightingInfoBuilder+metasHighlighting = metasHighlighting' . fmap (rToR . P.continuousPerLine)++metasHighlighting' :: [Ranges] -> HighlightingInfoBuilder+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).++computeUnsolvedConstraints :: [Ranges] -- ^ does not add ranges that would overlap with these.+                           -> TCM HighlightingInfoBuilder+computeUnsolvedConstraints ms = constraintsHighlighting ms <$> getAllConstraints++constraintsHighlighting ::+  [Ranges] -> Constraints -> HighlightingInfoBuilder+constraintsHighlighting ms cs =+  several (filter noOverlap $ map (rToR . P.continuousPerLine) rs)+          (parserBased { otherAspects = Set.singleton UnsolvedConstraint })+  where+  noOverlap r = not $ any (overlappings $ r) $ ms+  -- get ranges of interesting unsolved constraints+  rs = (`mapMaybe` (map theConstraint cs)) $ \case+    Closure{ clValue = IsEmpty r t           } -> Just r+    Closure{ clEnv = e, clValue = ValueCmp{} } -> Just $ getRange (envRange e)+    Closure{ clEnv = e, clValue = ElimCmp{}  } -> Just $ getRange (envRange e)+    Closure{ clEnv = e, clValue = SortCmp{}  } -> Just $ getRange (envRange e)+    Closure{ clEnv = e, clValue = LevelCmp{} } -> Just $ getRange (envRange e)+    Closure{ clEnv = e, clValue = CheckSizeLtSat{} } -> Just $ getRange (envRange e)+    _ -> Nothing+++-- * Disambiguation of constructors and projections.++storeDisambiguatedField :: A.QName -> TCM ()+storeDisambiguatedField = storeDisambiguatedName Field++storeDisambiguatedProjection :: A.QName -> TCM ()+storeDisambiguatedProjection = storeDisambiguatedField++storeDisambiguatedConstructor :: Induction -> A.QName -> TCM ()+storeDisambiguatedConstructor i = storeDisambiguatedName $ Constructor i++-- TODO: move the following function to a new module TypeChecking.Overloading+-- that gathers functions concerning disambiguation of overloading.++-- | Remember a name disambiguation (during type checking).+--   To be used later during syntax highlighting.+--   Also: raise user warnings associated with the name.+storeDisambiguatedName :: NameKind -> A.QName -> TCM ()+storeDisambiguatedName k q = do+  raiseWarningsOnUsage q+  whenJust (start $ getRange q) $ \ i ->+    modifyTCLens stDisambiguatedNames $ IntMap.insert i $ DisambiguatedName k q+  where+  start r = fromIntegral . P.posPos <$> P.rStart' r++-- | Store a disambiguation of record field tags for the purpose of highlighting.+disambiguateRecordFields+  :: [C.Name]   -- ^ Record field names in a record expression.+  -> [A.QName]  -- ^ Record field names in the corresponding record type definition+  -> TCM ()+disambiguateRecordFields cxs axs = forM_ cxs $ \ cx -> do+  caseMaybe (List.find ((cx ==) . A.nameConcrete . A.qnameName) axs) (return ()) $ \ ax -> do+    storeDisambiguatedField ax{ A.qnameName = (A.qnameName ax) { A.nameConcrete = cx } }
src/full/Agda/Interaction/Highlighting/Generate.hs-boot view
@@ -1,10 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.Highlighting.Generate where-import Agda.TypeChecking.Monad.Base-import Agda.Syntax.Position (Range) -highlightAsTypeChecked-  :: MonadTCM tcm-  => Range-  -> Range-  -> tcm a-  -> tcm a+import Agda.TypeChecking.Monad.Base (TCM, TCWarning)++highlightWarning :: TCWarning -> TCM ()
src/full/Agda/Interaction/Highlighting/HTML.hs view
@@ -1,210 +1,11 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} --- | Function for generating highlighted, hyperlinked HTML from Agda--- sources.+-- | Backend for generating highlighted, hyperlinked HTML from Agda sources.  module Agda.Interaction.Highlighting.HTML-  ( generateHTML-  -- Reused by PandocAgda-  , defaultCSSFile-  , generateHTMLWithPageGen-  , generatePage-  , page-  , tokenStream-  , code+  ( htmlBackend   ) where -import Control.Applicative-import Control.Monad-import Control.Monad.Trans--import Data.Function-import Data.Monoid-import Data.Maybe-import qualified Data.IntMap as IntMap-import qualified Data.Map    as Map-import qualified Data.List   as List--import System.FilePath-import System.Directory--import Text.XHtml.Strict--import Paths_Agda--import Agda.Interaction.Highlighting.Precise-import Agda.Interaction.Options--import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Common--import Agda.TypeChecking.Monad (TCM)-import qualified Agda.TypeChecking.Monad as TCM--import Agda.Utils.FileName (filePath)-import Agda.Utils.Lens-import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.Pretty-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible---- | The name of the default CSS file.--defaultCSSFile :: FilePath-defaultCSSFile = "Agda.css"---- | Generates HTML files from all the sources which have been---   visited during the type checking phase.------   This function should only be called after type checking has---   completed successfully.--generateHTML :: TCM ()-generateHTML = generateHTMLWithPageGen pageGen-  where-  pageGen dir mod hinfo = generatePage renderer dir mod-    where-    renderer css _ contents = page css mod $ code $ tokenStream contents hinfo---- | Prepare information for HTML page generation.------   The page generator receives the file path of the module,---   the top level module name of the module---   and the highlighting information of the module.--generateHTMLWithPageGen-  :: (FilePath -> C.TopLevelModuleName -> CompressedFile -> TCM ())  -- ^ Page generator-  -> TCM ()-generateHTMLWithPageGen generatePage = do-      options <- TCM.commandLineOptions--      -- There is a default directory given by 'defaultHTMLDir'-      let dir = optHTMLDir options-      liftIO $ createDirectoryIfMissing True dir--      -- If the default CSS file should be used, then it is copied to-      -- the output directory.-      liftIO $ when (isNothing $ optCSSFile options) $ do-        cssFile <- getDataFileName defaultCSSFile-        copyFile cssFile (dir </> defaultCSSFile)--      TCM.reportSLn "html" 1 $ unlines-        [ ""-        , "Warning: HTML is currently generated for ALL files which can be"-        , "reached from the given module, including library files."-        ]--      -- Pull highlighting info from the state and generate all the-      -- web pages.-      mapM_ (\(m, h) -> generatePage dir m h) =<<-        map (mapSnd $ TCM.iHighlighting . TCM.miInterface) .-          Map.toList <$> TCM.getVisitedModules---- | Converts module names to the corresponding HTML file names.--modToFile :: C.TopLevelModuleName -> FilePath-modToFile m = render (pretty m) <.> "html"---- | Generates a highlighted, hyperlinked version of the given module.--generatePage-  :: (FilePath -> FilePath -> String -> String)  -- ^ Page renderer-  -> FilePath              -- ^ Directory in which to create files.-  -> C.TopLevelModuleName  -- ^ Module to be highlighted.-  -> TCM ()-generatePage renderpage dir mod = do-  mf <- Map.lookup mod <$> use TCM.stModuleToSource-  case mf of-    Nothing -> __IMPOSSIBLE__-    Just f  -> do-      contents <- liftIO $ UTF8.readTextFile $ filePath f-      css      <- maybe defaultCSSFile id . optCSSFile <$>-                    TCM.commandLineOptions-      let html = renderpage css (filePath f) contents-      TCM.reportSLn "html" 1 $ "Generating HTML for " ++-                               render (pretty mod) ++-                               " (" ++ target ++ ")."-      liftIO $ UTF8.writeFile target html-  where target = dir </> modToFile mod---- | Constructs the web page, including headers.--page :: FilePath              -- ^ URL to the CSS file.-     -> C.TopLevelModuleName  -- ^ Module to be highlighted.-     -> Html-     -> String-page css modName pagecontent = renderHtml $-  header (thetitle << render (pretty modName)-            +++-          meta ! [ httpequiv "Content-Type"-                 , content "text/html; charset=UTF-8"-                 ]-            +++-          meta ! [ httpequiv "Content-Style-Type"-                 , content "text/css"-                 ]-            +++-          thelink noHtml ! [ href css-                           , rel "stylesheet"-                           , thetype "text/css"-                           ])-  +++-  body << pre << pagecontent---- | Constructs token stream ready to print.--tokenStream-     :: String         -- ^ The contents of the module.-     -> CompressedFile -- ^ Highlighting information.-     -> [(Int, String, Aspects)]  -- ^ (position, contents, info)-tokenStream contents info =-  map (\cs -> case cs of-          (mi, (pos, _)) : _ ->-            (pos, map (snd . snd) cs, maybe mempty id mi)-          [] -> __IMPOSSIBLE__) $-  List.groupBy ((==) `on` fst) $-  map (\(pos, c) -> (IntMap.lookup pos infoMap, (pos, c))) $-  zip [1..] contents-  where-  infoMap = toMap (decompress info)---- | Constructs the HTML displaying the code.--code :: [(Int, String, Aspects)]-     -> Html-code = mconcat . map (\(pos, s, mi) -> annotate pos mi (stringToHtml s))-  where-  annotate :: Int -> Aspects -> Html -> Html-  annotate pos mi = anchor ! attributes-    where-    attributes =-      [name (show pos)] ++-      maybe [] link (definitionSite mi) ++-      (case classes of-        [] -> []-        cs -> [theclass $ unwords cs])--    classes =-      maybe [] noteClasses (note mi)-      ++ otherAspectClasses (otherAspects mi)-      ++ maybe [] aspectClasses (aspect mi)--    aspectClasses (Name mKind op) = kindClass ++ opClass-      where-      kindClass = maybe [] ((: []) . showKind) mKind--      showKind (Constructor Inductive)   = "InductiveConstructor"-      showKind (Constructor CoInductive) = "CoinductiveConstructor"-      showKind k                         = show k--      opClass = if op then ["Operator"] else []-    aspectClasses a = [show a]--    otherAspectClasses = map show--    -- Notes are not included.-    noteClasses s = []--    link (m, pos) = [href $ modToFile m ++ "#" ++ show pos]+import Agda.Interaction.Highlighting.HTML.Backend as Exports+  ( htmlBackend+  )
+ src/full/Agda/Interaction/Highlighting/HTML/Backend.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Backend for generating highlighted, hyperlinked HTML from Agda sources.++module Agda.Interaction.Highlighting.HTML.Backend+  ( htmlBackend+  ) where++import Agda.Interaction.Highlighting.HTML.Base++import Prelude hiding ((!!), concatMap)++import Control.DeepSeq+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Except ( MonadError(throwError) )++import Data.Map (Map)++import GHC.Generics (Generic)++import Agda.Interaction.Options+    ( ArgDescr(ReqArg, NoArg)+    , OptDescr(..)+    , Flag+    )+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..))+import Agda.Compiler.Common (IsMain(..), curIF)++import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)++import Agda.TypeChecking.Monad+  ( MonadDebug+  , ReadTCState+  , Definition+  , reportS+  )++-- | Options for HTML generation++data HtmlFlags = HtmlFlags+  { htmlFlagEnabled              :: Bool+  , htmlFlagDir                  :: FilePath+  , htmlFlagHighlight            :: HtmlHighlight+  , htmlFlagHighlightOccurrences :: Bool+  , htmlFlagCssFile              :: Maybe FilePath+  } deriving (Eq, Generic)++instance NFData HtmlFlags++data HtmlCompileEnv = HtmlCompileEnv+  { htmlCompileEnvOpts :: HtmlOptions+  }++data HtmlModuleEnv = HtmlModuleEnv+  { htmlModEnvCompileEnv :: HtmlCompileEnv+  , htmlModEnvName       :: TopLevelModuleName+  }++data HtmlModule = HtmlModule+data HtmlDef = HtmlDef++htmlBackend :: Backend+htmlBackend = Backend htmlBackend'++htmlBackend' :: Backend' HtmlFlags HtmlCompileEnv HtmlModuleEnv HtmlModule HtmlDef+htmlBackend' = Backend'+  { backendName           = "HTML"+  , backendVersion        = Nothing+  , options               = initialHtmlFlags+  , commandLineFlags      = htmlFlags+  , isEnabled             = htmlFlagEnabled+  , preCompile            = preCompileHtml+  , preModule             = preModuleHtml+  , compileDef            = compileDefHtml+  , postModule            = postModuleHtml+  , postCompile           = postCompileHtml+  -- --only-scope-checking works, but with the caveat that cross-module links+  -- will not have their definition site populated.+  , scopeCheckingSuffices = True+  , mayEraseType          = const $ return False+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing+  }++initialHtmlFlags :: HtmlFlags+initialHtmlFlags = HtmlFlags+  { htmlFlagEnabled   = False+  , htmlFlagDir       = defaultHTMLDir+  , htmlFlagHighlight = HighlightAll+  -- Don't enable by default because it causes potential+  -- performance problems+  , htmlFlagHighlightOccurrences = False+  , htmlFlagCssFile              = Nothing+  }++htmlOptsOfFlags :: HtmlFlags -> HtmlOptions+htmlOptsOfFlags flags = HtmlOptions+  { htmlOptDir = htmlFlagDir flags+  , htmlOptHighlight = htmlFlagHighlight flags+  , htmlOptHighlightOccurrences = htmlFlagHighlightOccurrences flags+  , htmlOptCssFile = htmlFlagCssFile flags+  }++-- | The default output directory for HTML.++defaultHTMLDir :: FilePath+defaultHTMLDir = "html"++htmlFlags :: [OptDescr (Flag HtmlFlags)]+htmlFlags =+    [ Option []     ["html"] (NoArg htmlFlag)+                    "generate HTML files with highlighted source code"+    , Option []     ["html-dir"] (ReqArg htmlDirFlag "DIR")+                    ("directory in which HTML files are placed (default: " +++                     defaultHTMLDir ++ ")")+    , Option []     ["highlight-occurrences"] (NoArg highlightOccurrencesFlag)+                    ("highlight all occurrences of hovered symbol in generated " +++                     "HTML files")+    , Option []     ["css"] (ReqArg cssFlag "URL")+                    "the CSS file used by the HTML files (can be relative)"+    , Option []     ["html-highlight"] (ReqArg htmlHighlightFlag "[code,all,auto]")+                    ("whether to highlight only the code parts (code) or " +++                     "the file as a whole (all) or " +++                     "decide by source file type (auto)")+    ]++htmlFlag :: Flag HtmlFlags+htmlFlag o = return $ o { htmlFlagEnabled = True }++htmlDirFlag :: FilePath -> Flag HtmlFlags+htmlDirFlag d o = return $ o { htmlFlagDir = d }++cssFlag :: FilePath -> Flag HtmlFlags+cssFlag f o = return $ o { htmlFlagCssFile = Just f }++highlightOccurrencesFlag :: Flag HtmlFlags+highlightOccurrencesFlag o = return $ o { htmlFlagHighlightOccurrences = True }++parseHtmlHighlightFlag :: MonadError String m => String -> m HtmlHighlight+parseHtmlHighlightFlag "code" = return HighlightCode+parseHtmlHighlightFlag "all"  = return HighlightAll+parseHtmlHighlightFlag "auto" = return HighlightAuto+parseHtmlHighlightFlag opt    = throwError $ concat ["Invalid option <", opt, ">, expected <all>, <auto> or <code>"]++htmlHighlightFlag :: String -> Flag HtmlFlags+htmlHighlightFlag opt    o = do+  flag <- parseHtmlHighlightFlag opt+  return $ o { htmlFlagHighlight = flag }++runLogHtmlWithMonadDebug :: MonadDebug m => LogHtmlT m a -> m a+runLogHtmlWithMonadDebug = runLogHtmlWith $ reportS "html" 1++preCompileHtml+  :: (MonadIO m, MonadDebug m)+  => HtmlFlags+  -> m HtmlCompileEnv+preCompileHtml flags = runLogHtmlWithMonadDebug $ do+  logHtml $ unlines+    [ "Warning: HTML is currently generated for ALL files which can be"+    , "reached from the given module, including library files."+    ]+  let opts = htmlOptsOfFlags flags+  prepareCommonDestinationAssets opts+  return $ HtmlCompileEnv opts++preModuleHtml+  :: Applicative m+  => HtmlCompileEnv+  -> IsMain+  -> TopLevelModuleName+  -> Maybe FilePath+  -> m (Recompile HtmlModuleEnv HtmlModule)+preModuleHtml cenv _isMain modName _ifacePath = pure $ Recompile (HtmlModuleEnv cenv modName)++compileDefHtml+  :: Applicative m+  => HtmlCompileEnv+  -> HtmlModuleEnv+  -> IsMain+  -> Definition+  -> m HtmlDef+compileDefHtml _env _menv _isMain _def = pure HtmlDef++postModuleHtml+  :: (MonadIO m, MonadDebug m, ReadTCState m)+  => HtmlCompileEnv+  -> HtmlModuleEnv+  -> IsMain+  -> TopLevelModuleName+  -> [HtmlDef]+  -> m HtmlModule+postModuleHtml _env menv _isMain _modName _defs = do+  let generatePage = defaultPageGen . htmlCompileEnvOpts . htmlModEnvCompileEnv $ menv+  htmlSrc <- srcFileOfInterface (htmlModEnvName menv) <$> curIF+  runLogHtmlWithMonadDebug $ generatePage htmlSrc+  return HtmlModule++postCompileHtml+  :: Applicative m+  => HtmlCompileEnv+  -> IsMain+  -> Map TopLevelModuleName HtmlModule+  -> m ()+postCompileHtml _cenv _isMain _modulesByName = pure ()
+ src/full/Agda/Interaction/Highlighting/HTML/Base.hs view
@@ -0,0 +1,429 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Function for generating highlighted, hyperlinked HTML from Agda+-- sources.++module Agda.Interaction.Highlighting.HTML.Base+  ( HtmlOptions(..)+  , HtmlHighlight(..)+  , prepareCommonDestinationAssets+  , srcFileOfInterface+  , defaultPageGen+  , MonadLogHtml(logHtml)+  , LogHtmlT+  , runLogHtmlWith+  ) where++import Prelude hiding ((!!), concatMap)++import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( MonadIO(..), lift )+import Control.Monad.Trans.Reader ( ReaderT(runReaderT), ask )++import Data.Foldable (toList, concatMap)+import Data.Maybe+import qualified Data.IntMap as IntMap+import Data.List.Split (splitWhen)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T++import GHC.Generics (Generic)++import qualified Network.URI.Encode++import System.FilePath+import System.Directory++import Text.Blaze.Html5+    ( preEscapedToHtml+    , toHtml+    , stringValue+    , Html+    , (!)+    , Attribute+    )+import qualified Text.Blaze.Html5 as Html5+import qualified Text.Blaze.Html5.Attributes as Attr+import Text.Blaze.Html.Renderer.Text ( renderHtml )+  -- The imported operator (!) attaches an Attribute to an Html value+  -- The defined operator (!!) attaches a list of such Attributes++import Agda.Interaction.Highlighting.Precise hiding (toList)++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.Syntax.Common.Pretty++import Agda.Utils.Impossible++-- | The Agda data directory containing the files for the HTML backend.++htmlDataDir :: FilePath+htmlDataDir = "html"++-- | The name of the default CSS file.++defaultCSSFile :: FilePath+defaultCSSFile = "Agda.css"++-- | The name of the occurrence-highlighting JS file.++occurrenceHighlightJsFile :: FilePath+occurrenceHighlightJsFile = "highlight-hover.js"++-- | The directive inserted before the rendered code blocks++rstDelimiter :: String+rstDelimiter = ".. raw:: html\n"++-- | The directive inserted before rendered code blocks in org++orgDelimiterStart :: String+orgDelimiterStart = "#+BEGIN_EXPORT html\n<pre class=\"Agda\">\n"++-- | The directive inserted after rendered code blocks in org++orgDelimiterEnd :: String+orgDelimiterEnd = "</pre>\n#+END_EXPORT\n"++-- | Determine how to highlight the file++data HtmlHighlight = HighlightAll | HighlightCode | HighlightAuto+  deriving (Show, Eq, Generic)++instance NFData HtmlHighlight++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 TypstFileType = True+highlightOnlyCode HighlightAuto TreeFileType  = True+highlightOnlyCode HighlightAuto TexFileType   = False++-- | Determine the generated file extension++highlightedFileExt :: HtmlHighlight -> FileType -> String+highlightedFileExt hh ft+  | not $ highlightOnlyCode hh ft = "html"+  | otherwise = case ft of+      AgdaFileType  -> "html"+      MdFileType    -> "md"+      RstFileType   -> "rst"+      TexFileType   -> "tex"+      OrgFileType   -> "org"+      TypstFileType -> "typ"+      TreeFileType  -> "tree"++-- | Options for HTML generation++data HtmlOptions = HtmlOptions+  { htmlOptDir                  :: FilePath+  , htmlOptHighlight            :: HtmlHighlight+  , htmlOptHighlightOccurrences :: Bool+  , htmlOptCssFile              :: Maybe FilePath+  } deriving Eq++-- | Internal type bundling the information related to a module source file++data HtmlInputSourceFile = HtmlInputSourceFile+  { _srcFileModuleName :: TopLevelModuleName+  , _srcFileType :: FileType+  -- ^ Source file type+  , _srcFileText :: Text+  -- ^ Source text+  , _srcFileHighlightInfo :: HighlightingInfo+  -- ^ Highlighting info+  }++-- | Bundle up the highlighting info for a source file++srcFileOfInterface ::+  TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile+srcFileOfInterface m i = HtmlInputSourceFile m (TCM.iFileType i) (TCM.iSource i) (TCM.iHighlighting i)++-- | Logging during HTML generation++type HtmlLogMessage = String+type HtmlLogAction m = HtmlLogMessage -> m ()++class MonadLogHtml m where+  logHtml :: HtmlLogAction m++type LogHtmlT m = ReaderT (HtmlLogAction m) m++instance Monad m => MonadLogHtml (LogHtmlT m) where+  logHtml message = do+    doLog <- ask+    lift $ doLog message++runLogHtmlWith :: Monad m => HtmlLogAction m -> LogHtmlT m a -> m a+runLogHtmlWith = flip runReaderT++renderSourceFile :: HtmlOptions -> HtmlInputSourceFile -> Text+renderSourceFile opts = renderSourcePage+  where+  cssFile = fromMaybe defaultCSSFile (htmlOptCssFile opts)+  highlightOccur = htmlOptHighlightOccurrences opts+  htmlHighlight = htmlOptHighlight opts+  renderSourcePage (HtmlInputSourceFile moduleName fileType sourceCode hinfo) =+    page cssFile highlightOccur onlyCode moduleName pageContents+    where+      tokens = tokenStream sourceCode hinfo+      onlyCode = highlightOnlyCode htmlHighlight fileType+      pageContents = code onlyCode fileType tokens++defaultPageGen :: (MonadIO m, MonadLogHtml m) => HtmlOptions -> HtmlInputSourceFile -> m ()+defaultPageGen opts srcFile@(HtmlInputSourceFile moduleName ft _ _) = do+  logHtml $ render $ "Generating HTML for"  <+> pretty moduleName <+> ((parens (pretty target)) <> ".")+  writeRenderedHtml html target+  where+    ext = highlightedFileExt (htmlOptHighlight opts) ft+    target = (htmlOptDir opts) </> modToFile moduleName ext+    html = renderSourceFile opts srcFile++prepareCommonDestinationAssets :: MonadIO m => HtmlOptions -> m ()+prepareCommonDestinationAssets options = liftIO $ do+  -- There is a default directory given by 'defaultHTMLDir'+  let htmlDir = htmlOptDir options+  createDirectoryIfMissing True htmlDir++  -- If the default CSS file should be used, then it is copied to+  -- the output directory.+  let cssFile = htmlOptCssFile options+  when (isNothing $ cssFile) $ do+    defCssFile <- getDataFileName $+      htmlDataDir </> defaultCSSFile+    copyFile defCssFile (htmlDir </> defaultCSSFile)++  let highlightOccurrences = htmlOptHighlightOccurrences options+  when highlightOccurrences $ do+    highlightJsFile <- getDataFileName $+      htmlDataDir </> occurrenceHighlightJsFile+    copyFile highlightJsFile (htmlDir </> occurrenceHighlightJsFile)++-- | Converts module names to the corresponding HTML file names.++modToFile :: TopLevelModuleName -> String -> FilePath+modToFile m ext = Network.URI.Encode.encode $ render (pretty m) <.> ext++-- | Generates a highlighted, hyperlinked version of the given module.++writeRenderedHtml+  :: MonadIO m+  => Text       -- ^ Rendered page+  -> FilePath   -- ^ Output path.+  -> m ()+writeRenderedHtml html target = liftIO $ UTF8.writeTextToFile target html+++-- | Attach multiple Attributes++(!!) :: Html -> [Attribute] -> Html+h !! as = h ! mconcat as++-- | Constructs the web page, including headers.++page :: FilePath              -- ^ URL to the CSS file.+     -> Bool                  -- ^ Highlight occurrences+     -> Bool                  -- ^ Whether to reserve literate+     -> TopLevelModuleName    -- ^ Module to be highlighted.+     -> Html+     -> Text+page css+     highlightOccurrences+     htmlHighlight+     modName+     pageContent =+  renderHtml $ if htmlHighlight+               then pageContent+               else Html5.docTypeHtml $ hdr <> rest+  where++    hdr = Html5.head $ mconcat+      [ Html5.meta !! [ Attr.charset "utf-8" ]+      , Html5.title (toHtml . render $ pretty modName)+      , Html5.link !! [ Attr.rel "stylesheet"+                      , Attr.href $ stringValue css+                      ]+      , if highlightOccurrences+        then Html5.script mempty !!+          [ Attr.type_ "text/javascript"+          , Attr.src $ stringValue occurrenceHighlightJsFile+          ]+        else mempty+      ]++    rest = Html5.body $ (Html5.pre ! Attr.class_ "Agda") pageContent++-- | Position, Contents, Infomation++type TokenInfo =+  ( Int+  , String1+  , Aspects+  )++-- | Constructs token stream ready to print.++tokenStream+     :: Text             -- ^ The contents of the module.+     -> HighlightingInfo -- ^ Highlighting information.+     -> [TokenInfo]+tokenStream contents info =+  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++-- | Constructs the HTML displaying the code.++code :: Bool     -- ^ Whether to generate non-code contents as-is+     -> FileType -- ^ Source file type+     -> [TokenInfo]+     -> Html+code onlyCode fileType = mconcat . if onlyCode+  then case fileType of+         -- 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 . 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++  splitByMarkup :: [TokenInfo] -> [[TokenInfo]]+  splitByMarkup = splitWhen $ (== Just Markup) . aspect . trd++  mkHtml :: TokenInfo -> Html+  mkHtml (pos, s, mi) =+    -- Andreas, 2017-06-16, issue #2605:+    -- Do not create anchors for whitespace.+    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 backgroundOrAgdaToHtml++  -- 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+      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+      containsCode = any ((/= Just Background) . aspect . trd) tokens++      startDelimiter = preEscapedToHtml orgDelimiterStart+      endDelimiter = preEscapedToHtml orgDelimiterEnd++      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+  -- (issue #2756), as well as a heuristic name anchor for external references+  -- (issue #2604).+  annotate :: Int -> Aspects -> Html -> Html+  annotate pos mi =+    applyWhen hereAnchor (anchorage nameAttributes mempty <>) . anchorage posAttributes+    where+    -- Warp an anchor (<A> tag) with the given attributes around some HTML.+    anchorage :: [Attribute] -> Html -> Html+    anchorage attrs html = Html5.a html !! attrs++    -- File position anchor (unique, reliable).+    posAttributes :: [Attribute]+    posAttributes = concat+      [ [Attr.id $ stringValue $ show pos ]+      , toList $ link <$> definitionSite mi+      , Attr.class_ (stringValue $ unwords classes) <$ guard (not $ null classes)+      ]++    -- Named anchor (not reliable, but useful in the general case for outside refs).+    nameAttributes :: [Attribute]+    nameAttributes = [ Attr.id $ stringValue $ fromMaybe __IMPOSSIBLE__ $ mDefSiteAnchor ]++    classes = concat+      [ concatMap noteClasses (note mi)+      , otherAspectClasses (toList $ otherAspects mi)+      , concatMap aspectClasses (aspect mi)+      ]++    aspectClasses (Name mKind op) = kindClass ++ opClass+      where+      kindClass = toList $ fmap showKind mKind++      showKind (Constructor Inductive)   = "InductiveConstructor"+      showKind (Constructor CoInductive) = "CoinductiveConstructor"+      showKind k                         = show k++      opClass = ["Operator" | op]+    aspectClasses a = [show a]+++    otherAspectClasses = map show++    -- Notes are not included.+    noteClasses _s = []++    -- Should we output a named anchor?+    -- Only if we are at the definition site now (@here@)+    -- and such a pretty named anchor exists (see 'defSiteAnchor').+    hereAnchor      :: Bool+    hereAnchor      = here && isJust mDefSiteAnchor++    mDefinitionSite :: Maybe DefinitionSite+    mDefinitionSite = definitionSite mi++    -- Are we at the definition site now?+    here            :: Bool+    here            = maybe False defSiteHere mDefinitionSite++    mDefSiteAnchor  :: Maybe String+    mDefSiteAnchor  = maybe __IMPOSSIBLE__ defSiteAnchor mDefinitionSite++    link (DefinitionSite m defPos _here _aName) = Attr.href $ stringValue $+      -- If the definition site points to the top of a file,+      -- we drop the anchor part and just link to the file.+      applyUnless (defPos <= 1)+        (++ "#" +++         Network.URI.Encode.encode (show defPos))+         -- Network.URI.Encode.encode (fromMaybe (show defPos) aName)) -- Named links disabled+        (Network.URI.Encode.encode $ modToFile m "html")
+ src/full/Agda/Interaction/Highlighting/JSON.hs view
@@ -0,0 +1,82 @@+{-# 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, topLevelModuleFilePath)++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+  :: ModuleToSource+     -- ^ Must contain a mapping for the definition site's module, if any.+  -> (Range, Aspects) -> Value+showAspects modFile (range, aspect) = object+  [ "range" .= [from range, to range]+  , "atoms" .= toAtoms aspect+  , "tokenBased" .= tokenBased aspect+  , "note" .= note aspect+  , "definitionSite" .= fmap defSite (definitionSite aspect)+  ]+  where+    defSite (DefinitionSite mdl position _ _) = object+      [ "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+    toJSON TokenBased = String "TokenBased"+    toJSON NotOnlyTokenBased = String "NotOnlyTokenBased"++-- | Turns syntax highlighting information into a JSON value+jsonifyHighlightingInfo+  :: HighlightingInfo+  -> RemoveTokenBasedHighlighting+  -> HighlightingMethod+  -> ModuleToSource+     -- ^ Must contain a mapping for every definition site's module.+  -> IO Value+jsonifyHighlightingInfo info remove method modFile =+  case chooseHighlightingMethod info method of+    Direct   -> direct+    Indirect -> indirect+  where+    result :: Value+    result = object+      [ "remove" .= case remove of+          RemoveHighlighting -> True+          KeepHighlighting -> False+      , "payload" .= map (showAspects modFile) (toList info)+      ]++    direct :: IO Value+    direct = return $ object+      [ "kind"   .= String "HighlightingInfo"+      , "direct" .= True+      , "info"   .= result+      ]++    indirect :: IO Value+    indirect = do+      filepath <- writeToTempFile (BS.unpack (encode result))+      return $ object+        [ "kind"     .= String "HighlightingInfo"+        , "direct"   .= False+        , "filepath" .= filepath+        ]
src/full/Agda/Interaction/Highlighting/LaTeX.hs view
@@ -1,632 +1,11 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wunused-imports #-} --- | Function for generating highlighted and aligned LaTeX from literate--- Agda source.+-- | Generating highlighted and aligned LaTeX from literate Agda source.  module Agda.Interaction.Highlighting.LaTeX-  ( generateLaTeX+  ( module Exports   ) where -import Prelude hiding (log)-import Data.Char-import Data.Maybe-import Data.Function-import Control.Monad.RWS.Strict-import System.Directory-import System.FilePath-import Data.Text (Text)-import qualified Data.Text          as T-import qualified Data.Text.IO       as T-import qualified Data.Text.Encoding as E-import qualified Data.ByteString    as BS--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, projectRoot)-import qualified Agda.Interaction.FindFile as Find-import Agda.Interaction.Highlighting.Precise-import Agda.TypeChecking.Monad (TCM, Interface(..))-import qualified Agda.TypeChecking.Monad as TCM-import Agda.Interaction.Options-import Agda.Compiler.CallCompiler-import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.FileName (filePath)--import Agda.Utils.Except ( ExceptT, MonadError(throwError), runExceptT )--#include "undefined.h"-import Agda.Utils.Impossible----------------------------------------------------------------------------- * Datatypes.---- | The @LaTeX@ monad is a combination of @ExceptT@, @RWST@ and--- @IO@. The error part is just used to keep track whether we finished--- or not, the reader part isn't 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 I/O part is used for printing debugging info.-type LaTeX = ExceptT String (RWST () Text State IO)--data State = State-  { tokens     :: Tokens-  , column     :: !Int    -- ^ Column number, used for polytable alignment.-  , indent     :: !Int    -- ^ Indentation level, also for alignment.-  , indentPrev :: !Int-  , inCode     :: !Bool   -- ^ Keeps track of whether we are in a code-                          -- block or not.-  }--type Tokens = [Token]--data Token = Token-  { text     :: !Text-  , info     :: Aspects-  , position :: !Int     -- ^ Is not used currently, but could-                         -- potentially be used for hyperlinks as in-                         -- the HTML output?-  }-  deriving Show--data Debug = MoveColumn | NonCode | Code | Spaces | Output-  deriving (Eq, Show)---- | Says what debug information should printed.--debugs :: [Debug]-debugs = []---- | Run function for the @LaTeX@ monad.-runLaTeX :: LaTeX a -> () -> State -> IO (Either String a, State, Text)-runLaTeX = runRWST . runExceptT--emptyState :: State-emptyState = State-  { tokens     = []-  , column     = 0-  , indent     = 0-  , indentPrev = 0-  , inCode     = False-  }----------------------------------------------------------------------------- * Some helpers.--(<+>) :: Text -> Text -> Text-(<+>) = T.append--isInfixOf' :: Text -> Text -> Maybe (Text, Text)-isInfixOf' needle haystack = go (T.tails haystack) 0-  where-  go []                                         !n = Nothing-  go ((T.stripPrefix needle -> Just suf) : xss)  n = Just (T.take n haystack, suf)-  go (_                                  : xss)  n = go xss (n + 1)---- Same as above, but starts searching from the back rather than the--- front.-isInfixOfRev :: Text -> Text -> Maybe (Text, Text)-isInfixOfRev needle haystack-  = case T.reverse needle `isInfixOf'` T.reverse haystack of-      Nothing         -> Nothing-      Just (pre, suf) -> Just (T.reverse suf, T.reverse pre)--isSpaces :: Text -> Bool-isSpaces = T.all isSpace--isActualSpaces :: Text -> Bool-isActualSpaces = T.all (== ' ')---- | Yields the next token, taking special care to begin/end code--- blocks. Junk occuring before and after the code blocks is separated--- into separate tokens, this makes it easier to keep track of whether--- we are in a code block or not.-nextToken' :: LaTeX Token-nextToken' = do-  toks <- gets tokens-  case toks of-    []     -> throwError "Done"--    -- Clean begin/end code block or a LaTeX comment.-    t : ts | text t == beginCode || text t == endCode ||-             T.singleton '%' == T.take 1 (T.stripStart (text t)) -> do--      modify $ \s -> s { tokens = ts }-      return t--    t : ts -> do-      modify $ \s -> s { tokens = ts }--      inCode <- gets inCode-      let code = if inCode then endCode else beginCode--      case code `isInfixOf'` text t of-        Nothing -> do--          -- Spaces take care of their own column tracking.-          unless (isSpaces (text t)) $ do-            log MoveColumn $ text t-            moveColumn $ T.length $ text t--          return t--        Just (pre, suf) -> do--          let (textToReturn, textsToPutBack) =--               -- This bit fixes issue 954.--               -- Drop spaces up until and including the first trailing-               -- newline after begin code blocks.-               if code == beginCode && isSpaces suf-               then case T.singleton '\n' `isInfixOf'` suf of-                     Nothing        -> (pre, [ beginCode ])-                     Just (_, suf') -> (pre, [ beginCode, suf' ])--               -- Do the converse thing for end code blocks.-               else if code == endCode && isSpaces pre-                    then case T.singleton '\n' `isInfixOfRev` pre of-                           Nothing           -> (code, [ suf ])-                           Just (pre', suf') ->-                             (pre' <+> T.dropWhile (`elem` [' ', '\t']) suf',-                              [ code, suf ])--              -- This case happens for example when you have two code-              -- blocks after each other, i.e. the begin code of the-              -- second ends up in the suffix of the first's end code.-                    else (pre, [ code, suf ])--          let tokToReturn   = t { text = textToReturn }-          let toksToPutBack = map (\txt -> t { text = txt }) textsToPutBack--          unless (isSpaces pre) $ do-            log MoveColumn pre-            moveColumn $ T.length pre--          modify $ \s -> s { tokens = toksToPutBack ++ tokens s }-          return tokToReturn--nextToken :: LaTeX Text-nextToken = text `fmap` nextToken'--resetColumn :: LaTeX ()-resetColumn = modify $ \s -> s { column = 0 }--moveColumn :: Int -> LaTeX ()-moveColumn i = modify $ \s -> s { column = i + column s }--setIndent :: Int -> LaTeX ()-setIndent i = modify $ \s -> s { indent = i }--resetIndent :: LaTeX ()-resetIndent = modify $ \s -> s { indent = 0 }--setIndentPrev :: Int -> LaTeX ()-setIndentPrev i = modify $ \s -> s { indentPrev = i }--resetIndentPrev :: LaTeX ()-resetIndentPrev = modify $ \s -> s { indentPrev = 0 }--setInCode :: LaTeX ()-setInCode = modify $ \s -> s { inCode = True }--unsetInCode :: LaTeX ()-unsetInCode = modify $ \s -> s { inCode = False }--logHelper :: Debug -> Text -> [String] -> LaTeX ()-logHelper debug text extra =-  when (debug `elem` debugs) $ do-    lift $ lift $ T.putStrLn $ T.pack (show debug ++ ": ") <+>-      T.pack "'" <+> text <+> T.pack "' " <+>-      if null extra-         then T.empty-         else T.pack "(" <+> T.pack (unwords extra) <+> T.pack ")"--log :: Debug -> Text -> LaTeX ()-log MoveColumn text = do-  ind <- gets indent-  logHelper MoveColumn text ["ind=", show ind]-log Code text = do-  ind <- gets indent-  col <- gets column-  logHelper Code text ["ind=", show ind, "col=", show col]-log debug text = logHelper debug text []--log' :: Debug -> String -> LaTeX ()-log' d = log d . T.pack--output :: Text -> LaTeX ()-output text = do-  log Output text-  tell text----------------------------------------------------------------------------- * LaTeX and polytable strings.---- Polytable, http://www.ctan.org/pkg/polytable, is used for code--- alignment, similar to lhs2TeX's approach.--nl, beginCode, endCode :: Text-nl        = T.pack "%\n"-beginCode = T.pack "\\begin{code}"-endCode   = T.pack "\\end{code}"--ptOpen :: Text-ptOpen = T.pack "\\>"--ptOpen' :: Show a => a -> Text-ptOpen' i = ptOpen <+> T.pack ("[" ++ show i ++ "]")--ptClose :: Text-ptClose = T.pack "\\<"--ptClose' :: Show a => a -> Text-ptClose' i = ptClose <+> T.pack ("[" ++ show i ++ "]")--ptNL :: Text-ptNL = nl <+> T.pack "\\\\\n"--cmdPrefix :: Text-cmdPrefix = T.pack "\\Agda"--cmdArg :: Text -> Text-cmdArg x = T.singleton '{' <+> x <+> T.singleton '}'--cmdIndent :: Show a => a -> Text-cmdIndent i = cmdPrefix <+> T.pack "Indent" <+>-                  cmdArg (T.pack (show i)) <+> cmdArg T.empty----- Andreas, 2016-09-08, issue #2140:--- The following special treatment of infix declarations seems--- superfluous (and does the wrong thing with the fix for #2140):---- infixl', infix', infixr' :: Text--- infixl' = T.pack "infixl"--- infix'  = T.pack "infix"--- infixr' = T.pack "infixr"----------------------------------------------------------------------------- * Automaton.---- | The start state, @nonCode@, prints non-code (the LaTeX part of--- literate Agda) until it sees a @beginBlock@.-nonCode :: LaTeX ()-nonCode = do-  tok <- nextToken-  log NonCode tok--  if tok == beginCode--     then do-       output $ beginCode <+> nl-       resetColumn-       setInCode-       code--     else do-       output tok-       nonCode---- | Deals with code blocks. Every token, except spaces, is pretty--- printed as a LaTeX command.-code :: LaTeX ()-code = do--  -- Get the column information before grabbing the token, since-  -- grabbing (possibly) moves the column.-  col  <- gets column--  tok' <- nextToken'-  let tok = text tok'-  log Code tok--  when (tok == T.empty) code--  when (col == 0 && not (isActualSpaces tok)) $ do-    output ptOpen--  when (tok == endCode) $ do-    output $ ptClose <+> nl <+> endCode-    unsetInCode-    nonCode--  -- Andreas, 2016-09-08, issue #2140:-  -- The following special treatment of infix declarations seems-  -- superfluous (and does the wrong thing with the fix for #2140):--  -- when (tok `elem` [ infixl', infix', infixr' ]) $ do-  --   output $ cmdPrefix <+> T.pack "Keyword" <+> cmdArg tok-  --   fixity-  --   code--  when (isSpaces tok) $ do-    spaces $ T.group tok-    code--  case aspect (info tok') of-    Nothing -> output $ escape tok-    Just a  -> output $ cmdPrefix <+> T.pack (cmd a) <+> cmdArg (escape tok)--  code--  where-  cmd :: Aspect -> String-  cmd a = let s = show a in case a of-    Comment        -> s-    Keyword        -> s-    String         -> s-    Number         -> s-    Symbol         -> s-    PrimitiveType  -> s-    Name mKind _   -> maybe __IMPOSSIBLE__ showKind mKind-      where-      showKind :: NameKind -> String-      showKind n = let s = show n in case n of-        Bound                     -> s-        Constructor Inductive     -> "InductiveConstructor"-        Constructor CoInductive   -> "CoinductiveConstructor"-        Datatype                  -> s-        Field                     -> s-        Function                  -> s-        Module                    -> s-        Postulate                 -> s-        Primitive                 -> s-        Record                    -> s-        Argument                  -> s-        Macro                     -> s---- Escapes special characters.-escape :: Text -> Text-escape (T.uncons -> Nothing)     = T.empty-escape (T.uncons -> Just (c, s)) = T.pack (replace c) <+> escape s-  where-  replace :: Char -> String-  replace c = case c of-    '_'  -> "\\_"-    '{'  -> "\\{"-    '}'  -> "\\}"-    '#'  -> "\\#"-    '$'  -> "\\$"-    '&'  -> "\\&"-    '%'  -> "\\%"-    '~'  -> "\\textasciitilde{}"-    '^'  -> "\\textasciicircum{}"-    '\\' -> "\\textbackslash{}"-    -- Escaping newlines seems to fix the problem caused by pattern-    -- synonyms.-    '\n' -> "\\<\\\\\n\\>"-    _    -> [ c ]-escape _                         = __IMPOSSIBLE__----- Andreas, 2016-09-08, issue #2140:--- The following special treatment of infix declarations seems--- superfluous (and does the wrong thing with the fix for #2140):---- -- | Fixity declarations need a special treatment. The operations in--- -- declarations like:--- ----- --     infix num op1 op2 op3--- ----- -- are treated as comments and thus grouped together with the newlines--- -- that follow, which results incorrect LaTeX output -- the following--- -- state remedies the problem by breaking on newlines.--- fixity :: LaTeX ()--- fixity = do---   tok <- nextToken----   case T.breakOn (T.pack "\n") tok of----     -- Spaces.---     (sps, nls) | nls == T.empty && isSpaces sps -> do---         spaces $ T.group sps---         fixity----     -- Fixity level.---     (num, nls) | nls == T.empty -> do---         output $ cmdPrefix <+> T.pack "Number" <+> cmdArg num---         fixity----     -- Operations followed by newlines.---     (ops, nls) | otherwise      -> do---         output $ (T.pack " " <+>) $ T.unwords $ map ((cmdPrefix <+> T.pack "FixityOp" <+>) . cmdArg . escape) $ T.words ops---         spaces (T.group nls)----- | Spaces are grouped before processed, because multiple consecutive--- spaces determine the alignment of the code and consecutive newline--- characters need special treatment as well.-spaces :: [Text] -> LaTeX ()-spaces []                                 = return ()-spaces ((T.uncons -> Nothing)       : ss) = __IMPOSSIBLE__---- Single spaces are ignored.-spaces ((T.uncons -> Just (' ', s)) : []) | T.null s = do-  col <- gets column-  when (col == 0) $ do-    output ptOpen--  moveColumn 1-  output $ T.singleton ' '---- Multiple spaces.-spaces (s@(T.uncons -> Just (' ', _)) : ss) = do-  let len = T.length s--  col <- gets column-  moveColumn len--  if col /= 0--     then do-       log' Spaces "col /= 0"-       output $ T.singleton ' '-       col <- gets column-       output $ ptClose' col <+> nl <+> ptOpen' col--     else do-       log' Spaces "col == 0"-       indent <- gets indent-       indentPrev <- gets indentPrev--       case compare len indent of--         GT -> do-           log' Spaces "GT"-           setIndent len-           setIndentPrev indent-           output $ ptOpen' indent-           output $ cmdIndent len-           output $ ptClose' len <+> nl <+> ptOpen' len--         EQ -> do-           log' Spaces "EQ"-           output $ ptOpen' indentPrev-           output $ cmdIndent len-           output $ ptClose' len <+> nl <+> ptOpen' len--         LT -> do-           log' Spaces "LT"-           setIndent len-           resetIndentPrev-           output $ ptOpen' 0-           output $ cmdIndent len-           output $ ptClose' len <+> nl <+> ptOpen' len--  spaces ss---- Newlines.-spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do-  resetColumn-  output $ ptClose <+> T.replicate (T.length s) ptNL-  spaces ss---- Treat tabs and non-standard spaces as if they were spaces--- [Issue_#2019].-spaces (s@(T.uncons -> Just (c, _)) : ss)-  | isSpace c && (c /= '\n') =-      spaces $ T.replicate (T.length s) (T.singleton ' ') : ss-  | otherwise = __IMPOSSIBLE__--spaces (_ : ss) = __IMPOSSIBLE__---- Split multi-lines string literals into multiple string literals--- Isolating leading spaces for the alignment machinery to work--- properly-stringLiteral :: Token -> Tokens-stringLiteral t | aspect (info t) == Just String =-  reverse $ snd $ foldl insertShifted (0, [])-                $ concatMap leadingSpaces-                $ List.intersperse (T.pack "\n")-                $ T.lines (text t) where--    leadingSpaces :: Text -> [Text]-    leadingSpaces t = [pre, suf]-      where (pre , suf) = T.span (== ' ') t--    insertShifted :: (Int, Tokens) -> Text -> (Int, Tokens)-    insertShifted (i, xs) x =-      let tx = t { text = x, position = position t + i }-      in (i + T.length x, tx : xs)--stringLiteral t = [t]----------------------------------------------------------------------------- * Main.--defaultStyFile :: String-defaultStyFile = "agda.sty"---- | The only exported function.-generateLaTeX :: Interface -> TCM ()-generateLaTeX i = do-  let mod = toTopLevelModuleName $ iModuleName i-      hi  = iHighlighting i--  options <- TCM.commandLineOptions--  dir <- case optGHCiInteraction options of-    False -> return $ optLaTeXDir options-    True  -> do-      sourceFile <- Find.findFile mod-      return $ filePath (projectRoot sourceFile mod)-                 </> optLaTeXDir options-  liftIO $ createDirectoryIfMissing True dir--  TCM.reportSLn "latex" 1 $ unlines-    [ ""-    , "Checking if " ++ defaultStyFile ++ " is found by the LaTeX environment."-    ]--  merrors <- callCompiler' "kpsewhich" [ "--path=" ++ dir,  defaultStyFile ]--  when (isJust merrors) $ do-    TCM.reportSLn "latex" 1 $ unlines-      [ ""-      , defaultStyFile ++ " was not found. Copying a default version of " ++-          defaultStyFile-      , "into the directory " ++ dir ++ "."-      ]--    liftIO $ do-      styFile <- getDataFileName defaultStyFile-      liftIO $ copyFile styFile (dir </> defaultStyFile)--  let outPath = modToFile mod-  inAbsPath <- liftM filePath (Find.findFile mod)--  liftIO $ do-    source <- UTF8.readTextFile inAbsPath-    latex <- E.encodeUtf8 `fmap` toLaTeX source hi-    createDirectoryIfMissing True $ dir </> takeDirectory outPath-    BS.writeFile (dir </> outPath) latex--  where-    modToFile :: TopLevelModuleName -> FilePath-    modToFile m = List.intercalate [pathSeparator] (moduleNameParts m) <.> "tex"---- | Transforms the source code into LaTeX.-toLaTeX :: String -> HighlightingInfo -> IO Text-toLaTeX source hi--  = processTokens--  . concatMap stringLiteral--  -- Head the list (the grouped chars contain the same meta info) and-  -- collect the characters into a string.-  . map (\xs -> case xs of-                    (mi, (pos, _)) : _ ->-                        Token { text     = T.pack $ map (\(_, (_, c)) -> c) xs-                              , info     = fromMaybe mempty mi-                              , position = pos-                              }-                    []                 -> __IMPOSSIBLE__)--  . List.groupBy ((==) `on` fst)  -- Characters which share the same-                                  -- meta info are the same token, so-                                  -- group them together.--  -- Look up the meta info at each position in the highlighting info.-  . map (\(pos, char) ->-        (IntMap.lookup pos infoMap, (pos, char)))--  -- Add position in file to each character.-  . zip [1..]-  $ source-  where-  infoMap = toMap (decompress hi)--processTokens :: Tokens -> IO Text-processTokens ts = do-  (x, _, s) <- runLaTeX nonCode () (emptyState { tokens = ts })-  case x of-    Left "Done" -> return s-    _           -> __IMPOSSIBLE__+import Agda.Interaction.Highlighting.LaTeX.Backend as Exports+  ( latexBackend+  )
+ src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs view
@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.Highlighting.LaTeX.Backend+  ( latexBackend+  ) where++import Agda.Interaction.Highlighting.LaTeX.Base+  ( LaTeXOptions(..)+  , MonadLogLaTeX(logLaTeX)+  , logMsgToText+  , generateLaTeXIO+  , prepareCommonAssets+  )++import Control.DeepSeq+import Control.Monad.Trans (MonadIO)++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_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..))+import Agda.Compiler.Common (curIF, IsMain(IsMain, NotMain))++import Agda.Interaction.Options+  ( ArgDescr(NoArg, ReqArg)+  , CommandLineOptions ( optGHCiInteraction, optPragmaOptions )+  , optCountClusters+  , Flag+  , OptDescr(..)+  )++import Agda.Syntax.Position (mkRangeFile, rangeFilePath)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, projectRoot)++import Agda.TypeChecking.Monad+  ( HasOptions(commandLineOptions)+  , MonadDebug+  , stModuleToSourceId+  , useTC+  , ReadTCState+  , reportS+  , MonadFileId+  , srcFilePath+  )++import Agda.Utils.FileName (filePath, mkAbsolute)++------------------------------------------------------------------------+-- * Main.++-- Command-line flag options, prior to e.g. path resolution and validation.+data LaTeXFlags = LaTeXFlags+  { latexFlagOutDir        :: FilePath+  , latexFlagSourceFile    :: Maybe FilePath+  , latexFlagGenerateLaTeX :: Bool+    -- ^ Are we going to try to generate LaTeX at all?+  } deriving (Eq, Generic)++instance NFData LaTeXFlags++-- | The default output directory for LaTeX.++defaultLaTeXDir :: FilePath+defaultLaTeXDir = "latex"++defaultLaTeXFlags :: LaTeXFlags+defaultLaTeXFlags = LaTeXFlags+  { latexFlagOutDir        = defaultLaTeXDir+  , latexFlagSourceFile    = Nothing+  , latexFlagGenerateLaTeX = False+  }++latexFlagsDescriptions :: [OptDescr (Flag LaTeXFlags)]+latexFlagsDescriptions =+  [ Option []     ["latex"] (NoArg latexFlag)+                  "generate LaTeX with highlighted source code"+  , Option []     ["latex-dir"] (ReqArg latexDirFlag "DIR")+                  ("directory in which LaTeX files are placed (default: " +++                    defaultLaTeXDir ++ ")")+  ]++latexFlag :: Flag LaTeXFlags+latexFlag o = return $ o { latexFlagGenerateLaTeX = True }++latexDirFlag :: FilePath -> Flag LaTeXFlags+latexDirFlag d o = return $ o { latexFlagOutDir = d }++data LaTeXCompileEnv = LaTeXCompileEnv LaTeXFlags+data LaTeXModuleEnv  = LaTeXModuleEnv LaTeXOptions+data LaTeXModule     = LaTeXModule+data LaTeXDef        = LaTeXDef++latexBackend :: Backend+latexBackend = Backend latexBackend'++latexBackend' :: Backend' LaTeXFlags LaTeXCompileEnv LaTeXModuleEnv LaTeXModule LaTeXDef+latexBackend' = Backend'+  { backendName           = "LaTeX"+  , backendVersion        = Nothing+  , options               = defaultLaTeXFlags+  , commandLineFlags      = latexFlagsDescriptions+  , isEnabled             = latexFlagGenerateLaTeX+  , preCompile            = preCompileLaTeX+  , preModule             = preModuleLaTeX+  , compileDef            = compileDefLaTeX+  , postModule            = postModuleLaTeX+  , postCompile           = postCompileLaTeX+  , scopeCheckingSuffices = True+  , mayEraseType          = const $ return False+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing+  }++-- | 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, MonadFileId m)+  => LaTeXFlags+  -> TopLevelModuleName+  -> m LaTeXOptions+resolveLaTeXOptions flags moduleName = do+  options <- commandLineOptions+  modFiles <- useTC stModuleToSourceId+  let msrc = Map.lookup moduleName modFiles+  mf <- traverse srcFilePath msrc+  let+    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 (rangeFilePath sourceFile) moduleName) </>+        latexDir+      _ -> latexDir+  return LaTeXOptions+    { latexOptOutDir         = outDir+    , latexOptSourceFileName = mSrcFileName+    , latexOptCountClusters  = countClusters+    }++preCompileLaTeX+  :: Applicative m+  => LaTeXFlags+  -> m LaTeXCompileEnv+preCompileLaTeX flags = pure $ LaTeXCompileEnv flags++preModuleLaTeX+  :: (HasOptions m, ReadTCState m, MonadFileId m)+  => LaTeXCompileEnv+  -> IsMain+  -> TopLevelModuleName+  -> Maybe FilePath+  -> m (Recompile LaTeXModuleEnv LaTeXModule)+preModuleLaTeX (LaTeXCompileEnv flags) isMain moduleName _ifacePath = case isMain of+  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags moduleName+  NotMain -> return $ Skip LaTeXModule++compileDefLaTeX+  :: Applicative m+  => LaTeXCompileEnv+  -> LaTeXModuleEnv+  -> IsMain+  -> Definition+  -> m LaTeXDef+compileDefLaTeX _cenv _menv _main _def = pure LaTeXDef++postModuleLaTeX+  :: (MonadDebug m, ReadTCState m, MonadIO m)+  => LaTeXCompileEnv+  -> LaTeXModuleEnv+  -> IsMain+  -> TopLevelModuleName+  -> [LaTeXDef]+  -> m LaTeXModule+postModuleLaTeX _cenv (LaTeXModuleEnv latexOpts) _main _moduleName _defs = do+  i <- curIF+  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.+    -- However, for now that is OK because we only generate LaTeX for the main module.+    prepareCommonAssets (latexOptOutDir latexOpts)+    generateLaTeXIO latexOpts i+  return LaTeXModule++postCompileLaTeX+  :: Applicative m+  => LaTeXCompileEnv+  -> IsMain+  -> Map TopLevelModuleName LaTeXModule+  -> m ()+postCompileLaTeX _cenv _main _modulesByName = pure ()
+ src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs view
@@ -0,0 +1,831 @@+{-# LANGUAGE CPP #-}++-- | Function for generating highlighted and aligned LaTeX from literate+-- Agda source.++module Agda.Interaction.Highlighting.LaTeX.Base+  ( LaTeXOptions(..)+  , generateLaTeXIO+  , prepareCommonAssets+  , MonadLogLaTeX(logLaTeX)+  , LogMessage(..)+  , logMsgToText+  ) where++import Prelude hiding (log)++import Data.Bifunctor (second)+import Data.Char+import Data.Maybe+import Data.Function (on)+import Data.Foldable (toList)++import Control.Exception.Base (IOException, try)+import Control.Monad.Trans.Reader as R ( ReaderT(runReaderT))+import Control.Monad.RWS.Strict+  ( RWST(runRWST)+  , MonadReader(..), asks+  , MonadState(..), gets, modify+  , lift, tell+  )+import Control.Monad.IO.Class+  ( MonadIO(..)+  )++import System.Directory+import System.FilePath+import System.Process ( readProcess )++import Data.Text (Text)+import qualified Data.Text               as T+#ifdef COUNT_CLUSTERS+import qualified Data.Text.ICU           as ICU+#endif+import qualified Data.Text.Lazy          as L+import qualified Data.Text.Lazy.Encoding as E+import qualified Data.ByteString.Lazy    as BS++import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import qualified Data.IntMap  as IntMap+import qualified Data.List    as List++import Agda.Syntax.Common+import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers)+import qualified Agda.Syntax.Parser.Literate as L+import Agda.Syntax.Position (RangeFile, startPos')+import Agda.Syntax.TopLevelModuleName+  (TopLevelModuleName, moduleNameParts)++import Agda.Interaction.Highlighting.Precise hiding (toList)++import Agda.TypeChecking.Monad (Interface(..)) --, reportSLn)++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++------------------------------------------------------------------------+-- * Logging++-- | Log LaTeX messages using a provided action.+--+-- This could be accomplished by putting logs into the RWST output and splitting it+-- into a WriterT, but that becomes slightly more complicated to reason about in+-- the presence of IO exceptions.+--+-- 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.++class Monad m => MonadLogLaTeX m where+  logLaTeX :: LogMessage -> m ()++data LogMessage = LogMessage Debug Text [Text] deriving Show++------------------------------------------------------------------------+-- * The monad and its associated data types.++-- | 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 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 Output+  = Text !Text+    -- ^ A piece of text.+  | MaybeColumn !AlignmentColumn+    -- ^ A column. If it turns out to be an indentation column that is+    --   not used to indent or align something, then no column will be+    --   generated, only whitespace ('agdaSpace').+  deriving Show++-- | Column kinds.++data Kind+  = Indentation+    -- ^ Used only for indentation (the placement of the first token+    -- on a line, relative to tokens on previous lines).+  | Alignment+    -- ^ Used both for indentation and for alignment.+  deriving (Eq, Show)++-- | Unique identifiers for indentation columns.++type IndentationColumnId = Int++-- | Alignment and indentation columns.++data AlignmentColumn = AlignmentColumn+  { columnCodeBlock :: !Int+    -- ^ The column's code block.+  , columnColumn :: !Int+    -- ^ The column number.+  , columnKind :: Maybe IndentationColumnId+    -- ^ The column kind. 'Nothing' for alignment columns and @'Just'+    -- i@ for indentation columns, where @i@ is the column's unique+    -- identifier.+  } deriving Show++-- | Type of function for estimating column width of text.++type TextWidthEstimator = Text -> Int++data Env = Env+  { estimateTextWidth :: !TextWidthEstimator+    -- ^ How to estimate the column width of text (i.e. Count extended grapheme clusters vs. code points).+  , debugs :: [Debug]+    -- ^ Says what debug information should printed.+  }++data State = State+  { codeBlock     :: !Int   -- ^ The number of the current code block.+  , column        :: !Int   -- ^ The current column number.+  , columns       :: [AlignmentColumn]+                            -- ^ All alignment columns found on the+                            --   current line (so far), in reverse+                            --   order.+  , columnsPrev   :: [AlignmentColumn]+                            -- ^ All alignment columns found in+                            --   previous lines (in any code block),+                            --   with larger columns coming first.+  , nextId        :: !IndentationColumnId+                            -- ^ The next indentation column+                            -- identifier.+  , usedColumns   :: HashSet IndentationColumnId+                            -- ^ Indentation columns that have+                            -- actually+                            --   been used.+  }++type Tokens = [Token]++data Token = Token+  { text     :: !Text+  , info     :: Aspects+  }+  deriving Show++withTokenText :: (Text -> Text) -> Token -> Token+withTokenText f tok@Token{text = t} = tok{text = f t}++data Debug = MoveColumn | NonCode | Code | Spaces | Output | FileSystem+  deriving (Eq, Show)++-- | Run function for the @LaTeX@ monad.+runLaTeX :: MonadLogLaTeX m =>+  LaTeXT m a -> Env -> State -> m (a, State, [Output])+runLaTeX = runRWST++emptyState :: State+emptyState = State+  { codeBlock     = 0+  , column        = 0+  , columns       = []+  , columnsPrev   = []+  , nextId        = 0+  , usedColumns   = Set.empty+  }++emptyEnv+  :: TextWidthEstimator  -- ^ Count extended grapheme clusters?+  -> Env+emptyEnv twe = Env twe []+++------------------------------------------------------------------------+-- * Some helpers.++-- | Gives the size of the string. If cluster counting is enabled,+-- then the number of extended grapheme clusters is computed (the root+-- locale is used), and otherwise the number of code points.++size :: Text -> LaTeX Int+size t = asks estimateTextWidth <&> ($ t)++-- | Does the string consist solely of whitespace?++isSpaces :: Text -> Bool+isSpaces = T.all isSpace++-- | Is the character a whitespace character distinct from '\n'?++isSpaceNotNewline :: Char -> Bool+isSpaceNotNewline c = isSpace c && c /= '\n'++-- | Replaces all forms of whitespace, except for new-line characters,+-- with spaces.++replaceSpaces :: Text -> Text+replaceSpaces = T.map (\c -> if isSpaceNotNewline c then ' ' else c)+++-- | If the `Token` consists of spaces, the internal column counter is advanced+--   by the length of the token. Otherwise, `moveColumnForToken` is a no-op.+moveColumnForToken :: Token -> LaTeX ()+moveColumnForToken Token{ text = t } = do+  unless (isSpaces t) do+    log MoveColumn t+    moveColumn =<< size t++-- | Merges 'columns' into 'columnsPrev', resets 'column' and+-- 'columns'++resetColumn :: LaTeX ()+resetColumn = modify $ \s ->+  s { column      = 0+    , columnsPrev = mergeCols (columns s) (columnsPrev s)+    , columns     = []+    }+  where+  -- Remove shadowed columns from old.+  mergeCols []         old = old+  mergeCols new@(n:ns) old = new ++ filter ((< leastNew) . columnColumn) old+    where+    leastNew = columnColumn (last1 n ns)++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.++registerColumn :: Kind -> LaTeX AlignmentColumn+registerColumn kind = do+  column    <- gets column+  codeBlock <- gets codeBlock+  colKind   <- case kind of+                 Alignment   -> return Nothing+                 Indentation -> do+                   nextId <- gets nextId+                   modify $ \s -> s { nextId = succ nextId }+                   return (Just nextId)+  let c = AlignmentColumn { columnColumn    = column+                          , columnCodeBlock = codeBlock+                          , columnKind      = colKind+                          }+  modify $ \s -> s { columns = c : columns s }+  return c++-- | Registers the given column as used (if it is an indentation+-- column).++useColumn :: AlignmentColumn -> LaTeX ()+useColumn c = whenJust (columnKind c) $ \ i ->+  modify $ \ s -> s { usedColumns = Set.insert i (usedColumns s) }++-- | Alignment column zero in the current code block.++columnZero :: LaTeX AlignmentColumn+columnZero = do+  codeBlock <- gets codeBlock+  return $ AlignmentColumn { columnColumn    = 0+                           , columnCodeBlock = codeBlock+                           , columnKind      = Nothing+                           }++-- | Registers column zero as an alignment column.++registerColumnZero :: LaTeX ()+registerColumnZero = do+  c <- columnZero+  modify $ \s -> s { columns = [c] }++-- | Changes to the state that are performed at the start of a code+-- block.++enterCode :: LaTeX ()+enterCode = do+  resetColumn+  modify $ \s -> s { codeBlock = codeBlock s + 1 }++-- | Changes to the state that are performed at the end of a code+-- block.++leaveCode :: LaTeX ()+leaveCode = return ()++tshow :: Show a => a -> Text+tshow = T.pack . show++logMsgToText :: LogMessage -> Text+logMsgToText (LogMessage messageLabel text extra) = T.concat $+  [ tshow messageLabel, ": '", text, "' "+  ] ++ if null extra then [] else ["(", T.unwords extra, ")"]++logHelper :: Debug -> Text -> [Text] -> LaTeX ()+logHelper debug text extra = do+  logLevels <- debugs <$> ask+  when (debug `elem` logLevels) $ do+    lift $ logLaTeX (LogMessage debug text extra)++log :: Debug -> Text -> LaTeX ()+log MoveColumn text = do+  cols <- gets columns+  logHelper MoveColumn text ["columns=", tshow cols]+log Code text = do+  cols <- gets columns+  col <- gets column+  logHelper Code text ["columns=", tshow cols, "col=", tshow col]+log debug text = logHelper debug text []++output :: MonadLogLaTeX m => Output -> LaTeXT m ()+output item = do+  log Output $ tshow item+  tell [item]++------------------------------------------------------------------------+-- * LaTeX and polytable strings.++-- Polytable, http://www.ctan.org/pkg/polytable, is used for code+-- alignment, similar to lhs2TeX's approach.++nl :: Text+nl = "%\n"++-- | A command that is used when two tokens are put next to each other+-- in the same column.++agdaSpace :: Text+agdaSpace = cmdPrefix <> "Space" <> cmdArg T.empty <> nl++-- | The column's name.+--+-- Indentation columns have unique names, distinct from all alignment+-- column names.++columnName :: AlignmentColumn -> Text+columnName c = T.pack $ case columnKind c of+  Nothing -> show (columnColumn c)+  Just i  -> show i ++ "I"++-- | Opens a column with the given name.++ptOpen' :: Text -> Text+ptOpen' name = "\\>[" <> name <> "]"++-- | Opens the given column.++ptOpen :: AlignmentColumn -> Text+ptOpen c = ptOpen' (columnName c)++-- | Opens a special column that is only used at the beginning of+-- lines.++ptOpenBeginningOfLine :: Text+ptOpenBeginningOfLine = ptOpen' "." <> "[@{}l@{}]"++-- | Opens the given column, and inserts an indentation instruction+-- with the given argument at the end of it.++ptOpenIndent+  :: AlignmentColumn+  -> Int              -- ^ Indentation instruction argument.+  -> Text+ptOpenIndent c delta =+  ptOpen c <> "[@{}l@{"+           <> cmdPrefix+           <> "Indent"+           <> cmdArg (T.pack $ show delta)+           <> "}]"++ptClose :: Text+ptClose = "\\<"++ptClose' :: AlignmentColumn -> Text+ptClose' c =+  ptClose <> "[" <> columnName c <> "]"++ptNL :: Text+ptNL = nl <> "\\\\\n"++ptEmptyLine :: Text+ptEmptyLine =+  nl <> "\\\\["+     <> cmdPrefix+     <> "EmptyExtraSkip"+     <> "]%\n"++cmdPrefix :: Text+cmdPrefix = "\\Agda"++cmdArg :: Text -> Text+cmdArg x = "{" <> x <> "}"++------------------------------------------------------------------------+-- * Output generation from a stream of labelled tokens.++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 :: MonadLogLaTeX m => Tokens -> LaTeXT m ()+processMarkup = mapM_ \ t -> do+  moveColumnForToken t+  output $ Text $ text t++-- | Deals with literate text, which is output verbatim+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.+processCode :: Tokens -> LaTeX ()+processCode toks' = do+  output $ Text nl+  enterCode+  mapM_ go toks'+  ptOpenWhenColumnZero =<< gets column+  output $ Text $ ptClose <> nl+  leaveCode++  where+    go tok'@Token{ text = tok } = do+      -- Get the column information before grabbing the token, since+      -- grabbing (possibly) moves the column.+      col  <- gets column++      moveColumnForToken tok'+      log Code tok++      unless (T.null tok) $+        if (isSpaces tok) then do+            spaces $ T.group $ replaceSpaces tok+        else do+          ptOpenWhenColumnZero col+          output $ Text $+            -- we return the escaped token wrapped in commands corresponding+            -- to its aspect (if any) and other aspects (e.g. error, unsolved meta)+            foldr (\c t -> cmdPrefix <> T.pack c <> cmdArg t)+                  (escape tok)+                  $ map fromOtherAspect (toList $ otherAspects $ info tok') +++                    concatMap fromAspect (toList $ aspect $ info tok')++    -- Non-whitespace tokens at the start of a line trigger an+    -- alignment column.+    ptOpenWhenColumnZero col =+        when (col == 0) $ do+          registerColumnZero+          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)+    fromOtherAspect :: OtherAspect -> String+    fromOtherAspect = show++    fromAspect :: Aspect -> [String]+    fromAspect a = let s = [show a] in case a of+      Comment           -> s+      Keyword           -> s+      Hole              -> s+      String            -> s+      Number            -> s+      Symbol            -> s+      PrimitiveType     -> s+      Pragma            -> s+      Background        -> s+      Markup            -> s+      Name Nothing isOp -> fromAspect (Name (Just Postulate) isOp)+        -- At the time of writing the case above can be encountered in+        -- --only-scope-checking mode, for instance for the token "Size"+        -- in the following code:+        --+        --   {-# BUILTIN SIZE Size #-}+        --+        -- The choice of "Postulate" works for this example, but might+        -- be less appropriate for others.+      Name (Just kind) isOp ->+        (\c -> if isOp then ["Operator", c] else [c]) $+        case kind of+          Bound                     -> sk+          Generalizable             -> sk+          Constructor Inductive     -> "InductiveConstructor"+          Constructor CoInductive   -> "CoinductiveConstructor"+          Datatype                  -> sk+          Field                     -> sk+          Function                  -> sk+          Module                    -> sk+          Postulate                 -> sk+          Primitive                 -> sk+          Record                    -> sk+          Argument                  -> sk+          Macro                     -> sk+        where+        sk = show kind++-- | Escapes special characters.+escape :: Text -> Text+escape (T.uncons -> Nothing)     = T.empty+escape (T.uncons -> Just (c, s)) = T.pack (replace c) <> escape s+  where+  replace :: Char -> String+  replace char = case char of+    '_'  -> "\\AgdaUnderscore{}"+    '{'  -> "\\{"+    '}'  -> "\\}"+    '#'  -> "\\#"+    '$'  -> "\\$"+    '&'  -> "\\&"+    '%'  -> "\\%"+    '~'  -> "\\textasciitilde{}"+    '^'  -> "\\textasciicircum{}"+    '\\' -> "\\textbackslash{}"+    ' '  -> "\\ "+    _    -> [ char ]+#if __GLASGOW_HASKELL__ < 810+escape _                         = __IMPOSSIBLE__+#endif++-- | Every element in the list should consist of either one or more+-- newline characters, or one or more space characters. Two adjacent+-- list elements must not contain the same character.+--+-- If the final element of the list consists of spaces, then these+-- spaces are assumed to not be trailing whitespace.+spaces :: [Text] -> LaTeX ()+spaces [] = return ()++-- Newlines.+spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do+  col <- gets column+  when (col == 0) do+    output . Text . ptOpen =<< columnZero+  output $ Text $ ptClose <> ptNL <>+                  T.replicate (T.length s - 1) ptEmptyLine+  resetColumn+  spaces ss++-- Spaces followed by a newline character.+spaces (_ : ss@(_ : _)) = spaces ss++-- Spaces that are not followed by a newline character.+spaces [ s ] = do+  col <- gets column++  let len  = T.length s+      kind = if col /= 0 && len == 1+             then Indentation+             else Alignment++  moveColumn len+  column <- registerColumn kind++  if col /= 0+  then log Spaces "col /= 0"+  else do+    columns    <- gets columnsPrev+    codeBlock  <- gets codeBlock++    log Spaces $+      "col == 0: " <> T.pack (show (len, columns))++    case filter ((<= len) . columnColumn) columns of+      c : _ | columnColumn c == len, isJust (columnKind c) -> do+        -- Align. (This happens automatically if the column is an+        -- alignment column, but c is an indentation column.)+        useColumn c+        output $ Text $ ptOpenBeginningOfLine+        output $ Text $ ptClose' c+      c : _ | columnColumn c <  len -> do+        -- Indent.+        useColumn c+        output $ Text $ ptOpenIndent c (codeBlock - columnCodeBlock c)+      _ -> return ()++  output $ MaybeColumn column++-- | Split multi-lines string literals into multiple string literals+-- Isolating leading spaces for the alignment machinery to work+-- properly+stringLiteral :: Token -> Tokens+stringLiteral t | aspect (info t) == Just String =+  map (\ x -> t { text = x })+          $ concatMap leadingSpaces+          $ List.intersperse "\n"+          $ T.lines (text t)+  where+  leadingSpaces :: Text -> [Text]+  leadingSpaces tok = [pre, suf]+    where (pre , suf) = T.span isSpaceNotNewline tok++stringLiteral t = [t]++-- | Split multi-line comments into several tokens.+-- See issue #5398.+multiLineComment :: Token -> Tokens+multiLineComment Token{ text = s, info = i } | aspect i == Just Comment =+  map (`Token` i)+    $ List.intersperse "\n"+    $ T.lines s+-- multiLineComment Token{ text = s, info = i } | aspect i == Just Comment =+--   map emptyToPar+--     $ List1.groupBy ((==) `on` T.null)+--     $ T.lines s+--   where+--   emptyToPar :: List1 Text -> Token+--   emptyToPar ts@(t :| _)+--     | T.null t  = Token{ text = "\n", info = mempty }+--     | otherwise = Token{ text = sconcat $ List1.intersperse "\n" ts, info = i }+multiLineComment t = [t]++------------------------------------------------------------------------+-- * Main.++-- | The Agda data directory containing the files for the LaTeX backend.++latexDataDir :: FilePath+latexDataDir = "latex"++defaultStyFile :: String+defaultStyFile = "agda.sty"++data LaTeXOptions = LaTeXOptions+  { latexOptOutDir         :: FilePath+  , 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.+    -- This is a "nice-to-have" parameter.+  , latexOptCountClusters  :: Bool+    -- ^ Count extended grapheme clusters rather than code points when+    -- generating LaTeX.+  }++getTextWidthEstimator :: Bool -> TextWidthEstimator+getTextWidthEstimator _countClusters =+#ifdef COUNT_CLUSTERS+  if _countClusters+    then length . (ICU.breaks (ICU.breakCharacter ICU.Root))+    else T.length+#else+  T.length+#endif++-- | Create the common base output directory and check for/install the style file.+prepareCommonAssets :: (MonadLogLaTeX m, MonadIO m) => FilePath -> m ()+prepareCommonAssets dir = do+  -- 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"+        (applyWhen dirExisted (("--path=" ++ 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 (iTopLevelModuleName i)+  latex <- E.encodeUtf8 <$> toLaTeX+              (emptyEnv textWidthEstimator)+              (latexOptSourceFileName opts)+              (iSource i)+              (iHighlighting i)+  liftIO $ do+    createDirectoryIfMissing True (takeDirectory outPath)+    BS.writeFile outPath latex++latexOutRelativeFilePath :: TopLevelModuleName -> FilePath+latexOutRelativeFilePath m =+  List.intercalate [pathSeparator]+    (map T.unpack $ List1.toList $ moduleNameParts m) <.>+  "tex"++-- | Transforms the source code into LaTeX.+toLaTeX+  :: MonadLogLaTeX m+  => Env+  -> Maybe RangeFile+  -> L.Text+  -> HighlightingInfo+  -> m L.Text+toLaTeX env path source hi =++  processTokens env++    . map+      ( ( \(role, tokens) ->+            (role,) $+              -- This bit fixes issue 954+              ( applyWhen (L.isCode role) $+                  -- Remove trailing whitespace from the+                  -- final line; the function spaces+                  -- expects trailing whitespace to be+                  -- followed by a newline character.+                    whenMoreThanOne+                      ( updateLast+                          $ withTokenText+                          $ \suf ->+                            maybe+                              suf+                              (T.dropWhileEnd isSpaceNotNewline)+                              (T.stripSuffix "\n" suf)+                      )+                      . updateLast (withTokenText $ T.dropWhileEnd isSpaceNotNewline)+                      . updateHead+                        ( withTokenText $+                            \pre ->+                              fromMaybe pre $ T.stripPrefix "\n" $+                                T.dropWhile+                                  isSpaceNotNewline+                                  pre+                        )+              )+                tokens+        ) . ( second+                ( -- Split tokens at newlines+                  concatMap stringLiteral+                . concatMap multiLineComment+                . List1.toList+                . fmap (\ (mi, cs) -> Token+                        { text = T.pack $ List1.toList cs+                        , info = fromMaybe mempty mi+                        }+                      )+                . List1.groupByFst1+                )+            )+      )+    . List1.groupByFst++    -- 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++  whenMoreThanOne :: ([a] -> [a]) -> [a] -> [a]+  whenMoreThanOne f xs@(_:_:_) = f xs+  whenMoreThanOne _ xs         = xs+++processTokens+  :: MonadLogLaTeX m+  => Env+  -> [(LayerRole, Tokens)]+  -> m L.Text+processTokens env ts = do+  ((), s, os) <- runLaTeX (processLayers ts) env emptyState+  return $ L.fromChunks $ map (render s) os+  where+    render _ (Text s)        = s+    render s (MaybeColumn c)+      | Just i <- columnKind c,+        not (i `Set.member` usedColumns s) = agdaSpace+      | otherwise                          = nl <> ptOpen c
src/full/Agda/Interaction/Highlighting/Precise.hs view
@@ -1,355 +1,323 @@-{-# LANGUAGE DeriveDataTypeable #-}- -- | Types used for precise syntax highlighting.  module Agda.Interaction.Highlighting.Precise-  ( -- * Files+  ( -- * Highlighting information     Aspect(..)   , NameKind(..)   , OtherAspect(..)   , Aspects(..)-  , File(..)+  , DefinitionSite(..)+  , TokenBased(..)+  , RangePair(..)+  , rangePairInvariant+  , PositionMap(..)+  , DelayedMerge(..)+  , delayedMergeInvariant   , HighlightingInfo-    -- ** Creation-  , singleton-  , several-    -- ** Merging-  , merge-    -- ** Inspection-  , smallestPos-  , toMap-    -- * Compressed files-  , CompressedFile(..)-  , compressedFileInvariant-  , compress-  , decompress-  , noHighlightingInRange-    -- ** Creation-  , singletonC-  , severalC-  , splitAtC-  , selectC-    -- ** Inspection-  , smallestPosC-    -- ** Merge-  , mergeC+  , highlightingInfoInvariant+  , HighlightingInfoBuilder+  , highlightingInfoBuilderInvariant+    -- ** Operations+  , parserBased+  , kindOfNameToNameKind+  , IsBasicRangeMap(..)+  , RangeMap.several+  , Convert(..)+  , RangeMap.insideAndOutside+  , RangeMap.restrictTo   ) where -import Agda.Utils.String-import Agda.Utils.List-import Data.Maybe-import Data.List-import Data.Function+import Prelude hiding (null)++import Control.DeepSeq++import Data.Function (on) import Data.Semigroup-import Control.Applicative ((<$>), (<*>))-import Control.Arrow (second)-import Control.Monad+ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Typeable (Typeable)+import Data.Set (Set)+import qualified Data.Set as Set -import qualified Agda.Syntax.Position as P-import qualified Agda.Syntax.Common as Common-import qualified Agda.Syntax.Concrete as SC+import GHC.Generics (Generic) +import qualified Agda.Syntax.Common   as Common+import Agda.Syntax.TopLevelModuleName+import Agda.Syntax.Scope.Base                   ( KindOfName(..) )+ import Agda.Interaction.Highlighting.Range ---------------------------------------------------------------------------- Files+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 --- | Syntactic aspects of the code. (These cannot overlap.)---   They can be obtained from the lexed tokens already,---   except for the 'NameKind'.+import Agda.Syntax.Common.Aspect+import Agda.Utils.String -data Aspect-  = Comment-  | Keyword-  | String-  | Number-  | Symbol                     -- ^ Symbols like forall, =, ->, etc.-  | PrimitiveType              -- ^ Things like Set and Prop.-  | Name (Maybe NameKind) Bool -- ^ Is the name an operator part?-    deriving (Eq, Show, Typeable)+import Agda.Utils.Impossible --- | @NameKind@s are figured our during scope checking.+-- | A limited kind of syntax highlighting information: a pair+-- consisting of 'Ranges' and 'Aspects'.+--+-- Note the invariant which 'RangePair's should satisfy+-- ('rangePairInvariant'). -data NameKind-  = Bound                         -- ^ Bound variable.-  | 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, Typeable)+newtype RangePair = RangePair+  { rangePair :: (Ranges, Aspects)+  }+  deriving (Show, NFData) --- | Other aspects, generated by type checking.---   (These can overlap with each other and with 'Aspect's.)+-- | Invariant for 'RangePair'. -data OtherAspect-  = Error-  | DottedPattern-  | UnsolvedMeta-  | UnsolvedConstraint-    -- ^ Unsolved constraint not connected to meta-variable. This-    -- could for instance be an emptyness constraint.-  | TerminationProblem-  | PositivityProblem-  | 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.-    deriving (Eq, Show, Enum, Bounded, Typeable)+rangePairInvariant :: RangePair -> Bool+rangePairInvariant (RangePair (rs, _)) =+  rangesInvariant rs --- | Meta information which can be associated with a--- character\/character range.+-- | Syntax highlighting information, represented by maps from+-- positions to 'Aspects'.+--+-- The first position in the file has number 1. -data Aspects = Aspects-  { aspect       :: Maybe Aspect-  , otherAspects :: [OtherAspect]-  , note         :: Maybe String-    -- ^ This note, if present, 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 (SC.TopLevelModuleName, Int)-    -- ^ The definition site of the annotated thing, if applicable and-    --   known. File positions are counted from 1.+newtype PositionMap = PositionMap+  { positionMap :: IntMap Aspects   }-  deriving (Show, Typeable)+  deriving (Show, NFData) -instance Eq Aspects where-  Aspects a o _ d == Aspects a' o' _ d' = (a, nub o, d) == (a', nub o', d')+-- | Highlighting info with delayed merging.+--+-- Merging large sets of highlighting info repeatedly might be costly.+-- The idea of this type is to accumulate small pieces of highlighting+-- information, and then to merge them all at the end.+--+-- Note the invariant which values of this type should satisfy+-- ('delayedMergeInvariant'). --- | A 'File' is a mapping from file positions to meta information.+newtype DelayedMerge hl = DelayedMerge (Endo [hl])+  deriving (Semigroup, Monoid)++instance Show hl => Show (DelayedMerge hl) where+  showsPrec _ (DelayedMerge f) =+    showString "DelayedMerge (Endo (" .+    shows (appEndo f []) .+    showString " ++))"++-- | Invariant for @'DelayedMerge' hl@, parametrised by the invariant+-- for @hl@. ----- The first position in the file has number 1.+-- Additionally the endofunction should be extensionally equal to @(fs+-- '++')@ for some list @fs@. -newtype File = File { mapping :: IntMap Aspects }-  deriving (Eq, Show, Typeable)+delayedMergeInvariant :: (hl -> Bool) -> DelayedMerge hl -> Bool+delayedMergeInvariant inv (DelayedMerge f) =+  all inv (appEndo f []) --- | Syntax highlighting information.+-- | Highlighting information.+--+-- Note the invariant which values of this type should satisfy+-- ('highlightingInfoInvariant').+--+-- This is a type synonym in order to make it easy to change to+-- another representation. -type HighlightingInfo = CompressedFile+type HighlightingInfo = RangeMap Aspects ---------------------------------------------------------------------------- Creation+-- | The invariant for 'HighlightingInfo'. --- | @'singleton' rs m@ is a file whose positions are those in @rs@,--- and in which every position is associated with @m@.+highlightingInfoInvariant :: HighlightingInfo -> Bool+highlightingInfoInvariant = RangeMap.rangeMapInvariant -singleton :: Ranges -> Aspects -> File-singleton rs m = File {- mapping = IntMap.fromAscList [ (p, m) | p <- rangesToPositions rs ] }+-- | A type that is intended to be used when constructing highlighting+-- information.+--+-- Note the invariant which values of this type should satisfy+-- ('highlightingInfoBuilderInvariant').+--+-- This is a type synonym in order to make it easy to change to+-- another representation.+--+-- The type should be an instance of @'IsBasicRangeMap' 'Aspects'@,+-- 'Semigroup' and 'Monoid', and there should be an instance of+-- @'Convert' 'HighlightingInfoBuilder' 'HighlightingInfo'@. --- | Like 'singleton', but with several 'Ranges' instead of only one.+type HighlightingInfoBuilder = DelayedMerge RangePair -several :: [Ranges] -> Aspects -> File-several rs m = mconcat $ map (\r -> singleton r m) rs+-- | The invariant for 'HighlightingInfoBuilder'.+--+-- Additionally the endofunction should be extensionally equal to @(fs+-- '++')@ for some list @fs@. +highlightingInfoBuilderInvariant :: HighlightingInfoBuilder -> Bool+highlightingInfoBuilderInvariant =+  delayedMergeInvariant rangePairInvariant+ --------------------------------------------------------------------------- Merging+-- Creation and conversion --- | Merges meta information.+-- | A variant of 'mempty' with 'tokenBased' set to+-- 'NotOnlyTokenBased'. -mergeAspects :: Aspects -> Aspects -> Aspects-mergeAspects m1 m2 = Aspects-  { aspect       = (mplus `on` aspect) m1 m2-  , otherAspects = nub $ ((++) `on` otherAspects) m1 m2-  , note         = case (note m1, note m2) of-      (Just n1, Just n2) -> Just $-         if n1 == n2-           then n1-           else addFinalNewLine n1 ++ "----\n" ++ n2-      (Just n1, Nothing) -> Just n1-      (Nothing, Just n2) -> Just n2-      (Nothing, Nothing) -> Nothing-  , definitionSite = (mplus `on` definitionSite) m1 m2-  }+parserBased :: Aspects+parserBased = mempty { tokenBased = NotOnlyTokenBased } -instance Semigroup Aspects where-  (<>) = mergeAspects+-- | Conversion from classification of the scope checker. -instance Monoid Aspects where-  mempty = Aspects-    { aspect         = Nothing-    , otherAspects   = []-    , note           = Nothing-    , definitionSite = Nothing-    }-  mappend = (<>)+kindOfNameToNameKind :: KindOfName -> NameKind+kindOfNameToNameKind = \case+  -- Inductive is Constructor default, overwritten by CoInductive+  ConName                  -> Constructor Common.Inductive+  CoConName                -> Constructor Common.CoInductive+  FldName                  -> Field+  PatternSynName           -> Constructor Common.Inductive+  GeneralizeName           -> Generalizable+  DisallowedGeneralizeName -> Generalizable+  MacroName                -> Macro+  QuotableName             -> Function+  DataName                 -> Datatype+  RecName                  -> Record+  FunName                  -> Function+  AxiomName                -> Postulate+  PrimName                 -> Primitive+  OtherDefName             -> Function --- | Merges files.+instance IsBasicRangeMap Aspects RangePair where+  singleton rs m = RangePair (rs, m) -merge :: File -> File -> File-merge f1 f2 =-  File { mapping = (IntMap.unionWith mappend `on` mapping) f1 f2 }+  toList (RangePair (Ranges rs, m)) =+    [ (r, m) | r <- rs, not (null r) ] -instance Semigroup File where-  (<>) = merge+  toMap f = toMap (convert (DelayedMerge (Endo (f :))) :: PositionMap) -instance Monoid File where-  mempty  = File { mapping = IntMap.empty }-  mappend = (<>)+instance IsBasicRangeMap Aspects PositionMap where+  singleton rs m = PositionMap+    { positionMap =+      IntMap.fromDistinctAscList [ (p, m) | p <- rangesToPositions rs ]+    } ---------------------------------------------------------------------------- Inspection+  toList = map join . List1.groupBy' p . IntMap.toAscList . positionMap+    where+    p (pos1, m1) (pos2, m2) = pos2 == pos1 + 1 && m1 == m2+    join pms = ( Range { from = List1.head ps, to = List1.last ps + 1 }+               , List1.head ms+               )+      where (ps, ms) = List1.unzip pms --- | Returns the smallest position, if any, in the 'File'.+  toMap = positionMap -smallestPos :: File -> Maybe Int-smallestPos = fmap (fst . fst) . IntMap.minViewWithKey . mapping+instance Semigroup a =>+         IsBasicRangeMap a (DelayedMerge (RangeMap a)) where+  singleton r m = DelayedMerge (Endo (singleton r m :)) --- | Convert the 'File' to a map from file positions (counting from 1)--- to meta information.+  toMap  f = toMap  (convert f :: RangeMap a)+  toList f = toList (convert f :: RangeMap a) -toMap :: File -> IntMap Aspects-toMap = mapping+instance IsBasicRangeMap Aspects (DelayedMerge RangePair) where+  singleton r m = DelayedMerge (Endo (singleton r m :)) ---------------------------------------------------------------------------- Compressed files+  toMap  f = toMap  (convert f :: PositionMap)+  toList f = toList (convert f :: RangeMap Aspects) --- | A compressed 'File', in which consecutive positions with the same--- 'Aspects' are stored together.+instance IsBasicRangeMap Aspects (DelayedMerge PositionMap) where+  singleton r m = DelayedMerge (Endo (singleton r m :)) -newtype CompressedFile =-  CompressedFile { ranges :: [(Range, Aspects)] }-  deriving (Eq, Show, Typeable)+  toMap  f = toMap  (convert f :: PositionMap)+  toList f = toList (convert f :: PositionMap) --- | Invariant for compressed files.------ Note that these files are not required to be /maximally/--- compressed, because ranges are allowed to be empty, and the--- 'Aspects's in adjacent ranges are allowed to be equal.+-- | Conversion between different types. -compressedFileInvariant :: CompressedFile -> Bool-compressedFileInvariant (CompressedFile []) = True-compressedFileInvariant (CompressedFile f)  =-  all rangeInvariant rs &&-  all (not . empty) rs &&-  and (zipWith (<=) (map to $ init rs) (map from $ tail rs))-  where rs = map fst f+class Convert a b where+  convert :: a -> b --- | Compresses a file by merging consecutive positions with equal--- meta information into longer ranges.+instance Monoid hl => Convert (DelayedMerge hl) hl where+  convert (DelayedMerge f) = mconcat (appEndo f []) -compress :: File -> CompressedFile-compress f =-  CompressedFile $ map join $ groupBy' p (IntMap.toAscList $ mapping f)-  where-  p (pos1, m1) (pos2, m2) = pos2 == pos1 + 1 && m1 == m2-  join pms = ( Range { from = head ps, to = last ps + 1 }-             , head ms-             )-    where (ps, ms) = unzip pms+instance Convert (RangeMap Aspects) (RangeMap Aspects) where+  convert = id --- | Decompresses a compressed file.+instance Convert PositionMap (RangeMap Aspects) where+  convert =+    RangeMap.fromNonOverlappingNonEmptyAscendingList .+    toList -decompress :: CompressedFile -> File-decompress =-  File .-  IntMap.fromList .-  concat .-  map (\(r, m) -> [ (p, m) | p <- rangeToPositions r ]) .-  ranges+instance Convert (DelayedMerge PositionMap) (RangeMap Aspects) where+  convert f = convert (convert f :: PositionMap) --- | Clear any highlighting info for the given ranges. Used to make sure---   unsolved meta highlighting overrides error highlighting.-noHighlightingInRange :: Ranges -> CompressedFile -> CompressedFile-noHighlightingInRange rs (CompressedFile hs) =-    CompressedFile $ concatMap clear hs-  where-    clear (r, i) =-      case minus (Ranges [r]) rs of-        Ranges [] -> []-        Ranges rs -> [ (r, i) | r <- rs ]+instance Convert (DelayedMerge RangePair) PositionMap where+  convert (DelayedMerge f) =+    PositionMap $+    IntMap.fromListWith (flip (<>))+      [ (p, m)+      | RangePair (r, m) <- appEndo f []+      , p                <- rangesToPositions r+      ] +instance Convert (DelayedMerge RangePair) (RangeMap Aspects) where+  convert (DelayedMerge f) =+    mconcat+      [ singleton r m+      | RangePair (r, m) <- appEndo f []+      ]+ --------------------------------------------------------------------------- Operations that work directly with compressed files+-- Merging --- | @'singletonC' rs m@ is a file whose positions are those in @rs@,--- and in which every position is associated with @m@.+instance Semigroup TokenBased where+  b1@NotOnlyTokenBased <> b2 = b1+  TokenBased           <> b2 = b2 -singletonC :: Ranges -> Aspects -> CompressedFile-singletonC (Ranges rs) m =-  CompressedFile [(r, m) | r <- rs, not (empty r)]+instance Monoid TokenBased where+  mempty  = TokenBased+  mappend = (<>) --- | Like 'singletonR', but with a list of 'Ranges' instead of a--- single one. -severalC :: [Ranges] -> Aspects -> CompressedFile-severalC rss m = mconcat $ map (\rs -> singletonC rs m) rss---- | Merges compressed files.+instance Semigroup DefinitionSite where+  d1 <> d2 | d1 == d2  = d1+           | otherwise = d1 -- TODO: __IMPOSSIBLE__ -mergeC :: CompressedFile -> CompressedFile -> CompressedFile-mergeC (CompressedFile f1) (CompressedFile f2) =-  CompressedFile (mrg f1 f2)-  where-  mrg []             f2             = f2-  mrg f1             []             = f1-  mrg (p1@(i1,_):f1) (p2@(i2,_):f2)-    | to i1 <= from i2 = p1 : mrg f1      (p2:f2)-    | to i2 <= from i1 = p2 : mrg (p1:f1) f2-    | to i1 <= to i2   = ps1 ++ mrg f1 (ps2 ++ f2)-    | otherwise        = ps1 ++ mrg (ps2 ++ f1) f2-      where (ps1, ps2) = fuse p1 p2+-- | Merges meta information. -  -- Precondition: The ranges are overlapping.-  fuse (i1, m1) (i2, m2) =-    ( fix [ (Range { from = a, to = b }, ma)-          , (Range { from = b, to = c }, mergeAspects m1 m2)-          ]-    , fix [ (Range { from = c, to = d }, md)-          ]-    )-    where-    [(a, ma), (b, _), (c, _), (d, md)] =-      sortBy (compare `on` fst)-             [(from i1, m1), (to i1, m1), (from i2, m2), (to i2, m2)]-    fix = filter (not . empty . fst)+mergeAspects :: Aspects -> Aspects -> Aspects+mergeAspects m1 m2 = Aspects+  { aspect       = (unionMaybeWith (<>) `on` aspect) m1 m2+  , otherAspects = (Set.union `on` otherAspects) m1 m2+  , note         = case (note m1, note m2) of+      (n1, "") -> n1+      ("", n2) -> n2+      (n1, n2)+        | n1 == n2  -> n1+        | otherwise -> addFinalNewLine n1 ++ "----\n" ++ n2+  , definitionSite = (unionMaybeWith (<>) `on` definitionSite) m1 m2+  , tokenBased     = tokenBased m1 <> tokenBased m2+  } -instance Semigroup CompressedFile where-  (<>) = mergeC+instance Semigroup Aspects where+  (<>) = mergeAspects -instance Monoid CompressedFile where-  mempty  = CompressedFile []+instance Monoid Aspects where+  mempty = Aspects+    { aspect         = Nothing+    , otherAspects   = Set.empty+    , note           = []+    , definitionSite = Nothing+    , tokenBased     = mempty+    }   mappend = (<>) --- | @splitAtC p f@ splits the compressed file @f@ into @(f1, f2)@,--- where all the positions in @f1@ are @< p@, and all the positions--- in @f2@ are @>= p@.--splitAtC :: Int -> CompressedFile ->-            (CompressedFile, CompressedFile)-splitAtC p f = (CompressedFile f1, CompressedFile f2)-  where-  (f1, f2) = split $ ranges f--  split [] = ([], [])-  split (rx@(r,x) : f)-    | p <= from r = ([], rx:f)-    | to r <= p   = (rx:f1, f2)-    | otherwise   = ([ (toP, x) ], (fromP, x) : f)-    where (f1, f2) = split f-          toP      = Range { from = from r, to = p    }-          fromP    = Range { from = p,      to = to r }+instance Semigroup PositionMap where+  f1 <> f2 = PositionMap+    { positionMap = (IntMap.unionWith mappend `on` positionMap) f1 f2 } -selectC :: P.Range -> CompressedFile -> CompressedFile-selectC r cf = cf'-  where-    empty         = (0,0)-    (from, to)    = fromMaybe empty (rangeToEndPoints r)-    (_, (cf', _)) = (second (splitAtC to)) . splitAtC from $ cf+instance Monoid PositionMap where+  mempty  = PositionMap { positionMap = IntMap.empty }+  mappend = (<>) +------------------------------------------------------------------------+-- NFData instances --- | Returns the smallest position, if any, in the 'CompressedFile'.+instance NFData Aspect+instance NFData OtherAspect+instance NFData DefinitionSite -smallestPosC :: CompressedFile -> Maybe Int-smallestPosC (CompressedFile [])           = Nothing-smallestPosC (CompressedFile ((r, _) : _)) = Just (from r)+instance NFData Aspects where+  rnf (Aspects a b c d _) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
src/full/Agda/Interaction/Highlighting/Range.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}  -- | Ranges. @@ -8,20 +7,24 @@   , Ranges(..)   , rangesInvariant   , overlapping+  , overlappings   , empty   , rangeToPositions   , rangesToPositions   , rToR-  , rangeToEndPoints+  , rangeToRange   , minus   ) where -import Control.Applicative ((<$>))-import Data.List-import Data.Typeable (Typeable)+import Prelude hiding (null) +import Control.DeepSeq+ import qualified Agda.Syntax.Position as P+ import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Null  -- | Character ranges. The first character in the file has position 1. -- Note that the 'to' position is considered to be outside of the@@ -29,9 +32,16 @@ -- -- Invariant: @'from' '<=' 'to'@. -data Range = Range { from, to :: Int }-             deriving (Eq, Ord, Show, Typeable)+data Range = Range { from, to :: !Int }+             deriving (Eq, Ord, Show) +instance Null Range where+  empty  = Range 0 0+  null r = to r <= from r++instance NFData Range where+  rnf (Range _ _) = ()+ -- | The 'Range' invariant.  rangeInvariant :: Range -> Bool@@ -40,14 +50,12 @@ -- | Zero or more consecutive and separated ranges.  newtype Ranges = Ranges [Range]-  deriving (Eq, Show)+  deriving (Eq, Show, NFData)  -- | 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@@ -57,13 +65,15 @@ -- The ranges are assumed to be well-formed.  overlapping :: Range -> Range -> Bool-overlapping r1 r2 = not $-  to r1 <= from r2 || to r2 <= from r1+overlapping r1 r2 = not (r1 `isLeftOf` r2) && not (r2 `isLeftOf` r1) --- | 'True' iff the range is empty.+isLeftOf :: Range -> Range -> Bool+isLeftOf r1 r2 = to r1 <= from r2 -empty :: Range -> Bool-empty r = to r <= from r+overlappings :: Ranges -> Ranges -> Bool+-- specification: overlappings (Ranges r1s) (Ranges r2s) = or [ overlapping r1 r2 | r1 <- r1s, r2 <- r2s ]+overlappings (Ranges r1s) (Ranges r2s) =+  isNothing $ mergeStrictlyOrderedBy isLeftOf r1s r2s  ------------------------------------------------------------------------ -- Conversion@@ -83,17 +93,19 @@ 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 } -rangeToEndPoints :: P.Range -> Maybe (Int,Int)-rangeToEndPoints r =+-- | Converts a 'P.Range', seen as a continuous range, to a 'Range'.++rangeToRange :: P.Range -> Range+rangeToRange r =   case P.rangeToInterval r of-          Nothing -> Nothing-          Just i  -> Just ( fromIntegral $ P.posPos $ P.iStart i-                          , fromIntegral $ P.posPos $ P.iEnd i)+    Nothing -> Range { from = 0, to = 0 }+    Just (P.Interval _ s e) -> Range+      { from = fromIntegral $ P.posPos s+      , to   = fromIntegral $ P.posPos e+      }  ------------------------------------------------------------------------ -- Operations@@ -110,7 +122,7 @@   m []     _      = []   m xs     []     = xs   m (x:xs) (y:ys)-    | empty y         = m (x:xs) ys+    | null y          = m (x:xs) ys     | to x < from y   = x : m xs (y:ys)     | to y < from x   = m (x:xs) ys     | from x < from y = Range { from = from x, to = from y } :
src/full/Agda/Interaction/Highlighting/Vim.hs view
@@ -1,4 +1,4 @@--- {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Highlighting.Vim where @@ -7,6 +7,7 @@ import Data.Function ( on ) import qualified Data.List as List import qualified Data.Map as Map+import Data.Maybe  import System.FilePath @@ -16,8 +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.Syntax.Common.Pretty  vimFile :: FilePath -> FilePath vimFile file =@@ -27,6 +31,7 @@ escape :: String -> String escape = concatMap esc     where+        escchars :: String         escchars = "$\\^.*~[]"         esc c   | c `elem` escchars = ['\\',c]                 | otherwise         = [c]@@ -38,10 +43,13 @@ keyword _ [] = "" keyword cat ws  = "syn keyword " ++ unwords (cat : ws) -match :: String -> [String] -> String-match _ [] = ""-match cat ws    = "syn match " ++ cat ++ " \"" ++-                    concat (List.intersperse "\\|" $ map (wordBounded . escape) ws) ++ "\""+match :: String -> List1 String -> String+match cat (w :| ws) =+  "syn match "+    ++ cat+    ++ " \""+    ++ List.intercalate "\\|" (map (wordBounded . escape) $ w:ws)+    ++ "\""  matches :: [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] matches cons icons defs idefs flds iflds =@@ -53,33 +61,31 @@         icons' = foo "agdaInfixConstructor" $ classify length icons         defs'  = foo "agdaFunction"         $ classify length defs         idefs' = foo "agdaInfixFunction"    $ classify length idefs-        flds'  = foo "agdaProjection"       $ classify length flds-        iflds' = foo "agdaInfixProjection"  $ classify length iflds -        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, def:_) <- Map.toList ns, anameKind def == ConName ]-        defs = [ x | (x, def:_) <- Map.toList ns, anameKind def == DefName ]-        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 show cons-        mdefs = map show defs-        mflds = map show flds+        mcons = map prettyShow cons+        mdefs = map prettyShow defs+        mflds = map prettyShow flds          micons = concatMap parts cons         midefs = concatMap parts defs         miflds = concatMap parts flds -        parts (NoName _ _) = []-        parts (Name _ [_]) = []-        parts (Name _ ps)  = [ rawNameToString x | Id x <- ps ]+        parts n+          | isOperator n = map rawNameToString $ nameStringParts n+          | otherwise    = []  generateVimFile :: FilePath -> TCM () generateVimFile file = do
src/full/Agda/Interaction/Imports.hs view
@@ -1,950 +1,1461 @@-{-# LANGUAGE CPP               #-}--{-| This module deals with finding imported modules and loading their-    interface files.--}-module Agda.Interaction.Imports where--import Prelude hiding (null)--import Control.Arrow-import Control.DeepSeq-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Maybe-import qualified Control.Exception as E--#if __GLASGOW_HASKELL__ <= 708-import Data.Foldable ( Foldable )-import Data.Traversable ( Traversable, traverse )-#endif--import Data.Function (on)-import qualified Data.Map as Map-import qualified Data.List as List-import qualified Data.Set as Set-import qualified Data.Foldable as Fold (toList)-import Data.List hiding (null)-import Data.Maybe-import Data.Monoid (mempty, mappend)-import Data.Map (Map)-import Data.Set (Set)--import System.Directory (doesFileExist, getModificationTime, removeFile)-import System.FilePath ((</>))--import qualified Text.PrettyPrint.Boxes as Boxes--import Agda.Benchmarking--import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Abstract.Name-import Agda.Syntax.Parser-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import Agda.Syntax.Translation.ConcreteToAbstract-import Agda.Syntax.Internal--import Agda.TypeChecking.Errors-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.MetaVars ( openMetasToPostulates )-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Serialise-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Pretty as P-import Agda.TypeChecking.Rewriting (killCtxId)-import Agda.TypeChecking.DeadCode-import qualified Agda.TypeChecking.Monad.Benchmark as Bench--import Agda.TheTypeChecker--import Agda.Interaction.FindFile-import {-# SOURCE #-} Agda.Interaction.InteractionTop (showOpenMetas)-import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Lenses as Lens-import Agda.Interaction.Highlighting.Precise (HighlightingInfo)-import Agda.Interaction.Highlighting.Generate-import Agda.Interaction.Highlighting.Vim--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.FileName-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.IO.Binary-import Agda.Utils.Pretty-import Agda.Utils.Time-import Agda.Utils.Hash-import qualified Agda.Utils.HashMap as HMap-import qualified Agda.Utils.Trie as Trie--#include "undefined.h"-import Agda.Utils.Impossible---- | Are we loading the interface for the user-loaded file---   or for an import?-data MainInterface-  = MainInterface     -- ^ Interface for main file.-  | NotMainInterface  -- ^ Interface for imported file.-  deriving (Eq, Show)---- | Merge an interface into the current proof state.-mergeInterface :: Interface -> TCM ()-mergeInterface i = do-    let sig     = iSignature i-        builtin = Map.toList $ iBuiltin i-        prim    = [ x | (_,Prim x) <- builtin ]-        bi      = Map.fromList [ (x,Builtin t) | (x,Builtin t) <- builtin ]-    bs <- gets stBuiltinThings-    reportSLn "import.iface.merge" 10 $ "Merging interface"-    reportSLn "import.iface.merge" 20 $-      "  Current builtins " ++ show (Map.keys bs) ++ "\n" ++-      "  New builtins     " ++ show (Map.keys bi)-    let check b = case (b1, b2) of-            (Builtin x, Builtin y)-              | x == y    -> return ()-              | otherwise -> typeError $ DuplicateBuiltinBinding b x y-            _ -> __IMPOSSIBLE__-          where-            Just b1 = Map.lookup b bs-            Just b2 = Map.lookup b bi-    mapM_ check (map fst $ Map.toList $ Map.intersection bs bi)-    addImportedThings sig bi (iHaskellImports i) (iHaskellImportsUHC i) (iPatternSyns i) (iDisplayForms i)-    reportSLn "import.iface.merge" 20 $-      "  Rebinding primitives " ++ show prim-    mapM_ rebind prim-    where-        rebind (x, q) = do-            PrimImpl _ pf <- lookupPrimitiveFunction x-            stImportedBuiltins %= Map.insert x (Prim pf{ primFunName = q })--addImportedThings ::-  Signature -> BuiltinThings PrimFun ->-  Set String -> -- MAlonzo imoprts-  Set String -> -- UHC backend imports-  A.PatternSynDefns -> DisplayForms -> TCM ()-addImportedThings isig ibuiltin hsImports hsImportsUHC patsyns display = do-  stImports              %= \ imp -> unionSignatures [imp, over sigRewriteRules killCtxId isig]-  stImportedBuiltins     %= \ imp -> Map.union imp ibuiltin-  stHaskellImports       %= \ imp -> Set.union imp hsImports-  stHaskellImportsUHC    %= \ imp -> Set.union imp hsImportsUHC-  stPatternSynImports    %= \ imp -> Map.union imp patsyns-  stImportedDisplayForms %= \ imp -> HMap.unionWith (++) imp display-  addImportedInstances isig---- | Scope checks the given module. A proper version of the module--- name (with correct definition sites) is returned.--scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)-scopeCheckImport x = do-    reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x-    verboseS "import.scope" 10 $ do-      visited <- Map.keys <$> getVisitedModules-      reportSLn "import.scope" 10 $-        "  visited: " ++ intercalate ", " (map prettyShow visited)-    -- Since scopeCheckImport is called from the scope checker,-    -- we need to reimburse her account.-    i <- Bench.billTo [] $ getInterface x-    addImport x-    -- let s = publicModules $ iInsideScope i-    let s = iScope i-    return (iModuleName i `withRangesOfQ` mnameToConcrete x, s)--data MaybeWarnings' a = NoWarnings | SomeWarnings a-  deriving (Functor, Foldable, Traversable)-type MaybeWarnings = MaybeWarnings' [TCWarning]--applyFlagsToMaybeWarnings :: IgnoreFlags -> MaybeWarnings -> TCM MaybeWarnings-applyFlagsToMaybeWarnings r mw = do-  w' <- traverse (applyFlagsToTCWarnings r) mw-  return $ if null w' then NoWarnings else w'--instance Null a => Null (MaybeWarnings' a) where-  empty = NoWarnings-  null mws = case mws of-    NoWarnings      -> True-    SomeWarnings ws -> null ws--hasWarnings :: MaybeWarnings -> Bool-hasWarnings = not . null---- | 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 ->-                  TCM (Interface, MaybeWarnings) ->-                  TCM (Interface, MaybeWarnings)-alreadyVisited x getIface = do-    mm <- getVisitedModule x-    case mm of-        -- A module with warnings should never be allowed to be-        -- imported from another module.-        Just mi | not (miWarnings mi) -> do-          reportSLn "import.visit" 10 $ "  Already visited " ++ prettyShow x-          return (miInterface mi, NoWarnings)-        _ -> do-          reportSLn "import.visit" 5 $ "  Getting interface for " ++ prettyShow x-          r@(i, wt) <- getIface-          reportSLn "import.visit" 5 $ "  Now we've looked at " ++ prettyShow x-          visitModule $ ModuleInfo-            { miInterface  = i-            , miWarnings   = hasWarnings wt-            }-          return r---- | Type checks the main file of the interaction.---   This could be the file loaded in the interacting editor (emacs),---   or the file passed on the command line.------   First, the primitive modules are imported.---   Then, @getInterface'@ is called to do the main work.--typeCheckMain :: AbsolutePath -> TCM (Interface, MaybeWarnings)-typeCheckMain f = do-  -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f-  -- liftIO . putStrLn . show =<< getVerbosity-  reportSLn "import.main" 10 $ "Importing the primitive modules."-  libdir <- liftIO defaultLibDir-  reportSLn "import.main" 20 $ "Library dir = " ++ show libdir-  -- To allow posulating the built-ins, check the primitive module-  -- in unsafe mode-  _ <- bracket_ (gets $ Lens.getSafeMode) Lens.putSafeMode $ do-    Lens.putSafeMode False-    -- 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_ (gets $ Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do-      Lens.modifyPersistentVerbosity (Trie.delete [])  -- set root verbosity to 0-      -- We don't want to generate highlighting information for Agda.Primitive.-      withHighlightingLevel None $-        getInterface_ =<< do-          moduleName $ mkAbsolute $-            libdir </> "prim" </> "Agda" </> "Primitive.agda"-  reportSLn "import.main" 10 $ "Done importing the primitive modules."--  -- Now do the type checking via getInterface.-  m <- moduleName f-  getInterface' m MainInterface---- | 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.---   May type check the module.---   An error is raised if a warning is encountered.------   Do not use this for the main file, use 'typeCheckMain' instead.--getInterface :: ModuleName -> TCM Interface-getInterface = getInterface_ . toTopLevelModuleName---- | See 'getInterface'.--getInterface_ :: C.TopLevelModuleName -> TCM Interface-getInterface_ x = do-  (i, wt) <- getInterface' x NotMainInterface-  case wt of-    SomeWarnings w  -> tcWarningsToError (filter (notIM . tcWarning) w)-    NoWarnings      -> return i-   -- filter out unsolved interaction points for imported module so-   -- that we get the right error message (see test case Fail/Issue1296)-   where notIM UnsolvedInteractionMetas{} = False-         notIM _                          = True----- | A more precise variant of 'getInterface'. If warnings are--- encountered then they are returned instead of being turned into--- errors.--getInterface'-  :: C.TopLevelModuleName-  -> MainInterface-     -- ^ If type checking is necessary,-     --   should all state changes inflicted by 'createInterface' be preserved?-     --   Yes, if we are the 'MainInterface'.  No, if we are 'NotMainInterface'.-  -> TCM (Interface, MaybeWarnings)-getInterface' x isMain = do-  withIncreasedModuleNestingLevel $ do-    -- Preserve the pragma options unless includeStateChanges is True.-    bracket_ (use stPragmaOptions)-             (unless includeStateChanges . setPragmaOptions) $ do-     -- Forget the pragma options (locally).-     setCommandLineOptions . stPersistentOptions . stPersistentState =<< get--     alreadyVisited x $ addImportCycleCheck x $ do-      file <- findFile x  -- requires source to exist--      reportSLn "import.iface" 10 $ "  Check for cycle"-      checkForImportCycle--      uptodate <- Bench.billTo [Bench.Import] $ do-        ignore <- ignoreInterfaces-        cached <- runMaybeT $ isCached x file-          -- If it's cached ignoreInterfaces has no effect;-          -- to avoid typechecking a file more than once.-        sourceH <- liftIO $ hashFile file-        ifaceH  <--          case cached of-            Nothing -> fmap fst <$> getInterfaceFileHashes (filePath $ toIFile file)-            Just i  -> return $ Just $ iSourceHash i-        let unchanged = Just sourceH == ifaceH-        return $ unchanged && (not ignore || isJust cached)--      reportSLn "import.iface" 5 $-        "  " ++ prettyShow x ++ " is " ++-        (if uptodate then "" else "not ") ++ "up-to-date."--      (stateChangesIncluded, (i, wt)) <- do-        -- -- Andreas, 2014-10-20 AIM XX:-        -- -- Always retype-check the main file to get the iInsideScope-        -- -- which is no longer serialized.-        -- let maySkip = isMain == NotMainInterface-        -- Andreas, 2015-07-13: Serialize iInsideScope again.-        let maySkip = True-        if uptodate && maySkip-          then getStoredInterface x file includeStateChanges-          else typeCheck          x file includeStateChanges--      -- Ensure that the given module name matches the one in the file.-      let topLevelName = toTopLevelModuleName $ iModuleName i-      unless (topLevelName == x) $ do-        -- Andreas, 2014-03-27 This check is now done in the scope checker.-        -- checkModuleName topLevelName file-        typeError $ OverlappingProjects file topLevelName x--      visited <- isVisited x-      reportSLn "import.iface" 5 $ if visited then "  We've been here. Don't merge."-                                   else "  New module. Let's check it out."-      unless (visited || stateChangesIncluded) $ do-        mergeInterface i-        Bench.billTo [Bench.Highlighting] $-          ifTopLevelAndHighlightingLevelIs NonInteractive $-            highlightFromInterface i file--      stCurrentModule .= Just (iModuleName i)--      -- Interfaces are only stored if no warnings were encountered.-      case wt of-        SomeWarnings w -> return ()-        NoWarnings     -> storeDecodedModule i--      return (i, wt)--    where-      includeStateChanges = isMain == MainInterface---- | Check whether interface file exists and is in cache---   in the correct version (as testified by the interface file hash).--isCached-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> AbsolutePath-     -- ^ File we process.-  -> MaybeT TCM Interface--isCached x file = do-  let ifile = filePath $ toIFile file--  -- Make sure the file exists in the case sensitive spelling.-  guardM $ liftIO $ doesFileExistCaseSensitive ifile--  -- Check that we have cached the module.-  mi <- MaybeT $ getDecodedModule x--  -- Check that the interface file exists and return its hash.-  h  <- MaybeT $ fmap snd <$> getInterfaceFileHashes ifile--  -- Make sure the hashes match.-  guard $ iFullHash mi == h--  return mi----- | Try to get the interface from interface file or cache.--getStoredInterface-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> AbsolutePath-     -- ^ File we process.-  -> Bool-     -- ^ If type checking is necessary,-     --   should all state changes inflicted by 'createInterface' be preserved?-     --   @True@, if we are the 'MainInterface'.  @False@, if we are 'NotMainInterface'.-  -> TCM (Bool, (Interface, MaybeWarnings))-     -- ^ @Bool@ is: do we have to merge the interface?-getStoredInterface x file includeStateChanges = do-  -- If something goes wrong (interface outdated etc.)-  -- we revert to fresh type checking.-  let fallback = typeCheck x file includeStateChanges--  -- Examine the hash of the interface file. If it is different from the-  -- stored version (in stDecodedModules), or if there is no stored version,-  -- read and decode it. Otherwise use the stored version.-  let ifile = filePath $ toIFile file-  h <- fmap snd <$> getInterfaceFileHashes ifile-  mm <- getDecodedModule x-  (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of-    Just mi ->-      if Just (iFullHash mi) /= h-      then do-        dropDecodedModule x-        reportSLn "import.iface" 50 $ "  cached hash = " ++ show (iFullHash mi)-        reportSLn "import.iface" 50 $ "  stored hash = " ++ show h-        reportSLn "import.iface" 5 $ "  file is newer, re-reading " ++ ifile-        (False,) <$> readInterface ifile-      else do-        reportSLn "import.iface" 5 $ "  using stored version of " ++ ifile-        return (True, Just mi)-    Nothing -> do-      reportSLn "import.iface" 5 $ "  no stored version, reading " ++ ifile-      (False,) <$> readInterface ifile--  -- Check that it's the right version-  case mi of-    Nothing       -> do-      reportSLn "import.iface" 5 $ "  bad interface, re-type checking"-      fallback-    Just i        -> do-      reportSLn "import.iface" 5 $ "  imports: " ++ show (iImportedModules i)--      hs <- map iFullHash <$> mapM getInterface (map fst $ iImportedModules i)--      -- If any of the imports are newer we need to retype check-      if hs /= map snd (iImportedModules i)-        then do-          -- liftIO close -- Close the interface file. See above.-          fallback-        else do-          unless cached $ chaseMsg "Skipping" x $ Just ifile-          -- We set the pragma options of the skipped file here,-          -- because if the top-level file is skipped we want the-          -- pragmas to apply to interactive commands in the UI.-          mapM_ setOptionsFromPragma (iPragmaOptions i)-          return (False, (i, NoWarnings))---- | Run the type checker on a file and create an interface.------   Mostly, this function calls 'createInterface'.---   But if it is not the main module we check,---   we do it in a fresh state, suitably initialize,---   in order to forget some state changes after successful type checking.--typeCheck-  :: C.TopLevelModuleName-     -- ^ Module name of file we process.-  -> AbsolutePath-     -- ^ File we process.-  -> Bool-     -- ^ If type checking is necessary,-     --   should all state changes inflicted by 'createInterface' be preserved?-     --   @True@, if we are the 'MainInterface'.  @False@, if we are 'NotMainInterface'.-  -> TCM (Bool, (Interface, MaybeWarnings))-     -- ^ @Bool@ is: do we have to merge the interface?-typeCheck x file includeStateChanges = do-  unless includeStateChanges cleanCachedLog-  let withMsgs = bracket_-       (chaseMsg "Checking" x $ Just $ filePath file)-       (const $ do ws <- getAllWarnings' AllWarnings RespectFlags-                   let (we, wa) = classifyWarnings ws-                   unless (null wa) $ reportSDoc "warning" 1-                                    $ P.vcat $ P.prettyTCM <$> wa-                   unless (not $ null we) $ chaseMsg "Finished" x Nothing)--  -- Do the type checking.--  if includeStateChanges then do-     r <- withMsgs $ createInterface file x includeStateChanges--     -- Merge the signature with the signature for imported-     -- things.-     reportSLn "import.iface" 40 $ "Merging with state changes included."-     sig     <- getSignature-     patsyns <- getPatternSyns-     display <- use stImportsDisplayForms-     addImportedThings sig Map.empty Set.empty Set.empty patsyns display-     setSignature emptySignature-     setPatternSyns Map.empty--     return (True, r)-   else do-    ms       <- getImportPath-    nesting  <- asks envModuleNestingLevel-    range    <- asks envRange-    call     <- asks envCall-    mf       <- use stModuleToSource-    vs       <- getVisitedModules-    ds       <- getDecodedModules-    opts     <- stPersistentOptions . stPersistentState <$> get-    isig     <- use stImports-    ibuiltin <- use stImportedBuiltins-    display  <- use stImportsDisplayForms-    ipatsyns <- getPatternSynImports-    ho       <- getInteractionOutputCallback-    -- Every interface is treated in isolation. Note: Changes-    -- to stDecodedModules are not preserved if an error is-    -- encountered in an imported module.-    -- Andreas, 2014-03-23: freshTCM spawns a new TCM computation-    -- with initial state and environment-    -- but on the same Benchmark accounts.-    r <- freshTCM $-           withImportPath ms $-           local (\e -> e { envModuleNestingLevel = nesting-                            -- Andreas, 2014-08-18:-                            -- Preserve the range of import statement-                            -- for reporting termination errors in-                            -- imported modules:-                          , envRange              = range-                          , envCall               = call-                          }) $ do-             setDecodedModules ds-             setCommandLineOptions opts-             setInteractionOutputCallback ho-             stModuleToSource .= mf-             setVisitedModules vs-             addImportedThings isig ibuiltin Set.empty Set.empty ipatsyns display--             r  <- withMsgs $ createInterface file x includeStateChanges-             mf <- use stModuleToSource-             ds <- getDecodedModules-             return (r, do-                stModuleToSource .= mf-                setDecodedModules ds-                case r of-                  (i, NoWarnings) -> storeDecodedModule i-                  _               -> return ()-                )--    case r of-        Left err          -> throwError err-        Right (r, update) -> do-          update-          case r of-            (_, NoWarnings) ->-              -- We skip the file which has just been type-checked to-              -- be able to forget some of the local state from-              -- checking the module.-              -- Note that this doesn't actually read the interface-              -- file, only the cached interface.-              getStoredInterface x file includeStateChanges-            _ -> return (False, r)----- | Formats and outputs the "Checking", "Finished" and "Skipping" messages.--chaseMsg-  :: String               -- ^ The prefix, like @Checking@, @Finished@, @Skipping@.-  -> C.TopLevelModuleName -- ^ The module name.-  -> Maybe String         -- ^ Optionally: the file name.-  -> TCM ()-chaseMsg kind x file = do-  indentation <- (`replicate` ' ') <$> asks envModuleNestingLevel-  let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")."-  reportSLn "import.chase" 1 $ concat $-    [ indentation, kind, " ", prettyShow x, maybeFile ]----- | Print the highlighting information contained in the given interface.--highlightFromInterface-  :: Interface-  -> AbsolutePath-     -- ^ The corresponding file.-  -> TCM ()-highlightFromInterface i file = do-  reportSLn "import.iface" 5 $-    "Generating syntax info for " ++ filePath file ++-    " (read from interface)."-  printHighlightingInfo (iHighlighting i)---readInterface :: FilePath -> TCM (Maybe Interface)-readInterface file = do-    -- Decode the interface file-    (s, close) <- liftIO $ readBinaryFile' file-    do  mi <- liftIO . E.evaluate =<< decodeInterface s--        -- Close the file. Note-        -- ⑴ that evaluate ensures that i is evaluated to WHNF (before-        --   the next IO operation is executed), and-        -- ⑵ that decode returns Nothing if an error is encountered,-        -- so it is safe to close the file here.-        liftIO close--        return $ constructIScope <$> mi-      -- Catch exceptions and close-      `catchError` \e -> liftIO close >> handler e-  -- Catch exceptions-  `catchError` handler-  where-    handler e = case e of-      IOException _ e -> do-        reportSLn "" 0 $ "IO exception: " ++ show e-        return Nothing   -- Work-around for file locking bug.-                         -- TODO: What does this refer to? Please-                         -- document.-      _               -> throwError e---- | Writes the given interface to the given file.--writeInterface :: FilePath -> Interface -> TCM ()-writeInterface file i = do-    reportSLn "import.iface.write" 5  $ "Writing interface file " ++ file ++ "."-    -- Andreas, 2015-07-13-    -- After QName memoization (AIM XXI), scope serialization might be cheap enough.-    -- -- Andreas, Makoto, 2014-10-18 AIM XX:-    -- -- iInsideScope is bloating the interface files, so we do not serialize it?-    -- i <- return $-    --   i { iInsideScope  = emptyScopeInfo-    --     }-    -- Andreas, 2016-02-02 this causes issue #1804, so don't do it:-    -- i <- return $-    --   i { iInsideScope  = removePrivates $ iInsideScope i-    --     }-    encodeFile file i-    reportSLn "import.iface.write" 5 $ "Wrote interface file."-    reportSLn "import.iface.write" 50 $ "  hash = " ++ show (iFullHash i) ++ ""-  `catchError` \e -> do-    reportSLn "" 1 $-      "Failed to write interface " ++ file ++ "."-    liftIO $-      whenM (doesFileExist file) $ removeFile file-    throwError e--removePrivates :: ScopeInfo -> ScopeInfo-removePrivates si = si { scopeModules = restrictPrivate <$> scopeModules si }---- | Tries to type check a module and write out its interface. The--- function only writes out an interface file if it does not encounter--- any warnings.------ If appropriate this function writes out syntax highlighting--- information.--createInterface-  :: AbsolutePath          -- ^ The file to type check.-  -> C.TopLevelModuleName  -- ^ The expected module name.-  -> Bool-  -> TCM (Interface, MaybeWarnings)-createInterface file mname isMain =-  local (\e -> e { envCurrentPath = Just file }) $ do-    modFile       <- use stModuleToSource-    fileTokenInfo <- Bench.billTo [Bench.Highlighting] $-                       generateTokenInfo file-    stTokens .= fileTokenInfo--    reportSLn "import.iface.create" 5 $-      "Creating interface for " ++ prettyShow mname ++ "."-    verboseS "import.iface.create" 10 $ do-      visited <- Map.keys <$> getVisitedModules-      reportSLn "import.iface.create" 10 $-        "  visited: " ++ intercalate ", " (map prettyShow visited)--    previousHsImports <- getHaskellImports-    previousHsImportsUHC <- getHaskellImportsUHC--    -- Parsing.-    (pragmas, top) <- Bench.billTo [Bench.Parsing] $-      runPM $ parseFile' moduleParser file--    pragmas <- concat <$> concreteToAbstract_ pragmas-               -- identity for top-level pragmas at the moment-    let getOptions (A.OptionsPragma opts) = Just opts-        getOptions _                      = Nothing-        options = catMaybes $ map getOptions pragmas-    mapM_ setOptionsFromPragma options---    -- Scope checking.-    reportSLn "import.iface.create" 7 $ "Starting scope checking."-    topLevel <- Bench.billTo [Bench.Scoping] $-      concreteToAbstract_ (TopLevel file mname top)-    reportSLn "import.iface.create" 7 $ "Finished scope checking."--    let ds    = topLevelDecls topLevel-        scope = topLevelScope topLevel--    -- Highlighting from scope checker.-    reportSLn "import.iface.create" 7 $ "Starting highlighting from scope."-    Bench.billTo [Bench.Highlighting] $ do-      ifTopLevelAndHighlightingLevelIs NonInteractive $ do-        -- Generate and print approximate syntax highlighting info.-        printHighlightingInfo fileTokenInfo-        mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial) ds-    reportSLn "import.iface.create" 7 $ "Finished highlighting from scope."---    -- Type checking.--    -- invalidate cache if pragmas change, TODO move-    cachingStarts-    opts <- use stPragmaOptions-    me <- readFromCachedLog-    case me of-      Just (Pragmas opts', _) | opts == opts'-        -> return ()-      _ -> do-        reportSLn "cache" 10 $ "pragma changed: " ++ show (isJust me)-        cleanCachedLog-    writeToCurrentLog $ Pragmas opts--    reportSLn "import.iface.create" 7 $ "Starting type checking."-    Bench.billTo [Bench.Typing] $ mapM_ checkDeclCached ds `finally_` cacheCurrentLog-    reportSLn "import.iface.create" 7 $ "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.-    -- Ulf, 2013-11-13: Errors are now caught and highlighted in InteractionTop.-    -- catchError_ (checkDecls ds) $ \e -> do-    --   ifTopLevelAndHighlightingLevelIs NonInteractive $-    --     printErrorInfo e-    --   throwError e--    unfreezeMetas--    -- Profiling: Count number of metas.-    verboseS "profile.metas" 10 $ do-      MetaId n <- fresh-      tickN "metas" (fromIntegral n)--    -- Highlighting from type checker.-    reportSLn "import.iface.create" 7 $ "Starting highlighting from type info."-    Bench.billTo [Bench.Highlighting] $ do--      -- Move any remaining token highlighting to stSyntaxInfo.-      toks <- use stTokens-      ifTopLevelAndHighlightingLevelIs NonInteractive $ printHighlightingInfo toks-      stTokens .= mempty-      stSyntaxInfo %= \inf -> inf `mappend` toks--      whenM (optGenerateVimFile <$> commandLineOptions) $-        -- Generate Vim file.-        withScope_ scope $ generateVimFile $ filePath file-    reportSLn "import.iface.create" 7 $ "Finished highlighting from type info."--    setScope scope-    reportSLn "scope.top" 50 $ "SCOPE " ++ show scope--    -- TODO: It would be nice if unsolved things were highlighted-    -- after every mutual block.--    openMetas           <- getOpenMetas-    unless (null openMetas) $ do-      reportSLn "import.metas" 10 "We have unsolved metas."-      reportSLn "import.metas" 10 . unlines =<< showOpenMetas--    ifTopLevelAndHighlightingLevelIs NonInteractive $-      printUnsolvedInfo--    -- Andreas, 2016-08-03, issue #964-    -- When open metas are allowed,-    -- permanently freeze them now by turning them into postulates.-    -- This will enable serialization.-    -- savedMetaStore <- use stMetaStore-    unless isMain $-      whenM (optAllowUnsolved <$> pragmaOptions) $ do-        withCurrentModule (scopeCurrent scope) $-          openMetasToPostulates-        -- Clear constraints as they might refer to what-        -- they think are open metas.-        stAwakeConstraints    .= []-        stSleepingConstraints .= []--    -- Serialization.-    reportSLn "import.iface.create" 7 $ "Starting serialization."-    syntaxInfo <- use stSyntaxInfo-    i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $ do-      buildInterface file topLevel syntaxInfo previousHsImports previousHsImportsUHC options--    reportSLn "tc.top" 101 $ concat $-      "Signature:\n" :-      [ show x ++ "\n  type: " ++ show (defType def)-               ++ "\n  def:  " ++ show cc ++ "\n"-      | (x, def) <- HMap.toList $ iSignature i ^. sigDefinitions,-        Function{ funCompiled = cc } <- [theDef def]-      ]-    reportSLn "import.iface.create" 7 $ "Finished serialization."--    mallWarnings <- getAllWarnings ErrorWarnings-                      $ if isMain then IgnoreFlags else RespectFlags--    reportSLn "import.iface.create" 7 $ "Considering writing to interface file."-    case mallWarnings of-      SomeWarnings allWarnings -> return ()-      NoWarnings               -> Bench.billTo [Bench.Serialization] $ do-        -- The file was successfully type-checked (and no warnings were-        -- encountered), so the interface should be written out.-        let ifile = filePath $ toIFile file-        writeInterface ifile i-    reportSLn "import.iface.create" 7 $ "Finished (or skipped) writing to interface file."--    -- -- Restore the open metas, as we might continue in interaction mode.-    -- Actually, we do not serialize the metas if checking the MainInterface-    -- stMetaStore .= savedMetaStore--    -- Profiling: Print statistics.-    printStatistics 30 (Just mname) =<< getStatistics--    -- Get the statistics of the current module-    -- and add it to the accumulated statistics.-    localStatistics <- getStatistics-    lensAccumStatistics %= Map.unionWith (+) localStatistics-    verboseS "profile" 1 $ do-      reportSLn "import.iface" 5 $ "Accumulated statistics."--    return $ first constructIScope (i, mallWarnings)---- | Collect all warnings that have accumulated in the state.--- Depending on the argument, we either respect the flags passed--- in by the user, or not (for instance when deciding if we are--- writing an interface file or not)--data WhichWarnings = ErrorWarnings | AllWarnings-  -- ^ order of constructors important for derived Ord instance-  deriving (Eq, Ord)--classifyWarning :: Warning -> WhichWarnings-classifyWarning w = case w of-  OldBuiltin{}               -> AllWarnings-  EmptyRewritePragma         -> AllWarnings-  TerminationIssue{}         -> ErrorWarnings-  NotStrictlyPositive{}      -> ErrorWarnings-  UnsolvedMetaVariables{}    -> ErrorWarnings-  UnsolvedInteractionMetas{} -> ErrorWarnings-  UnsolvedConstraints{}      -> ErrorWarnings-  ParseWarning{}             -> ErrorWarnings--classifyWarnings :: [TCWarning] -> ([TCWarning], [TCWarning])-classifyWarnings = partition $ (< AllWarnings) . classifyWarning . tcWarning--getAllWarnings' :: WhichWarnings -> IgnoreFlags -> TCM [TCWarning]-getAllWarnings' ww ifs = do-  openMetas            <- getOpenMetas-  interactionMetas     <- getInteractionMetas-  let getUniqueMetas = fmap List.nub . mapM getMetaRange-  unsolvedInteractions <- getUniqueMetas interactionMetas-  unsolvedMetas        <- getUniqueMetas (openMetas List.\\ interactionMetas)-  unsolvedConstraints  <- getAllConstraints-  collectedTCWarnings  <- use stTCWarnings--  unsolved <- mapM warning_-                   [ UnsolvedInteractionMetas unsolvedInteractions-                   , UnsolvedMetaVariables    unsolvedMetas-                   , UnsolvedConstraints      unsolvedConstraints ]--  fmap (filter ((<= ww) . classifyWarning . tcWarning))-    $ applyFlagsToTCWarnings ifs $ reverse-    $ unsolved ++ collectedTCWarnings--getAllWarnings :: WhichWarnings -> IgnoreFlags -> TCM MaybeWarnings-getAllWarnings ww ifs = do-  allWarnings <- getAllWarnings' ww ifs-  return $ if null allWarnings-    -- Andreas, issue 964: not checking null interactionPoints-    -- anymore; we want to serialize with open interaction points now!-           then NoWarnings-           else SomeWarnings allWarnings---- constructIScope :: ScopeInfo -> Map ModuleName Scope-constructIScope :: Interface -> Interface-constructIScope i = i{ iScope = billToPure [ Deserialization ] $ publicModules $ iInsideScope i }---- | Builds an interface for the current module, which should already--- have been successfully type checked.--buildInterface-  :: AbsolutePath-  -> TopLevelInfo-     -- ^ 'TopLevelInfo' for the current module.-  -> HighlightingInfo-     -- ^ Syntax highlighting info for the module.-  -> Set String-     -- ^ MAlonzo: Haskell modules imported in imported modules (transitively).-  -> Set String-     -- ^ UHC backend: Haskell modules imported in imported modules (transitively).-  -> [OptionsPragma]-     -- ^ Options set in @OPTIONS@ pragmas.-  -> TCM Interface-buildInterface file topLevel syntaxInfo previousHsImports previousHsImportsUHC pragmas = do-    reportSLn "import.iface" 5 "Building interface..."-    let m = topLevelModuleName topLevel-    scope'  <- getScope-    let scope = scope' { scopeCurrent = m }-    -- 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-    -- with discarding also the nameBindingSite in QName:-    -- Saves 10% on serialization time (and file size)!-    ---    -- NOTE: We no longer discard all nameBindingSites (but the commit-    -- 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 <- use stLocalBuiltins-    ms      <- getImports-    mhs     <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms-    hsImps  <- getHaskellImports-    uhcHsImps <- getHaskellImportsUHC-    hsCode  <- use stHaskellCode-    -- Ulf, 2016-04-12:-    -- Non-closed display forms are not applicable outside the module anyway,-    -- and should be dead-code eliminated (#1928).-    display <- HMap.filter (not . null) . HMap.map (filter isGlobal) <$> use stImportsDisplayForms-    -- TODO: Kill some ranges?-    (display, sig) <- eliminateDeadCode display =<< getSignature-    -- Andreas, 2015-02-09 kill ranges in pattern synonyms before-    -- serialization to avoid error locations pointing to external files-    -- when expanding a pattern synoym.-    patsyns <- killRange <$> getPatternSyns-    h       <- liftIO $ hashFile file-    let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin-    reportSLn "import.iface" 7 "  instantiating all meta variables"-    i <- instantiateFull $ Interface-      { iSourceHash      = h-      , iImportedModules = mhs-      , iModuleName      = m-      , iScope           = empty -- publicModules scope-      , iInsideScope     = topLevelScope topLevel-      , iSignature       = sig-      , iDisplayForms    = display-      , iBuiltin         = builtin'-      , iHaskellImports  = hsImps `Set.difference` previousHsImports-      , iHaskellImportsUHC = uhcHsImps `Set.difference` previousHsImportsUHC-      , iHaskellCode     = hsCode-      , iHighlighting    = syntaxInfo-      , iPragmaOptions   = pragmas-      , iPatternSyns     = patsyns-      }-    reportSLn "import.iface" 7 "  interface complete"-    return i---- | Returns (iSourceHash, iFullHash)-getInterfaceFileHashes :: FilePath -> TCM (Maybe (Hash, Hash))-getInterfaceFileHashes ifile = do-  exist <- liftIO $ doesFileExist ifile-  if not exist then return Nothing else do-    (s, close) <- liftIO $ readBinaryFile' ifile-    let hs = decodeHashes s-    liftIO $ maybe 0 (uncurry (+)) hs `seq` close-    return hs--moduleHash :: ModuleName -> TCM Hash-moduleHash m = iFullHash <$> getInterface m---- | True if the first file is newer than the second file. If a file doesn't--- exist it is considered to be infinitely old.-isNewerThan :: FilePath -> FilePath -> IO Bool-isNewerThan new old = do-    newExist <- doesFileExist new-    oldExist <- doesFileExist old-    if not (newExist && oldExist)-        then return newExist-        else do-            newT <- getModificationTime new-            oldT <- getModificationTime old-            return $ newT >= oldT+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}++{-| This module deals with finding imported modules and loading their+    interface files.+-}+module Agda.Interaction.Imports+  ( Mode, pattern ScopeCheck, pattern TypeCheck++  , CheckResult (CheckResult)+  , crModuleInfo+  , crInterface+  , crWarnings+  , crMode+  , crSource++  , Source(..)+  , scopeCheckImport+  , parseSource+  , typeCheckMain+  , getNonMainInterface+  , getNonMainModuleInfo+  , getInterface+  , importPrimitiveModules+  , raiseNonFatalErrors++  -- Currently only used by test/api/Issue1168.hs:+  , readInterface+  ) where++import Prelude hiding (null)++import Control.Monad.Except        ( MonadError(..), ExceptT, runExceptT, withExceptT )+import Control.Monad.IO.Class      ( MonadIO(..) )+import Control.Monad.State         ( MonadState(..), execStateT )+import Control.Monad.Trans.Maybe+import qualified Control.Exception as E++import Data.Either+import Data.List (intercalate)+import qualified Data.List as List+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  ( (</>) )++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, sortRulesOfSymbol )+import Agda.TypeChecking.MetaVars ( openMetasToPostulates )+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Serialise+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Pretty as P+import Agda.TypeChecking.DeadCode+import qualified Agda.TypeChecking.Monad.Benchmark as Bench++import Agda.TheTypeChecker++import Agda.Interaction.BasicOps ( getGoals, showGoals )+import Agda.Interaction.FindFile+import Agda.Interaction.Highlighting.Generate+import qualified Agda.Interaction.Highlighting.Precise as Highlighting ( convert )+import Agda.Interaction.Highlighting.Vim+import Agda.Interaction.Library+import Agda.Interaction.Options+import qualified Agda.Interaction.Options.Lenses as Lens+import Agda.Interaction.Options.Warnings (unsolvedWarnings)+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 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++-- | Whether to ignore interfaces (@.agdai@) other than built-in modules++ignoreInterfaces :: HasOptions m => m Bool+ignoreInterfaces = optIgnoreInterfaces <$> commandLineOptions++-- | Whether to ignore all interface files (@.agdai@)++ignoreAllInterfaces :: HasOptions m => m Bool+ignoreAllInterfaces = optIgnoreAllInterfaces <$> commandLineOptions++-- | The decorated source code.++data Source = Source+  { srcText        :: TL.Text               -- ^ Source code.+  , srcFileType    :: FileType              -- ^ Source file type+  , srcOrigin      :: SourceFile            -- ^ Source location at the time of its parsing+  , srcModule      :: C.Module              -- ^ The parsed module.+  , 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 = 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+    , srcOrigin      = sourceFile+    , 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)++srcFilePragmas :: Source -> [OptionsPragma]+srcFilePragmas src = pragmas+  where+  cpragmas = C.modPragmas (srcModule 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. 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?++data Mode+  = ScopeCheck+  | TypeCheck+  deriving (Eq, Show)++-- | Are we loading the interface for the user-loaded file+--   or for an import?+data MainInterface+  = MainInterface Mode -- ^ For the main file.+                       --+                       --   In this case state changes inflicted by+                       --   'createInterface' are preserved.+  | NotMainInterface   -- ^ For an imported file.+                       --+                       --   In this case state changes inflicted by+                       --   'createInterface' are not preserved.+  deriving (Eq, Show)++-- | Should state changes inflicted by 'createInterface' be preserved?++includeStateChanges :: MainInterface -> Bool+includeStateChanges (MainInterface _) = True+includeStateChanges NotMainInterface  = False++-- | The kind of interface produced by 'createInterface'+moduleCheckMode :: MainInterface -> ModuleCheckMode+moduleCheckMode = \case+    MainInterface TypeCheck                       -> ModuleTypeChecked+    NotMainInterface                              -> ModuleTypeChecked+    MainInterface ScopeCheck                      -> ModuleScopeChecked++-- | Merge an interface into the current proof state.+mergeInterface :: Interface -> TCM ()+mergeInterface i = do+    let sig     = iSignature i+        builtin = Map.toAscList $ iBuiltin i+        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 " ++ prettyShow (iTopLevelModuleName i)+    reportSLn "import.iface.merge" 20 $+      "  Current builtins " ++ show (Map.keys bs) ++ "\n" +++      "  New builtins     " ++ show (Map.keys bi)+    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+      (iMetaBindings i)+      bi+      (iPatternSyns i)+      (iDisplayForms i)+      (iUserWarnings i)+      (iPartialDefs i)+      warns+      (iOpaqueBlocks i)+      (iOpaqueNames i)+    reportSLn "import.iface.merge" 50 $+      "  Rebinding primitives " ++ show prim+    mapM_ rebind prim+    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 (someBuiltin x) (Prim pf{ primFunName = q })++addImportedThings+  :: Signature+  -> RemoteMetaStore+  -> BuiltinThings+  -> A.PatternSynDefns+  -> DisplayForms+  -> UserWarnings      -- ^ Imported user warnings+  -> Set QName             -- ^ Name of imported definitions which are partial+  -> Set TCWarning+  -> Map OpaqueId OpaqueBlock+  -> Map QName OpaqueId+  -> TCM ()+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 -> Set.union imp warnings+  stOpaqueBlocks         `modifyTCLens` \ imp -> imp `Map.union` oblock+  stOpaqueIds            `modifyTCLens` \ imp -> imp `Map.union` oid++-- | 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" 30 $ "  visited: " ++ visited+    -- Since scopeCheckImport is called from the scope checker,+    -- we need to reimburse her account.+    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, 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 :: TopLevelModuleName ->+                  MainInterface ->+                  PragmaOptions ->+                  TCM ModuleInfo ->+                  TCM ModuleInfo+alreadyVisited x isMain currentOptions getModule =+  case isMain of+    MainInterface TypeCheck                       -> useExistingOrLoadAndRecordVisited ModuleTypeChecked+    NotMainInterface                              -> useExistingOrLoadAndRecordVisited ModuleTypeChecked+    MainInterface ScopeCheck                      -> useExistingOrLoadAndRecordVisited ModuleScopeChecked+  where+  useExistingOrLoadAndRecordVisited :: ModuleCheckMode -> TCM ModuleInfo+  useExistingOrLoadAndRecordVisited mode = fromMaybeM loadAndRecordVisited (existingWithoutWarnings mode)++  -- Case: already visited.+  --+  -- A module with warnings should never be allowed to be+  -- imported from another module.+  existingWithoutWarnings :: ModuleCheckMode -> TCM (Maybe ModuleInfo)+  existingWithoutWarnings mode = runMaybeT $ exceptToMaybeT $ do+    mi <- maybeToExceptT "interface has not been visited in this context" $ MaybeT $+      getVisitedModule x++    when (miMode mi < mode) $+      throwError "previously-visited interface was not sufficiently checked"++    unless (null $ miWarnings mi) $+      throwError "previously-visited interface had warnings"++    reportSLn "import.visit" 10 $ "  Already visited " ++ prettyShow x++    lift $ processResultingModule mi++  processResultingModule :: ModuleInfo -> TCM ModuleInfo+  processResultingModule mi = do+    let ModuleInfo { miInterface = i, miPrimitive = isPrim, miWarnings = ws } = mi++    -- 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++    return mi { miWarnings = wt }++  loadAndRecordVisited :: TCM ModuleInfo+  loadAndRecordVisited = do+    reportSLn "import.visit" 5 $ "  Getting interface for " ++ prettyShow x+    mi <- processResultingModule =<< getModule+    reportSLn "import.visit" 5 $ "  Now we've looked at " ++ prettyShow x++    -- Interfaces are not stored if we are only scope-checking, or+    -- if any warnings were encountered.+    case (isMain, null $ miWarnings mi) of+      (MainInterface ScopeCheck, _) -> return ()+      (_, False)                    -> return ()+      _                             -> storeDecodedModule mi++    reportS "warning.import" 10+      [ "module: " ++ show (moduleNameParts x)+      , "WarningOnImport: " ++ show (iImportWarning (miInterface mi))+      ]++    visitModule mi+    return mi+++-- | The result and associated parameters of a type-checked file,+--   when invoked directly via interaction or a backend.+--   Note that the constructor is not exported.++data CheckResult = CheckResult'+  { crModuleInfo :: ModuleInfo+  , crSource'    :: Source+  }++-- | Flattened unidirectional pattern for 'CheckResult' for destructuring inside+--   the 'ModuleInfo' field.+pattern CheckResult :: Interface -> Set TCWarning -> ModuleCheckMode -> Source -> CheckResult+pattern CheckResult { crInterface, crWarnings, crMode, crSource } <- CheckResult'+    { crModuleInfo = ModuleInfo+        { miInterface = crInterface+        , miWarnings = crWarnings+        , miMode = crMode+        }+    , crSource' = crSource+    }++-- | Type checks the main file of the interaction.+--   This could be the file loaded in the interacting editor (emacs),+--   or the file passed on the command line.+--+--   First, the primitive modules are imported.+--   Then, @getInterface@ is called to do the main work.+--+--   If the 'Mode' is 'ScopeCheck', then type-checking is not+--   performed, only scope-checking. (This may include type-checking+--   of imported modules.) In this case the generated, partial+--   interface is not stored in the state ('stDecodedModules'). Note,+--   however, that if the file has already been type-checked, then a+--   complete interface is returned.++typeCheckMain+  :: Mode+     -- ^ Should the file be type-checked, or only scope-checked?+  -> Source+     -- ^ The decorated source code.+  -> TCM CheckResult+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 <- 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+      (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_ (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."++-- | 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.+--   May type check the module.+--   An error is raised if a warning is encountered.+--+--   Do not use this for the main file, use 'typeCheckMain' instead.++getNonMainInterface+  :: 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.+  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+  :: TopLevelModuleName+  -> MainInterface+  -> Maybe Source+     -- ^ Optional: the source code and some information about the source code.+  -> TCM ModuleInfo+getInterface x isMain msrc =+  addImportCycleCheck x $ do+     -- We remember but reset the pragma options locally+     -- Issue #3644 (Abel 2020-05-08): Set approximate range for errors in options+     currentOptions <- useTC stPragmaOptions+     setCurrentRange (C.modPragmas . srcModule <$> msrc) $+       -- Now reset the options+       setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC++     alreadyVisited x isMain currentOptions $ do+      file <- case msrc of+        Nothing  -> findFile x+        Just src -> do+          -- Andreas, 2021-08-17, issue #5508.+          -- So it happened with @msrc == Just{}@ that the file was not added to @ModuleToSource@,+          -- only with @msrc == Nothing@ (then @findFile@ does it).+          -- As a consequence, the file was added later, but with a file name constructed+          -- from a module name.  As #5508 shows, this can be fatal in case-insensitive file systems.+          -- The file name (with case variant) then no longer maps to the module name.+          -- 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 stModuleToSourceId $ Map.insert x file+          pure file+      reportSDoc "import.iface" 15 do+        path <- srcFilePath file+        P.text $ List.intercalate "\n" $ map ("  " ++)+          [ "module: " ++ prettyShow x+          , "file:   " ++ prettyShow path+          ]++      reportSLn "import.iface" 15 $ "  Check for cycle"+      checkForImportCycle++      -- -- Andreas, 2014-10-20 AIM XX:+      -- -- Always retype-check the main file to get the iInsideScope+      -- -- which is no longer serialized.+      -- let maySkip = isMain == NotMainInterface+      -- Andreas, 2015-07-13: Serialize iInsideScope again.+      -- Andreas, 2020-05-13 issue #4647: don't skip if reload because of top-level command+      stored <- runExceptT $ Bench.billTo [Bench.Import] $ do+        getStoredInterface x file msrc++      let recheck = \reason -> do+            reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is not up-to-date because ", reason, "."]+            setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC+            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 -> TopLevelModuleName -> TCM Bool+checkOptionsCompatible current imported importedModule = flip execStateT True $ 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 $+        (case icOptionKind opt of+           Infective   -> InfectiveImport+           Coinfective -> CoInfectiveImport)+        (icOptionWarning opt importedModule)+  where+  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 (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)+                  (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 :: HasCallStack+  => TopLevelModuleName+     -- ^ Module name of file we process.+  -> SourceFile+     -- ^ File we process.+  -> Maybe Source+  -> ExceptT String TCM ModuleInfo+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).+  --+  -- This is a lazy action which may be skipped if there is no cached interface+  -- and we're ignoring interface files for some reason.+  let getIFileHashesET = do+        -- Check that the interface file exists and return its hash.+        ifile <- maybeToExceptT "the interface file could not be found" $ MaybeT $+          findInterfaceFile' file++        -- Check that the interface file exists and return its hash.+        hashes <- maybeToExceptT "the interface file hash could not be read" $ MaybeT $ liftIO $+          getInterfaceFileHashes ifile++        return (ifile, hashes)++  -- Examine the hash of the interface file. If it is different from the+  -- stored version (in stDecodedModules), or if there is no stored version,+  -- read and decode it. Otherwise use the stored version.+  --+  -- This is a lazy action which may be skipped if the cached or on-disk interface+  -- is invalid, missing, or skipped for some other reason.+  let checkSourceHashET ifaceH = do+        sourceH <- case msrc of+                    Nothing -> do+                      path <- srcFilePath file+                      liftIO $ hashTextFile path+                    Just src -> return $ hashText (srcText src)++        unless (sourceH == ifaceH) $+          throwError $ concat+            [ "the source hash (", show sourceH, ")"+            , " does not match the source hash for the interface (", show ifaceH, ")"+            ]++        reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is up-to-date."]++  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 $+        whenNothingM (isBuiltinModule fi) $+            throwError "we're ignoring non-builtin interface files"++      (ifile, hashes) <- getIFileHashesET++      let ifp = (filePath . intFilePath $ ifile)++      Bench.billTo [Bench.Deserialization] $ do+        checkSourceHashET (fst hashes)++        reportSLn "import.iface" 5 $ "  no stored version, reading " ++ ifp++        i <- maybeToExceptT "bad interface, re-type checking" $ MaybeT $+          readInterface ifile++        -- Ensure that the given module name matches the one in the file.+        let topLevelName = iTopLevelModuleName i+        unless (topLevelName == x) do+          path <- srcFilePath file+          lift $ typeError $ OverlappingProjects path topLevelName x++        isPrimitiveMod <- isPrimitiveModule fi++        lift $ chaseMsg "Loading " x $ Just ifp+        -- print imported warnings+        reportWarningsForModule x $ iWarnings i++        loadDecodedModule file $ ModuleInfo+          { miInterface = i+          , 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 sf@(SourceFile fi) mi = do+  file <- srcFilePath sf+  let fp      = filePath file+  let i       = miInterface mi+  let imports = iImportedModules i+  let name    = iTopLevelModuleName 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+  -- imported modules. Also, if the top-level file is skipped we+  -- 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 file name+  lift $ mapM_ setOptionsFromPragma (libOptions ++ iFilePragmaOptions i)++  -- Check that options that matter haven't changed compared to+  -- 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 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]+    when (impHash /= latestImpHash) $+      throwError $ concat+        [ "module hash for imported module ", prettyShow impName, " is out of date"+        , " (import cached=", prettyShow impHash, ", latest=", prettyShow latestImpHash, ")"+        ]++  unlessNull badHashMessages (throwError . unlines)++  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 sf++  return mi++-- | Run the type checker on a file and create an interface.+--+--   Mostly, this function calls 'createInterface'.+--   But if it is not the main module we check,+--   we do it in a fresh state, suitably initialize,+--   in order to forget some state changes after successful type checking.++createInterfaceIsolated+  :: TopLevelModuleName+     -- ^ Module name of file we process.+  -> SourceFile+     -- ^ File we process.+  -> Maybe Source+     -- ^ Optional: the source code and some information about the source code.+  -> TCM ModuleInfo+createInterfaceIsolated x file msrc = do+      cleanCachedLog++      ms          <- getImportPath+      range       <- asksTC envRange+      call        <- asksTC envCall+      mf          <- useTC stModuleToSource+      vs          <- getVisitedModules+      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+      -- the persistent state may not be preserved if an error other+      -- than a type error or an IO exception is encountered in an+      -- imported module.+      (mi, newModToSource, newDecodedModules) <- (either throwError pure =<<) $+           withoutCache $+           -- The cache should not be used for an imported module, and it+           -- should be restored after the module has been type-checked+           freshTCM $+             withImportPath ms $+             localTC (\e -> e+                              -- Andreas, 2014-08-18:+                              -- Preserve the range of import statement+                              -- for reporting termination errors in+                              -- imported modules:+                            { envRange              = range+                            , envCall               = call+                            }) $ do+               setDecodedModules ds+               setCommandLineOptions opts+               setInteractionOutputCallback ho+               stModuleToSource `setTCLens` mf+               setVisitedModules vs+               addImportedThings isig metas ibuiltin ipatsyns display+                 userwarn partialdefs empty opaqueblk opaqueid++               r  <- createInterface x file NotMainInterface msrc+               mf' <- useTC stModuleToSource+               ds' <- getDecodedModules+               return (r, mf', ds')++      stModuleToSource `setTCLens` newModToSource+      setDecodedModules newDecodedModules++      -- We skip the file which has just been type-checked to+      -- be able to forget some of the local state from+      -- checking the module.+      -- Note that this doesn't actually read the interface+      -- file, only the cached interface. (This comment is not+      -- correct, see+      -- test/Fail/customised/NestedProjectRoots.err.)+      validated <- runExceptT $ loadDecodedModule file mi++      -- NOTE: This attempts to type-check FOREVER if for some+      -- reason it continually fails to validate interface.+      let recheckOnError = \msg -> do+            alwaysReportSLn "import.iface" 1 $ "Failed to validate just-loaded interface: " ++ msg+            createInterfaceIsolated x file msrc++      either recheckOnError pure validated+++-- | Formats and outputs the "Checking", "Finished" and "Loading " messages.++chaseMsg+  :: String               -- ^ The prefix, like @Checking@, @Finished@, @Loading @.+  -> 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"+             && 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.++highlightFromInterface+  :: Interface+  -> SourceFile+     -- ^ The corresponding file.+  -> TCM ()+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.++readInterface :: InterfaceFile -> TCM (Maybe Interface)+readInterface file = do+    let ifp = filePath $ intFilePath file+    -- Decode the interface file+    (s, close) <- liftIO $ readBinaryFile' ifp+    do  mi <- liftIO . E.evaluate =<< decodeInterface s++        -- Close the file. Note+        -- ⑴ that evaluate ensures that i is evaluated to WHNF (before+        --   the next IO operation is executed), and+        -- ⑵ that decode returns Nothing if an error is encountered,+        -- so it is safe to close the file here.+        liftIO close++        return $ constructIScope <$> mi+      -- Catch exceptions and close+      `catchError` \e -> liftIO close >> handler e+  -- Catch exceptions+  `catchError` handler+  where+    handler = \case+      IOException _ _ e -> do+        alwaysReportSLn "" 0 $ "IO exception: " ++ show e+        return Nothing   -- Work-around for file locking bug.+                         -- TODO: What does this refer to? Please+                         -- document.+      e -> throwError e++-- | Writes the given interface to the given file.+--+-- The written interface is decoded and returned.++writeInterface :: AbsolutePath -> Interface -> TCM Interface+writeInterface file i = let fp = filePath file in do+    reportSLn "import.iface.write" 5  $+      "Writing interface file " ++ fp ++ "."+    -- Andreas, 2015-07-13+    -- After QName memoization (AIM XXI), scope serialization might be cheap enough.+    -- -- Andreas, Makoto, 2014-10-18 AIM XX:+    -- -- iInsideScope is bloating the interface files, so we do not serialize it?+    -- i <- return $+    --   i { iInsideScope  = emptyScopeInfo+    --     }+    -- [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 }+    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."+    fromMaybe __IMPOSSIBLE__ <$> (Bench.billTo [Bench.Deserialization] (decode encodedIface))+  `catchError` \e -> do+    alwaysReportSLn "" 1 $+      "Failed to write interface " ++ fp ++ "."+    liftIO $+      whenM (doesFileExist fp) $ removeFile fp+    throwError e++-- | Tries to type check a module and write out its interface. The+-- function only writes out an interface file if it does not encounter+-- any warnings.+--+-- If appropriate this function writes out syntax highlighting+-- information.++createInterface+  :: 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 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 mname $ Just fp)+       (const $ do ws <- getAllWarnings AllWarnings+                   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 sfi }) do++    let onlyScope = isMain == MainInterface ScopeCheck++    reportSLn "import.iface.create" 5 $+      "Creating interface for " ++ prettyShow mname ++ "..."+    verboseS "import.iface.create" 10 $ do+      visited <- prettyShow <$> getPrettyVisitedModules+      reportSLn "import.iface.create" 10 $ "  visited: " ++ visited++    src <- maybe (parseSource sf) pure msrc++    srcPath <- srcFilePath $ srcOrigin src++    fileTokenInfo <- Bench.billTo [Bench.Highlighting] $+      generateTokenInfoFromSource+        (let !top = srcModuleName src in+         mkRangeFile srcPath (Just top))+        (TL.unpack $ srcText src)+    stTokens `modifyTCLens` (fileTokenInfo <>)++    -- 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)+      highlightingLevel <- asksTC envHighlightingLevel+      reportSLn "import.iface.create" 15 $ unlines+        [ "  nesting      level: " ++ show nestingLevel+        , "  highlighting level: " ++ show highlightingLevel+        ]++    -- 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 (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.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.highlight" 15 $ prettyShow mname ++ ": Finished highlighting from scope."+++    -- Type checking.++    -- Now that all the options are in we can check if caching should+    -- be on.+    activateLoadedFileCache++    -- invalidate cache if pragmas change, TODO move+    cachingStarts+    opts <- useTC stPragmaOptions+    me <- readFromCachedLog+    case me of+      Just (Pragmas opts', _) | opts == opts'+        -> return ()+      _ -> do+        reportSLn "cache" 10 $ "pragma changed: " ++ show (isJust me)+        cleanCachedLog+    writeToCurrentLog $ Pragmas opts++    if onlyScope+      then do+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Skipping type checking."+        cacheCurrentLog+      else do+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Starting type checking."+        Bench.billTo [Bench.Typing] $ mapM_ checkDeclCached ds `finally_` cacheCurrentLog+        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.+    -- Ulf, 2013-11-13: Errors are now caught and highlighted in InteractionTop.+    -- catchError_ (checkDecls ds) $ \e -> do+    --   ifTopLevelAndHighlightingLevelIs NonInteractive $+    --     printErrorInfo e+    --   throwError e++    unfreezeMetas++    -- Profiling: Count number of metas.+    whenProfile Profile.Metas $ do+      m <- fresh+      tickN "metas" (fromIntegral (metaId m))++    -- Highlighting from type checker.+    reportSLn "import.iface.highlight" 15 $ prettyShow mname ++ ": Starting highlighting from type info."+    Bench.billTo [Bench.Highlighting] $ do++      -- Move any remaining token highlighting to stSyntaxInfo.+      toks <- useTC stTokens+      ifTopLevelAndHighlightingLevelIs NonInteractive $+        printHighlightingInfo KeepHighlighting toks+      stTokens `setTCLens` mempty++      -- Grabbing warnings and unsolved metas to highlight them+      warnings <- getAllWarnings AllWarnings+      unless (null warnings) $ reportSDoc "import.iface.highlight" 20 $+        "collected warnings: " <> prettyTCM warnings+      unsolved <- getAllUnsolvedWarnings+      unless (null unsolved) $ reportSDoc "import.iface.highlight" 20 $+        "collected unsolved: " <> prettyTCM unsolved+      let warningInfo =+            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" 15 $ prettyShow mname ++ ": Finished highlighting from type info."++    setScope scope+    reportSLn "scope.top" 50 $ "SCOPE " ++ show scope++    -- TODO: It would be nice if unsolved things were highlighted+    -- after every mutual block.++    openMetas <- getOpenMetas+    unless (null openMetas) $ do+      reportSLn "import.metas" 10 $ prettyShow mname ++ ": We have unsolved metas."+      reportSLn "import.metas" 10 =<< showGoals =<< getGoals++    ifTopLevelAndHighlightingLevelIs NonInteractive printUnsolvedInfo++    -- Andreas, 2016-08-03, issue #964+    -- When open metas are allowed,+    -- permanently freeze them now by turning them into postulates.+    -- This will enable serialization.+    -- savedMetaStore <- useTC stMetaStore+    unless (includeStateChanges isMain) $+      -- Andreas, 2018-11-15, re issue #3393:+      -- We do not get here when checking the main module+      -- (then includeStateChanges is True).+      whenM (optAllowUnsolved <$> pragmaOptions) $ do+        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.+        stAwakeConstraints    `setTCLens` []+        stSleepingConstraints `setTCLens` []++    -- Serialization.+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Starting serialization."+    i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $+      buildInterface src topLevel++    reportS "tc.top" 101 $+      "Signature:" :+      [ unlines+          [ prettyShow q+          , "  type: " ++ show (defType def)+          , "  def:  " ++ show cc+          ]+      | (q, def) <- HMap.toList $ iSignature i ^. sigDefinitions,+        Function{ funCompiled = cc } <- [theDef def]+      ]+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished serialization."++    mallWarnings <- getAllWarnings' isMain ErrorWarnings++    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 $ prettyShow mname ++ ": We have warnings, skipping writing interface file."+        return i+      (True, MainInterface ScopeCheck) -> do+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We are just scope-checking, skipping writing interface file."+        return i+      (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 sf+        serializedIface <- writeInterface ifile i+        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.+    -- Actually, we do not serialize the metas if checking the MainInterface+    -- stMetaStore `setTCLens` savedMetaStore++    -- Profiling: Print statistics.+    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+    reportSLn "import.iface" 25 $ prettyShow mname ++ ": Added statistics to the accumulated statistics."++    isPrimitiveMod <- isPrimitiveModule sfi++    return ModuleInfo+      { miInterface = finalIface+      , miWarnings = mallWarnings+      , miPrimitive = isPrimitiveMod+      , miMode = moduleCheckMode isMain+      }++-- | Expert version of 'getAllWarnings'; if 'isMain' is a+-- 'MainInterface', the warnings definitely include also unsolved+-- warnings.++getAllWarnings' :: (ReadTCState m, MonadWarning m, MonadTCM m) => MainInterface -> WhichWarnings -> m (Set TCWarning)+getAllWarnings' (MainInterface _) = getAllWarningsPreserving unsolvedWarnings+getAllWarnings' NotMainInterface  = getAllWarningsPreserving Set.empty++-- Andreas, issue 964: not checking null interactionPoints+-- anymore; we want to serialize with open interaction points now!++-- | Reconstruct the 'iScope' (not serialized)+--   from the 'iInsideScope' (serialized).++constructIScope :: Interface -> Interface+constructIScope i = billToPure [ Deserialization ] $+  i{ iScope = publicModules $ iInsideScope i }++-- | Builds an interface for the current module, which should already+--   have been successfully type checked.+buildInterface+  :: Source+     -- ^ 'Source' for the current module.+  -> TopLevelInfo+     -- ^ 'TopLevelInfo' scope information for the current module.+  -> TCM Interface+buildInterface src topLevel = do+    reportSLn "import.iface" 5 "Building interface..."+    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+    -- with discarding also the nameBindingSite in QName:+    -- Saves 10% on serialization time (and file size)!+    --+    -- NOTE: We no longer discard all nameBindingSites (but the commit+    -- 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).+    !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++    !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@!+getInterfaceFileHashes :: InterfaceFile -> IO (Maybe (Hash, Hash))+getInterfaceFileHashes fp = do+  let ifile = filePath $ intFilePath fp+  (s, close) <- readBinaryFile' ifile+  let hs = decodeHashes s+  maybe 0 (uncurry (+)) hs `seq` close+  return hs++moduleHash :: TopLevelModuleName -> TCM Hash+moduleHash m = iFullHash <$> getNonMainInterface m Nothing
src/full/Agda/Interaction/Imports.hs-boot view
@@ -1,9 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Imports where -import Agda.Syntax.Abstract.Name    ( ModuleName )-import Agda.Syntax.Scope.Base       ( Scope )-import Agda.TypeChecking.Monad.Base ( TCM )-import Data.Map                     ( Map )+import Data.Map                       ( Map ) -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)+import Agda.Syntax.Abstract.Name      ( ModuleName )+import Agda.Syntax.Scope.Base         ( Scope )+import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName )+import Agda.TypeChecking.Monad.Base   ( TCM )++scopeCheckImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)
src/full/Agda/Interaction/InteractionTop.hs view
@@ -1,1338 +1,1191 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ScopedTypeVariables   #-}--{-# OPTIONS_GHC -fno-cse #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.Interaction.InteractionTop-  ( module Agda.Interaction.InteractionTop-  )-  where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import qualified Control.Exception as E-import Control.Monad.Identity-import Control.Monad.Reader-import Control.Monad.State--import qualified Data.Char as Char-import Data.Foldable (Foldable)-import Data.Function-import Data.List as List hiding (null)-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Monoid-import Data.Traversable (Traversable)-import qualified Data.Traversable as Trav--import System.Directory-import System.FilePath--import Agda.TypeChecking.Monad as TM-  hiding (initState, setCommandLineOptions)-import qualified Agda.TypeChecking.Monad as TM-import qualified Agda.TypeChecking.Pretty as TCP-import Agda.TypeChecking.Errors--import Agda.Syntax.Fixity-import Agda.Syntax.Position-import Agda.Syntax.Parser-import Agda.Syntax.Common-import Agda.Syntax.Literal-import Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Generic as C-import Agda.Syntax.Concrete.Pretty ()-import Agda.Syntax.Abstract as A-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.Scope.Base--import Agda.Interaction.FindFile-import Agda.Interaction.Options-import Agda.Interaction.Options.Lenses as Lenses-import Agda.Interaction.MakeCase-import Agda.Interaction.SearchAbout-import Agda.Interaction.Response hiding (Function, ExtendedLambda)-import qualified Agda.Interaction.Response as R-import qualified Agda.Interaction.BasicOps as B-import Agda.Interaction.BasicOps hiding (whyInScope)-import Agda.Interaction.Highlighting.Precise hiding (Postulate)-import qualified Agda.Interaction.Imports as Imp-import Agda.Interaction.Highlighting.Generate-import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX-import qualified Agda.Interaction.Highlighting.Range as H--import Agda.Compiler.Common (IsMain (..))-import qualified Agda.Compiler.MAlonzo.Compiler as MAlonzo-import qualified Agda.Compiler.JS.Compiler as JS--import qualified Agda.Auto.Auto as Auto--import Agda.Utils.Except-  ( ExceptT-  , mkExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--import Agda.Utils.FileName-import Agda.Utils.Function-import Agda.Utils.Hash-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Lens-import Agda.Utils.Maybe-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty-import Agda.Utils.String-import Agda.Utils.Time--#include "undefined.h"-import Agda.Utils.Impossible------------------------------------------------ | Auxiliary state of an interactive computation.--data CommandState = CommandState-  { theInteractionPoints :: [InteractionId]-    -- ^ The interaction points of the buffer, in the order in which-    --   they appear in the buffer. The interaction points are-    --   recorded in 'theTCState', but when new interaction points are-    --   added by give or refine Agda does not ensure that the ranges-    --   of later interaction points are updated.-  , theCurrentFile       :: Maybe (AbsolutePath, ClockTime)-    -- ^ The file which the state applies to. Only stored if the-    -- module was successfully type checked (potentially with-    -- warnings). The 'ClockTime' is the modification time stamp of-    -- the file when it was last loaded.-  , optionsOnReload :: CommandLineOptions-    -- ^ Reset the options on each reload to these.-  , oldInteractionScopes :: !OldInteractionScopes-    -- ^ We remember (the scope of) old interaction points to make it-    --   possible to parse and compute highlighting information for the-    --   expression that it got replaced by.-  }--type OldInteractionScopes = Map InteractionId ScopeInfo---- | Initial auxiliary interaction state--initCommandState :: CommandState-initCommandState = CommandState-  { theInteractionPoints = []-  , theCurrentFile       = Nothing-  , optionsOnReload      = defaultOptions-  , oldInteractionScopes = Map.empty-  }----- | Monad for computing answers to interactive commands.------   'CommandM' is 'TCM' extended with state 'CommandState'.--type CommandM = StateT CommandState TCM---- | Restore both 'TCState' and 'CommandState'.--localStateCommandM :: CommandM a -> CommandM a-localStateCommandM m = do-  cSt <- get-  tcSt <- lift $ get-  x <- m-  lift $ put tcSt-  put cSt-  return x---- | Restore 'TCState', do not touch 'CommandState'.--liftLocalState :: TCM a -> CommandM a-liftLocalState = lift . localState---- | 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---- | Opposite of 'liftIO' for 'CommandM'.---   Use only if main errors are already catched.--commandMToIO :: (forall x . (CommandM a -> IO x) -> IO x) -> CommandM a-commandMToIO ci_i = revLift runStateT lift $ \ct -> revLift runSafeTCM liftIO $ ci_i . (. ct)---- | Lift a TCM action transformer to a CommandM action transformer.--liftCommandMT :: (forall a . TCM a -> TCM a) -> CommandM a -> CommandM a-liftCommandMT f m = revLift runStateT lift $ f . ($ m)---- | Ditto, but restore state.--liftCommandMTLocalState :: (forall a . TCM a -> TCM a) -> CommandM a -> CommandM a-liftCommandMTLocalState f = liftCommandMT f . localStateCommandM---- | Put a response by the callback function given by 'stInteractionOutputCallback'.--putResponse :: Response -> CommandM ()-putResponse = lift . appInteractionOutputCallback----- | A Lens for 'theInteractionPoints'.--modifyTheInteractionPoints :: ([InteractionId] -> [InteractionId]) -> CommandM ()-modifyTheInteractionPoints f = modify $ \ s ->-  s { theInteractionPoints = f (theInteractionPoints s) }----- * Operations for manipulating 'oldInteractionScopes'.---- | A Lens for 'oldInteractionScopes'.-modifyOldInteractionScopes :: (OldInteractionScopes -> OldInteractionScopes) -> CommandM ()-modifyOldInteractionScopes f = modify $ \ s ->-  s { oldInteractionScopes = f $ oldInteractionScopes s }--insertOldInteractionScope :: InteractionId -> ScopeInfo -> CommandM ()-insertOldInteractionScope ii scope = do-  lift $ reportSLn "interaction.scope" 20 $ "inserting old interaction scope " ++ show ii-  modifyOldInteractionScopes $ Map.insert ii scope--removeOldInteractionScope :: InteractionId -> CommandM ()-removeOldInteractionScope ii = do-  lift $ reportSLn "interaction.scope" 20 $ "removing old interaction scope " ++ show ii-  modifyOldInteractionScopes $ Map.delete ii--getOldInteractionScope :: InteractionId -> CommandM ScopeInfo-getOldInteractionScope ii = do-  ms <- gets $ Map.lookup ii . oldInteractionScopes-  case ms of-    Nothing    -> fail $ "not an old interaction point: " ++ show ii-    Just scope -> return scope---- | Do setup and error handling for a command.--handleCommand_ :: CommandM () -> CommandM ()-handleCommand_ = handleCommand id (return ())--handleCommand :: (forall a. CommandM a -> CommandM a) -> CommandM () -> CommandM () -> CommandM ()-handleCommand wrap onFail cmd = handleNastyErrors $ wrap $ do-    tcSt <- lift get--    -- -- Andreas, 2016-11-18 OLD CODE:-    -- -- onFail and handleErr are executed in "new" command state (not TCState).-    -- -- But it seems that if an exception is raised, it is identical to the old state,-    -- -- see code for catchErr.-    -- res <- (`catchErr` (return . Just)) $ Nothing <$ cmd-    -- maybe (return ()) (\ e -> onFail >> handleErr e) res--    -- Andreas, 2016-11-18 NEW CODE: execute onFail and handleErr in handler-    -- which means (looking at catchErr) they run in state s rathern than s'.-    -- Yet, it looks like s == s' in case the command failed.-    cmd `catchErr` \ e -> do-      onFail-      handleErr e-      -- Andreas, 2016-11-18, issue #2174-      -- Reset TCState after error is handled, to get rid of metas created during failed command-      lift $ put tcSt--  where-    -- Preserves state so we can do unsolved meta highlighting-    catchErr :: CommandM a -> (TCErr -> CommandM a) -> CommandM a-    catchErr m h = do-      s       <- get-      (x, s') <- lift $ do disableDestructiveUpdate (runStateT m s)-         `catchError_` \ e ->-           runStateT (h e) s-      put s'-      return x--    -- | Handle nasty errors like stack space overflow (issue 637)-    -- We assume that the input action handles other kind of errors.-    handleNastyErrors :: CommandM () -> CommandM ()-    handleNastyErrors m = commandMToIO $ \ toIO ->-        toIO m `E.catch` \ (e :: E.SomeException) ->-          toIO $ handleErr $ Exception noRange $ text $ show e--    -- | Displays an error and instructs Emacs to jump to the site of the-    -- error. Because this function may switch the focus to another file-    -- the status information is also updated.-    handleErr e = do-        unsolvedNotOK <- lift $ not . optAllowUnsolved <$> pragmaOptions-        meta    <- lift $ computeUnsolvedMetaWarnings-        constr  <- lift $ computeUnsolvedConstraints-        err     <- lift $ errorHighlighting e-        modFile <- lift $ use stModuleToSource-        let info = compress $ mconcat $-                     -- Errors take precedence over unsolved things.-                     err : if unsolvedNotOK then [meta, constr] else []-        s <- lift $ prettyError e-        x <- lift $ optShowImplicit <$> use stPragmaOptions-        unless (null s) $ mapM_ putResponse $-            [ Resp_DisplayInfo $ Info_Error s ] ++-            tellEmacsToJumpToError (getRange e) ++-            [ Resp_HighlightingInfo info modFile ] ++-            [ Resp_Status $ Status { sChecked = False-                                   , sShowImplicitArguments = x-                                   } ]---- | Run an 'IOTCM' value, catch the exceptions, emit output------   If an error happens the state of 'CommandM' does not change,---   but stPersistent may change (which contains successfully---   loaded interfaces for example).--runInteraction :: IOTCM -> CommandM ()-runInteraction (IOTCM current highlighting highlightingMethod cmd) =-  handleCommand inEmacs onFail $ do-    current <- liftIO $ absolute current-    -- Raises an error if the given file is not the one currently-    -- loaded.-    cf <- gets theCurrentFile-    when (not (independent cmd) && Just current /= (fst <$> cf)) $-        lift $ typeError $ GenericError "Error: First load the file."--    withCurrentFile $ interpret cmd--    cf <- gets theCurrentFile-    when (Just current == (fst <$> cf)) $-        putResponse . Resp_InteractionPoints =<< gets theInteractionPoints--  where-    inEmacs = liftCommandMT $ withEnv $ initEnv-            { envHighlightingLevel  = highlighting-            , envHighlightingMethod = highlightingMethod-            }--    -- If an independent command fails we should reset theCurrentFile (Issue853).-    onFail | independent cmd = modify $ \ s -> s { theCurrentFile = Nothing }-           | otherwise       = return ()--------------------------------------------------------------------------------- | An interactive computation.--type Interaction = Interaction' Range--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         Backend FilePath [String]--  | Cmd_constraints--    -- | Show unsolved metas. If there are no unsolved metas but unsolved constraints-    -- show those instead.-  | Cmd_metas--    -- | Display all warnings.-  | Cmd_warnings--    -- | Shows all the top-level names in the given module, along with-    -- their types. Uses the top-level scope.-  | Cmd_show_module_contents_toplevel-                        B.Rewrite-                        String--    -- | Shows all the top-level names in scope which mention all the given-    -- identifiers in their type.-  | Cmd_search_about_toplevel B.Rewrite String--    -- | Solve (all goals / the goal at point) whose values are determined by-    -- the constraints.-  | Cmd_solveAll B.Rewrite-  | Cmd_solveOne B.Rewrite InteractionId range String--    -- | Parse the given expression (as if it were defined at the-    -- top-level of the current module) and infer its type.-  | Cmd_infer_toplevel  B.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 B.ComputeMode-                         String--    -------------------------------------------------------------------------    -- Syntax highlighting--    -- | @cmd_load_highlighting_info source@ loads syntax highlighting-    -- information for the module in @source@, and asks Emacs to apply-    -- highlighting info from this file.-    ---    -- If the module does not exist, or its module name is malformed or-    -- cannot be determined, or the module has not already been visited,-    -- or the cached info is out of date, then no highlighting information-    -- is printed.-    ---    -- This command is used to load syntax highlighting information when a-    -- new file is opened, and it would probably be annoying if jumping to-    -- the definition of an identifier reset the proof state, so this-    -- command tries not to do that. One result of this is that the-    -- command uses the current include directories, whatever they happen-    -- to be.-  | Cmd_load_highlighting_info-                        FilePath--    -- | Tells Agda to compute highlighting information for the expression just-    --   spliced into an interaction point.-  | Cmd_highlight InteractionId range String--    -------------------------------------------------------------------------    -- Implicit arguments--    -- | Tells Agda whether or not to show implicit arguments.-  | ShowImplicitArgs    Bool -- Show them?---    -- | Toggle display of implicit arguments.-  | ToggleImplicitArgs--    -------------------------------------------------------------------------    -- | Goal commands-    ---    -- If the range is 'noRange', then the string comes from the-    -- minibuffer rather than the goal.--  | Cmd_give            InteractionId range String--  | Cmd_refine          InteractionId range String--  | Cmd_intro           Bool InteractionId range String--  | Cmd_refine_or_intro Bool InteractionId range String--  | Cmd_auto            InteractionId range String--  | Cmd_context         B.Rewrite InteractionId range String--  | Cmd_helper_function B.Rewrite InteractionId range String--  | Cmd_infer           B.Rewrite InteractionId range String--  | Cmd_goal_type       B.Rewrite InteractionId range String--    -- | Displays the current goal and context.-  | Cmd_goal_type_context B.Rewrite InteractionId range String--    -- | Displays the current goal and context /and/ infers the type of an-    -- expression.-  | Cmd_goal_type_context_infer-                        B.Rewrite InteractionId range String--    -- | Shows all the top-level names in the given module, along with-    -- their types. Uses the scope of the given goal.-  | Cmd_show_module_contents-                        B.Rewrite InteractionId range String--  | Cmd_make_case       InteractionId range String--  | Cmd_compute         B.ComputeMode-                        InteractionId range String--  | Cmd_why_in_scope    InteractionId range String-  | Cmd_why_in_scope_toplevel String-    -- | Displays version of the running Agda-  | Cmd_show_version-        deriving (Read, Functor, Foldable, Traversable)---type IOTCM = IOTCM' Range-data IOTCM' range-    = IOTCM-        FilePath-         -- -^ The current file. If this file does not match-         -- 'theCurrentFile, and the 'Interaction' is not-         -- \"independent\", then an error is raised.-        HighlightingLevel-        HighlightingMethod-        (Interaction' range)-         -- -^ What to do-            deriving (Read, Functor, Foldable, Traversable)-------------------------------------------------------------- Read instances----- | The 'Parse' monad.---   'StateT' state holds the remaining input.--type Parse a = ExceptT String (StateT String Identity) a---- | Converter from the type of 'reads' to 'Parse'---   The first paramter is part of the error message---   in case the parse fails.--readsToParse :: String -> (String -> Maybe (a, String)) -> Parse a-readsToParse s f = do-    st <- lift get-    case f st of-        Nothing -> throwError s-        Just (a, st) -> do-            lift $ put st-            return a--parseToReadsPrec :: Parse a -> Int -> String -> [(a, String)]-parseToReadsPrec p i s = case runIdentity . flip runStateT s . runExceptT $ parens' p of-    (Right a, s) -> [(a,s)]-    _ -> []---- | Demand an exact string.--exact :: String -> Parse ()-exact s = readsToParse (show s) $ fmap (\x -> ((),x)) . stripPrefix s . dropWhile (==' ')--readParse :: Read a => Parse a-readParse = readsToParse "read failed" $ listToMaybe . reads--parens' :: Parse a -> Parse a-parens' p = do-    exact "("-    x <- p-    exact ")"-    return x-  `mplus`-    p--instance Read InteractionId where-    readsPrec = parseToReadsPrec $-        fmap InteractionId readParse---- | Note that the grammar implemented by this instance does not--- necessarily match the current representation of ranges.--instance Read a => Read (Range' a) where-    readsPrec = parseToReadsPrec $-      (exact "intervalsToRange" >>-       liftM2 intervalsToRange readParse readParse)-        `mplus`-      (exact "noRange" >> return noRange)--instance Read a => Read (Interval' a) where-    readsPrec = parseToReadsPrec $ do-        exact "Interval"-        liftM2 Interval readParse readParse--instance Read AbsolutePath where-    readsPrec = parseToReadsPrec $ do-        exact "mkAbsolute"-        fmap mkAbsolute readParse--instance Read a => Read (Position' a) where-    readsPrec = parseToReadsPrec $ do-        exact "Pn"-        liftM4 Pn readParse readParse readParse readParse--------------------------------------------------------------- | Can the command run even if the relevant file has not been loaded---   into the state?--independent :: Interaction -> Bool-independent (Cmd_load {})                   = True-independent (Cmd_compile {})                = True-independent (Cmd_load_highlighting_info {}) = True-independent Cmd_show_version                = True-independent _                               = False---- | Interpret an interaction--interpret :: Interaction -> CommandM ()--interpret (Cmd_load m argv) =-  cmd_load' m argv True $ \_ -> interpret Cmd_metas--interpret (Cmd_compile b file argv) =-  cmd_load' file argv (b == LaTeX) $ \(i, mw) -> do-    mw <- lift $ Imp.applyFlagsToMaybeWarnings RespectFlags mw-    case mw of-      Imp.NoWarnings -> do-        lift $ case b of-          GHC       -> MAlonzo.compilerMain IsMain i-          GHCNoMain -> MAlonzo.compilerMain NotMain i-          JS        -> JS.compilerMain i-          LaTeX     -> LaTeX.generateLaTeX i-        display_info $ Info_CompilationOk-      Imp.SomeWarnings w ->-        display_info $ Info_Error $ unlines-          [ "You can only compile modules without unsolved metavariables"-          , "or termination checking problems."-          ]--interpret Cmd_constraints =-    display_info . Info_Constraints . unlines . map show =<< lift B.getConstraints--interpret Cmd_metas = do -- CL.showMetas []-  unsolvedNotOK <- lift $ not . optAllowUnsolved <$> pragmaOptions-  ms <- lift showOpenMetas-  (pwe, pwa) <- interpretWarnings-  display_info $ Info_AllGoalsWarnings (unlines ms) pwa pwe--interpret Cmd_warnings = do-  -- Ulf, 2016-08-09: Warnings are now printed in the info buffer by Cmd_metas.-  -- pws <- interpretWarnings-  -- unless (null pwd) $ display_info $ Info_Warning pws-  return ()---interpret (Cmd_show_module_contents_toplevel norm s) =-  liftCommandMT B.atTopLevel $ showModuleContents norm noRange s--interpret (Cmd_search_about_toplevel norm s) =-  liftCommandMT B.atTopLevel $ searchAbout norm noRange s--interpret (Cmd_solveAll norm)        = solveInstantiatedGoals norm Nothing-interpret (Cmd_solveOne norm ii _ _) = solveInstantiatedGoals norm' (Just ii)-  -- `solveOne` is called via `agda2-maybe-normalised` which does not use-  -- AsIs < Simplified < Normalised but rather Simplified < Instantiated < Normalised-  -- So we remap the Rewrite modifiers to match solveAll's behaviour.-  -- NB: instantiate is called in getSolvedInteractionPoints no matter what.-  where norm' = case norm of-                  Simplified   -> AsIs-                  Instantiated -> Simplified-                  _            -> norm--interpret (Cmd_infer_toplevel norm s) =-  parseAndDoAtToplevel (B.typeInCurrent norm) Info_InferredType s--interpret (Cmd_compute_toplevel cmode s) =-  parseAndDoAtToplevel' action Info_NormalForm $ computeWrapInput cmode s-  where-  action = allowNonTerminatingReductions-         . (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)-         . (B.showComputed cmode <=< B.evalInCurrent)---interpret (ShowImplicitArgs showImpl) = do-  opts <- lift commandLineOptions-  setCommandLineOpts $-    opts { optPragmaOptions =-             (optPragmaOptions opts) { optShowImplicit = showImpl } }--interpret ToggleImplicitArgs = do-  opts <- lift commandLineOptions-  let ps = optPragmaOptions opts-  setCommandLineOpts $-    opts { optPragmaOptions =-             ps { optShowImplicit = not $ optShowImplicit ps } }--interpret (Cmd_load_highlighting_info source) = do-    -- Make sure that the include directories have-    -- been set.-    setCommandLineOpts =<< lift commandLineOptions--    resp <- lift $ liftIO . tellToUpdateHighlighting =<< do-      ex <- liftIO $ doesFileExist source-      absSource <- liftIO $ absolute source-      case ex of-        False -> return Nothing-        True  -> do-          mmi <- (getVisitedModule =<<-                    moduleName absSource)-                   `catchError`-                 \_ -> return Nothing-          case mmi of-            Nothing -> return Nothing-            Just mi -> do-              sourceH <- liftIO $ hashFile absSource-              if sourceH == iSourceHash (miInterface mi)-               then do-                modFile <- use stModuleToSource-                return $ Just (iHighlighting $ miInterface mi, modFile)-               else-                return Nothing-    mapM_ putResponse resp--interpret (Cmd_highlight ii rng s) = do-  scope <- getOldInteractionScope ii-  removeOldInteractionScope ii-  handle $ do-    e <- try ("Highlighting failed to parse expression in " ++ show ii) $-           B.parseExpr rng s-    e <- try ("Highlighting failed to scope check expression in " ++ show ii) $-           concreteToAbstract scope e-    lift $ printHighlightingInfo =<< generateTokenInfoFromString rng s-    lift $ highlightExpr e-  where-    handle :: ExceptT String TCM () -> CommandM ()-    handle m = do-      res <- lift $ runExceptT m-      case res of-        Left s  -> display_info $ Info_Error s-        Right _ -> return ()-    try :: String -> TCM a -> ExceptT String TCM a-    try err m = mkExceptT $ do-      (Right <$> m) `catchError` \ _ -> return (Left err)--interpret (Cmd_give   ii rng s) = give_gen ii rng s Give-interpret (Cmd_refine ii rng s) = give_gen ii rng s Refine--interpret (Cmd_intro pmLambda ii rng _) = do-  ss <- lift $ B.introTactic pmLambda ii-  liftCommandMT (B.withInteractionId ii) $ case ss of-    []    -> do-      display_info $ Info_Intro $ text "No introduction forms found."-    [s]   -> give_gen ii rng s Intro-    _:_:_ -> do-      display_info $ Info_Intro $-        sep [ text "Don't know which constructor to introduce of"-            , let mkOr []     = []-                  mkOr [x, y] = [text x <+> text "or" <+> text y]-                  mkOr (x:xs) = text x : mkOr xs-              in nest 2 $ fsep $ punctuate comma (mkOr ss)-            ]--interpret (Cmd_refine_or_intro pmLambda ii r s) = interpret $-  let s' = trim s-  in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s'--interpret (Cmd_auto ii rng s) = 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 <- lift $ get-  (res, msg) <- lift $ Auto.auto ii rng s-  case res of-   Left xs -> do-    lift $ reportSLn "auto" 10 $ "Auto produced the following solutions " ++ show xs-    forM_ xs $ \(ii, s) -> 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 (put 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 s-    -- Andreas, 2014-07-07: Remove the interaction points in one go.-    modifyTheInteractionPoints (\\ (map fst xs))-    case msg of-     Nothing -> interpret Cmd_metas-     Just msg -> display_info $ Info_Auto msg-   Right (Left cs) -> do-    case msg of-     Nothing -> return ()-     Just msg -> display_info $ Info_Auto msg-    putResponse $ Resp_MakeCase R.Function cs-   Right (Right s) -> give_gen ii rng s Refine--interpret (Cmd_context norm ii _ _) =-  display_info . Info_Context =<< liftLocalState (prettyContext norm False ii)--interpret (Cmd_helper_function norm ii rng s) =-  display_info . Info_HelperFunction =<< liftLocalState (cmd_helper_function norm ii rng s)--interpret (Cmd_infer norm ii rng s) =-  display_info . Info_InferredType-    =<< liftLocalState (B.withInteractionId ii-          (prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s))--interpret (Cmd_goal_type norm ii _ _) =-  display_info . Info_CurrentGoal-    =<< liftLocalState (B.withInteractionId ii $ prettyTypeOfMeta norm ii)--interpret (Cmd_goal_type_context norm ii rng s) =-  cmd_goal_type_context_and empty norm ii rng s--interpret (Cmd_goal_type_context_infer norm ii rng s) = do-  -- In case of the empty expression to type, don't fail with-  -- a stupid parse error, but just fall back to-  -- Cmd_goal_type_context.-  have <- if all Char.isSpace s then return empty else liftLocalState $ do-    typ <- B.withInteractionId ii $-      prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s-    return $ text "Have:" <+> typ-  cmd_goal_type_context_and have norm ii rng s--interpret (Cmd_show_module_contents norm ii rng s) =-  liftCommandMT (B.withInteractionId ii) $ showModuleContents norm rng s--interpret (Cmd_why_in_scope_toplevel s) =-  liftCommandMT B.atTopLevel $ whyInScope s--interpret (Cmd_why_in_scope ii rng s) =-  liftCommandMT (B.withInteractionId ii) $ whyInScope s--interpret (Cmd_make_case ii rng s) = do-  (f, casectxt, cs) <- lift $ makeCase ii rng s-  liftCommandMT (B.withInteractionId ii) $ do-    hidden <- lift $ showImplicitArguments-    tel <- lift $ lookupSection (qnameModule f) -- don't shadow the names in this telescope-    let cs'  :: [A.Clause] = List.map (extlam_dropLLifted casectxt hidden) cs-    pcs      :: [Doc]     <- lift $ inTopContext $ addContext tel $ mapM prettyA cs'-    let pcs' :: [String]   = List.map (extlam_dropName casectxt . render) pcs-    lift $ reportSDoc "interaction.case" 60 $ TCP.vcat-      [ TCP.text "InteractionTop.Cmd_make_case"-      , TCP.nest 2 $ TCP.vcat-        [ TCP.text "cs   = " TCP.<+> TCP.vcat (map prettyA cs)-        , TCP.text "cs'  = " TCP.<+> TCP.vcat (map prettyA cs')-        , TCP.text "pcs  = " TCP.<+> TCP.vcat (map return pcs)-        , TCP.text "pcs' = " TCP.<+> TCP.vcat (map TCP.text pcs')-        ]-      ]-    putResponse $ Resp_MakeCase (makeCaseVariant casectxt) pcs'-  where-    render = 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 :: CaseContext -> String -> String-    extlam_dropName Nothing x = x-    extlam_dropName Just{}  x-        = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x-      where-        replEquals ("=" : ws) = "→" : ws-        replEquals (w   : ws) = w : replEquals ws-        replEquals []         = []--    -- Drops pattern added to extended lambda functions when lambda lifting them-    extlam_dropLLifted :: CaseContext -> Bool -> A.Clause -> A.Clause-    extlam_dropLLifted Nothing _ x = x-    extlam_dropLLifted _ _ (A.Clause (A.LHS _ A.LHSProj{} _) _ _ _ _) = __IMPOSSIBLE__-    extlam_dropLLifted (Just (ExtLamInfo h nh)) hidden (A.Clause (A.LHS info (A.LHSHead name nps) ps) dots rhs decl catchall)-      = let n = if hidden then h + nh else nh-        in-         (A.Clause (A.LHS info (A.LHSHead name (drop n nps)) ps) dots rhs decl catchall)--interpret (Cmd_compute cmode ii rng s) = display_info . Info_NormalForm =<< do-  liftLocalState $ do-    e <- B.parseExprIn ii rng $ computeWrapInput cmode s-    B.withInteractionId ii $ do-      showComputed cmode =<< do applyWhen (computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent e---interpret Cmd_show_version = display_info Info_Version---- | Show warnings-interpretWarnings :: CommandM (String, String)-interpretWarnings = do-  mws <- lift $ Imp.getAllWarnings Imp.AllWarnings RespectFlags-  case filter isNotMeta <$> mws of-    Imp.SomeWarnings ws@(_:_) -> do-      let (we, wa) = Imp.classifyWarnings ws-      pwe <- lift $ prettyTCWarnings we-      pwa <- lift $ prettyTCWarnings wa-      return (pwe, pwa)-    _ -> return ("", "")-   where isNotMeta w = case tcWarning w of-                         UnsolvedInteractionMetas{} -> False-                         UnsolvedMetaVariables{}    -> False-                         _                          -> True----- | Solved goals already instantiated internally--- The second argument potentially limits it to one specific goal.-solveInstantiatedGoals :: B.Rewrite -> Maybe InteractionId -> CommandM ()-solveInstantiatedGoals norm mii = do-  -- Andreas, 2016-10-23 issue #2280: throw away meta elims.-  out <- lift $ local (\ e -> e { envPrintMetasBare = True }) $ do-    sip <- B.getSolvedInteractionPoints False norm-           -- only solve metas which have a proper instantiation, i.e., not another meta-    maybe id (\ ii -> filter ((ii ==) . fst)) mii <$> mapM prt sip-  putResponse $ Resp_SolveAll out-  where-      prt (i, m, e) = do-        mi <- getMetaInfo <$> lookupMeta m-        e <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e-        return (i, e)----- | Print open metas nicely.-showOpenMetas :: TCM [String]-showOpenMetas = do-  ims <- B.typesOfVisibleMetas B.AsIs-  di <- forM ims $ \ i ->-    B.withInteractionId (B.outputFormId $ B.OutputForm noRange [] i) $-      showATop i-  -- Show unsolved implicit arguments simplified.-  unsolvedNotOK <- not . optAllowUnsolved <$> pragmaOptions-  hms <- (guard unsolvedNotOK >>) <$> B.typesOfHiddenMetas B.Simplified-  dh <- mapM showA' hms-  return $ di ++ dh-  where-    metaId (B.OfType i _) = i-    metaId (B.JustType i) = i-    metaId (B.JustSort i) = i-    metaId (B.Assign i e) = i-    metaId _ = __IMPOSSIBLE__-    showA' :: B.OutputConstraint A.Expr NamedMeta -> TCM String-    showA' m = do-      let i = nmid $ metaId m-      r <- getMetaRange i-      d <- B.withMetaId i (showATop m)-      return $ d ++ "  [ at " ++ show r ++ " ]"----- | @cmd_load' file argv unsolvedOk cmd@---   loads the module in file @file@,---   using @argv@ as the command-line options.------ If type checking completes without any exceptions having been--- encountered then the command @cmd r@ is executed, where @r@ is the--- result of 'Imp.typeCheckMain'.--cmd_load' :: FilePath -> [String]-          -> Bool -- ^ Allow unsolved meta-variables?-          -> ((Interface, Imp.MaybeWarnings) -> CommandM ())-          -> CommandM ()-cmd_load' file argv unsolvedOK cmd = do-    f <- liftIO $ absolute file-    ex <- liftIO $ doesFileExist $ filePath f-    let relativeTo | ex        = ProjectRoot f-                   | otherwise = CurrentDir--    -- Forget the previous "current file" and interaction points.-    modify $ \st -> st { theInteractionPoints = []-                       , theCurrentFile       = Nothing-                       }--    t <- liftIO $ getModificationTime file--    -- All options are reset when a file is reloaded, including the-    -- choice of whether or not to display implicit arguments.-    opts0 <- gets optionsOnReload-    z <- liftIO $ runOptM $ parseStandardOptions' argv opts0-    case z of-      Left err   -> lift $ typeError $ GenericError err-      Right opts -> do-        let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}-        lift $ TM.setCommandLineOptions' relativeTo $ mapPragmaOptions update opts-        displayStatus--    -- Reset the state, preserving options and decoded modules. Note-    -- that if the include directories have changed, then the decoded-    -- modules are reset when cmd_load' is run by ioTCM.-    lift resetState--    -- Clear the info buffer to make room for information about which-    -- module is currently being type-checked.-    putResponse Resp_ClearRunningInfo--    -- Remove any prior syntax highlighting.-    putResponse Resp_ClearHighlighting--    -- We activate the cache only when agda is used interactively-    lift activateLoadedFileCache--    ok <- lift $ Imp.typeCheckMain f--    -- The module type checked. If the file was not changed while the-    -- type checker was running then the interaction points and the-    -- "current file" are stored.-    t' <- liftIO $ getModificationTime file-    when (t == t') $ do-      is <- lift $ sortInteractionPoints =<< getInteractionPoints-      modify $ \st -> st { theInteractionPoints = is-                         , theCurrentFile       = Just (f, t)-                         }--    cmd ok---- | Set 'envCurrentPath' to 'theCurrentFile', if any.-withCurrentFile :: CommandM a -> CommandM a-withCurrentFile m = do-  mfile <- fmap fst <$> gets theCurrentFile-  local (\ e -> e { envCurrentPath = mfile }) m---- | Available backends.--data Backend = GHC-             | GHCNoMain-             | JS-             | LaTeX-    deriving (Show, Read, Eq)--data GiveRefine = Give | Refine | Intro-  deriving (Eq, Show)---- | A "give"-like action (give, refine, etc).------   @give_gen ii rng s give_ref mk_newtxt@---   acts on interaction point @ii@---   occupying range @rng@,---   placing the new content given by string @s@,---   and replacing @ii@ by the newly created interaction points---   in the state.-give_gen-  :: InteractionId-  -> Range-  -> String-  -> GiveRefine-  -> CommandM ()-give_gen ii rng s0 giveRefine = do-  let s = trim s0-  lift $ reportSLn "interaction.give" 20 $ "give_gen  " ++ s-  -- Andreas, 2015-02-26 if string is empty do nothing rather-  -- than giving a parse error.-  unless (null s) $ do-    let give_ref =-          case giveRefine of-            Give   -> B.give-            Refine -> B.refine-            Intro  -> B.refine-    -- save scope of the interaction point (for printing the given expr. later)-    scope     <- lift $ getInteractionScope ii-    -- parse string and "give", obtaining an abstract expression-    -- and newly created interaction points-    (time, (ae, ae0, iis)) <- maybeTimed $ lift $ do-        mis  <- getInteractionPoints-        reportSLn "interaction.give" 30 $ "interaction points before = " ++ show mis-        given <- B.parseExprIn ii rng s-        ae    <- give_ref ii Nothing given-        mis' <- getInteractionPoints-        reportSLn "interaction.give" 30 $ "interaction points after = " ++ show mis'-        return (ae, given, mis' \\ mis)-    -- favonia: backup the old scope for highlighting-    insertOldInteractionScope ii scope-    -- sort the new interaction points and put them into the state-    -- in replacement of the old interaction point-    iis       <- lift $ sortInteractionPoints iis-    modifyTheInteractionPoints $ replace ii iis-    -- print abstract expr-    ce        <- lift $ abstractToConcreteEnv (makeEnv scope) ae-    lift $ reportSLn "interaction.give" 30 $ unlines-      [ "ce = " ++ show ce-      , "scopePrecedence = " ++ show (scopePrecedence scope)-      ]-    -- 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-    -- without arguments.  Then there are no interaction metas, but-    -- we still cannot just `give' the user string (which may be empty).-    -- WRONG: also, if no interaction metas were created by @Refine@-    -- WRONG: let literally = (giveRefine == Give || null iis) && rng /= noRange-    -- Ulf, 2015-03-30, if we're doing intro we can't do literal give since-    -- there is nothing in the hole (issue 1892).-    let literally = giveRefine /= Intro && ae == ae0 && rng /= noRange-    -- Ulf, 2014-01-24: This works for give since we're highlighting the string-    -- that's already in the buffer. Doing it before the give action means that-    -- the highlighting is moved together with the text when the hole goes away.-    -- To make it work for refine we'd have to adjust the ranges.-    when literally $ lift $ do-      printHighlightingInfo =<< generateTokenInfoFromString rng s-      highlightExpr ae-    putResponse $ Resp_GiveAction ii $ mkNewTxt literally ce-    lift $ reportSLn "interaction.give" 30 $ "putResponse GiveAction passed"-    -- display new goal set (if not measuring time)-    maybe (interpret Cmd_metas) (display_info . Info_Time) time-    lift $ reportSLn "interaction.give" 30 $ "interpret Cmd_metas passed"-  where-    -- Substitutes xs for x in ys.-    replace x xs ys = concatMap (\ y -> if y == x then xs else [y]) ys-    -- For @Give@ we can replace the ii by the user given input.-    mkNewTxt True  C.Paren{} = Give_Paren-    mkNewTxt True  _         = Give_NoParen-    -- Otherwise, we replace it by the reified value Agda computed.-    mkNewTxt False ce        = Give_String $ show ce--highlightExpr :: A.Expr -> TCM ()-highlightExpr e =-  local (\e -> e { envModuleNestingLevel = 0-                 , envHighlightingLevel  = NonInteractive-                 , envHighlightingMethod = Direct }) $-    generateAndPrintSyntaxInfo decl Full-  where-    dummy = mkName_ (NameId 0 0) "dummy"-    info  = mkDefInfo (nameConcrete dummy) noFixity' PublicAccess ConcreteDef (getRange e)-    decl  = A.Axiom NoFunSig info defaultArgInfo Nothing (qnameFromList [dummy]) e---- | Sorts interaction points based on their ranges.--sortInteractionPoints :: [InteractionId] -> TCM [InteractionId]-sortInteractionPoints is =-  map fst . sortBy (compare `on` snd) <$> do-    forM is $ \ i -> do-      (i,) <$> getInteractionRange i---- | Pretty-prints the type of the meta-variable.--prettyTypeOfMeta :: B.Rewrite -> InteractionId -> TCM Doc-prettyTypeOfMeta norm ii = do-  form <- B.typeOfMeta norm ii-  case form of-    B.OfType _ e -> prettyATop e-    _            -> text <$> showATop form---- | Pretty-prints the context of the given meta-variable.--prettyContext-  :: B.Rewrite      -- ^ Normalise?-  -> Bool           -- ^ Print the elements in reverse order?-  -> InteractionId-  -> TCM Doc-prettyContext norm rev ii = B.withInteractionId ii $ do-  ctx <- B.contextOfMeta ii norm-  es  <- mapM (prettyATop . B.ofExpr) ctx-  ns  <- mapM (showATop   . B.ofName) ctx-  return $ align 10 $ applyWhen rev reverse $-    filter (not . null . fst) $ zip ns $ map (text ":" <+>) es---- | Create type of application of new helper function that would solve the goal.--cmd_helper_function :: B.Rewrite -> InteractionId -> Range -> String -> TCM Doc-cmd_helper_function norm ii r s = B.withInteractionId ii $ inTopContext $-  prettyATop =<< B.metaHelperType norm ii r s---- | Displays the current goal, the given document, and the current---   context.------   Should not modify the state.--cmd_goal_type_context_and :: Doc -> B.Rewrite -> InteractionId -> Range ->-                             String -> StateT CommandState (TCMT IO) ()-cmd_goal_type_context_and doc norm ii _ _ = display_info . Info_GoalType =<< do-  lift $ do-    goal <- B.withInteractionId ii $ prettyTypeOfMeta norm ii-    ctx  <- prettyContext norm True ii-    return $ vcat-      [ text "Goal:" <+> goal-      , doc-      , text (replicate 60 '\x2014')-      , ctx-      ]---- | Shows all the top-level names in the given module, along with--- their types.--showModuleContents :: B.Rewrite -> Range -> String -> CommandM ()-showModuleContents norm rng s = display_info . Info_ModuleContents =<< do-  liftLocalState $ do-    (modules, types) <- B.moduleContents norm rng s-    types' <- forM types $ \ (x, t) -> do-      t <- TCP.prettyTCM t-      return (show x, text ":" <+> t)-    return $ vcat-      [ text "Modules"-      , nest 2 $ vcat $ map (text . show) modules-      , text "Names"-      , nest 2 $ align 10 types'-      ]---- | Shows all the top-level names in scope which mention all the given--- identifiers in their type.--searchAbout :: B.Rewrite -> Range -> String -> CommandM ()-searchAbout norm rg nm = do-  let tnm = trim nm-  unless (null tnm) $ do-    fancy <- lift $ B.atTopLevel $ do-       hits <- findMentions norm rg tnm-       forM hits $ \ (x, t) -> do-         t <- TCP.prettyTCM t-         return (show x, text ":" <+> t)-    display_info $ Info_SearchAbout $-      text "Definitions about" <+> text (intercalate ", " $ words nm) $$-      nest 2 (align 10 fancy)---- | Explain why something is in scope.--whyInScope :: String -> CommandM ()-whyInScope s = display_info . Info_WhyInScope =<< do-  Just (file, _) <- gets theCurrentFile-  let cwd = takeDirectory $ filePath file-  liftLocalState $ do-    (v, xs, ms) <- B.whyInScope s-    explanation cwd v xs ms-  where-    explanation _ Nothing [] [] = TCP.text (s ++ " is not in scope.")-    explanation cwd v xs ms = TCP.vcat-      [ TCP.text (s ++ " is in scope as")-      , TCP.nest 2 $ TCP.vcat [variable v xs, modules ms]-      ]-      where-        prettyRange :: Range -> TCM Doc-        prettyRange r = text . show . (fmap . fmap) mkRel <$> do-          return r-        mkRel = Str . makeRelative cwd . filePath--        -- variable :: Maybe _ -> [_] -> TCM Doc-        variable Nothing xs = names xs-        variable (Just x) xs-          | null xs   = asVar-          | otherwise = TCP.vcat-             [ TCP.sep [ asVar, TCP.nest 2 $ shadowing x]-             , TCP.nest 2 $ names xs-             ]-          where-            asVar :: TCM Doc-            asVar = do-              TCP.text "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x)-            shadowing :: LocalVar -> TCM Doc-            shadowing LocalVar{}    = TCP.text "shadowing"-            shadowing ShadowedVar{} = TCP.text "in conflict with"-        names   xs = TCP.vcat $ map pName xs-        modules ms = TCP.vcat $ map pMod ms--        pKind DefName        = TCP.text "defined name"-        pKind ConName        = TCP.text "constructor"-        pKind FldName        = TCP.text "record field"-        pKind PatternSynName = TCP.text "pattern synonym"-        pKind MacroName      = TCP.text "macro name"-        pKind QuotableName   = TCP.text "quotable name"--        pName :: AbstractName -> TCM Doc-        pName a = TCP.sep-          [ TCP.text "* a"-            TCP.<+> pKind (anameKind a)-            TCP.<+> TCP.text (prettyShow $ anameName a)-          , TCP.nest 2 $ TCP.text "brought into scope by"-          ] TCP.$$-          TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))-        pMod :: AbstractModule -> TCM Doc-        pMod  a = TCP.sep-          [ TCP.text "* a module" TCP.<+> TCP.text (prettyShow $ amodName a)-          , TCP.nest 2 $ TCP.text "brought into scope by"-          ] TCP.$$-          TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))--        pWhy :: Range -> WhyInScope -> TCM Doc-        pWhy r Defined = TCP.text "- its definition at" TCP.<+> TCP.prettyTCM r-        pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w-        pWhy r (Opened m w) =-          TCP.text "- the opening of"-          TCP.<+> TCP.text (show m)-          TCP.<+> TCP.text "at"-          TCP.<+> TCP.prettyTCM (getRange m)-          TCP.$$-          pWhy r w-        pWhy r (Applied m w) =-          TCP.text "- the application of"-          TCP.<+> TCP.text (show m)-          TCP.<+> TCP.text "at"-          TCP.<+> TCP.prettyTCM (getRange m)-          TCP.$$-          pWhy r w---- | Sets the command line options and updates the status information.--setCommandLineOpts :: CommandLineOptions -> CommandM ()-setCommandLineOpts opts = do-    lift $ TM.setCommandLineOptions opts-    displayStatus----- | Computes some status information.------   Does not change the state.--status :: CommandM Status-status = do-  cf <- gets theCurrentFile-  showImpl <- lift showImplicitArguments--  -- Check if the file was successfully type checked, and has not-  -- 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 (f, t) -> do-      t' <- liftIO $ getModificationTime $ filePath f-      case t == t' of-        False -> return False-        True  -> do-          mm <- lookupModuleFromSource f-          case mm of-            Nothing -> return False -- work-around for Issue1007-            Just m  -> not . miWarnings . fromMaybe __IMPOSSIBLE__ <$> getVisitedModule m--  return $ Status { sShowImplicitArguments = showImpl-                  , sChecked               = checked-                  }---- | Displays or updates status information.------   Does not change the state.--displayStatus :: CommandM ()-displayStatus =-  putResponse . Resp_Status  =<< status---- | @display_info@ does what @'display_info'' False@ does, but---   additionally displays some status information (see 'status' and---   'displayStatus').--display_info :: DisplayInfo -> CommandM ()-display_info info = do-  displayStatus-  putResponse $ Resp_DisplayInfo info--refreshStr :: [String] -> String -> ([String], String)-refreshStr taken s = go nameModifiers where-  go (m:mods) = let s' = s ++ m in-                if s' `elem` taken then go mods else (s':taken, s')-  go _        = __IMPOSSIBLE__--nameModifiers :: [String]-nameModifiers = "" : "'" : "''" : [show i | i <-[3..]]----- | Parses and scope checks an expression (using the \"inside scope\"--- as the scope), performs the given command with the expression as--- input, and displays the result.--parseAndDoAtToplevel'-  :: (A.Expr -> TCM Doc)-     -- ^ The command to perform.-  -> (Doc -> DisplayInfo)-     -- ^ The name to use for the buffer displaying the output.-  -> String-     -- ^ The expression to parse.-  -> CommandM ()-parseAndDoAtToplevel' cmd title s = do-  (time, res) <- localStateCommandM $ do-    e <- lift $ runPM $ parse exprParser s-    maybeTimed (lift $ B.atTopLevel $-                cmd =<< concreteToAbstract_ e)-  display_info (title $ fromMaybe empty time $$ res)--parseAndDoAtToplevel :: (A.Expr -> TCM A.Expr) -> (Doc -> DisplayInfo) -> String -> CommandM ()-parseAndDoAtToplevel cmd = parseAndDoAtToplevel' (prettyA <=< cmd)--maybeTimed :: CommandM a -> CommandM (Maybe Doc, a)-maybeTimed work = do-  doTime <- lift $ hasVerbosity "profile.interactive" 10-  if not doTime then (Nothing,) <$> work else do-    (r, time) <- measureTime work-    return (Just $ text "Time:" <+> pretty time, r)---- | Tell to highlight the code using the given highlighting--- info (unless it is @Nothing@).--tellToUpdateHighlighting-  :: Maybe (HighlightingInfo, ModuleToSource) -> IO [Response]-tellToUpdateHighlighting Nothing                = return []-tellToUpdateHighlighting (Just (info, modFile)) =-  return [Resp_HighlightingInfo info modFile]---- | Tells the Emacs mode to go to the first error position (if any).--tellEmacsToJumpToError :: Range -> [Response]-tellEmacsToJumpToError r =-  case rStart r of-    Nothing                                           -> []-    Just (Pn { srcFile = Strict.Nothing })            -> []-    Just (Pn { srcFile = Strict.Just f, posPos = p }) ->-       [ Resp_JumpToError (filePath f) p ]+{-# LANGUAGE NondecreasingIndentation #-}+{-# OPTIONS_GHC -fno-cse #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Agda.Interaction.InteractionTop+  ( module Agda.Interaction.InteractionTop+  )+  where++import Prelude hiding (null)++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TVar+import qualified Control.Exception  as E++import Control.Monad.Except         ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.IO.Class       ( MonadIO(..) )+import Control.Monad.State          ( MonadState(..), gets, modify, runStateT )+import Control.Monad.STM+import Control.Monad.State          ( StateT )++import qualified Data.Char as Char+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+import qualified Agda.TypeChecking.Pretty as TCP+import Agda.TypeChecking.Errors+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+import Agda.Syntax.Parser+import Agda.Syntax.Common+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Glyph+import Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pretty+import Agda.Syntax.Info (mkDefInfo)+import Agda.Syntax.Translation.ConcreteToAbstract+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+import Agda.Interaction.MakeCase+import Agda.Interaction.SearchAbout+import Agda.Interaction.Response hiding (Function, ExtendedLambda)+import qualified Agda.Interaction.Response as R+import qualified Agda.Interaction.BasicOps as B+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.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.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++-- | Opposite of 'liftIO' for 'CommandM'.+--+-- This function should only be applied to computations that are+-- guaranteed not to raise any errors (except for 'IOException's).++commandMToIO :: (forall x . (CommandM a -> IO x) -> IO x) -> CommandM a+commandMToIO ci_i = revLift runStateT lift $ \ct -> revLiftTC runSafeTCM liftIO $ ci_i . (. ct)++-- | Lift a TCM action transformer to a CommandM action transformer.++liftCommandMT :: (forall x . TCM x -> TCM x) -> CommandM a -> CommandM a+liftCommandMT f m = revLift runStateT lift $ f . ($ m)++-- | Ditto, but restore state.++liftCommandMTLocalState :: (forall x . TCM x -> TCM x) -> CommandM a -> CommandM a+liftCommandMTLocalState f = liftCommandMT f . localStateCommandM++-- | Put a response by the callback function given by 'stInteractionOutputCallback'.++putResponse :: Response -> CommandM ()+putResponse = lift . appInteractionOutputCallback+++-- | A Lens for 'theInteractionPoints'.++modifyTheInteractionPoints :: ([InteractionId] -> [InteractionId]) -> CommandM ()+modifyTheInteractionPoints f = modify $ \ s ->+  s { theInteractionPoints = f (theInteractionPoints s) }+++-- * Operations for manipulating 'oldInteractionScopes'.++-- | A Lens for 'oldInteractionScopes'.+modifyOldInteractionScopes :: (OldInteractionScopes -> OldInteractionScopes) -> CommandM ()+modifyOldInteractionScopes f = modify $ \ s ->+  s { oldInteractionScopes = f $ oldInteractionScopes s }++insertOldInteractionScope :: InteractionId -> ScopeInfo -> CommandM ()+insertOldInteractionScope ii scope = do+  lift $ reportSLn "interaction.scope" 20 $ "inserting old interaction scope " ++ show ii+  modifyOldInteractionScopes $ Map.insert ii scope++removeOldInteractionScope :: InteractionId -> CommandM ()+removeOldInteractionScope ii = do+  lift $ reportSLn "interaction.scope" 20 $ "removing old interaction scope " ++ show ii+  modifyOldInteractionScopes $ Map.delete ii++getOldInteractionScope :: InteractionId -> CommandM ScopeInfo+getOldInteractionScope ii = do+  ms <- gets $ Map.lookup ii . oldInteractionScopes+  case ms of+    Nothing    -> __IMPOSSIBLE_VERBOSE__ $ "not an old interaction point: " ++ show ii+    Just scope -> return scope++-- | Do setup and error handling for a command.++handleCommand_ :: CommandM () -> CommandM ()+handleCommand_ = handleCommand id (return ())++handleCommand :: (forall a. CommandM a -> CommandM a) -> CommandM () -> CommandM () -> CommandM ()+handleCommand wrap onFail cmd = handleNastyErrors $ wrap $ do+    oldState <- getTC++    -- -- Andreas, 2016-11-18 OLD CODE:+    -- -- onFail and handleErr are executed in "new" command state (not TCState).+    -- -- But it seems that if an exception is raised, it is identical to the old state,+    -- -- see code for catchErr.+    -- res <- (`catchErr` (return . Just)) $ Nothing <$ cmd+    -- maybe (return ()) (\ e -> onFail >> handleErr e) res++    -- Andreas, 2016-11-18 NEW CODE: execute onFail and handleErr in handler+    -- which means (looking at catchErr) they run in state s rathern than s'.+    -- Yet, it looks like s == s' in case the command failed.+    cmd `catchErr` \ e -> do+      onFail+      handleErr Nothing e+      -- Andreas, 2016-11-18, issue #2174+      -- Reset TCState after error is handled, to get rid of metas created during failed command+      lift $ do+        newPersistentState <- useTC lensPersistentState+        putTC oldState+        lensPersistentState `setTCLens` newPersistentState++  where+    -- Preserves state so we can do unsolved meta highlighting+    catchErr :: CommandM a -> (TCErr -> CommandM a) -> CommandM a+    catchErr m h = do+      s       <- get+      (x, s') <- lift $ do runStateT m s+         `catchError_` \ e ->+           runStateT (h e) s+      put s'+      return x++    -- Handle every possible kind of error (#637), except for+    -- AsyncCancelled, which is used to abort Agda.+    handleNastyErrors :: CommandM () -> CommandM ()+    handleNastyErrors m = commandMToIO $ \ toIO -> do++      let asyncHandler e@AsyncCancelled = return (Left e)++          ioHandler (e :: E.IOException) = Right <$> do+            toIO $ handleErr (Just Direct) $ IOException Nothing noRange e++          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+        Left e  -> E.throwIO e++    -- Displays an error and instructs Emacs to jump to the site of the+    -- 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+        method  <- case method of+          Nothing -> lift $ viewTC eHighlightingMethod+          Just m  -> return m+        let info = convert $ err <> unsolved+                     -- Errors take precedence over unsolved things.++        showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions+        showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions+        do+          mapM_ putResponse $+            [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] +++            tellEmacsToJumpToError (getRange e) +++            [ Resp_HighlightingInfo info KeepHighlighting+                                    method modFile ] +++            [ Resp_Status $ Status { sChecked = False+                                   , sShowImplicitArguments = showImpl+                                   , sShowIrrelevantArguments = showIrr+                                   } ]+          whenM (optExitOnError <$> commandLineOptions) $+            liftIO $ exitAgdaWith TCMError++-- | Run an 'IOTCM' value, catch the exceptions, emit output+--+--   If an error happens the state of 'CommandM' does not change,+--   but stPersistent may change (which contains successfully+--   loaded interfaces for example).++runInteraction :: IOTCM -> CommandM ()+runInteraction iotcm =+  handleCommand inEmacs onFail $ do+    currentAbs <- liftIO $ absolute current+    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++    cf' <- gets theCurrentFile+    when (updateInteractionPointsAfter cmd+            &&+          Just currentAbs == (currentFilePath <$> cf')) $ do+        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+            , envHighlightingMethod = highlightingMethod+            }++    -- If an independent command fails we should reset theCurrentFile (Issue853).+    onFail | independent cmd = modify $ \ s -> s { theCurrentFile = Nothing }+           | otherwise       = return ()++------------------------------------------------------------------------+-- Command queues++-- | If the next command from the command queue is anything but an+-- actual command, then the command is returned.+--+-- If the command is an 'IOTCM' command, then the following happens:+-- The given computation is applied to the command and executed. If an+-- abort command is encountered (and acted upon), then the computation+-- is interrupted, the persistent state and all options are restored,+-- and some commands are sent to the frontend. If the computation was+-- not interrupted, then its result is returned.++-- TODO: It might be nice if some of the changes to the persistent+-- state inflicted by the interrupted computation were preserved.++maybeAbort :: (IOTCM -> CommandM a) -> CommandM (Command' (Maybe a))+maybeAbort m = do+  commandState <- get+  let q = commandQueue commandState+  (n, cmd) <- liftIO $ atomically $ readTChan (commands q)+  case cmd of+    Done      -> return Done+    Error e   -> return (Error e)+    Command c -> do+      tcState <- getTC+      tcEnv   <- askTC+      result  <- liftIO $ race+                   (runTCM tcEnv tcState $+                    runStateT (m c) commandState)+                   (waitForAbort n q)+      case result of+        Left ((x, commandState'), tcState') -> do+          putTC tcState'+          put commandState'+          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 $ set lensPragmaOptions (tcState ^. lensPragmaOptions) $+            initStateFromPersistentState $ stPersistentState tcState+          put $ (initCommandState (commandQueue commandState))+            { optionsOnReload = optionsOnReload commandState+            }+          putResponse Resp_DoneAborting+          displayStatus+          return (Command Nothing)+  where++  -- Returns if the currently executing command should be aborted.+  -- The "abort number" is returned.++  waitForAbort+    :: Integer       -- The number of the currently executing command.+    -> CommandQueue  -- The command queue.+    -> IO Integer+  waitForAbort n q = do+    atomically $ do+      a <- readTVar (abort q)+      case a of+        Just a' | n <= a' -> return a'+        _                 -> retry++  -- Removes every command for which the command number is at most+  -- the given number (the "abort number") from the command queue.+  --+  -- New commands could be added to the end of the queue while this+  -- computation is running. This does not lead to a race condition,+  -- because those commands have higher command numbers, so they will+  -- not be removed.++  popAbortedCommands :: CommandQueue -> Integer -> IO ()+  popAbortedCommands q n = do+    done <- atomically $ do+      cmd <- tryReadTChan (commands q)+      case cmd of+        Nothing -> return True+        Just c  ->+          if fst c <= n then+            return False+           else do+            unGetTChan (commands q) c+            return True+    unless done $+      popAbortedCommands q n++-- | Creates a command queue, and forks a thread that writes commands+-- to the queue. The queue is returned.++initialiseCommandQueue+  :: IO Command+     -- ^ Returns the next command.+  -> IO CommandQueue+initialiseCommandQueue next = do+  commands <- newTChanIO+  abort    <- newTVarIO Nothing++  let -- Read commands. The argument is the number of the previous+      -- command (other than abort commands) that was read, if any.+      readCommands n = do+        c <- next+        case c of+          Command c | IOTCM _ _ _ Cmd_abort <- c Nothing -> do+            atomically $ writeTVar abort (Just n)+            readCommands n+          _ -> do+            let n' = (succ n)+            atomically $ writeTChan commands (n', c)+            case c of+              Done -> return ()+              _    -> readCommands n'++  _ <- forkIO (readCommands 0)++  return (CommandQueue { .. })++---------------------------------------------------------++-- | Can the command run even if the relevant file has not been loaded+--   into the state?++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+independent Cmd_show_version                = True+independent _                               = False++-- | Should 'Resp_InteractionPoints' be issued after the command has+-- run?++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+updateInteractionPointsAfter Cmd_solveOne{}                      = True+updateInteractionPointsAfter Cmd_infer_toplevel{}                = False+updateInteractionPointsAfter Cmd_compute_toplevel{}              = False+updateInteractionPointsAfter Cmd_load_highlighting_info{}        = False+updateInteractionPointsAfter Cmd_tokenHighlighting{}             = False+updateInteractionPointsAfter Cmd_highlight{}                     = True+updateInteractionPointsAfter ShowImplicitArgs{}                  = False+updateInteractionPointsAfter ToggleImplicitArgs{}                = False+updateInteractionPointsAfter ShowIrrelevantArgs{}                = False+updateInteractionPointsAfter ToggleIrrelevantArgs{}              = False+updateInteractionPointsAfter Cmd_give{}                          = True+updateInteractionPointsAfter Cmd_refine{}                        = True+updateInteractionPointsAfter Cmd_intro{}                         = True+updateInteractionPointsAfter Cmd_refine_or_intro{}               = True+updateInteractionPointsAfter Cmd_autoOne{}                       = True+updateInteractionPointsAfter Cmd_autoAll{}                       = True+updateInteractionPointsAfter Cmd_context{}                       = False+updateInteractionPointsAfter Cmd_helper_function{}               = False+updateInteractionPointsAfter Cmd_infer{}                         = False+updateInteractionPointsAfter Cmd_goal_type{}                     = False+updateInteractionPointsAfter Cmd_elaborate_give{}                = True+updateInteractionPointsAfter Cmd_goal_type_context{}             = False+updateInteractionPointsAfter Cmd_goal_type_context_infer{}       = False+updateInteractionPointsAfter Cmd_goal_type_context_check{}       = False+updateInteractionPointsAfter Cmd_show_module_contents{}          = False+updateInteractionPointsAfter Cmd_make_case{}                     = True+updateInteractionPointsAfter Cmd_compute{}                       = False+updateInteractionPointsAfter Cmd_why_in_scope{}                  = False+updateInteractionPointsAfter Cmd_why_in_scope_toplevel{}         = False+updateInteractionPointsAfter Cmd_show_version{}                  = False+updateInteractionPointsAfter Cmd_abort{}                         = False+updateInteractionPointsAfter Cmd_exit{}                          = False++-- | 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) =+  cmd_load' m argv True mode $ \_ -> interpret $ Cmd_metas AsIs+  where+  mode = TypeCheck++interpret (Cmd_compile backend file argv) =+  cmd_load' file argv allowUnsolved mode $ \ checkResult -> do+    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+      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++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++interpret (Cmd_search_about_toplevel norm s) =+  atTopLevel $ searchAbout norm noRange s++interpret (Cmd_solveAll norm)        = solveInstantiatedGoals norm Nothing+interpret (Cmd_solveOne norm ii _ _) = solveInstantiatedGoals norm' (Just ii)+  -- `solveOne` is called via `agda2-maybe-normalised` which does not use+  -- AsIs < Simplified < Normalised but rather Simplified < Instantiated < Normalised+  -- So we remap the Rewrite modifiers to match solveAll's behaviour.+  -- NB: instantiate is called in getSolvedInteractionPoints no matter what.+  where norm' = case norm of+                  Simplified   -> AsIs+                  Instantiated -> Simplified+                  _            -> norm++interpret (Cmd_infer_toplevel norm s) = do+  (time, expr) <- parseAndDoAtToplevel (B.typeInCurrent norm) s+  state <- get+  display_info $ Info_InferredType state time expr++interpret (Cmd_compute_toplevel cmode s) = do+  (time, expr) <- parseAndDoAtToplevel action (B.computeWrapInput cmode s)+  state <- get+  display_info $ Info_NormalForm state cmode time expr+    where+    action = allowNonTerminatingReductions+           . (if B.computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)+           . B.evalInCurrent cmode+-- interpret (Cmd_compute_toplevel cmode s) =+--   parseAndDoAtToplevel action Info_NormalForm $ computeWrapInput cmode s+--   where+--   action = allowNonTerminatingReductions+--          . (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)+--          . (B.showComputed cmode <=< B.evalInCurrent)+++interpret (ShowImplicitArgs showImpl) = do+  opts <- lift commandLineOptions+  setCommandLineOpts $+    set (lensPragmaOptions . lensOptShowImplicit . lensKeepDefault) showImpl opts++interpret ToggleImplicitArgs = do+  opts <- lift commandLineOptions+  setCommandLineOpts $+    over (lensPragmaOptions . lensOptShowImplicit . lensCollapseDefault) not opts++interpret (ShowIrrelevantArgs showIrr) = do+  opts <- lift commandLineOptions+  setCommandLineOpts $+    set (lensPragmaOptions . lensOptShowIrrelevant . lensKeepDefault) showIrr opts++interpret ToggleIrrelevantArgs = do+  opts <- lift commandLineOptions+  setCommandLineOpts $+    over (lensPragmaOptions . lensOptShowIrrelevant . lensCollapseDefault) not opts++interpret (Cmd_load_highlighting_info source) = do+  l <- asksTC envHighlightingLevel+  when (l /= None) $ do+    -- Make sure that the include directories have+    -- been set.+    setCommandLineOpts =<< lift commandLineOptions+    resp <- lift $ liftIO . tellToUpdateHighlighting =<< do+      ex        <- liftIO $ doesFileExist source+      absSource <- srcFromPath =<< liftIO (absolute source)+      if ex+        then+           do+              src <- Imp.parseSource absSource+              let m = Imp.srcModuleName src+              checkModuleName m absSource Nothing+              mmi <- getVisitedModule m+              case mmi of+                Nothing -> return Nothing+                Just mi ->+                  if hashText (Imp.srcText src) == iSourceHash (miInterface mi)+                    then do+                      modFile <- useTC stModuleToSource+                      method  <- viewTC eHighlightingMethod+                      return $ Just (iHighlighting $ miInterface mi, method, modFile)+                    else+                      return Nothing+            `catchError` \_ -> return Nothing+        else+          return Nothing+    mapM_ putResponse resp++interpret (Cmd_tokenHighlighting source remove) = do+  info <- do l <- asksTC envHighlightingLevel+             if l == None+               then return Nothing+               else do+                 source' <- liftIO (absolute source)+                 lift $ (Just <$> generateTokenInfo source')+                           `catchError` \_ ->+                        return Nothing+      `finally`+    case remove of+      Remove -> liftIO $ removeFile source+      Keep   -> return ()+  case info of+    Just info' -> lift $ printHighlightingInfo RemoveHighlighting info'+    Nothing    -> return ()++interpret (Cmd_highlight ii rng s) = do+  l <- asksTC envHighlightingLevel+  when (l /= None) $ do+    scope <- getOldInteractionScope ii+    removeOldInteractionScope ii+    handle $ do+      parsed <- try (Info_HighlightingParseError ii) $+             B.parseExpr rng s+      expr <- try (Info_HighlightingScopeCheckError ii) $+             concreteToAbstract scope parsed+      lift $ printHighlightingInfo KeepHighlighting =<<+               generateTokenInfoFromString rng s+      lift $ highlightExpr expr+  where+    handle :: ExceptT Info_Error TCM () -> CommandM ()+    handle m = do+      res <- lift $ runExceptT m+      case res of+        Left err -> display_info $ Info_Error err+        Right _ -> return ()+    try :: Info_Error -> TCM a -> ExceptT Info_Error TCM a+    try err m = ExceptT $ do+      (mapLeft (const err) <$> freshTCM m) `catchError` \ _ -> return (Left err)+      -- freshTCM to avoid scope checking creating new interaction points++interpret (Cmd_give   force ii rng s) = give_gen force ii rng s Give+interpret (Cmd_refine ii rng s) = give_gen WithoutForce ii rng s Refine++interpret (Cmd_intro pmLambda ii rng _) = do+  ss <- lift $ B.introTactic pmLambda ii+  liftCommandMT (withInteractionId ii) $ case ss of+    []    -> do+      display_info $ Info_Intro_NotFound+    [s]   -> give_gen WithoutForce ii rng s Intro+    _:_:_ -> do+      display_info $ Info_Intro_ConstructorUnknown ss++interpret (Cmd_refine_or_intro pmLambda ii r s) = interpret $+  let s' = trim s+  in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s'++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 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 <- fmap concat $ forM iis $ \ ii -> do+      rng <- getInteractionRange ii+      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)++interpret (Cmd_helper_function norm ii rng s) = do+  -- Create type of application of new helper function that would solve the goal.+  helperType <- liftLocalState $ withInteractionId ii $ inTopContext $ B.metaHelperType norm ii rng s+  display_info $ Info_GoalSpecific ii (Goal_HelperFunction helperType)++interpret (Cmd_infer norm ii rng s) = do+  expr <- liftLocalState $ withInteractionId ii $ B.typeInMeta ii norm =<< B.parseExprIn ii rng s+  display_info $ Info_GoalSpecific ii (Goal_InferredType expr)++interpret (Cmd_goal_type norm ii _ _) =+  display_info $ Info_GoalSpecific ii (Goal_CurrentGoal norm)++interpret (Cmd_elaborate_give norm ii rng s) =+  give_gen WithoutForce ii rng s $ ElaborateGive norm++interpret (Cmd_goal_type_context norm ii rng s) =+  cmd_goal_type_context_and GoalOnly norm ii rng s++interpret (Cmd_goal_type_context_infer norm ii rng s) = do+  -- In case of the empty expression to type, don't fail with+  -- a stupid parse error, but just fall back to+  -- Cmd_goal_type_context.+  aux <- if all Char.isSpace s+            then return GoalOnly+            else do+              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+  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__+    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++interpret (Cmd_why_in_scope_toplevel s) =+  atTopLevel $ whyInScope s++interpret (Cmd_why_in_scope ii _range s) =+  liftCommandMT (withInteractionId ii) $ whyInScope s++interpret (Cmd_make_case ii rng s) = do+  (f, casectxt, cs) <- lift $ makeCase ii rng s+  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 prettyAUnqualify cs+    let pcs' :: [String]    = List.map (extlam_dropName unicode casectxt . decorate) pcs+    lift $ reportSDoc "interaction.case" 60 $ TCP.vcat+      [ "InteractionTop.Cmd_make_case"+      , TCP.nest 2 $ TCP.vcat+        [ "cs   = " TCP.<+> TCP.vcat (map prettyA cs)+        , "pcs  = " TCP.<+> TCP.vcat (map return pcs)+        , "pcs' = " TCP.<+> TCP.vcat (map TCP.text pcs')+        ]+      ]+    lift $ reportSDoc "interaction.case" 90 $ TCP.vcat+      [ "InteractionTop.Cmd_make_case"+      , TCP.nest 2 $ TCP.vcat+        [ "cs   = " TCP.<+> TCP.text (show cs)+        ]+      ]+    putResponse $ Resp_MakeCase ii (makeCaseVariant casectxt) pcs'+++interpret (Cmd_compute cmode ii rng s) = do+  expr <- liftLocalState $ do+    e <- B.parseExprIn ii rng $ B.computeWrapInput cmode s+    withInteractionId ii $ applyWhen (B.computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent cmode e+  display_info $ Info_GoalSpecific ii (Goal_NormalForm cmode expr)++interpret Cmd_show_version = display_info Info_Version++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 ()+solveInstantiatedGoals norm mii = do+  -- Andreas, 2016-10-23 issue #2280: throw away meta elims.+  out <- lift $ localTC (\ e -> e { envPrintMetasBare = True }) $ do+    sip <- B.getSolvedInteractionPoints False norm+           -- only solve metas which have a proper instantiation, i.e., not another meta+    let sip' = maybe id (\ ii -> filter ((ii ==) . fst3)) mii sip+    mapM prt sip'+  putResponse $ Resp_SolveAll out+  where+      prt (i, m, e) = do+        mi <- getMetaInfo <$> lookupLocalMeta m+        e' <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e+        return (i, e')++-- | @cmd_load' file argv unsolvedOk cmd@+--   loads the module in file @file@,+--   using @argv@ as the command-line options.+--+-- If type checking completes without any exceptions having been+-- encountered then the command @cmd r@ is executed, where @r@ is the+-- result of 'Imp.typeCheckMain'.++cmd_load'+  :: FilePath  -- ^ File to load into interaction.+  -> [String]  -- ^ Arguments to Agda for loading this file+  -> Bool      -- ^ Allow unsolved meta-variables?+  -> Mode      -- ^ Full type-checking, or only scope-checking?+  -> (CheckResult -> CommandM a)+               -- ^ Continuation after successful loading.+  -> CommandM a+cmd_load' file argv unsolvedOK mode cmd = do++    -- Forget the previous "current file" and interaction points.+    modify $ \ st -> st { theInteractionPoints = []+                        , theCurrentFile       = Nothing+                        }++    -- Update the status. Because the "current file" is not set the+    -- status is not "Checked".+    displayStatus++    -- Reset the state, preserving options and decoded modules. Note+    -- that if the include directories have changed, then the decoded+    -- modules are reset by TCM.setCommandLineOptions' below.+    lift resetState++    -- Clear the info buffer to make room for information about which+    -- module is currently being type-checked.+    putResponse Resp_ClearRunningInfo++    -- Remove any prior syntax highlighting.+    putResponse (Resp_ClearHighlighting NotOnlyTokenBased)++    -- Parse the file.+    --+    -- Note that options are set below.+    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++    -- All options are reset when a file is reloaded, including the+    -- choice of whether or not to display implicit arguments.+    opts0 <- gets optionsOnReload+    backends <- useTC stBackends+    let (z, warns) = runOptM $ parseBackendOptions backends argv opts0+    mapM_ (lift . warning . OptionWarning) warns+    case z of+      Left err -> lift $ typeError $ OptionError err+      Right (_, opts) -> do+        opts <- lift $ addTrustedExecutables opts+        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 $ Set.union warnings++    ok <- lift $ Imp.typeCheckMain mode src++    -- The module type checked. If the file was not changed while the+    -- type checker was running then the interaction points and the+    -- "current file" are stored.+    t' <- liftIO $ getModificationTime file+    when (t == t') $ do+      is <- lift $ sortInteractionPoints =<< getInteractionPoints+      modify $ \st -> st { theInteractionPoints = is+                         , theCurrentFile       = Just $ CurrentFile+                             { currentFilePath   = fp+                             , currentFileModule = Imp.srcModuleName src+                             , currentFileArgs   = argv+                             , currentFileStamp  = t+                             }+                         }++    cmd ok++-- | Set 'envCurrentPath' to 'theCurrentFile', if any.+withCurrentFile :: CommandM a -> CommandM a+withCurrentFile m = do+  mfile <- gets $ fmap currentFilePath . theCurrentFile+  i <- traverse idFromFile mfile+  localTC (\ e -> e { envCurrentPath = i }) m++atTopLevel :: CommandM a -> CommandM a+atTopLevel cmd = liftCommandMT B.atTopLevel cmd++---------------------------------------------------------------------------+-- Giving, refining.++data GiveRefine = Give | Refine | Intro | ElaborateGive Rewrite+  deriving (Eq, Show)++-- | A "give"-like action (give, refine, etc).+--+--   @give_gen force ii rng s give_ref mk_newtxt@+--   acts on interaction point @ii@+--   occupying range @rng@,+--   placing the new content given by string @s@,+--   and replacing @ii@ by the newly created interaction points+--   in the state if safety checks pass (unless @force@ is applied).+give_gen+  :: UseForce       -- ^ Should safety checks be skipped?+  -> InteractionId+  -> Range+  -> String+  -> GiveRefine+  -> CommandM ()+give_gen force ii rng s0 giveRefine = do+  let s = trim s0+  reportSLn "interaction.give" 20 $ "give_gen  " ++ s+  -- Andreas, 2015-02-26 if string is empty do nothing rather+  -- than giving a parse error.+  unless (null s) $ do+    let give_ref =+          case giveRefine of+            Give               -> B.give+            Refine             -> B.refine+            Intro              -> B.refine+            ElaborateGive norm -> B.elaborate_give norm+    -- save scope of the interaction point (for printing the given expr. later)+    scope     <- getInteractionScope ii+    -- parse string and "give", obtaining an abstract expression+    -- and newly created interaction points+    (time, (ae, ae0, iis)) <- maybeTimed $ do+        -- Issue 3000: mark the current hole as solved before giving, to avoid confusing it with potential+        -- new interaction points introduced by the give.+        removeInteractionPoint ii+        mis  <- getInteractionPoints+        reportSLn "interaction.give" 30 $ "interaction points before = " ++ show mis+        given <- lift $ B.parseExprIn ii rng s+        ae    <- lift $ give_ref force ii Nothing given+        mis' <- getInteractionPoints+        reportSLn "interaction.give" 30 $ "interaction points after = " ++ show mis'+        return (ae, given, mis' List.\\ mis)+    -- favonia: backup the old scope for highlighting+    insertOldInteractionScope ii scope+    -- sort the new interaction points and put them into the state+    -- in replacement of the old interaction point+    iis' <- sortInteractionPoints iis+    modifyTheInteractionPoints $ replace ii iis'+    -- print abstract expr+    ce        <- abstractToConcreteScope scope ae+    reportS "interaction.give" 30+      [ "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+    -- without arguments.  Then there are no interaction metas, but+    -- we still cannot just `give' the user string (which may be empty).+    -- WRONG: also, if no interaction metas were created by @Refine@+    -- WRONG: let literally = (giveRefine == Give || null iis) && rng /= noRange+    -- Ulf, 2015-03-30, if we're doing intro we can't do literal give since+    -- there is nothing in the hole (issue 1892).+    let literally = (giveRefine == Give || giveRefine == Refine) && ae == ae0 && rng /= noRange+    -- Ulf, 2014-01-24: This works for give since we're highlighting the string+    -- that's already in the buffer. Doing it before the give action means that+    -- the highlighting is moved together with the text when the hole goes away.+    -- To make it work for refine we'd have to adjust the ranges.+    when literally $ do+      l <- asksTC envHighlightingLevel+      when (l /= None) $ lift $ do+        printHighlightingInfo KeepHighlighting =<<+          generateTokenInfoFromString rng s+        highlightExpr ae+    putResponse $ Resp_GiveAction ii $ mkNewTxt literally ce+    reportSLn "interaction.give" 30 $ "putResponse GiveAction passed"+    -- display new goal set (if not measuring time)+    maybe (interpret $ Cmd_metas AsIs) (display_info . Info_Time) time+    reportSLn "interaction.give" 30 $ "interpret Cmd_metas passed"+  where+    -- Substitutes xs for x in ys.+    replace x xs ys = concatMap (\ y -> if y == x then xs else [y]) ys+    -- For @Give@ we can replace the ii by the user given input.+    mkNewTxt True  C.Paren{} = Give_Paren+    mkNewTxt True  _         = Give_NoParen+    -- Otherwise, we replace it by the reified value Agda computed.+    mkNewTxt False ce        = Give_String $ prettyShow ce++highlightExpr :: A.Expr -> TCM ()+highlightExpr e =+  localTC (\st -> st { envImportPath         = []+                     , envHighlightingLevel  = NonInteractive+                     , envHighlightingMethod = Direct }) $+    generateAndPrintSyntaxInfo decl Full True+  where+    dummy = mkName_ (NameId 0 noModuleNameHash) ("dummy" :: String)+    info  = mkDefInfo (nameConcrete dummy) noFixity' PublicAccess ConcreteDef (getRange e)+    decl  = A.Axiom OtherDefName info defaultArgInfo Nothing (qnameFromList $ singleton dummy) e++-- | Sorts interaction points based on their ranges.++sortInteractionPoints+  :: (MonadInteractionPoints m, MonadError TCErr m, MonadDebug m)+  => [InteractionId] -> m [InteractionId]+sortInteractionPoints is =+  map fst . List.sortBy (compare `on` snd) <$> do+    forM is $ \ i -> do+      (i,) <$> getInteractionRange i++-- | Displays the current goal, the given document, and the current+--   context.+--+--   Should not modify the state.++cmd_goal_type_context_and :: GoalTypeAux -> Rewrite -> InteractionId -> Range ->+                             String -> CommandM ()+cmd_goal_type_context_and aux norm ii _ _ = do+  ctx <- lift $ B.getResponseContext norm ii+  constr <- lift $ lookupInteractionId ii >>= B.getConstraintsMentioning norm+  boundary <- lift $ B.getIPBoundary norm ii+  display_info $ Info_GoalSpecific ii (Goal_GoalType norm aux ctx boundary constr)++-- | Shows all the top-level names in the given module, along with+-- their types.++showModuleContents :: Rewrite -> Range -> String -> CommandM ()+showModuleContents norm rng s = do+  (modules, tel, types) <- lift $ B.moduleContents norm rng s+  display_info $ Info_ModuleContents modules tel types++-- | Shows all the top-level names in scope which mention all the given+-- identifiers in their type.++searchAbout :: Rewrite -> Range -> String -> CommandM ()+searchAbout norm rg names = do+  unlessNull (trim names) $ \ trimmedNames -> do+    hits <- lift $ findMentions norm rg trimmedNames+    display_info $ Info_SearchAbout hits trimmedNames++-- | Explain why something is in scope.++whyInScope :: String -> CommandM ()+whyInScope s = do+  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.++setCommandLineOpts :: CommandLineOptions -> CommandM ()+setCommandLineOpts opts = do+    lift $ TCM.setCommandLineOptions opts+    displayStatus+++-- | Computes some status information.+--+--   Does not change the state.++status :: CommandM Status+status = do+  cf       <- gets theCurrentFile+  showImpl <- lift showImplicitArguments+  showIrr  <- lift showIrrelevantArguments++  -- Check if the file was successfully type checked, and has not+  -- 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 f  -> do+      t <- liftIO $ getModificationTime $ filePath (currentFilePath f)+      if currentFileStamp f == t+        then+          maybe False (null . miWarnings) <$>+          getVisitedModule (currentFileModule f)+        else+            return False++  return $ Status { sShowImplicitArguments   = showImpl,+                    sShowIrrelevantArguments = showIrr,+                    sChecked                 = checked }++-- | Displays or updates status information.+--+--   Does not change the state.++displayStatus :: CommandM ()+displayStatus =+  putResponse . Resp_Status  =<< status++-- | @display_info@ does what @'display_info'' False@ does, but+--   additionally displays some status information (see 'status' and+--   'displayStatus').++display_info :: DisplayInfo -> CommandM ()+display_info info = do+  displayStatus+  putResponse $ Resp_DisplayInfo info++-- | Parses and scope checks an expression (using the \"inside scope\"+-- as the scope), performs the given command with the expression as+-- input, and returns the result and the time it takes.++parseAndDoAtToplevel+  :: (A.Expr -> TCM a)+     -- ^ The command to perform.+  -> String+     -- ^ The expression to parse.+  -> CommandM (Maybe CPUTime, a)+parseAndDoAtToplevel cmd s = do+  localStateCommandM $ do+    (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 $ hasProfileOption Profile.Interactive+  if not doTime+    then (Nothing,) <$> work+    else do+      (r, time) <- measureTime work+      return (Just time, r)++-- | Tell to highlight the code using the given highlighting+-- info (unless it is @Nothing@).++tellToUpdateHighlighting+  :: Maybe (HighlightingInfo, HighlightingMethod, ModuleToSource) -> IO [Response]+tellToUpdateHighlighting Nothing                = return []+tellToUpdateHighlighting (Just (info, method, modFile)) =+  return [Resp_HighlightingInfo info KeepHighlighting method modFile]++-- | Tells the Emacs mode to go to the first error position (if any).++tellEmacsToJumpToError :: Range -> [Response]+tellEmacsToJumpToError r =+  case rStart r of+    Nothing                                           -> []+    Just (Pn { srcFile = Strict.Nothing })            -> []+    Just (Pn { srcFile = Strict.Just f, posPos = p }) ->+       [ Resp_JumpToError (filePath (rangeFilePath f)) p ]
− src/full/Agda/Interaction/InteractionTop.hs-boot 
@@ -1,5 +0,0 @@-module Agda.Interaction.InteractionTop where--import Agda.TypeChecking.Monad.Base (TCM)--showOpenMetas :: TCM [String]
+ src/full/Agda/Interaction/JSON.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Encoding stuff into JSON values in TCM++module Agda.Interaction.JSON+  ( module Export+  , EncodeTCM(..)+  , obj, kind, kind'+  , (.=)+  , (@=), (#=)+  ) where++import Control.Monad as Export ((>=>), (<=<))+import Data.Aeson    as Export hiding (Result(..), (.=))++import qualified Data.Aeson+import Data.Aeson.Types ( Pair )+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+#endif++import Data.Text (Text)+import Data.Word (Word32)++-- import qualified Agda.Syntax.Translation.InternalToAbstract as I2A+-- import qualified Agda.Syntax.Translation.AbstractToConcrete as A2C++-- import qualified Agda.Syntax.Concrete as C+-- import qualified Agda.Syntax.Internal as I+import Agda.TypeChecking.Monad+import Agda.Syntax.Common.Pretty+import qualified Agda.Utils.FileName as File+import qualified Agda.Utils.Maybe.Strict as Strict++#if MIN_VERSION_aeson(2,0,0)+toKey :: Text -> Key+toKey = Key.fromText+#else+type Key = Text++toKey :: Text -> Key+toKey = id+#endif++---------------------------------------------------------------------------+-- * The EncodeTCM class++-- | The JSON version of`PrettyTCM`, for encoding JSON value in TCM+class EncodeTCM a where+  encodeTCM :: a -> TCM Value+  default encodeTCM :: ToJSON a => a -> TCM Value+  encodeTCM = pure . toJSON++-- | TCM monadic version of object+obj :: [TCM Pair] -> TCM Value+obj = (object <$>) . sequence++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON a => Text -> a -> Pair+(.=) = (Data.Aeson..=) . toKey++-- | Pairs a key with a value wrapped in TCM+(#=) :: (ToJSON a) => Text -> TCM a -> TCM Pair+(#=) key boxed = do+  value <- boxed+  pure $ key .= toJSON value++-- | Abbreviation of `_ #= encodeTCM _`+(@=) :: (EncodeTCM a) => Text -> a -> TCM Pair+(@=) key value = do+  encoded <- encodeTCM value+  pure $ key .= encoded++-- | A handy alternative of `obj` with kind specified+kind :: Text -> [TCM Pair] -> TCM Value+kind k = obj . (("kind" @= String k) :)++-- | A handy alternative of `object` with kind specified+kind' :: Text -> [Pair] -> Value+kind' k = object . (("kind" .= String k) :)++-- ---------------------------------------------------------------------------+-- -- * The Rep & ToRep class+--+-- -- | Translates internal types to concrete types+-- class ToRep i c | i -> c where+--   toRep :: i -> TCM c+--+-- instance ToRep I.Term C.Expr where+--   toRep internal = I2A.reify internal >>= A2C.abstractToConcrete_+--+-- instance ToRep I.Type C.Expr where+--   toRep internal = I2A.reify internal >>= A2C.abstractToConcrete_+--+-- data Rep internal concrete = Rep+--   { internalRep :: internal+--   , concreteRep :: concrete+--   }+--+-- instance (ToJSON i, ToJSON c) => ToJSON (Rep i c) where+--   toJSON (Rep i c) = object+--     [ "internal" .= i+--     , "concrete" .= c+--     ]+--+-- rep :: (ToRep i c) => i -> TCM (Rep i c)+-- rep internal = do+--   concrete <- toRep internal+--   return $ Rep+--     { internalRep = internal+--     , concreteRep = concrete+--     }++--------------------------------------------------------------------------------+-- Instances of ToJSON or EncodeTCM++encodeListTCM :: EncodeTCM a => [a] -> TCM Value+encodeListTCM = mapM encodeTCM >=> return . toJSONList++instance EncodeTCM a => EncodeTCM [a] where+  encodeTCM = mapM encodeTCM >=> return . toJSONList++-- overlaps with the instance declared above+instance {-# OVERLAPPING #-} EncodeTCM String++instance EncodeTCM Bool+instance EncodeTCM Int+instance EncodeTCM Word32+instance EncodeTCM Value+instance EncodeTCM Doc++instance ToJSON Doc where+  toJSON = toJSON . render++instance EncodeTCM a => EncodeTCM (Maybe a) where+  encodeTCM Nothing   = return Null+  encodeTCM (Just a)  = encodeTCM a++instance ToJSON File.AbsolutePath where+  toJSON (File.AbsolutePath path) = toJSON path++#if !(MIN_VERSION_aeson(1,5,3))+instance ToJSON a => ToJSON (Strict.Maybe a) where+  toJSON (Strict.Just a) = toJSON a+  toJSON Strict.Nothing  = Null+#endif
+ src/full/Agda/Interaction/JSONTop.hs view
@@ -0,0 +1,482 @@+module Agda.Interaction.JSONTop+    ( jsonREPL+    ) where++import Control.Monad+         ( (<=<), forM )+import Control.Monad.IO.Class+         ( MonadIO(..) )++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Text as T+import qualified Data.Set as Set++import Agda.Interaction.AgdaTop+import Agda.Interaction.Base+         ( 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.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.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 )+-- borrowed from EmacsTop, for temporarily serialising stuff+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.+--+--   'jsonREPL' reads Haskell values (that starts from 'IOTCM' ...) from stdin,+--   interprets them, and outputs JSON-encoded strings. into stdout.++jsonREPL :: TCM () -> TCM ()+jsonREPL = repl (liftIO . BS.putStrLn <=< jsonifyResponse) "JSON> "++instance EncodeTCM NameInScope where+instance ToJSON NameInScope where+  toJSON InScope    = toJSON True+  toJSON NotInScope = toJSON False++instance EncodeTCM Status where+instance ToJSON Status where+  toJSON status = object+    [ "showImplicitArguments"   .= sShowImplicitArguments status+    , "showIrrelevantArguments" .= sShowIrrelevantArguments status+    , "checked"                 .= sChecked status+    ]++instance EncodeTCM CommandState where+instance ToJSON CommandState where+  toJSON commandState = object+    [ "interactionPoints" .= theInteractionPoints commandState+    , "currentFile"       .= theCurrentFile commandState+    -- more?+    ]++instance EncodeTCM CurrentFile where+instance ToJSON CurrentFile where+  toJSON (CurrentFile path _ _ time) = toJSON (path, time)  -- backwards compat.++instance EncodeTCM ResponseContextEntry where+  encodeTCM entry = obj+    [ "originalName" @= encodePretty (respOrigName entry)+    , "reifiedName"  @= encodePretty (respReifName entry)+    , "binding"      #= prettyATop (unArg (respType entry))+    , "inScope"      @= respInScope entry+    ]++instance EncodeTCM (Position' ()) where+instance ToJSON (Position' ()) where+  toJSON p = object+    [ "pos"  .= toJSON (posPos p)+    , "line" .= toJSON (posLine p)+    , "col"  .= toJSON (posCol p)+    ]++instance EncodeTCM Range where+instance ToJSON Range where+  toJSON = toJSON . map prettyInterval . rangeIntervals+    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 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+    , "range" #= intervalsTCM+    ]+    where+      intervalsTCM = toJSON <$> getInteractionRange ii+instance ToJSON InteractionId where+  toJSON (InteractionId i) = toJSON i++instance EncodeTCM NamedMeta where+  encodeTCM m = obj+    [ "name"  #= nameTCM+    , "range" #= intervalsTCM+    ]+    where+      nameTCM = encodeShow <$> withMetaId (nmid m) (prettyATop m)+      intervalsTCM = toJSON <$> getMetaRange (nmid m)++instance EncodeTCM GiveResult where+instance ToJSON GiveResult where+  toJSON (Give_String s) = object [ "str" .= s ]+  toJSON Give_Paren   = object [ "paren" .= True ]+  toJSON Give_NoParen = object [ "paren" .= False ]++instance EncodeTCM MakeCaseVariant where+instance ToJSON MakeCaseVariant where+  toJSON R.Function = String "Function"+  toJSON R.ExtendedLambda = String "ExtendedLambda"++encodePretty :: Pretty a => a -> Value+encodePretty = encodeShow . pretty++encodeShow :: Show a => a -> Value+encodeShow = String . T.pack . show++encodePrettyTCM :: PrettyTCM a => a -> TCM Value+encodePrettyTCM = (encodeShow <$>) . prettyTCM++instance EncodeTCM Rewrite where+instance ToJSON Rewrite where toJSON = encodeShow++instance EncodeTCM CPUTime where+instance ToJSON CPUTime where toJSON = encodePretty++instance EncodeTCM ComputeMode where+instance ToJSON ComputeMode where toJSON = encodeShow++encodeOCCmp :: (a -> TCM Value)+  -> Comparison -> a -> a -> T.Text+  -> TCM Value+encodeOCCmp f c i j k = kind k+  [ "comparison"     @= encodeShow c+  , "constraintObjs" #= traverse f [i, j]+  ]++  -- Goals+encodeOC :: (a -> TCM Value)+  -> (b -> TCM Value)+  -> OutputConstraint b a+  -> TCM Value+encodeOC f encPrettyTCM = \case+ OfType i a -> kind "OfType"+  [ "constraintObj" #= f i+  , "type"          #= encPrettyTCM a+  ]+ CmpInType c a i j -> kind "CmpInType"+  [ "comparison"     @= encodeShow c+  , "type"           #= encPrettyTCM a+  , "constraintObjs" #= traverse f [i, j]+  ]+ CmpElim ps a is js -> kind "CmpElim"+  [ "polarities"     @= map encodeShow ps+  , "type"           #= encPrettyTCM a+  , "constraintObjs" #= traverse (traverse f) [is, js]+  ]+ JustType a -> kind "JustType"+  [ "constraintObj"  #= f a+  ]+ JustSort a -> kind "JustSort"+  [ "constraintObj"  #= f a+  ]+ CmpTypes  c i j -> encodeOCCmp f c i j "CmpTypes"+ CmpLevels c i j -> encodeOCCmp f c i j "CmpLevels"+ CmpTeles  c i j -> encodeOCCmp f c i j "CmpTeles"+ CmpSorts  c i j -> encodeOCCmp f c i j "CmpSorts"+ Assign i a -> kind "Assign"+  [ "constraintObj"  #= f i+  , "value"          #= encPrettyTCM a+  ]+ TypedAssign i v t -> kind "TypedAssign"+  [ "constraintObj"  #= f i+  , "value"          #= encPrettyTCM v+  , "type"           #= encPrettyTCM t+  ]+ PostponedCheckArgs i es t0 t1 -> kind "PostponedCheckArgs"+  [ "constraintObj"  #= f i+  , "ofType"         #= encPrettyTCM t0+  , "arguments"      #= forM es encPrettyTCM+  , "type"           #= encPrettyTCM t1+  ]+ IsEmptyType a -> kind "IsEmptyType"+  [ "type"           #= encPrettyTCM a+  ]+ SizeLtSat a -> kind "SizeLtSat"+  [ "type"           #= encPrettyTCM a+  ]+ FindInstanceOF i t cs -> kind "FindInstanceOF"+  [ "constraintObj"  #= f i+  , "candidates"     #= forM cs encodeKVPairs+  , "type"           #= encPrettyTCM t+  ]+  where encodeKVPairs (_, v, t) = obj -- TODO: encode kind+          [ "value"  #= encPrettyTCM v+          , "type"   #= encPrettyTCM t+          ]+ ResolveInstanceOF q -> kind "ResolveInstanceOF"+  [ "name"           @= encodePretty q+  ]+ PTSInstance a b -> kind "PTSInstance"+  [ "constraintObjs" #= traverse f [a, b]+  ]+ PostponedCheckFunDef name a err -> kind "PostponedCheckFunDef"+  [ "name"           @= encodePretty name+  , "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+  ]+ UsableAtMod mod t -> kind "UsableAtMod"+  [ "mod"           @= encodePretty mod+  , "term"          #= f t+  ]++encodeNamedPretty :: PrettyTCM a => (Name, a) -> TCM Value+encodeNamedPretty (name, a) = obj+  [ "name" @= encodePretty name+  , "term" #= encodePrettyTCM a+  ]++instance EncodeTCM (OutputForm C.Expr C.Expr) where+  encodeTCM (OutputForm range problems unblock oc) = obj+    [ "range"      @= range+    , "problems"   @= problems+    , "unblocker"  @= unblock+    , "constraint" #= encodeOC (pure . encodePretty) (pure . encodePretty) oc+    ]++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 :: 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) = 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+    ]+  encodeTCM (Info_Error err) = encodeTCM err+  encodeTCM Info_Intro_NotFound = kind "IntroNotFound" []+  encodeTCM (Info_Intro_ConstructorUnknown introductions) = kind "IntroConstructorUnknown"+    [ "constructors"      @= map toJSON introductions+    ]+  encodeTCM (Info_Auto info) = kind "Auto"+    [ "info"              @= toJSON info+    ]+  encodeTCM (Info_ModuleContents names tele contents) = kind "ModuleContents"+    [ "contents"          #= forM contents encodeNamedPretty+    , "telescope"         #= forM (telToList tele) encodeDomType+    , "names"             @= map encodePretty names+    ]+    where+      encodeDomType :: PrettyTCM a => Dom (ArgName, a) -> TCM Value+      encodeDomType dom = obj+        [ "dom"       #= encodePrettyTCM (unDom dom)+        , "name"      @= fmap encodePretty (bareNameOf dom)+        , "finite"    @= toJSON (domIsFinite dom)+        , "cohesion"  @= encodeShow (modCohesion . argInfoModality $ domInfo dom)+        , "relevance" @= encodeShow (modRelevance . argInfoModality $ domInfo dom)+        , "hiding"    @= case argInfoHiding $ domInfo dom of+          Instance o -> show o+          o -> show o+        ]+  encodeTCM (Info_SearchAbout results search) = kind "SearchAbout"+    [ "results"           #= forM results encodeNamedPretty+    , "search"            @= toJSON search+    ]+  encodeTCM (Info_WhyInScope why@(WhyInScopeData y path _ _ _)) = kind "WhyInScope"+    [ "thing"             @= prettyShow y+    , "filepath"          @= toJSON path+    -- use Emacs message first+    , "message"           #= explainWhyInScope why+    ]+  encodeTCM (Info_NormalForm commandState computeMode time expr) = kind "NormalForm"+    [ "commandState"      @= commandState+    , "computeMode"       @= computeMode+    , "time"              @= time+    , "expr"              #= encodePrettyTCM expr+    ]+  encodeTCM (Info_InferredType commandState time expr) = kind "InferredType"+    [ "commandState"      @= commandState+    , "time"              @= time+    , "expr"              #= encodePrettyTCM expr+    ]+  encodeTCM (Info_Context ii ctx) = kind "Context"+    [ "interactionPoint"  @= ii+    , "context"           @= ctx+    ]+  encodeTCM Info_Version = kind "Version"+    [ "version"           @= (versionWithCommitInfo :: String)+    ]+  encodeTCM (Info_GoalSpecific ii info) = kind "GoalSpecific"+    [ "interactionPoint"  @= ii+    , "goalInfo"          #= withInteractionId ii (encodeGoalSpecific ii info)+    ]++instance EncodeTCM GoalTypeAux where+  encodeTCM GoalOnly = kind "GoalOnly" []+  encodeTCM (GoalAndHave expr _) = kind "GoalAndHave"+    [ "expr" #= encodePrettyTCM expr ]+  encodeTCM (GoalAndElaboration expr) = kind "GoalAndElaboration"+    [ "term" #= encodePrettyTCM expr ]++encodeGoalSpecific :: InteractionId -> GoalDisplayInfo -> TCM Value+encodeGoalSpecific ii = go+  where+  go (Goal_HelperFunction helperType) = kind "HelperFunction"+    [ "signature"   #= inTopContext (prettyATop helperType)+    ]+  go (Goal_NormalForm computeMode expr) = kind "NormalForm"+    [ "computeMode" @= computeMode+    , "expr"        #= B.showComputed computeMode expr+    ]+  go (Goal_GoalType rewrite goalType entries boundary outputForms) = kind "GoalType"+    [ "rewrite"     @= rewrite+    , "typeAux"     @= goalType+    , "type"        #= prettyTypeOfMeta rewrite ii+    , "entries"     @= entries+    , "boundary"    @= map encodePretty boundary+    , "outputForms" @= map encodePretty outputForms+    ]+  go (Goal_CurrentGoal rewrite) = kind "CurrentGoal"+    [ "rewrite"     @= rewrite+    , "type"        #= prettyTypeOfMeta rewrite ii+    ]+  go (Goal_InferredType expr) = kind "InferredType"+    [ "expr"        #= prettyATop expr+    ]++instance EncodeTCM Info_Error where+  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+      [ "message"           #= showInfoError err+      ]+    ]++instance EncodeTCM TCErr where+  encodeTCM err = obj+    [ "message"     #= encodePrettyTCM err+    ]++instance EncodeTCM TCWarning where+  encodeTCM w = obj+    [ "message"     #= (P.render <$> prettyTCM w)+    ]++instance EncodeTCM Response where+  encodeTCM (Resp_HighlightingInfo info remove method modFile) =+    liftIO $ jsonifyHighlightingInfo info remove method modFile+  encodeTCM (Resp_DisplayInfo info) = kind "DisplayInfo"+    [ "info"          @= info+    ]+  encodeTCM (Resp_ClearHighlighting tokenBased) = kind "ClearHighlighting"+    [ "tokenBased"    @= tokenBased+    ]+  encodeTCM Resp_DoneAborting = kind "DoneAborting" []+  encodeTCM Resp_DoneExiting = kind "DoneExiting" []+  encodeTCM Resp_ClearRunningInfo = kind "ClearRunningInfo" []+  encodeTCM (Resp_RunningInfo debugLevel msg) = kind "RunningInfo"+    [ "debugLevel"    @= debugLevel+    , "message"       @= msg+    ]+  encodeTCM (Resp_Status status) = kind "Status"+    [ "status"        @= status+    ]+  encodeTCM (Resp_JumpToError filepath position) = kind "JumpToError"+    [ "filepath"      @= filepath+    , "position"      @= position+    ]+  encodeTCM (Resp_InteractionPoints interactionPoints) = kind "InteractionPoints"+    [ "interactionPoints" @= interactionPoints+    ]+  encodeTCM (Resp_GiveAction i giveResult) = kind "GiveAction"+    [ "interactionPoint"  @= i+    , "giveResult"        @= giveResult+    ]+  encodeTCM (Resp_MakeCase id variant clauses) = kind "MakeCase"+    [ "interactionPoint"  @= id+    , "variant"           @= variant+    , "clauses"           @= clauses+    ]+  encodeTCM (Resp_SolveAll solutions) = kind "SolveAll"+    [ "solutions"     @= map encodeSolution solutions+    ]+    where+      encodeSolution (i, expr) = object+        [ "interactionPoint"  .= i+        , "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+jsonifyResponse = pure . encode <=< encodeTCM
src/full/Agda/Interaction/Library.hs view
@@ -1,198 +1,568 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wunused-imports #-} +-- | Library management.+--+--   Sample use:+--+--   @+--     -- Get libraries as listed in @.agda/libraries@ file.+--     libs <- getInstalledLibraries Nothing+--+--     -- Get the libraries (and immediate paths) relevant for @projectRoot@.+--     -- This involves locating and processing the @.agda-lib@ file for the project.+--     (libNames, includePaths) <-  getDefaultLibraries projectRoot True+--+--     -- Get include paths of depended-on libraries.+--     resolvedPaths <- libraryIncludePaths Nothing libs libNames+--+--     let allPaths = includePaths ++ resolvedPaths+--   @+-- module Agda.Interaction.Library-  ( getDefaultLibraries+  ( findProjectRoot+  , getDefaultLibraries   , getInstalledLibraries+  , getTrustedExecutables   , libraryIncludePaths-  , LibName+  , getAgdaLibFile+  , getPrimitiveLibDir+  , classifyBuiltinModule_+  , builtinModules+  , builtinModulesWithSafePostulates+  , builtinModulesWithUnsafePostulates+  , primitiveModules+  , LibName, parseLibName+  , OptionsPragma(..)+  , AgdaLibFile(..)+  , ExeName   , LibM+  , mkLibM+  , LibWarning(..)+  , LibPositionInfo(..)+  , libraryWarningName+  , ProjectConfig(..)+  -- * Exported for testing+  , findLib'   ) where -import Control.Arrow (first, second)-import Control.Applicative-import Control.Exception-import Control.Monad.Writer-import Data.Char+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.Bifunctor ( second ) import Data.Either-import Data.Function-import Data.List-import Data.Maybe+import Data.Function (on)+import qualified Data.List as List+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 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.Utils.Monad++import Agda.TypeChecking.Monad.Base.Types ( IsBuiltinModule(..) )+ import Agda.Utils.Environment-import Agda.Utils.Except ( ExceptT, runExceptT, MonadError(throwError) )+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-import Agda.Utils.Pretty+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.Singleton+import Agda.Utils.Tuple ( mapSndM ) +import Agda.Setup ( getDataFileName, getAgdaAppDir ) import Agda.Version -type LibM = ExceptT Doc IO+------------------------------------------------------------------------+-- * Types and Monads+------------------------------------------------------------------------ -catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch+-- | Raise collected 'LibErrors' as exception.+--+mkLibM :: [AgdaLibFile] -> LibErrorIO a -> LibM a+mkLibM libs m = do+  (x, ews) <- lift $ lift $ runWriterT m+  let (errs, warns) = partitionEithers ews+  tell warns+  () <- List1.unlessNull errs \ errs -> throwError $ LibErrors libs errs+  return x -getAgdaAppDir :: IO FilePath-getAgdaAppDir = do-  agdaDir <- lookupEnv "AGDA_DIR"-  case agdaDir of-    Nothing  -> getAppUserDataDirectory "agda"-    Just dir ->-      ifM (doesDirectoryExist dir) (canonicalizePath dir) $ do-        d <- getAppUserDataDirectory "agda"-        putStrLn $ "Warning: Environment variable AGDA_DIR points to non-existing directory " ++ show dir ++ ", using " ++ show d ++ " instead."-        return d+------------------------------------------------------------------------+-- * Resources+------------------------------------------------------------------------ -defaultLibraryFiles :: [FilePath]-defaultLibraryFiles = ["libraries-" ++ version, "libraries"]+-- | Returns the absolute default lib dir. This directory is used to+-- store the Primitive.agda file.+getPrimitiveLibDir :: IO AbsolutePath+getPrimitiveLibDir = do+  libdir <- filePath <$> (absolute =<< getDataFileName "lib")+  ifM (doesDirectoryExist libdir)+      (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@.+--+--   @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process+--   by default.  The first file in this list that exists is actually used.+--+defaultLibraryFiles :: List1 FilePath+defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : []++-- | The @defaultsFile@ contains a list of library names relevant for each Agda project.+-- defaultsFile :: FilePath defaultsFile = "defaults" -data LibError = LibNotFound FilePath LibName-              | AmbiguousLib LibName [AgdaLibFile]-              | OtherError String-  deriving (Show)+-- | 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@.+--+--   @defaultExecutablesFiles@ gives a list of all @executables@ Agda should process+--   by default.  The first file in this list that exists is actually used.+--+defaultExecutableFiles :: List1 FilePath+defaultExecutableFiles = ("executables-" ++ version) :| "executables" : [] -mkLibM :: [AgdaLibFile] -> IO (a, [LibError]) -> LibM a-mkLibM libs m = do-  (x, err) <- lift m-  case err of-    [] -> return x-    _  -> throwError =<< lift (vcat <$> mapM (formatLibError libs) err)+------------------------------------------------------------------------+-- * Agda builtin modules+------------------------------------------------------------------------ -findAgdaLibFiles :: FilePath -> IO [FilePath]-findAgdaLibFiles root = do-  libs <- map (root </>) . filter ((== ".agda-lib") . takeExtension) <$> getDirectoryContents root-  case libs of-    []    -> do+-- | 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+------------------------------------------------------------------------++-- | Find project root by looking for @.agda-lib@ files.+--+--   If there are none, look in the parent directories until one is found.++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   -> 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 <- over lensConfigAbove (+ 1) <$> findProjectConfig up+            storeCachedProjectConfig root conf+            return conf+          Nothing -> return DefaultProjectConfig+        [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.+    --+    -- Quoting from https://hackage.haskell.org/package/directory-1.3.6.1/docs/System-Directory.html#v:canonicalizePath :+    --+    --   Note that on Windows parent directories .. are always fully+    --   expanded before the symbolic links, as consistent with the+    --   rest of the Windows API (such as GetFullPathName). In+    --   contrast, on POSIX systems parent directories .. are+    --   expanded alongside symbolic links from left to right. To+    --   put this more concretely: if L is a symbolic link for R/P,+    --   then on Windows L\.. refers to ., whereas on other+    --   operating systems L/.. refers to R.+    upPath :: FilePath -> IO (Maybe FilePath)+    upPath root = do       up <- canonicalizePath $ root </> ".."-      if up == root then return [] else findAgdaLibFiles up-    files -> return files+      if up == root then return Nothing else return $ Just up -getDefaultLibraries :: FilePath -> Bool -> LibM ([LibName], [FilePath])-getDefaultLibraries root optDefaultLibs = mkLibM [] $ do-  libs <- findAgdaLibFiles root++-- | Get project root++findProjectRoot :: FilePath -> LibM (Maybe FilePath)+findProjectRoot root = findProjectConfig root <&> \case+  ProjectConfig p _ _  -> Just p+  DefaultProjectConfig -> Nothing+++-- | 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:+--+--   Look for @.agda-lib@ files according to 'findAgdaLibFiles'.+--   If none are found, use default dependencies (according to @defaults@ file)+--   and current directory (project root).+--+getDefaultLibraries+  :: 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 = do+  libs <- getAgdaLibFile root   if null libs-    then-    if optDefaultLibs then first (, []) <$> readDefaultsFile else return (([], []), [])-    else first libsAndPaths <$> parseLibFiles Nothing (zip (repeat 0) libs)+    then (,[]) <$> if optDefaultLibs then mkLibM [] $ (libNameForCurrentDir :) <$> readDefaultsFile else return []+    else return $ libsAndPaths libs   where-    libsAndPaths ls = (concatMap libDepends ls, concatMap libIncludes ls)+    libsAndPaths ls = ( concatMap _libDepends ls+                      , nubOn id (concatMap _libIncludes ls)+                      ) -readDefaultsFile :: IO ([LibName], [LibError])+-- | Return list of libraries to be used by default.+--+--   None if the @defaults@ file does not exist.+--+readDefaultsFile :: LibErrorIO [LibName] readDefaultsFile = do-    agdaDir <- getAgdaAppDir+    agdaDir <- liftIO getAgdaAppDir     let file = agdaDir </> defaultsFile-    ifM (doesFileExist file) (do-      ls <- map snd . stripCommentLines <$> readFile file-      return ("." : concatMap splitCommas ls, [])-      ) {- else -} (return (["."], []))-  `catchIO` \e -> return (["."], [OtherError $ "Failed to read defaults file.\n" ++ show e])+    ifNotM (liftIO $ doesFileExist file) (return []) $ {-else-} do+      ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file+      return $ map parseLibName $ concatMap splitCommas ls+  `catchIO` \ e -> do+    raiseErrors' [ ReadError e "Failed to read defaults file." ]+    return [] -getLibrariesFile :: Maybe FilePath -> IO FilePath-getLibrariesFile (Just overrideLibFile) = return overrideLibFile+------------------------------------------------------------------------+-- * Reading the installed libraries+------------------------------------------------------------------------++-- | Returns the path of the @libraries@ file which lists the libraries Agda knows about.+--+--   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 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 overrideLibFile) getLibrariesFile Nothing = do-  agdaDir <- getAgdaAppDir-  let defaults = map (agdaDir </>) defaultLibraryFiles-  files <- filterM doesFileExist defaults+  agdaDir <- liftIO $ getAgdaAppDir+  let defaults = List1.map (agdaDir </>) defaultLibraryFiles -- NB: very short list+  files <- liftIO $ filterM doesFileExist (List1.toList defaults)   case files of-    file : _ -> return file-    []       -> return (last defaults) -- doesn't exist, but that's ok+    file : _ -> return $ LibrariesFile file True+    []       -> return $ LibrariesFile (List1.last defaults) False -- doesn't exist, but that's ok -getInstalledLibraries :: Maybe FilePath -> LibM [AgdaLibFile]+-- | Parse the descriptions of the libraries Agda knows about.+--+--   Returns none if there is no @libraries@ file.+--+getInstalledLibraries+  :: Maybe FilePath     -- ^ Override the default @libraries@ file?+  -> LibM [AgdaLibFile] -- ^ Content of library files.  (Might have empty @LibName@s.) getInstalledLibraries overrideLibFile = mkLibM [] $ do-    file <- getLibrariesFile overrideLibFile-    ifM (doesFileExist file) (do-      ls    <- stripCommentLines <$> readFile file-      files <- sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ]-      parseLibFiles (Just file) files-      ) {- else -} (return ([], []))-  `catchIO` \e -> return ([], [OtherError $ "Failed to read installed libraries.\n" ++ show e])+    filem <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile+    case filem of+      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' [ ReadError e "Failed to read installed libraries." ]+    return [] -parseLibFiles :: Maybe FilePath -> [(Int, FilePath)] -> IO ([AgdaLibFile], [LibError])-parseLibFiles libFile files = do-  rs <- mapM (parseLibFile . snd) files-  let loc line | Just f <- libFile = f ++ ":" ++ show line ++ ": "-               | otherwise         = ""-      errs = [ if isPrefixOf "Failed to read" err-                then OtherError $ loc line ++ err-                else OtherError $ path ++ ":" ++ (if all isDigit (take 1 err) then "" else " ") ++ err-             | ((line, path), Left err) <- zip files rs ]-  return (rights rs, errs)+-- | Parse the given library files.+--+parseLibFiles+  :: Maybe LibrariesFile       -- ^ Name of @libraries@ file for error reporting.+  -> [(LineNumber, FilePath)]  -- ^ Library files paired with their line number in @libraries@.+  -> LibErrorIO [AgdaLibFile]  -- ^ Content of library files.  (Might have empty @LibName@s.)+parseLibFiles mlibFile files = do -stripCommentLines :: String -> [(Int, String)]+  anns <- forM files $ \(ln, file) -> do+    getCachedAgdaLibFile file >>= \case+      Just lib -> return (Right lib, [])+      Nothing  -> do+        (e, ws) <- liftIO $ runP <$> parseLibFile file+        let pos = LibPositionInfo (lfPath <$> mlibFile) ln file+            ws' = map (LibWarning (Just pos)) ws+        case e of+          Left err -> do+            return (Left (Just pos, err), ws')+          Right lib -> do+            storeCachedAgdaLibFile file lib+            return (Right lib, ws')++  let (xs, warns) = unzip anns+      (errs, als) = partitionEithers xs++  List1.unlessNull (concat warns) warnings+  List1.unlessNull errs $ \ errs1 ->+    raiseErrors $ fmap (\ (mc, err) -> LibError mc $ LibParseError err) errs1++  return $ nubOn _libFile als++-- | Remove trailing white space and line comments.+--+stripCommentLines :: String -> [(LineNumber, String)] stripCommentLines = concatMap strip . zip [1..] . lines   where     strip (i, s) = [ (i, s') | not $ null s' ]-      where s' = stripComments $ dropWhile isSpace s+      where s' = trimLineComment s -formatLibError :: [AgdaLibFile] -> LibError -> IO Doc-formatLibError installed (LibNotFound file lib) = do-  return $ vcat $-    [ text $ "Library '" ++ lib ++ "' not found."-    , sep [ text "Add the path to its .agda-lib file to"-          , nest 2 $ text $ "'" ++ file ++ "'"-          , text "to install." ]-    , text "Installed libraries:"-    ] ++-    map (nest 2)-      (if null installed then [text "(none)"]-      else [ sep [ text $ libName l, nest 2 $ parens $ text $ libFile l ] | l <- installed ])-formatLibError _ (AmbiguousLib lib tgts) = return $-  vcat $ sep [ text $ "Ambiguous library '" ++ lib ++ "'."-             , text "Could refer to any one of" ]-       : [ nest 2 $ text (libName l) <+> parens (text $ libFile l) | l <- tgts ]-formatLibError _ (OtherError err) = return $ text err+-- | Returns the path of the @executables@ file which lists the trusted executables Agda knows about.+--+--   Note: file may not exist.+--+getExecutablesFile+  :: IO ExecutablesFile+getExecutablesFile = do+  agdaDir <- getAgdaAppDir+  let defaults = List1.map (agdaDir </>) defaultExecutableFiles  -- NB: very short list+  files <- filterM doesFileExist (List1.toList defaults)+  case files of+    file : _ -> return $ ExecutablesFile file True+    []       -> return $ ExecutablesFile (List1.last defaults) False -- doesn't exist, but that's ok -libraryIncludePaths :: Maybe FilePath -> [AgdaLibFile] -> [LibName] -> LibM [FilePath]+-- | Return the trusted executables Agda knows about.+--+--   Returns none if there is no @executables@ file.+--+getTrustedExecutables+  :: LibM (Map ExeName FilePath)  -- ^ Content of @executables@ files.+getTrustedExecutables = mkLibM [] $ do+    file <- liftIO getExecutablesFile+    if not (efExists file) then return Map.empty else do+      es    <- liftIO $ stripCommentLines <$> UTF8.readFile (efPath file)+      lines <- liftIO $ mapM (mapSndM expandEnvironmentVariables) es+      parseExecutablesFile file lines+  `catchIO` \ e -> do+    raiseErrors' [ ReadError e "Failed to read trusted executables." ]+    return Map.empty++-- | Parse the @executables@ file.+--+parseExecutablesFile+  :: ExecutablesFile+  -> [(LineNumber, FilePath)]+  -> LibErrorIO (Map ExeName FilePath)+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 (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+------------------------------------------------------------------------++-- | Get all include pathes for a list of libraries to use.+libraryIncludePaths+  :: Maybe FilePath  -- ^ @libraries@ file (error reporting only).+  -> [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 $ do-    file <- getLibrariesFile overrideLibFile-    return $ runWriter ((dot ++) . incs <$> find file [] xs)+    efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile+    case efile of+      Left theOverrideLibFile -> do+        raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ]+        return []+      Right file -> embedWriter $ (dot ++) . incs <$> find file [] xs   where-    xs = map trim $ delete "." xs0-    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace-    incs = nub . concatMap libIncludes-    dot = [ "." | elem "." xs0 ]+    (dots, xs) = List.partition (== libNameForCurrentDir) xs0+    incs       = nubOn id . concatMap _libIncludes+    dot        = [ "." | not $ null dots ] -    find :: FilePath -> [LibName] -> [LibName] -> Writer [LibError] [AgdaLibFile]+    -- Due to library dependencies, the work list may grow temporarily.+    find+      :: LibrariesFile  -- Only for error reporting.+      -> [LibName]      -- Already resolved libraries.+      -> [LibName]      -- Work list: libraries left to be resolved.+      -> Writer LibErrWarns [AgdaLibFile]     find _ _ [] = pure []     find file visited (x : xs)-      | elem x visited = find file visited xs-      | otherwise =-          case findLib x libs of-            [l] -> (l :) <$> find file (x : visited) (libDepends l ++ xs)-            []  -> tell [LibNotFound file x] >> find file (x : visited) xs-            ls  -> tell [AmbiguousLib x ls] >> find file (x : visited) xs+      | x `elem` visited = find file visited xs+      | otherwise = do+          -- May or may not find the library+          ml <- case findLib x libs of+            [l] -> pure (Just l)+            []  -> Nothing <$ raiseErrors' [LibNotFound file x]+            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' +-- | @findLib x libs@ retrieves the matches for @x@ from list @libs@.+--+--   1. Case @x@ is unversioned:+--      If @x@ is contained in @libs@, then that match is returned.+--      Otherwise, the matches with the highest version number are returned.+--+--   2. Case @x@ is versioned: the matches with the highest version number are returned.+--+--   Examples, see 'findLib''.+-- findLib :: LibName -> [AgdaLibFile] -> [AgdaLibFile]-findLib x libs =+findLib = findLib' _libName++-- | Generalized version of 'findLib' for testing.+--+--   > findLib' id "a"   [ "a-1", "a-02", "a-2", "b" ] == [ "a-02", "a-2" ]+--+--   > findLib' id "a"   [ "a", "a-1", "a-01", "a-2", "b" ] == [ "a" ]+--   > findLib' id "a-1" [ "a", "a-1", "a-01", "a-2", "b" ] == [ "a-1", "a-01" ]+--   > findLib' id "a-2" [ "a", "a-1", "a-01", "a-2", "b" ] == [ "a-2" ]+--   > findLib' id "c"   [ "a", "a-1", "a-01", "a-2", "b" ] == []+--+findLib' :: (a -> LibName) -> LibName -> [a] -> [a]+findLib' libName x libs =   case ls of-    l : ls -> l : takeWhile ((== versionMeasure l) . versionMeasure) ls-    []     -> []+    -- Take the first and all exact matches (modulo leading zeros in version numbers).+    l : ls' -> l : takeWhile (((==) `on` libName) l) ls'+    []      -> []   where-    ls = sortBy (flip compare `on` versionMeasure) [ l | l <- libs, matchLib x l ]-+    -- @LibName@s that match @x@, sorted descendingly.+    -- The unversioned LibName, if any, will come first.+    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-        (rx, vs) = versionView (libName l) -matchLib :: LibName -> AgdaLibFile -> Bool-matchLib x l = rx == ry && (vx == vy || null vx)-  where-    (rx, vx) = versionView x-    (ry, vy) = versionView $ libName l---- versionView "foo-1.2.3" == ("foo", [1, 2, 3])-versionView :: LibName -> (LibName, [Int])-versionView s =-  case span (\ c -> isDigit c || c == '.') (reverse s) of-    (v, '-' : x) | valid vs -> (reverse x, reverse $ map (read . reverse) vs)-      where vs = chopWhen (== '.') v-            valid [] = False-            valid vs = not $ any null vs-    _ -> (s, [])+-- | @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 (LibName rx vx) (LibName ry vy) = rx == ry && (vx == vy || null vx)
src/full/Agda/Interaction/Library/Base.hs view
@@ -1,13 +1,572 @@+-- | Basic data types for library management.  module Agda.Interaction.Library.Base where -type LibName = String+import Prelude hiding (null) -data AgdaLibFile = AgdaLib-  { libName     :: LibName-  , libFile     :: FilePath-  , libIncludes :: [FilePath]-  , libDepends  :: [LibName]+import Control.DeepSeq+import qualified Control.Exception as E++import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Writer        ( WriterT, runWriterT, MonadWriter, tell )+import Control.Monad.IO.Class      ( MonadIO(..) )++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 System.Directory++import Agda.Interaction.Options.Warnings++import Agda.Syntax.Common.Pretty+import Agda.Syntax.Position++import Agda.Utils.IO               ( showIOException )+import Agda.Utils.Lens+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.+--+--   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, Generic)++-- | A symbolic executable name.+--+type ExeName = Text+type ExeMap  = Map ExeName FilePath++data ExecutablesFile = ExecutablesFile+  { efPath   :: FilePath+      -- ^ E.g. @~/.agda/executables@.+  , efExists :: Bool+       -- ^ The executables file might not exist,+       --   but we may print its assumed location in error messages.+  } deriving (Show, Generic)++-- | The special name @\".\"@ is used to indicated that the current directory+--   should count as a project root.+--+libNameForCurrentDir :: LibName+libNameForCurrentDir = LibName "." []++-- | A file can either belong to a project located at a given root+--   containing an .agda-lib file, or be part of the default project.+data ProjectConfig+  = ProjectConfig+    { configRoot         :: 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)+  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  :: OptionsPragma+                                -- ^ Default pragma options for all files in the library.+  }+  deriving (Show, Generic)++emptyLibFile :: AgdaLibFile+emptyLibFile = AgdaLibFile+  { _libName     = empty+  , _libFile     = ""+  , _libAbove    = 0+  , _libIncludes = []+  , _libDepends  = []+  , _libPragmas  = mempty+  }++---------------------------------------------------------------------------+-- * Lenses+---------------------------------------------------------------------------++-- ** 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' AgdaLibFile FilePath+libFile f a = f (_libFile a) <&> \ x -> a { _libFile = x }++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' AgdaLibFile [LibName]+libDepends f a = f (_libDepends a) <&> \ x -> a { _libDepends = x }++libPragmas :: Lens' AgdaLibFile OptionsPragma+libPragmas f a = f (_libPragmas a) <&> \ x -> a { _libPragmas = x }+++------------------------------------------------------------------------+-- * 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.+  , lineNumPos :: LineNumber     -- ^ Line number in @libraries@ file.+  , filePos    :: FilePath       -- ^ Library file.+  }+  deriving (Show, Generic)++-- ** Warnings++data LibWarning = LibWarning (Maybe LibPositionInfo) LibWarning'+  deriving (Show, Generic)++-- | Library Warnings.+data LibWarning'+  = UnknownField String+  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'+  = 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 (List2 AgdaLibFile)+      -- ^ Raised when a library name is defined in several @.agda-lib files@.+  | 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)++-- | 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)++-- ** Raising warnings and errors++-- | Collection of 'LibError's and 'LibWarning's.+--+type LibErrWarns = [Either LibError LibWarning]++warnings :: MonadWriter LibErrWarns m => List1 LibWarning -> m ()+warnings = tell . map Right . toList++warnings' :: MonadWriter LibErrWarns m => List1 LibWarning' -> m ()+warnings' = tell . map (Right . LibWarning Nothing) . toList++raiseErrors' :: MonadWriter LibErrWarns m => List1 LibError' -> m ()+raiseErrors' = tell . map (Left . (LibError Nothing)) . toList++raiseErrors :: MonadWriter LibErrWarns m => List1 LibError -> m ()+raiseErrors = tell . map Left . toList+++------------------------------------------------------------------------+-- * 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+  Map.lookup path <$> gets projectConfigs++storeCachedProjectConfig+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> ProjectConfig -> m ()+storeCachedProjectConfig path conf = do+  path <- liftIO $ canonicalizePath path+  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+  Map.lookup path <$> gets agdaLibFiles++storeCachedAgdaLibFile+  :: (MonadState LibState m, MonadIO m)+  => FilePath -> AgdaLibFile -> m ()+storeCachedAgdaLibFile path lib = do+  path <- liftIO $ canonicalizePath path+  modify \ s -> s { agdaLibFiles = Map.insert path lib $ agdaLibFiles s }++------------------------------------------------------------------------+-- * Prettyprinting errors and warnings+------------------------------------------------------------------------++-- | Pretty-print 'LibError'.+formatLibError :: [AgdaLibFile] -> LibError -> Doc+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+++-- | 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 $+      [ hcat [ "Library '", pretty lib, "' not found." ]+      , sep [ "Add the path to its .agda-lib file to"+            , nest 2 $ text $ "'" ++ lfPath file ++ "'"+            , "to install."+            ]+      ]++    AmbiguousLib lib tgts -> vcat $+      sep [ hcat [ "Ambiguous library '", pretty lib, "'." ]+            , "Could refer to any one of"+          ]+        : [ 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)++    LibParseError err -> pretty err++    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+    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
@@ -1,127 +1,300 @@-module Agda.Interaction.Library.Parse (parseLibFile, stripComments, splitCommas) where+-- | Parser for @.agda-lib@ files.+--+--   Example file:+--+--   @+--     name: Main+--     depend:+--       standard-library+--     include: .+--       src more-src+--+--   @+--+--   Should parse as:+--+--   @+--     AgdaLib+--       { libName     = "Main"+--       , libFile     = path_to_this_file+--       , libIncludes = [ "." , "src" , "more-src" ]+--       , libDepends  = [ "standard-library" ]+--       }+--   @+--+module Agda.Interaction.Library.Parse+  ( parseLibFile+  , splitCommas+  , trimLineComment+  , runP+  ) where -import Control.Applicative-import Control.Exception import Control.Monad+import Control.Monad.Except+import Control.Monad.Writer import Data.Char-import Data.List+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.Utils.Except ( MonadError(throwError) ) -catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch+import Agda.Syntax.Position -type P = Either String+import Agda.Utils.Applicative+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.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 ) -type GenericFile = [(String, [String])]+-- | Parser monad: Can throw @LibParseError@s, and collects+-- @LibWarning'@s library warnings.+type P = ExceptT LibParseError (Writer [LibWarning']) +runP :: P a -> (Either LibParseError a, [LibWarning'])+runP = runWriter . runExceptT++warningP :: LibWarning' -> P ()+warningP = tell . pure++-- | The config files we parse have the generic structure of a sequence+--   of @field : content@ entries.+type GenericFile = [GenericEntry]++data GenericEntry = GenericEntry+  { geHeader   :: String   -- ^ E.g. field name.    @trim@med.+  , _geContent :: [String] -- ^ E.g. field content. @trim@med.+  }++-- | Library file field format format [sic!]. data Field = forall a. Field   { fName     :: String+      -- ^ Name of the field.   , fOptional :: Bool-  , fParse    :: [String] -> P a-  , fSet      :: a -> AgdaLibFile -> AgdaLibFile }+      -- ^ 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.+  } --- | .agda-lib file format+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 =-  [ Field "name"    False parseName                      $ \ name l -> l { libName     = name }-  , Field "include" True  (pure . concatMap words)       $ \ inc  l -> l { libIncludes = inc }-  , Field "depend"  True  (pure . concatMap splitCommas) $ \ ds   l -> l { libDepends  = ds }+  -- Andreas, 2017-08-23, issue #2708, field "name" is optional.+  [ 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 [s] | [name] <- words s = pure name-    parseName ls = throwError $ "Bad library name: '" ++ unwords ls ++ "'"+    parseName :: [String] -> P LibName+    parseName [s] | [name] <- words s = pure $ parseLibName name+    parseName ls = throwError $ BadLibraryName $ unwords ls -defaultLibFile :: AgdaLibFile-defaultLibFile = AgdaLib { libName = "", libFile = "", libIncludes = [], libDepends = [] }+    parsePaths :: String -> [FilePath]+    parsePaths = go id where+      fixup acc = let fp = acc [] in not (null fp) ?$> fp+      go acc []           = fixup acc+      go acc ('\\' : ' '  :cs) = go (acc . (' ':)) cs+      go acc ('\\' : '\\' :cs) = go (acc . ('\\':)) cs+      go acc (       ' '  :cs) = fixup acc ++ go id cs+      go acc (c           :cs) = go (acc . (c:)) cs --- | .agda-lib parser+    parseFlags :: Range -> String -> OptionsPragma+    parseFlags r s = OptionsPragma+      { pragmaStrings = words s+      , pragmaRange   = r+      }++-- | Parse @.agda-lib@ file.+--+-- Sets 'libFile' name and turn mentioned include directories into absolute+-- pathes (provided the given 'FilePath' is absolute).+-- parseLibFile :: FilePath -> IO (P AgdaLibFile)-parseLibFile file =-  (fmap setPath . parseLib <$> readFile file) `catchIO` \e ->-    return (Left $ "Failed to read library file " ++ file ++ ".\nReason: " ++ 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) lib{ libFile = file }-    unrelativise dir lib = lib { libIncludes = map (dir </>) (libIncludes lib) }+    setPath      lib = unrelativise (takeDirectory file) (set libFile file lib)+    unrelativise dir = over libIncludes (map (dir </>)) -parseLib :: String -> P AgdaLibFile-parseLib s = fromGeneric =<< parseGeneric s+-- | Parse file contents.+parseLib+  :: AbsolutePath+     -- ^ The parsed file.+  -> String+  -> P AgdaLibFile+parseLib file s = fromGeneric file =<< parseGeneric s -findField :: String -> [Field] -> P Field-findField s fs =-  case [ f | f <- fs, fName f == s ] of-    f : _ -> return f-    []    -> throwError $ "Unknown field '" ++ s ++ "'"+-- | Parse 'GenericFile' with 'agdaLibFields' descriptors.+fromGeneric+  :: AbsolutePath+     -- ^ The parsed file.+  -> GenericFile+  -> P AgdaLibFile+fromGeneric file = fromGeneric' file agdaLibFields -fromGeneric :: GenericFile -> P AgdaLibFile-fromGeneric = fromGeneric' agdaLibFields+-- | Given a list of 'Field' descriptors (with their custom parsers),+--   parse a 'GenericFile' into the 'AgdaLibFile' structure.+--+--   Checks mandatory fields are present;+--   no duplicate fields, no unknown fields. -fromGeneric' :: [Field] -> GenericFile -> P AgdaLibFile-fromGeneric' fields fs = do-  checkFields fields (map fst fs)-  foldM upd defaultLibFile fs+fromGeneric'+  :: AbsolutePath+     -- ^ The parsed file.+  -> [Field]+  -> GenericFile+  -> P AgdaLibFile+fromGeneric' file fields fs = do+  checkFields fields (map geHeader fs)+  foldM upd emptyLibFile fs   where-    upd :: AgdaLibFile -> (String, [String]) -> P AgdaLibFile-    upd l (h, cs) = do-      Field{..} <- findField h fields-      x         <- fParse cs-      return $ fSet x l+    -- 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 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   = mandatory \\ fs-      dup       = fs \\ nub fs-      s xs      = if length xs > 1 then "s" else ""-      list xs   = intercalate ", " [ "'" ++ f ++ "'" | f <- xs ]-  when (not $ null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing-  when (not $ 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)+findField s fs = maybe err (return . Just) $ List.find ((s ==) . fName) fs+  where err = warningP (UnknownField s) >> return Nothing+ -- Generic file parser ---------------------------------------------------- +-- | Example:+--+-- @+--     parseGeneric "name:Main--BLA\ndepend:--BLA\n  standard-library--BLA\ninclude : . --BLA\n  src more-src   \n"+--     == Right [("name",["Main"]),("depend",["standard-library"]),("include",[".","src more-src"])]+-- @ parseGeneric :: String -> P GenericFile parseGeneric s =-  groupLines =<< concat <$> mapM (uncurry parseLine) (zip [1..] $ map stripComments $ lines s)+  groupLines =<< concat <$> zipWithM parseLine [1..] (map stripComments $ lines s) -data GenericLine = Header Int String | Content Int String+-- | Lines with line numbers.+data GenericLine+  = Header  LineNumber String+      -- ^ Header line, like a field name, e.g. "include :".  Cannot be indented.+      --   @String@ is 'trim'med.+  | Content LineNumber String+      -- ^ Other line.  Must be indented.+      --   @String@ is 'trim'med.   deriving (Show) -parseLine :: Int -> String -> P [GenericLine]+-- | Parse line into 'Header' and 'Content' components.+--+--   Precondition: line comments and trailing whitespace have been stripped away.+--+--   Example file:+--+--   @+--     name: Main+--     depend:+--       standard-library+--     include: .+--       src more-src+--   @+--+--   This should give+--+--   @+--     [ Header  1 "name"+--     , Content 1 "Main"+--     , Header  2 "depend"+--     , Content 3 "standard-library"+--     , Header  4 "include"+--     , Content 4 "."+--     , Content 5 "src more-src"+--     ]+--   @+parseLine :: LineNumber -> String -> P [GenericLine] parseLine _ "" = pure [] parseLine l s@(c:_)-  | isSpace c   = pure [Content l $ trim s]+    -- Indented lines are 'Content'.+  | 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 s | let s = trim r, not (null s)]-          []  -> throwError $ show l ++ ": Missing field name"-          hs  -> throwError $ show l ++ ": Bad field name " ++ show h-      _ -> throwError $ show l ++ ": Missing ':' for field " ++ show (trim s)+          [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')]+          []  -> throwError $ MissingFieldName l+          hs  -> throwError $ BadFieldName l h+      _ -> throwError $ MissingColonForField l (ltrim s) +-- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'.+--+--   Leading 'Content's?  That's an error.+-- groupLines :: [GenericLine] -> P GenericFile groupLines [] = pure []-groupLines (Content l c : _) = throwError $ show l ++ ": Missing field"-groupLines (Header _ h : ls) = ((h, [ c | Content _ c <- cs ]) :) <$> groupLines ls1+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     isContent Content{} = True     isContent Header{} = False -trim :: String -> String-trim = stripComments . dropWhile isSpace+-- | Remove leading whitespace and line comment.+trimLineComment :: String -> String+trimLineComment = stripComments . ltrim +-- | 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 stripComments "" = ""-stripComments ('-':'-':_) = ""-stripComments (c : s)     = cons c (stripComments s)+stripComments ('-':'-':c:_) | isSpace c = ""+stripComments (c : s) = cons c (stripComments s)   where     cons c "" | isSpace c = ""     cons c s = c : s-
src/full/Agda/Interaction/MakeCase.hs view
@@ -1,52 +1,52 @@-{-# LANGUAGE CPP             #-}+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Interaction.MakeCase where+{-# LANGUAGE NondecreasingIndentation #-} -import Prelude hiding (mapM, mapM_, null)+module Agda.Interaction.MakeCase where -import Control.Applicative hiding (empty)-import Control.Monad hiding (mapM, mapM_, forM)+import Prelude hiding ((!!), null) -import qualified Data.Map as Map+import Data.Either import qualified Data.List as List import Data.Maybe-import Data.Traversable+import Data.Monoid  import Agda.Syntax.Common+import Agda.Syntax.Info import Agda.Syntax.Position+import Agda.Syntax.Concrete (NameInScope(..)) import qualified Agda.Syntax.Concrete as C+import qualified Agda.Syntax.Concrete.Pattern as C import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Info 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.Scope.Monad (resolveName, ResolvedName(..))-import Agda.Syntax.Translation.ConcreteToAbstract+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  import Agda.TypeChecking.Monad import Agda.TypeChecking.Coverage+import Agda.TypeChecking.Coverage.Match ( SplitPatVar(..) , SplitPattern , applySplitPSubst , fromSplitPatterns )+import Agda.TypeChecking.Empty ( isEmptyTel ) import Agda.TypeChecking.Pretty-import Agda.TypeChecking.RecordPatterns-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Rules.LHS.Implicit-import Agda.TheTypeChecker+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+import Agda.Utils.Lens   (set) import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Singleton-import Agda.Utils.Size-import qualified Agda.Utils.HashMap as HMap+import Agda.Utils.WithDefault (lensKeepDefault) -#include "undefined.h" import Agda.Utils.Impossible  type CaseContext = Maybe ExtLamInfo@@ -56,135 +56,256 @@  parseVariables   :: QName           -- ^ The function name.-  -> Telescope       -- ^ The telescope of the clause we are splitting.+  -> Context         -- ^ The context of the RHS of the clause we are splitting.+  -> [AsBinding]     -- ^ The as-bindings of the clause we are splitting   -> InteractionId   -- ^ The hole of this function we are working on.   -> Range           -- ^ The range of this hole.   -> [String]        -- ^ The words the user entered in this hole (variable names).-  -> TCM [Int]       -- ^ The computed de Bruijn indices of the variables to split on.-parseVariables f tel ii rng ss = do+  -> TCM [(Int,NameInScope)] -- ^ The computed de Bruijn indices of the variables to split on,+                             --   with information about whether each variable is in scope.+parseVariables f cxt asb ii rng ss = do +  -- We parse the variables in two steps:+  -- (1) Convert the strings given by the user to abstract names,+  --     using the scope information from the interaction meta.+  -- (2) Convert the abstract names to de Bruijn indices,+  --     using the context of the clause.+   -- 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 -    -- Get printed representation of variables in context.-    n  <- getContextSize-    xs <- forM (downFrom n) $ \ i -> do-      (,i) . P.render <$> prettyTCM (var i)+  reportSDoc "interaction.case" 20 $ do+    m   <- currentModule+    tel <- lookupSection m+    vcat+     [ "parseVariables:"+     , "current module  =" <+> prettyTCM m+     , "current section =" <+> inTopContext (prettyTCM tel)+     , "clause context  =" <+> prettyTCM (PrettyContext cxt)+     ] -    -- We might be under some lambdas, in which case the context-    -- is bigger than the number of pattern variables.-    let nlocals = n - size tel-    unless (nlocals >= 0) __IMPOSSIBLE__+  -- Get printed representation of variables in context.  These are+  -- used for recognizing when the user wants to make a hidden+  -- variable (which is not in scope) visible.+  n  <- getContextSize+  xs <- forM (downFrom n) $ \ i ->+    (,) <$> (P.render <$> prettyTCM (var i)) <*> nameOfBV i -    reportSDoc "interaction.case" 20 $ do-      m   <- currentModule-      tel <- lookupSection m-      fv  <- getDefFreeVars f-      vcat-       [ text "parseVariables:"-       , text "current module  =" <+> prettyTCM m-       , text "current section =" <+> inTopContext (prettyTCM tel)-       , text $ "function's fvs  = " ++ show fv-       , text $ "number of locals= " ++ show nlocals-       ]+  -- Step 1: From strings to abstract names+  abstractNames :: [(A.Name, Maybe BindingSource)] <- forM ss $ \s -> do -    -- Compute which variables correspond to module parameters. These cannot be split on.-    -- Note: these are not necessarily the outer-most bound variables, since-    -- module parameter refinement may have instantiated them, or-    -- with-abstraction might have reshuffled the variables (#2181).-    pars <- freeVarsToApply f-    let nonSplittableVars = [ i | Var i [] <- map unArg pars ]+    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.+    resolveName' (exceptKindsOfNames [GeneralizeName]) Nothing cname >>= \case -    -- Resolve each string to a variable.-    forM ss $ \ s -> do-      let failNotVar = typeError $ GenericError $ "Not a variable: " ++ s-          done i-            | i < 0                    = typeError $ GenericError $-               "Cannot split on local variable " ++ s-               -- See issue #2239+      -- Fail if s is a name, but not of a variable.+      DefinedName{}       -> failNotVar s+      FieldName{}         -> failNotVar s+      ConstructorName{}   -> failNotVar s+      PatternSynResName{} -> failNotVar s -            | elem i nonSplittableVars = typeError $ GenericError $-               "Cannot split on variable " ++ s ++ ". It is either a module parameter " ++-               "or already instantiated by a dot pattern"+      -- If s is a variable name, return it together with binding information.+      VarName x b -> return (x, Just b) -            | otherwise                = return i+      -- If s is not a name, compare it to the printed variable representation.+      UnknownName -> case (lookup s xs) of+        Nothing -> failUnbound s+        Just x  -> return (x, Nothing) -      -- Note: the range in the concrete name is only approximate.-      resName <- resolveName $ C.QName $ C.Name r $ C.stringNameParts s-      case resName of+  -- Step 2: Resolve each abstract name to a de Bruijn index. -        -- Fail if s is a name, but not of a variable.-        DefinedName{}       -> failNotVar-        FieldName{}         -> failNotVar-        ConstructorName{}   -> failNotVar-        PatternSynResName{} -> failNotVar+  -- First, get context names of the clause.+  let clauseCxtNames = contextNames' cxt -        -- If s is a variable name in scope, get its de Bruijn index-        -- via the type checker.-        VarName x -> do-          (v, _) <- getVarInfo x-          case ignoreSharing v of-            Var i [] -> done $ i - nlocals-            _        -> failNotVar+  -- 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 -        -- If s is not a name, compare it to the printed variable representation.-        -- This fallback is to enable splitting on hidden variables.-        UnknownName -> do-          case filter ((s ==) . fst) xs of-            []      -> typeError $ GenericError $ "Unbound variable " ++ s-            [(_,i)] -> done $ i - nlocals-            -- Issue 1325: Variable names in context can be ambiguous.-            _       -> typeError $ GenericError $ "Ambiguous variable " ++ s+  -- We cannot split on module parameters or make them visible+  params <- moduleParamsToApply $ qnameModule f+  let isParam i = any ((== var i) . unArg) params +  forM (zip ss abstractNames) $ \(s, (name, bound)) -> case bound of+    -- Case 1: variable has a binding site. Check if it also exists in+    -- the clause context so we can split on it.+    Just bindingSource -> case (lookup name clauseVars, bindingSource) of+      -- Case 1a: it is also known in the clause telescope and is+      -- actually a variable. If a pattern variable (`PatternBound`)+      -- 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)+      -- Case 1b: the variable has been refined.+      (Just v         , PatternBound _) -> failInstantiatedVar s v+      -- Case 1c: the variable is bound locally (e.g. a record let)+      (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+      (_              , 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+      -- Case 2a: there is a variable with that concrete name in the+      -- clause context. If it is not a parameter, we can make it+      -- visible.+      Just (x, Var i []) | isParam i -> failHiddenModuleBound s+                         | otherwise -> return (i, C.NotInScope)+      -- Case 2b: there is a variable with that concrete name, but it+      -- has been refined.+      Just (x, v) -> failInstantiatedVar s v+      -- Case 2c: there is no variable with that name. Since it was in+      -- scope for the interaction meta, the only possibility is that+      -- it is a hidden lambda-bound variable.+      Nothing -> failHiddenLocal s++  where++  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 = interactionError $ CaseSplitError $ P.text $+    "Cannot make hidden lambda-bound variable " ++ s ++ " visible"+  failModuleBound s = interactionError $ CaseSplitError $ P.text $+    "Cannot split on module parameter " ++ s+  failHiddenModuleBound s = interactionError $ CaseSplitError $ P.text $+    "Cannot make hidden module parameter " ++ s ++ " visible"+  failLetBound s = interactionError $ CaseSplitError $ P.text $+    "Cannot split on let-bound variable " ++ s+  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     = interactionError $ CaseSplitError $ P.text $+    "Cannot split on variable " ++ s +++    ", because let-declarations may not be defined by pattern-matching"+++ -- | Lookup the clause for an interaction point in the signature.---   Returns the CaseContext, the clause itself, and a list of previous clauses+--   Returns the CaseContext, the previous clauses, the clause itself,+--   and a list of the remaining ones. --- Andreas, 2016-06-08, issue #289 and #2006.--- This replace the old findClause hack (shutter with disgust).-getClauseForIP :: QName -> Int -> TCM (CaseContext, Clause, [Clause])-getClauseForIP f clauseNo = do+type ClauseZipper =+   ( [Clause] -- previous clauses+   , Clause   -- clause of interest+   , [Clause] -- other clauses+   )++getClauseZipperForIP :: QName -> Int -> TCM (CaseContext, ClauseZipper)+getClauseZipperForIP f clauseNo = do   (theDef <$> getConstInfo f) >>= \case     Function{funClauses = cs, funExtLam = extlam} -> do-      let (cs1,cs2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt clauseNo cs-          c         = fromMaybe __IMPOSSIBLE__ $ headMaybe cs2-      return (extlam, c, cs1)+      let (cs1,ccs2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt clauseNo cs+          (c,cs2)    = fromMaybe __IMPOSSIBLE__ $ uncons ccs2+      return (extlam, (cs1, c, cs2))     d -> do       reportSDoc "impossible" 10 $ vcat-        [ text "getClauseForIP" <+> prettyTCM f <+> text (show clauseNo)-          <+> text "received"+        [ "getClauseZipperForIP" <+> prettyTCM f <+> text (show clauseNo)+          <+> "received"         , text (show d)         ]       __IMPOSSIBLE__ +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    = 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) + -- | Entry point for case splitting tactic. -makeCase :: InteractionId -> Range -> String -> TCM (QName, CaseContext , [A.Clause])-makeCase hole rng s = withInteractionId hole $ do+makeCase :: InteractionId -> Range -> String -> TCM (QName, CaseContext, [A.Clause])+makeCase hole rng s = withInteractionId hole $ locallyTC eMakeCase (const True) $ do -  -- Get function clause which contains the interaction point.+  -- Jesper, 2018-12-10: print unsolved metas in dot patterns as _+  localTC (\ e -> e { envPrintMetasBare = True }) $ do +  -- Get function clause which contains the interaction point.   InteractionPoint { ipMeta = mm, ipClause = ipCl} <- lookupInteractionPoint hole-  let meta = fromMaybe __IMPOSSIBLE__ mm-  (f, clauseNo, rhs) <- case ipCl of-    IPClause f clauseNo rhs-> return (f, clauseNo, rhs)-    IPNoClause -> typeError $ GenericError $+  (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                -> interactionError $ CaseSplitError $       "Cannot split here, as we are not in a function definition"-  (casectxt, clause, prevClauses) <- getClauseForIP f clauseNo+  (casectxt, (prevClauses0, _clause, follClauses0)) <- getClauseZipperForIP f clauseNo++  -- Instead of using the actual internal clause, we retype check the abstract clause (with+  -- eMakeCase = True). This disables the forcing translation in the unifier, which allows us to+  -- split on forced variables.+  (clause, clauseCxt, clauseAsBindings) <-+    enterClosure clClos $ \ _ -> locallyTC eMakeCase (const True) $+      recheckAbstractClause clTy clWithSub absCl++  let (prevClauses, follClauses) = killRange (prevClauses0, follClauses0)+    -- Andreas, 2019-08-08, issue #3966+    -- Kill the ranges of the existing clauses to prevent wrong error+    -- location to be set by the coverage checker (via isCovered)+    -- for test/interaction/Issue191   let perm = fromMaybe __IMPOSSIBLE__ $ clausePerm clause       tel  = clauseTel  clause       ps   = namedClausePats clause+      ell  = clauseEllipsis clause+  reportSDoc "interaction.case" 100 $ vcat+    [ "splitting clause:"+    , nest 2 $ vcat+      [ "f       =" <+> (text . show) f+      , "context =" <+> ((inTopContext . (text . show)) =<< getContextTelescope)+      , "tel     =" <+> (text . show) tel+      , "perm    =" <+> text (show perm)+      , "ps      =" <+> (text . show) ps+      ]+    ]+  reportSDoc "interaction.case" 60 $ vcat+    [ "splitting clause:"+    , nest 2 $ vcat+      [ "f       =" <+> pretty f+      , "context =" <+> ((inTopContext . pretty) =<< getContextTelescope)+      , "tel     =" <+> pretty tel+      , "perm    =" <+> (text . show) perm+      , "ps      =" <+> pretty ps+      ]+    ]   reportSDoc "interaction.case" 10 $ vcat-    [ text "splitting clause:"+    [ "splitting clause:"     , nest 2 $ vcat-      [ text "f       =" <+> prettyTCM f-      , text "context =" <+> (prettyTCM =<< getContextTelescope)-      , text "tel     =" <+> prettyTCM tel-      , text "perm    =" <+> text (show perm)-      , text "ps      =" <+> text (show ps)+      [ "f       =" <+> prettyTCM f+      , "context =" <+> ((inTopContext . prettyTCM) =<< getContextTelescope)+      , "tel     =" <+> (inTopContext . prettyTCM) tel+      , "perm    =" <+> text (show perm)+      , "ps      =" <+> addContext tel (prettyTCMPatternList ps)+      , "ell     =" <+> text (show ell)+      , "type    =" <+> addContext tel (prettyTCM $ clauseType clause)       ]     ] @@ -192,10 +313,22 @@    let vars = words s +  -- If the user just entered ".", do nothing.+  -- This will expand an ellipsis, if present.++  if concat vars == "." then do+    cl <- makeAbstractClause f rhs NoEllipsis $ clauseToSplitClause clause+    return (f, casectxt, [cl])+   -- If we have no split variables, split on result. -  if null vars then do-    (piTel, sc) <- fixTarget $ clauseToSplitClause clause+  else if null vars then do+    -- Andreas, 2017-07-24, issue #2654:+    -- When we introduce projection patterns in an extended lambda,+    -- we need to print them postfix.+    let postProjInExtLam = applyWhen (isJust casectxt) $+          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.     -- To split on result, he can then C-c C-c again.@@ -207,39 +340,103 @@       -- if any of them is shown by the printer       imp <- optShowImplicit <$> pragmaOptions       return $ imp || any visible (telToList piTel)-    scs <- if newPats then return [sc] else do+    scs <- if newPats then return [sc] else postProjInExtLam $ do       res <- splitResult f sc       case res of-        Nothing  -> typeError $ GenericError $ "Cannot split on result here"-        Just cov -> ifNotM (optCopatterns <$> pragmaOptions) failNoCop $ {-else-} do++        Left err  -> do+          -- Andreas, 2017-12-16, issue #2871+          -- If there is nothing to split, introduce trailing hidden arguments.++          -- Get trailing hidden pattern variables+          let trailingPatVars :: [NamedArg DBPatVar]+              trailingPatVars = takeWhileJust isVarP $ reverse ps+              isVarP (Arg ai (Named n (VarP _ x))) = Just $ Arg ai $ Named n x+              isVarP _ = Nothing+          -- If all are already coming from the user, there is really nothing todo!+          when (all ((UserWritten ==) . getOrigin) trailingPatVars) $ do+            typeError $ SplitError err+          -- Otherwise, we make these user-written+          let xs = map (dbPatVarIndex . namedArg) trailingPatVars+          return [makePatternVarsVisible xs sc]++        Right cov -> ifNotM (optCopatterns <$> pragmaOptions) failNoCop $ {-else-} do           -- Andreas, 2016-05-03: do not introduce function arguments after projection.           -- This is sometimes annoying and can anyway be done by another C-c C-c.           -- mapM (snd <.> fixTarget) $ splitClauses cov-          return $ splitClauses cov+          return cov     checkClauseIsClean ipCl-    (f, casectxt,) <$> mapM (makeAbstractClause f rhs) scs+    (f, casectxt,) <$> do+      -- Andreas, 2020-05-18, issue #4536+      -- When result splitting yields no clauses, replace rhs by @record{}@.+      if null scs then+        return [ A.spineToLhs $ absCl{ A.clauseRHS = makeRHSEmptyRecord rhs } ]+      else mapM (makeAbstractClause f rhs ell) scs   else do     -- split on variables-    xs <- parseVariables f tel hole rng vars+    xs <- parseVariables f clauseCxt clauseAsBindings hole rng vars+    reportSLn "interaction.case" 30 $ "parsedVariables: " ++ show (zip xs vars)     -- Variables that are not in scope yet are brought into scope (@toShow@)     -- The other variables are split on (@toSplit@).-    let (toShow, toSplit) = flip mapEither (zip xs vars) $ \ (x, s) ->-          if take 1 s == "." then Left x else Right x+    let (toShow, toSplit) = partitionEithers $ for (zip xs vars) $ \ ((x,nis), s) ->+          if (nis == C.NotInScope) then Left x else Right x     let sc = makePatternVarsVisible toShow $ clauseToSplitClause clause     scs <- split f toSplit sc-    -- filter out clauses that are already covered-    scs <- filterM (not <.> isCovered f prevClauses . fst) scs-    cs <- forM scs $ \(sc, isAbsurd) -> do-            if isAbsurd then makeAbsurdClause f sc else makeAbstractClause f rhs sc+    reportSLn "interaction.case" 70 $ "makeCase: survived the splitting"++    -- If any of the split variables is hidden by the ellipsis, we+    -- should force the expansion of the ellipsis.+    let splitNames = map (\i -> ctxEntryName $ clauseCxt !! i) toSplit+    shouldExpandEllipsis <- return (not $ null toShow) `or2M` anyEllipsisVar f absCl splitNames+    let ell' | shouldExpandEllipsis = NoEllipsis+             | otherwise            = ell++    -- CLEAN UP OF THE GENERATED CLAUSES+    -- 1. filter out the generated clauses that are already covered+    --    we consider a generated clause already covered if it is covered by:+    --    a. a pre-existing clause defined before the one we splitted (prevClauses)+    --    b. a pre-existing clause defined after the one we splitted (follClauses)+    --       under the condition that it did not cover the one we splitted but was+    --       covered by it (i.e. it was considered unreachable).+    -- The key idea here is:+    --       f m    zero = ?  ---- split on m --->  f (suc m) zero = ?+    --       f zero zero = ?                        f zero    zero = ?+    --       f _    _    = ?                        f _       _    = ?+    -- because [f zero zero] is already defined.+    -- However we ignore [f _ _]: [f m zero] was already a refinement of it,+    -- hinting that we considered it more important than the catchall.+    let sclause = clauseToSplitClause clause+    fcs <- filterM (\ cl -> (isCovered f [clause] (clauseToSplitClause cl)) `and2M`+                            (not <$> isCovered f [cl] sclause))+                   follClauses+    scs <- filterM (not <.> isCovered f (prevClauses ++ fcs) . fst) scs+    reportSLn "interaction.case" 70 $ "makeCase: survived filtering out already covered clauses"+    -- 2. filter out trivially impossible clauses not asked for by the user+    cs <- catMaybes <$> do+     forM scs $ \ (sc, isAbsurd) -> if isAbsurd+      -- absurd clause coming from a split asked for by the user+      then Just <$> makeAbsurdClause f ell' sc+      -- trivially empty clause due to the refined patterns+      else+        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"+    -- 3. If the cleanup removed everything then we know that none of the clauses where+    --    absurd but that all of them were trivially empty. In this case we rewind and+    --    insert all the clauses (garbage in, garbage out!)+    cs <- if not (null cs) then pure cs+          else mapM (makeAbstractClause f rhs ell' . fst) scs+     reportSDoc "interaction.case" 65 $ vcat-      [ text "split result:"-      , nest 2 $ vcat $ map (text . show) cs+      [ "split result:"+      , nest 2 $ vcat $ map prettyA cs       ]     checkClauseIsClean ipCl     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@@ -247,7 +444,7 @@   split :: QName -> [Nat] -> SplitClause -> TCM [(SplitClause, Bool)]   split f [] clause = return [(clause,False)]   split f (var : vars) clause = do-    z <- splitClauseWithAbsurd clause var+    z <- dontAssignMetas $ splitClauseWithAbsurd clause var     case z of       Left err          -> typeError $ SplitError err       Right (Left cl)   -> return [(cl,True)]@@ -257,7 +454,7 @@    -- Finds the new variable corresponding to an old one, if any.   newVar :: SplitClause -> Nat -> Maybe Nat-  newVar c x = case ignoreSharing $ applyPatSubst (scSubst c) (var x) of+  newVar c x = case applySplitPSubst (scSubst c) (var x) of     Var y [] -> Just y     _        -> Nothing @@ -265,59 +462,95 @@   -- In this case, we refuse to split, as this might lose the refinements.   checkClauseIsClean :: IPClause -> TCM ()   checkClauseIsClean ipCl = do-    sips <- Map.elems <$> use stSolvedInteractionPoints+    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" --- | Mark the variables given by the list of deBruijn indices as 'UserWritten'---   in the 'SplitClause'.+-- | Make the given pattern variables visible by marking their origin as+--   'CaseSplit' and pattern origin as 'PatOSplit' in the 'SplitClause'. makePatternVarsVisible :: [Nat] -> SplitClause -> SplitClause makePatternVarsVisible [] sc = sc makePatternVarsVisible is sc@SClause{ scPats = ps } =-  sc{ scPats = map (mapNamedArg mkVis) ps }+  sc{ scPats = mapNamedArgPattern mkVis ps }   where-  mkVis :: NamedArg DBPatVar -> NamedArg DBPatVar-  mkVis nx@(Arg ai (Named n (DBPatVar x i)))+  mkVis :: NamedArg SplitPattern -> NamedArg SplitPattern+  mkVis (Arg ai (Named n (VarP o (SplitPatVar x i ls))))     | i `elem` is =       -- We could introduce extra consistency checks, like       -- if visible ai then __IMPOSSIBLE__ else       -- or passing the parsed name along and comparing it with @x@-      setOrigin UserWritten nx-    | otherwise = nx+      Arg (setOrigin CaseSplit ai) $ Named n $ VarP (PatternInfo PatOSplit []) $ SplitPatVar x i ls+  mkVis np = np +-- | If a copattern split yields no clauses, we must be at an empty record type.+--   In this case, replace the rhs by @record{}@+makeRHSEmptyRecord :: A.RHS -> A.RHS+makeRHSEmptyRecord = \case+  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__+ -- | Make clause with no rhs (because of absurd match). -makeAbsurdClause :: QName -> SplitClause -> TCM A.Clause-makeAbsurdClause f (SClause tel ps _ _ t) = do+makeAbsurdClause :: QName -> ExpandedEllipsis -> SplitClause -> TCM A.Clause+makeAbsurdClause f ell (SClause tel sps _ _ t) = do+  let ps = fromSplitPatterns sps   reportSDoc "interaction.case" 10 $ vcat-    [ text "Interaction.MakeCase.makeAbsurdClause: split clause:"+    [ "Interaction.MakeCase.makeAbsurdClause: split clause:"     , nest 2 $ vcat-      [ text "context =" <+> (prettyTCM =<< getContextTelescope)-      , text "tel =" <+> prettyTCM tel-      , text "ps =" <+> text (show ps)+      [ "context =" <+> do (inTopContext . prettyTCM) =<< getContextTelescope+      , "tel     =" <+> do inTopContext $ prettyTCM tel+      , "ps      =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList ps -- P.sep <$> prettyTCMPatterns ps+      , "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 tel ps Nothing t False-    -- Normalise the dot patterns-    ps <- addContext tel $ normalise $ namedClausePats c-    reportSDoc "interaction.case" 60 $ text "normalized patterns: " <+> text (show ps)-    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. -makeAbstractClause :: QName -> A.RHS -> SplitClause -> TCM A.Clause-makeAbstractClause f rhs cl = do+makeAbstractClause :: QName -> A.RHS -> ExpandedEllipsis -> SplitClause -> TCM A.Clause+makeAbstractClause f rhs ell cl = do -  A.Clause lhs _ _ _ _ <- makeAbsurdClause f cl-  reportSDoc "interaction.case" 60 $ text "reified lhs: " <+> text (show lhs)-  return $ A.Clause lhs [] rhs [] False+  lhs <- A.clauseLHS <$> makeAbsurdClause f ell cl+  reportSDoc "interaction.case" 60 $ "reified lhs: " <+> prettyA lhs+  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   -- return $ A.Clause lhs [] (A.RHS $ A.QuestionMark info ii) [] False++anyEllipsisVar :: QName -> A.SpineClause -> [Name] -> TCM Bool+anyEllipsisVar f cl xs = do+  let lhs = A.clauseLHS cl+      ps  = A.spLhsPats lhs+      ell = lhsEllipsis $ A.spLhsInfo lhs+      anyVar :: A.Pattern -> Any -> Any+      anyVar p acc = Any $ getAny acc || case p of+        A.VarP x -> A.unBind x `elem` xs+        _        -> False+  case ell of+    NoEllipsis           -> return False+    ExpandedEllipsis _ k -> do+      ps' <- snd <$> reifyDisplayFormP f ps []+      let ellipsisPats :: A.Patterns+          ellipsisPats = fst $ C.splitEllipsis k ps'+      reportSDoc "interaction.case.ellipsis" 40 $ vcat+        [ "should we expand the ellipsis?"+        , nest 2 $ "xs           =" <+> prettyList_ (map prettyA xs)+        , nest 2 $ "ellipsisPats =" <+> prettyList_ (map prettyA ellipsisPats)+        ]+      return $ getAny $ A.foldrAPattern anyVar ellipsisPats
src/full/Agda/Interaction/Monad.hs view
@@ -1,12 +1,53 @@-module Agda.Interaction.Monad (IM, runIM, readline) where+{-# OPTIONS_GHC -Wunused-imports #-} -import Control.Monad.Trans-import System.Console.Haskeline+{-# OPTIONS_GHC -fwarn-orphans #-}+{-# LANGUAGE CPP               #-} +module Agda.Interaction.Monad+  ( IM+  , runIM+  , 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+  , ReadTCState+  , TCErr+  , TCM, TCMT(..)+  , mapTCMT+  ) +-- | Interaction monad.+newtype IM a = IM {unIM :: TCMT (Haskeline.InputT IO) a}+  deriving+  ( Functor, Applicative, Monad, MonadIO+  , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM+  , MonadFileId+  )++runIM :: IM a -> TCM a+runIM = mapTCMT (Haskeline.runInputT Haskeline.defaultSettings) . unIM++instance MonadError TCErr IM where+  throwError                = liftIO . throwIO+  catchError (IM (TCM m)) h = IM . TCM $ \s e ->+    m s e `Haskeline.catch` \err -> unTCM (unIM (h err)) s e+ -- | Line reader. The line reader history is not stored between -- sessions.- readline :: String -> IM (Maybe String)-readline s = lift (getInputLine s)+readline s = IM $ lift (Haskeline.getInputLine s)
src/full/Agda/Interaction/Options.hs view
@@ -1,824 +1,11 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Options-    ( CommandLineOptions(..)-    , IgnoreFlags(..)-    , PragmaOptions(..)-    , OptionsPragma-    , Flag, OptM, runOptM-    , Verbosity-    , checkOpts-    , parseStandardOptions, parseStandardOptions'-    , parsePragmaOptions-    , parsePluginOptions-    , defaultOptions-    , defaultInteractionOptions-    , defaultVerbosity-    , defaultCutOff-    , defaultPragmaOptions-    , standardOptions_-    , unsafePragmaOptions-    , isLiterate-    , mapFlag-    , usage-    , defaultLibDir-    -- Reused by PandocAgda-    , inputFlag-    , standardOptions-    , getOptSimple+    ( module Agda.Interaction.Options.Base+    , module Agda.Interaction.Options.HasOptions+    , module Agda.Interaction.Options.Types     ) where -import Control.Applicative-import Control.Monad            ( (>=>), when )-import Control.Monad.Trans---- base-4.7 defines the Functor instances for OptDescr and ArgDescr-#if !(MIN_VERSION_base(4,7,0))-import Data.Orphans             ()-#endif--import Data.Either-import Data.Maybe-import Data.List                ( isSuffixOf , intercalate )-import System.Console.GetOpt    ( getOpt', usageInfo, ArgOrder(ReturnInOrder)-                                , OptDescr(..), ArgDescr(..)-                                )-import System.Directory         ( doesFileExist, doesDirectoryExist )--import Text.EditDistance--import Agda.Termination.CutOff  ( CutOff(..) )--import Agda.Interaction.Library--import Agda.Utils.Except-  ( ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--import Agda.Utils.FileName      ( absolute, AbsolutePath, filePath )-import Agda.Utils.Monad         ( ifM, readM )-import Agda.Utils.List          ( groupOn, wordsBy )-import Agda.Utils.String        ( indent )-import Agda.Utils.Trie          ( Trie )-import Agda.Syntax.Parser.Literate ( literateExts )-import qualified Agda.Utils.Trie as Trie--import Agda.Version--- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/.-import Paths_Agda ( getDataFileName )---- | This should probably go somewhere else.-isLiterate :: FilePath -> Bool-isLiterate file = any (`isSuffixOf` file) literateExts---- OptDescr is a Functor ----------------------------------------------------type Verbosity = Trie String Int---- ignore or respect the flags --allow-unsolved-metas,--- --no-termination-check, --no-positivity-check?-data IgnoreFlags = IgnoreFlags | RespectFlags-  deriving Eq--data CommandLineOptions = Options-  { optProgramName      :: String-  , optInputFile        :: Maybe FilePath-  , optIncludePaths     :: [FilePath]-  , optAbsoluteIncludePaths :: [AbsolutePath]-  , 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-  , optShowVersion      :: Bool-  , optShowHelp         :: Bool-  , optInteractive      :: Bool-  , optGHCiInteraction  :: Bool-  , optCompileNoMain    :: Bool-  , optGhcCompile       :: Bool-  , optGhcCallGhc       :: Bool-  , optGhcFlags         :: [String]-  , optEpicCompile      :: Bool-  , optJSCompile        :: Bool-  , optUHCCompile       :: Bool-  , optUHCBin           :: Maybe FilePath-  , optUHCTextualCore   :: Bool-  , optUHCCallUHC       :: Bool-  , optUHCTraceLevel    :: Int-  , optUHCFlags         :: [String]-  , optOptimSmashing    :: Bool-  , optCompileDir       :: Maybe FilePath-  -- ^ In the absence of a path the project root is used.-  , optGenerateVimFile  :: Bool-  , optGenerateLaTeX    :: Bool-  , optGenerateHTML     :: Bool-  , optDependencyGraph  :: Maybe FilePath-  , optLaTeXDir         :: FilePath-  , optHTMLDir          :: FilePath-  , optCSSFile          :: Maybe FilePath-  , optIgnoreInterfaces :: Bool-  , optForcing          :: Bool-  , optPragmaOptions    :: PragmaOptions-  , optEpicFlags        :: [String]-  , optSafe             :: Bool-  , optSharing          :: Bool-  , optCaching          :: Bool-  }-  deriving Show---- | Options which can be set in a pragma.--data PragmaOptions = PragmaOptions-  { optShowImplicit              :: Bool-  , optShowIrrelevant            :: Bool-  , optVerbose                   :: Verbosity-  , optProofIrrelevance          :: Bool-  , optAllowUnsolved             :: Bool-  , optDisablePositivity         :: Bool-  , optTerminationCheck          :: Bool-  , optTerminationDepth          :: CutOff-    -- ^ Cut off structural order comparison at some depth in termination checker?-  , optCompletenessCheck         :: Bool-  , optUniverseCheck             :: Bool-  , optSizedTypes                :: Bool-  , optInjectiveTypeConstructors :: Bool-  , optGuardingTypeConstructors  :: Bool-  , optUniversePolymorphism      :: Bool-  , optIrrelevantProjections     :: Bool-  , optExperimentalIrrelevance   :: Bool  -- ^ irrelevant levels, irrelevant data matching-  , optWithoutK                  :: Bool-  , optCopatterns                :: Bool  -- ^ Allow definitions by copattern matching?-  , optPatternMatching           :: Bool  -- ^ Is pattern matching allowed in the current file?-  , optExactSplit                :: Bool-  , optEta                       :: Bool-  , optRewriting                 :: Bool  -- ^ Can rewrite rules be added and used?-  , optPostfixProjections        :: Bool-      -- ^ Should system generated projections 'ProjSystem' be printed-      --   postfix (True) or prefix (False).-  , optInstanceSearchDepth       :: Int-  }-  deriving (Show,Eq)---- | 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-  , optShowVersion      = False-  , optShowHelp         = False-  , optInteractive      = False-  , optGHCiInteraction  = False-  , optCompileNoMain    = False-  , optGhcCompile       = False-  , optGhcCallGhc       = True-  , optGhcFlags         = []-  , optEpicCompile      = False-  , optJSCompile        = False-  , optUHCCompile       = False-  , optUHCBin           = Nothing-  , optUHCTextualCore   = False-  , optUHCCallUHC       = True-  , optUHCTraceLevel    = 0-  , optUHCFlags         = []-  , optOptimSmashing    = True-  , optCompileDir       = Nothing-  , optGenerateVimFile  = False-  , optGenerateLaTeX    = False-  , optGenerateHTML     = False-  , optDependencyGraph  = Nothing-  , optLaTeXDir         = defaultLaTeXDir-  , optHTMLDir          = defaultHTMLDir-  , optCSSFile          = Nothing-  , optIgnoreInterfaces = False-  , optForcing          = True-  , optPragmaOptions    = defaultPragmaOptions-  , optEpicFlags        = []-  , optSafe             = False-  , optSharing          = False-  , optCaching          = False-  }--defaultPragmaOptions :: PragmaOptions-defaultPragmaOptions = PragmaOptions-  { optShowImplicit              = False-  , optShowIrrelevant            = False-  , optVerbose                   = defaultVerbosity-  , optProofIrrelevance          = False-  , optExperimentalIrrelevance   = False-  , optIrrelevantProjections     = True-  , optAllowUnsolved             = False-  , optDisablePositivity         = False-  , optTerminationCheck          = True-  , optTerminationDepth          = defaultCutOff-  , optCompletenessCheck         = True-  , optUniverseCheck             = True-  , optSizedTypes                = True-  , optInjectiveTypeConstructors = False-  , optGuardingTypeConstructors  = False-  , optUniversePolymorphism      = True-  , optWithoutK                  = False-  , optCopatterns                = True-  , optPatternMatching           = True-  , optExactSplit                = False-  , optEta                       = True-  , optRewriting                 = False-  , optPostfixProjections        = False-  , optInstanceSearchDepth       = 500-  }---- | The default termination depth.--defaultCutOff :: CutOff-defaultCutOff = CutOff 0 -- minimum value---- | The default output directory for LaTeX.--defaultLaTeXDir :: String-defaultLaTeXDir = "latex"---- | The default output directory for HTML.--defaultHTMLDir :: String-defaultHTMLDir = "html"--type OptM = ExceptT String IO--runOptM :: OptM a -> IO (Either String a)-runOptM = runExceptT--{- | @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-  | not (atMostOne [optAllowUnsolved . p, \x -> optGhcCompile x]) = throwError-      "Unsolved meta variables are not allowed when compiling.\n"-  | optCompileNoMain opts && (not (optGhcCompile opts || optUHCCompile opts)) = throwError-      "--no-main only allowed in combination with --compile.\n"-  | not (atMostOne [optGHCiInteraction, isJust . optInputFile]) =-      throwError "Choose at most one: input file or --interaction.\n"-  | not (atMostOne $ interactive ++ [\x -> optGhcCompile x, optEpicCompile, optJSCompile]) =-      throwError "Choose at most one: compilers/--interactive/--interaction.\n"-  | not (atMostOne $ interactive ++ [optGenerateHTML]) =-      throwError "Choose at most one: --html/--interactive/--interaction.\n"-  | not (atMostOne $ interactive ++ [isJust . optDependencyGraph]) =-      throwError "Choose at most one: --dependency-graph/--interactive/--interaction.\n"-  | not (atMostOne $ interactive ++ [optGenerateLaTeX]) =-      throwError "Choose at most one: --latex/--interactive/--interaction.\n"-  | (not . null . optEpicFlags $ opts)-      && not (optEpicCompile opts) =-      throwError "Cannot set Epic flags without using the Epic backend.\n"-  | (isJust $ optUHCBin opts)-      && not (optUHCCompile opts) =-      throwError "Cannot set uhc binary without using UHC backend.\n"-  | (optUHCTextualCore opts)-      && not (optUHCCompile opts) =-      throwError "Cannot set --uhc-textual-core without using UHC backend.\n"-  | otherwise = return opts-  where-  atMostOne bs = length (filter ($ opts) bs) <= 1--  p = optPragmaOptions--  interactive = [optInteractive, optGHCiInteraction]---- | Check for unsafe pramas. Gives a list of used unsafe flags.--unsafePragmaOptions :: PragmaOptions -> [String]-unsafePragmaOptions opts =-  [ "--allow-unsolved-metas"                     | optAllowUnsolved opts             ] ++-  [ "--no-positivity-check"                      | optDisablePositivity opts         ] ++-  [ "--no-termination-check"                     | not (optTerminationCheck opts)    ] ++-  [ "--type-in-type"                             | not (optUniverseCheck opts)       ] ++-  -- [ "--sized-types"                              | optSizedTypes opts                ] ++-  [ "--injective-type-constructors"              | optInjectiveTypeConstructors opts ] ++-  [ "--guardedness-preserving-type-constructors" | optGuardingTypeConstructors opts  ] ++-  [ "--experimental-irrelevance"                 | optExperimentalIrrelevance opts   ] ++-  [ "--rewriting"                                | optRewriting opts                 ] ++-  []--inputFlag :: FilePath -> Flag CommandLineOptions-inputFlag f o =-    case optInputFile o of-        Nothing  -> return $ o { optInputFile = Just f }-        Just _   -> throwError "only one input file allowed"--versionFlag :: Flag CommandLineOptions-versionFlag o = return $ o { optShowVersion = True }--helpFlag :: Flag CommandLineOptions-helpFlag o = return $ o { optShowHelp = True }--safeFlag :: Flag CommandLineOptions-safeFlag o = return $ o { optSafe = True }--sharingFlag :: Bool -> Flag CommandLineOptions-sharingFlag b o = return $ o { optSharing = b }--cachingFlag :: Bool -> Flag CommandLineOptions-cachingFlag b o = return $ o { optCaching = b }--proofIrrelevanceFlag :: Flag PragmaOptions-proofIrrelevanceFlag o = return $ o { optProofIrrelevance = True }--experimentalIrrelevanceFlag :: Flag PragmaOptions-experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }--noIrrelevantProjectionsFlag :: Flag PragmaOptions-noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }--ignoreInterfacesFlag :: Flag CommandLineOptions-ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }--allowUnsolvedFlag :: Flag PragmaOptions-allowUnsolvedFlag o = return $ o { optAllowUnsolved = True }--showImplicitFlag :: Flag PragmaOptions-showImplicitFlag o = return $ o { optShowImplicit = True }--showIrrelevantFlag :: Flag PragmaOptions-showIrrelevantFlag o = return $ o { optShowIrrelevant = True }--ghciInteractionFlag :: Flag CommandLineOptions-ghciInteractionFlag o = return $ o { optGHCiInteraction = True }--vimFlag :: Flag CommandLineOptions-vimFlag o = return $ o { optGenerateVimFile = True }--latexFlag :: Flag CommandLineOptions-latexFlag o = return $ o { optGenerateLaTeX = True }--latexDirFlag :: FilePath -> Flag CommandLineOptions-latexDirFlag d o = return $ o { optLaTeXDir = d }--noPositivityFlag :: Flag PragmaOptions-noPositivityFlag o = return $ o { optDisablePositivity = True }--dontTerminationCheckFlag :: Flag PragmaOptions-dontTerminationCheckFlag o = return $ o { optTerminationCheck = False }---- 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-                                     }-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 = True }--noSizedTypes :: Flag PragmaOptions-noSizedTypes o = return $ o { optSizedTypes = False }--injectiveTypeConstructorFlag :: Flag PragmaOptions-injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }--guardingTypeConstructorFlag :: Flag PragmaOptions-guardingTypeConstructorFlag o = return $ o { optGuardingTypeConstructors = True }--universePolymorphismFlag :: Flag PragmaOptions-universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }--noUniversePolymorphismFlag :: Flag PragmaOptions-noUniversePolymorphismFlag  o = return $ o { optUniversePolymorphism = False }--noForcingFlag :: Flag CommandLineOptions-noForcingFlag o = return $ o { optForcing = False }--withKFlag :: Flag PragmaOptions-withKFlag o = return $ o { optWithoutK = False }--withoutKFlag :: Flag PragmaOptions-withoutKFlag o = return $ o { optWithoutK = 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 = return $ o { optExactSplit = True }--noExactSplitFlag :: Flag PragmaOptions-noExactSplitFlag o = return $ o { optExactSplit = False }--rewritingFlag :: Flag PragmaOptions-rewritingFlag o = return $ o { optRewriting = True }--postfixProjectionsFlag :: Flag PragmaOptions-postfixProjectionsFlag o = return $ o { optPostfixProjections = True }--instanceDepthFlag :: String -> Flag PragmaOptions-instanceDepthFlag s o = do-  d <- integerArgument "--instance-search-depth" s-  return $ o { optInstanceSearchDepth = d }--interactiveFlag :: Flag CommandLineOptions-interactiveFlag  o = return $ o { optInteractive    = True-                                , optPragmaOptions  = (optPragmaOptions o)-                                                      { optAllowUnsolved = True }-                                }--compileFlagNoMain :: Flag CommandLineOptions-compileFlagNoMain o = return $ o { optCompileNoMain = True }--compileGhcFlag :: Flag CommandLineOptions-compileGhcFlag o = return $ o { optGhcCompile = True }--ghcDontCallGhcFlag :: Flag CommandLineOptions-ghcDontCallGhcFlag o = return $ o { optGhcCallGhc = False }---- NOTE: Quadratic in number of flags.-ghcFlag :: String -> Flag CommandLineOptions-ghcFlag f o = return $ o { optGhcFlags = optGhcFlags o ++ [f] }---- The Epic backend has been removed. See Issue 1481.-compileEpicFlag :: Flag CommandLineOptions--- compileEpicFlag o = return $ o { optEpicCompile = True}-compileEpicFlag o = throwError "the Epic backend has been disabled"--compileJSFlag :: Flag CommandLineOptions-compileJSFlag  o = return $ o { optJSCompile = True }--compileUHCFlag :: Flag CommandLineOptions-compileUHCFlag o = return $ o { optUHCCompile = True}--compileDirFlag :: FilePath -> Flag CommandLineOptions-compileDirFlag f o = return $ o { optCompileDir = Just f }---- NOTE: Quadratic in number of flags.--- The Epic backend has been removed. See Issue 1481.-epicFlagsFlag :: String -> Flag CommandLineOptions--- epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] }-epicFlagsFlag s o = throwError "the Epic backend has been disabled"--uhcBinFlag :: String -> Flag CommandLineOptions-uhcBinFlag s o = return $ o { optUHCBin  = Just s }--uhcTextualCoreFlag :: Flag CommandLineOptions-uhcTextualCoreFlag o = return $ o { optUHCTextualCore = True }--uhcDontCallUHCFlag :: Flag CommandLineOptions-uhcDontCallUHCFlag o = return $ o { optUHCCallUHC = False }--uhcTraceLevelFlag :: String -> Flag CommandLineOptions--- TODO proper parsing and error handling-uhcTraceLevelFlag i o = return $ o { optUHCTraceLevel = read i }--uhcFlagsFlag :: String -> Flag CommandLineOptions-uhcFlagsFlag s o = return $ o { optUHCFlags = optUHCFlags o ++ [s] }--htmlFlag :: Flag CommandLineOptions-htmlFlag o = return $ o { optGenerateHTML = True }--dependencyGraphFlag :: FilePath -> Flag CommandLineOptions-dependencyGraphFlag f o = return $ o { optDependencyGraph = Just f }--htmlDirFlag :: FilePath -> Flag CommandLineOptions-htmlDirFlag d o = return $ o { optHTMLDir = d }--cssFlag :: FilePath -> Flag CommandLineOptions-cssFlag f o = return $ o { optCSSFile = 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 = do-  ifM (liftIO $ doesFileExist s)-    {-then-} (return $ o { optOverrideLibrariesFile = Just s })-    {-else-} (throwError $ "Libraries file not found: " ++ s)--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 s = case wordsBy (`elem` ":.") s of-      []  -> usage-      ss  -> do-        n <- readM (last ss) `catchError` \_ -> usage-        return (init ss, n)-    usage = throwError "argument to verbose should be on the form x.y.z:N or N"--terminationDepthFlag :: String -> Flag PragmaOptions-terminationDepthFlag s o =-    do k <- readM s `catchError` \_ -> usage-       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"--integerArgument :: String -> String -> OptM Int-integerArgument flag s =-    readM s `catchError` \_ ->-        throwError $ "option '" ++ flag ++ "' requires an integer argument"--standardOptions :: [OptDescr (Flag CommandLineOptions)]-standardOptions =-    [ Option ['V']  ["version"] (NoArg versionFlag) "show version number"-    , Option ['?']  ["help"]    (NoArg helpFlag)    "show this help"-    , Option ['I']  ["interactive"] (NoArg interactiveFlag)-                    "start in interactive mode"-    , Option []     ["interaction"] (NoArg ghciInteractionFlag)-                    "for use with the Emacs mode"-    , Option ['c']  ["compile", "ghc"] (NoArg compileGhcFlag)-                    "compile program using the GHC backend"-    , Option []     ["ghc-dont-call-ghc"] (NoArg ghcDontCallGhcFlag) "Don't call ghc, just write the GHC Haskell files."-    , Option []     ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")-                    "give the flag GHC-FLAG to GHC when compiling using the GHC backend"-    , Option []     ["no-main"] (NoArg compileFlagNoMain)-                    "when compiling using the GHC backend or the UHC backend (experimental), do not treat the requested module as the main module of a program"--    -- The Epic backend has been removed. See Issue 1481.-    , Option []     ["epic"] (NoArg compileEpicFlag)-    --                "compile program using the Epic backend"-                    "the Epic backend has been removed"--    , Option []     ["js"] (NoArg compileJSFlag) "compile program using the JS backend"-    , Option []     ["uhc"] (NoArg compileUHCFlag) "compile program using the UHC backend"-    , Option []     ["uhc-bin"] (ReqArg uhcBinFlag "UHC") "The uhc binary to use when compiling with the UHC backend."-    , Option []     ["uhc-textual-core"] (NoArg uhcTextualCoreFlag) "Use textual core as intermediate representation instead of binary core."-    , Option []     ["uhc-dont-call-uhc"] (NoArg uhcDontCallUHCFlag) "Don't call uhc, just write the UHC Core files."-    , Option []     ["uhc-gen-trace"] (ReqArg uhcTraceLevelFlag "TRACE") "Add tracing code to generated executable."-    , Option []     ["uhc-flag"] (ReqArg uhcFlagsFlag "UHC-FLAG")-                    "give the flag UHC-FLAG to UHC when compiling using the UHC backend"-    , Option []     ["compile-dir"] (ReqArg compileDirFlag "DIR")-                    ("directory for compiler output (default: the project root)")--    -- The Epic backend has been removed. See Issue 1481.-    , Option []     ["epic-flag"] (ReqArg epicFlagsFlag "EPIC-FLAG")-    --                "give the flag EPIC-FLAG to Epic when compiling using Epic"-                    "the Epic backend has been removed"--    , Option []     ["vim"] (NoArg vimFlag)-                    "generate Vim highlighting files"-    , Option []     ["latex"] (NoArg latexFlag)-                    "generate LaTeX with highlighted source code"-    , Option []     ["latex-dir"] (ReqArg latexDirFlag "DIR")-                    ("directory in which LaTeX files are placed (default: " ++-                     defaultLaTeXDir ++ ")")-    , Option []     ["html"] (NoArg htmlFlag)-                    "generate HTML files with highlighted source code"-    , Option []     ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")-                    "generate a Dot file with a module dependency graph"-    , Option []     ["html-dir"] (ReqArg htmlDirFlag "DIR")-                    ("directory in which HTML files are placed (default: " ++-                     defaultHTMLDir ++ ")")-    , Option []     ["css"] (ReqArg cssFlag "URL")-                    "the CSS file used by the HTML files (can be relative)"-    , 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 []     ["no-forcing"] (NoArg noForcingFlag)-                    "disable the forcing optimisation"-    , Option []     ["safe"] (NoArg safeFlag)-                    "disable postulates, unsafe OPTION pragmas and primTrustMe"-    , Option []     ["sharing"] (NoArg $ sharingFlag True)-                    "enable sharing and call-by-need evaluation (experimental) (default: OFF)"-    , Option []     ["no-sharing"] (NoArg $ sharingFlag False)-                    "disable sharing and call-by-need evaluation"-    , Option []     ["caching"] (NoArg $ cachingFlag True)-                    "enable caching of typechecking (experimental) (default: OFF)"-    , Option []     ["no-caching"] (NoArg $ cachingFlag False)-                    "disable caching of typechecking"-    ] ++ map (fmap lift) pragmaOptions-  where-  lift :: Flag PragmaOptions -> Flag CommandLineOptions-  lift f = \opts -> do-    ps <- f (optPragmaOptions opts)-    return (opts { optPragmaOptions = ps })--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 ['v']  ["verbose"] (ReqArg verboseFlag "N")-                    "set verbosity level to N"-    -- , Option []          ["proof-irrelevance"] (NoArg proofIrrelevanceFlag)-    --              "enable proof irrelevance (experimental feature)"-    , Option []     ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)-                    "allow unsolved meta variables (only needed in batch mode)"-    , 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 []     ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)-                    "the option has been removed"-    , Option []     ["type-in-type"] (NoArg dontUniverseCheckFlag)-                    "ignore universe levels (this makes Agda inconsistent)"-    , Option []     ["sized-types"] (NoArg sizedTypes)-                    "use sized types (default, inconsistent with `musical' coinduction)"-    , Option []     ["no-sized-types"] (NoArg noSizedTypes)-                    "disable sized types"-    , Option []     ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag)-                    "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)"-    , Option []     ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag)-                    "treat type constructors as inductive constructors when checking productivity"-    , Option []     ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag)-                    "disable universe polymorphism"-    , Option []     ["universe-polymorphism"] (NoArg universePolymorphismFlag)-                    "enable universe polymorphism (default)"-    , Option []     ["no-irrelevant-projections"] (NoArg noIrrelevantProjectionsFlag)-                    "disable projection of irrelevant record fields"-    , 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"-    , 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 by pattern matching to hold as definitional equalities (except those marked as CATCHALL)"-    , Option []     ["no-exact-split"] (NoArg noExactSplitFlag)-                    "do not require all clauses in a definition by pattern matching to hold as definitional equalities (ignore those marked as CATCHALL)"-    , Option []     ["no-eta-equality"] (NoArg noEtaFlag)-                    "disable eta rules for records"-    , Option []     ["rewriting"] (NoArg rewritingFlag)-                    "enable declaration and use of REWRITE rules"-    , Option []     ["postfix-projections"] (NoArg postfixProjectionsFlag)-                    "make postfix projection notation the default"-    , Option []     ["instance-search-depth"] (ReqArg instanceDepthFlag "N")-                    "set instance search depth to N (default: 500)"-    ]---- | Used for printing usage info.-standardOptions_ :: [OptDescr ()]-standardOptions_ = map (fmap $ const ()) 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 ("--" ++) $ concat $ map (\ (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 " ++ intercalate " " as---- | 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) 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 pragmaOptions-          (\s _ -> throwError $ "Bad option in pragma: " ++ s)-          (optPragmaOptions opts)-  _ <- checkOpts (opts { optPragmaOptions = ps })-  return ps---- | Parse options for a plugin.-parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts-parsePluginOptions argv opts =-  getOptSimple argv opts-    (\s _ -> throwError $-               "Internal error: Flag " ++ s ++ " passed to a plugin")---- | The usage info message. The argument is the program name (probably---   agda).-usage :: [OptDescr ()] -> String -> String-usage options progName = usageInfo (header progName) options-    where-        header progName = unlines [ "Agda version " ++ version, ""-                                  , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]" ]---- Remove +RTS .. -RTS from arguments-stripRTS :: [String] -> [String]-stripRTS [] = []-stripRTS ("--RTS" : argv) = argv-stripRTS (arg : argv)-  | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv-  | otherwise     = arg : stripRTS argv-  where-    is x arg = [x] == take 1 (words arg)----------------------------------------------------------------------------- Some paths---- | Returns the absolute default lib dir. This directory is used to--- store the Primitive.agda file.-defaultLibDir :: IO FilePath-defaultLibDir = do-  libdir <- fmap filePath (absolute =<< getDataFileName "lib")-  ifM (doesDirectoryExist libdir)-      (return libdir)-      (error $ "The lib directory " ++ libdir ++ " does not exist")+import Agda.Interaction.Options.Base+import Agda.Interaction.Options.HasOptions+import Agda.Interaction.Options.Types
+ src/full/Agda/Interaction/Options/Base.hs view
@@ -0,0 +1,1873 @@+{-# LANGUAGE CPP       #-}+{-# LANGUAGE DataKinds #-}+{-# 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+parsePluginOptions argv opts =+  getOptSimple argv opts+    (\s _ -> throwError $+               "Internal error: Flag " ++ s ++ " passed to a plugin")++-- | The usage info message. The argument is the program name (probably+--   agda).+usage :: [OptDescr ()] -> String -> Help -> String+usage options progName GeneralHelp = usageInfo (header progName) options+    where+        header progName = unlines [ "Agda version " ++ version, ""+                                  , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]" ]++usage options progName (HelpFor topic) = helpTopicUsage topic++-- | Removes RTS options from a list of options.++stripRTS :: [String] -> [String]+stripRTS [] = []+stripRTS ("--RTS" : argv) = argv+stripRTS (arg : argv)+  | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv+  | otherwise     = arg : stripRTS argv+  where+    is x arg = [x] == take 1 (words arg)
+ 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
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.Options.HasOptions+  ( HasOptions (pragmaOptions, commandLineOptions)+  ) where++import Control.Monad.Except (ExceptT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State (StateT)+import Control.Monad.Trans ( MonadTrans, lift )+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Writer (WriterT)++import Agda.Interaction.Options.Types (PragmaOptions, CommandLineOptions)+import Agda.Utils.Update (ChangeT)+import Agda.Utils.ListT (ListT)++class (Functor m, Applicative m, Monad m) => HasOptions m where+  -- | Returns the pragma options which are currently in effect.+  pragmaOptions      :: m PragmaOptions+  -- | Returns the command line options which are currently in effect.+  commandLineOptions :: m CommandLineOptions++  default pragmaOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m PragmaOptions+  pragmaOptions      = lift pragmaOptions++  default commandLineOptions :: (HasOptions n, MonadTrans t, m ~ t n) => m CommandLineOptions+  commandLineOptions = lift commandLineOptions++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++instance HasOptions m => HasOptions (ChangeT m)+instance HasOptions m => HasOptions (ExceptT e m)+instance HasOptions m => HasOptions (IdentityT m)+instance HasOptions m => HasOptions (ListT m)+instance HasOptions m => HasOptions (MaybeT m)+instance HasOptions m => HasOptions (ReaderT r m)+instance HasOptions m => HasOptions (StateT s m)+instance (HasOptions m, Monoid w) => HasOptions (WriterT w m)
+ src/full/Agda/Interaction/Options/Help.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Interaction.Options.Help+       (+         Help (..)+       , helpTopicUsage+       , string2HelpTopic+       , allHelpTopics+       ) where++import Control.DeepSeq++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+  -- ^ General usage information+  | HelpFor HelpTopic+  -- ^ Specialised usage information about TOPIC+  deriving (Eq, Show, Generic)++instance NFData Help++-- | List of Help Topics+-- NOTA BENE:+-- You need to add each new topic together with its name to @allHelpTopics@++data HelpTopic+  = Warning+  | Error+  | EmacsMode+  deriving (Eq, Show, Generic)++instance NFData HelpTopic++allHelpTopics :: [(String, HelpTopic)]+allHelpTopics =+  [ ("warning"   , Warning  )+  , ("error"     , Error    )+  , ("emacs-mode", EmacsMode)+  ]++-- | Usage information generation++helpTopicUsage :: HelpTopic -> String+helpTopicUsage = \case+  Warning   -> usageWarning+  Error     -> helpErrors+  EmacsMode -> EmacsMode.help++-- | Conversion functions to strings++string2HelpTopic :: String -> Maybe HelpTopic+string2HelpTopic = flip lookup allHelpTopics++-- UNUSED Liang-Ting Chen 2019-07-15+--helpTopic2String :: HelpTopic -> String+--helpTopic2String w = fromMaybe __IMPOSSIBLE__ $ lookup w (map swap allHelpTopics)+--
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,38 +8,18 @@  module Agda.Interaction.Options.Lenses where -import Control.Monad.State- import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.State 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--  -- 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 }--instance LensPragmaOptions TCState where-  getPragmaOptions = (^.stPragmaOptions)-  setPragmaOptions = set stPragmaOptions--modifyPragmaOptions :: (PragmaOptions -> PragmaOptions) -> TCM ()-modifyPragmaOptions = modify . mapPragmaOptions+modifyPragmaOptions :: MonadTCState m => (PragmaOptions -> PragmaOptions) -> m ()+modifyPragmaOptions = modifyTC . mapPragmaOptions  --------------------------------------------------------------------------- -- ** Verbosity in the local pragma options@@ -53,18 +35,18 @@   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   mapVerbosity = mapPragmaOptions . mapVerbosity -modifyVerbosity :: (Verbosity -> Verbosity) -> TCM ()-modifyVerbosity = modify . mapVerbosity+modifyVerbosity :: MonadTCState m => (Verbosity -> Verbosity) -> m ()+modifyVerbosity = modifyTC . mapVerbosity -putVerbosity :: Verbosity -> TCM ()-putVerbosity = modify . setVerbosity+putVerbosity :: MonadTCState m => Verbosity -> m ()+putVerbosity = modifyTC . setVerbosity  --------------------------------------------------------------------------- -- * Command line options@@ -87,8 +69,8 @@   getCommandLineOptions = getCommandLineOptions . stPersistentState   mapCommandLineOptions = updatePersistentState . mapCommandLineOptions -modifyCommandLineOptions :: (CommandLineOptions -> CommandLineOptions) -> TCM ()-modifyCommandLineOptions = modify . mapCommandLineOptions+modifyCommandLineOptions :: MonadTCState m => (CommandLineOptions -> CommandLineOptions) -> m ()+modifyCommandLineOptions = modifyTC . mapCommandLineOptions  --------------------------------------------------------------------------- -- ** Safe mode@@ -105,10 +87,14 @@   setSafeMode     = mapSafeMode . const   mapSafeMode f a = setSafeMode (f $ getSafeMode a) a -instance LensSafeMode CommandLineOptions where+instance LensSafeMode PragmaOptions where   getSafeMode = optSafe-  setSafeMode is opts = opts { optSafe = is }+  setSafeMode is opts = opts { _optSafe = Value is } -- setSafeOption +instance LensSafeMode CommandLineOptions where+  getSafeMode = getSafeMode . getPragmaOptions+  mapSafeMode = mapPragmaOptions . mapSafeMode+ instance LensSafeMode PersistentTCState where   getSafeMode = getSafeMode . getCommandLineOptions   mapSafeMode = mapCommandLineOptions . mapSafeMode@@ -117,12 +103,11 @@   getSafeMode = getSafeMode . getCommandLineOptions   mapSafeMode = mapCommandLineOptions . mapSafeMode -modifySafeMode :: (SafeMode -> SafeMode) -> TCM ()-modifySafeMode = modify . mapSafeMode--putSafeMode :: SafeMode -> TCM ()-putSafeMode = modify . setSafeMode+modifySafeMode :: MonadTCState m => (SafeMode -> SafeMode) -> m ()+modifySafeMode = modifyTC . mapSafeMode +putSafeMode :: MonadTCState m => SafeMode -> m ()+putSafeMode = modifyTC . setSafeMode  --------------------------------------------------------------------------- -- ** Include directories@@ -161,17 +146,17 @@   getAbsoluteIncludePaths = getAbsoluteIncludePaths . getCommandLineOptions   mapAbsoluteIncludePaths = mapCommandLineOptions . mapAbsoluteIncludePaths -modifyIncludePaths :: ([FilePath] -> [FilePath]) -> TCM ()-modifyIncludePaths = modify . mapIncludePaths+modifyIncludePaths :: MonadTCState m => ([FilePath] -> [FilePath]) -> m ()+modifyIncludePaths = modifyTC . mapIncludePaths -putIncludePaths :: [FilePath] -> TCM ()-putIncludePaths = modify . setIncludePaths+putIncludePaths :: MonadTCState m => [FilePath] -> m ()+putIncludePaths = modifyTC . setIncludePaths -modifyAbsoluteIncludePaths :: ([AbsolutePath] -> [AbsolutePath]) -> TCM ()-modifyAbsoluteIncludePaths = modify . mapAbsoluteIncludePaths+modifyAbsoluteIncludePaths :: MonadTCState m => ([AbsolutePath] -> [AbsolutePath]) -> m ()+modifyAbsoluteIncludePaths = modifyTC . mapAbsoluteIncludePaths -putAbsoluteIncludePaths :: [AbsolutePath] -> TCM ()-putAbsoluteIncludePaths = modify . setAbsoluteIncludePaths+putAbsoluteIncludePaths :: MonadTCState m => [AbsolutePath] -> m ()+putAbsoluteIncludePaths = modifyTC . setAbsoluteIncludePaths  --------------------------------------------------------------------------- -- ** Include directories@@ -203,8 +188,8 @@   getPersistentVerbosity = getPersistentVerbosity . getCommandLineOptions   mapPersistentVerbosity = mapCommandLineOptions . mapPersistentVerbosity -modifyPersistentVerbosity :: (PersistentVerbosity -> PersistentVerbosity) -> TCM ()-modifyPersistentVerbosity = modify . mapPersistentVerbosity+modifyPersistentVerbosity :: MonadTCState m => (PersistentVerbosity -> PersistentVerbosity) -> m ()+modifyPersistentVerbosity = modifyTC . mapPersistentVerbosity -putPersistentVerbosity :: PersistentVerbosity -> TCM ()-putPersistentVerbosity = modify . setPersistentVerbosity+putPersistentVerbosity :: MonadTCState m => PersistentVerbosity -> m ()+putPersistentVerbosity = modifyTC . setPersistentVerbosity
+ 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
@@ -0,0 +1,625 @@++module Agda.Interaction.Options.Warnings+       (+         WarningMode (..)+       , warningSet+       , warn2Error+       , lensSingleWarning+       , defaultWarningSet+       , allWarnings+       , usualWarnings+       , noWarnings+       , unsolvedWarnings+       , incompleteMatchWarnings+       , errorWarnings+       , exactSplitWarnings+       , defaultWarningMode+       , WarningModeError(..)+       , prettyWarningModeError+       , warningModeUpdate+       , warningSets+       , WarningName (..)+       , warningName2String+       , string2WarningName+       , usageWarning+       )+where++import Control.Arrow ( (&&&) )+import Control.DeepSeq+import Control.Monad ( guard, when )+import Control.Monad.Except ( throwError )++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.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++import Agda.Utils.Impossible+++-- | A @WarningMode@ has two components: a set of warnings to be displayed+-- and a flag stating whether warnings should be turned into fatal errors.+data WarningMode = WarningMode+  { _warningSet :: Set WarningName+  , _warn2Error :: Bool+  } deriving (Eq, Show, Generic)++instance NFData WarningMode++-- Lenses++warningSet :: Lens' WarningMode (Set WarningName)+warningSet f o = (\ ws -> o { _warningSet = ws }) <$> f (_warningSet o)++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++defaultWarningSet :: String+defaultWarningSet = "warn"++defaultWarningMode :: WarningMode+defaultWarningMode = WarningMode ws False where+  ws = fst $ fromMaybe __IMPOSSIBLE__ $ lookup defaultWarningSet warningSets++-- | Some warnings are errors and cannot be turned off.+data WarningModeError+  = Unknown Text+      -- ^ Unknown warning.+  | NoNoError Text+      -- ^ Warning that cannot be disabled.+  deriving (Show, Generic)++instance NFData WarningModeError++prettyWarningModeError :: WarningModeError -> Text+prettyWarningModeError = \case+  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++-- | @warningModeUpdate str@ computes the action of @str@ over the current+-- @WarningMode@: it may reset the set of warnings, add or remove a specific+-- flag or demand that any warning be turned into an error++warningModeUpdate :: String -> Either WarningModeError WarningModeUpdate+warningModeUpdate str = case str of+  "error"   -> pure $ set warn2Error True+  "noerror" -> pure $ set warn2Error False+  _ | Just ws <- fst <$> lookup str warningSets+            -> pure $ set warningSet ws+  _ -> case stripPrefix "no" str of+    Nothing   -> do+      wname <- stringToWarningName str+      pure (over warningSet $ Set.insert wname)+    Just str' -> do+      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))]+warningSets = [ ("all"   , (allWarnings, "All of the existing warnings"))+              , ("warn"  , (usualWarnings, "Default warning level"))+              , ("ignore", (errorWarnings, "Ignore all the benign warnings"))+              ]++noWarnings :: Set WarningName+noWarnings = Set.empty++unsolvedWarnings :: Set WarningName+unsolvedWarnings = Set.fromList+                 [ UnsolvedMetaVariables_+                 , UnsolvedInteractionMetas_+                 , UnsolvedConstraints_+                 ]++incompleteMatchWarnings :: Set WarningName+incompleteMatchWarnings = Set.fromList [ CoverageIssue_ ]++errorWarnings :: Set WarningName+errorWarnings = Set.fromList+  [ CoverageIssue_+  , InvalidCharacterLiteral_+  , MissingDefinitions_+  , MissingDataDeclaration_+  , NotAllowedInMutual_+  , NotStrictlyPositive_+  , ConstructorDoesNotFitInData_+  , OverlappingTokensWarning_+  , PragmaCompiled_+  , SafeFlagPostulate_+  , SafeFlagPragma_+  , SafeFlagNonTerminating_+  , SafeFlagTerminating_+  , SafeFlagWithoutKFlagPrimEraseEquality_+  , SafeFlagNoPositivityCheck_+  , SafeFlagPolarity_+  , SafeFlagNoUniverseCheck_+  , SafeFlagEta_+  , 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.\\ 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_+  | MisplacedAttributes_+  | UnknownPolarity_+  | UnknownAttribute_+  | UnsupportedAttribute_+  | MultipleAttributes_+  -- Library Warnings+  | LibUnknownField_+  -- Nicifer Warnings+  | EmptyAbstract_+  | EmptyConstructor_+  | EmptyField_+  | EmptyGeneralize_+  | EmptyInstance_+  | EmptyMacro_+  | EmptyMutual_+  | EmptyPostulate_+  | EmptyPrimitive_+  | EmptyPrivate_+  | EmptyRewritePragma_+  | EmptyWhere_+  | EmptyPolarityPragma_+  | HiddenGeneralize_+  | InvalidCatchallPragma_+  | InvalidConstructorBlock_+  | InvalidCoverageCheckPragma_+  | InvalidNoPositivityCheckPragma_+  | InvalidNoUniverseCheckPragma_+  | DuplicateRecordDirective_+  | InvalidTerminationCheckPragma_+  | MissingDataDeclaration_+  | MissingDefinitions_+  | NotAllowedInMutual_+  | OpenImportAbstract_+  | OpenImportPrivate_+  | PolarityPragmasButNotPostulates_+  | PragmaCompiled_+  | PragmaNoTerminationCheck_+  | ShadowingInTelescope_+  | UnknownFixityInMixfixDecl_+  | UnknownNamesInFixityDecl_+  | UnknownNamesInPolarityPragmas_+  | UselessAbstract_+  | UselessInstance_+  | UselessMacro_+  | UselessPrivate_+  -- Scope and Type Checking Warnings+  | AbsurdPatternRequiresAbsentRHS_+  | AsPatternShadowsConstructorOrPatternSynonym_+  | PatternShadowsConstructor_+  | CantGeneralizeOverSorts_+  | ClashesViaRenaming_                -- issue #4154+  | CoverageIssue_+  | CoverageNoExactSplit_+  | InlineNoExactSplit_+  | DeprecationWarning_+  | DuplicateUsing_+  | FixingCohesion_+  | FixingPolarity_+  | FixingRelevance_+  -- TODO: linearity+  -- -- | FixingQuantity_+  | FixityInRenamingModule_+  | InvalidCharacterLiteral_+  | UselessPragma_+  | IllformedAsClause_+  | InstanceArgWithExplicitArg_+  | InstanceWithExplicitArg_+  | InstanceNoOutputTypeName_+  | InteractionMetaBoundaries_+  | InversionDepthReached_+  | ModuleDoesntExport_+  | 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_+  | SafeFlagNonTerminating_+  | SafeFlagNoPositivityCheck_+  | SafeFlagNoUniverseCheck_+  | SafeFlagPolarity_+  | SafeFlagPostulate_+  | SafeFlagPragma_+  | SafeFlagTerminating_+  | SafeFlagWithoutKFlagPrimEraseEquality_+  | TerminationIssue_+  | TooManyArgumentsToSort_+  | UnreachableClauses_+  | UnsolvedConstraints_+  | UnsolvedInteractionMetas_+  | UnsolvedMetaVariables_+  | UselessHiding_+  | UselessInline_+  | UselessPatternDeclarationForRecord_+  | UselessPublic_+  | UselessTactic_+  | UserWarning_+  | InvalidDisplayForm_+  | UnusedVariablesInDisplayForm_+  | RewritesNothing_+  | WithClauseProjectionFixityMismatch_+  | WithoutKFlagPrimEraseEquality_+  | ConflictingPragmaOptions_+  | WrongInstanceDeclaration_+  | TooManyPolarities_+  | TopLevelPolarity_+  -- Checking consistency of options+  | CoInfectiveImport_+  | InfectiveImport_+  -- Record field warnings+  | 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++-- | The flag corresponding to a warning is precisely the name of the constructor+-- minus the trailing underscore.++string2WarningName :: String -> Maybe WarningName+string2WarningName = (`HMap.lookup` warnings) where+  warnings = HMap.fromList $ map (\x -> (warningName2String x, x)) [minBound..maxBound]++warningName2String :: WarningName -> String+warningName2String = initWithDefault __IMPOSSIBLE__ . show++-- | @warningUsage@ generated using @warningNameDescription@++usageWarning :: String+usageWarning = intercalate "\n"+  [ "The -W or --warning option can be used to disable or enable\+    \ different warnings. The flag -W error (or --warning=error)\+    \ can be used to turn all warnings into errors, while -W noerror\+    \ turns this off again."+  , ""+  , "A group of warnings can be enabled by -W group, where group is\+    \ 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):"+  , ""+  , 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 $ 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 fields in library files."+  -- Nicifer Warnings+  EmptyAbstract_                   -> "Empty `abstract' blocks."+  EmptyConstructor_                -> "Empty `constructor' blocks."+  EmptyField_                      -> "Empty `field` blocks."+  EmptyGeneralize_                 -> "Empty `variable' blocks."+  EmptyInstance_                   -> "Empty `instance' blocks."+  EmptyMacro_                      -> "Empty `macro' blocks."+  EmptyMutual_                     -> "Empty `mutual' blocks."+  EmptyPostulate_                  -> "Empty `postulate' blocks."+  EmptyPrimitive_                  -> "Empty `primitive' blocks."+  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."+  InvalidConstructorBlock_         -> "`constructor' blocks outside of `interleaved mutual' blocks."+  InvalidCoverageCheckPragma_      -> "Coverage checking pragmas before non-function or `mutual' blocks."+  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."+  MissingDataDeclaration_          -> "Constructor definitions not associated to a data declaration."+  MissingDefinitions_              -> "Declarations not associated to a definition."+  NotAllowedInMutual_              -> "Declarations not allowed in a mutual 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 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."+  UselessAbstract_                 -> "`abstract' blocks where they have no effect."+  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' 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+  AbsurdPatternRequiresAbsentRHS_  -> "Clauses with an absurd pattern that have a right hand side."+  AsPatternShadowsConstructorOrPatternSynonym_ -> "@-patterns that shadow constructors or pattern synonyms."+  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."+  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; 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_          -> "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."+  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."+  SafeFlagNonTerminating_          -> "`NON_TERMINATING' pragmas with the safe flag."+  SafeFlagNoPositivityCheck_       -> "`NO_POSITIVITY_CHECK' pragmas with the safe flag."+  SafeFlagNoUniverseCheck_         -> "`NO_UNIVERSE_CHECK' pragmas with the safe flag."+  SafeFlagPolarity_                -> "`POLARITY' pragmas with the safe flag."+  SafeFlagPostulate_               -> "`postulate' blocks with the safe flag."+  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 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 does not."+  -- Record field warnings+  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,141 +1,25 @@-{-# LANGUAGE CPP #-} ---------------------------------------------------------------------------- | Data type for all interactive responses-------------------------------------------------------------------------- module Agda.Interaction.Response-  ( Response (..)-  , MakeCaseVariant (..)-  , DisplayInfo (..)-  , Status (..)-  , GiveResult (..)-  , InteractionOutputCallback-  , defaultInteractionOutputCallback-  ) where--import Agda.Interaction.Highlighting.Precise-import {-# SOURCE #-} Agda.TypeChecking.Monad.Base-import Agda.Syntax.Common   (InteractionId(..))-import Agda.Syntax.Concrete (Expr)-import Agda.Utils.Pretty--import Control.Monad.Trans-import Data.Int-import System.IO--#include "undefined.h"-import Agda.Utils.Impossible---- | 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 ModuleToSource-    | Resp_Status Status-    | Resp_JumpToError FilePath Int32-    | Resp_InteractionPoints [InteractionId]-    | Resp_GiveAction InteractionId GiveResult-    | Resp_MakeCase MakeCaseVariant [String]-    | 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---- | 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-    | Info_Constraints String-    | Info_AllGoalsWarnings String String String-        -- ^ Strings are the goals, the warnings and the (non-fatal) errors-    | Info_Time Doc-    | Info_Error String-        -- ^ When an error message is displayed this constructor should be-        -- used, if appropriate.---    | Info_Warning String --FNF: currently unused-    | Info_Intro Doc-        -- ^ 'Info_Intro' denotes two different types of errors-        --   TODO: split these into separate constructors-    | 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 Doc-    | Info_SearchAbout Doc-    | Info_WhyInScope Doc-    | Info_NormalForm Doc-    | Info_GoalType Doc-    | Info_CurrentGoal Doc-    | Info_InferredType Doc-    | Info_Context Doc-    | Info_HelperFunction Doc-    | Info_Version-        deriving Show---- | Status information.--data Status = Status-  { sShowImplicitArguments :: Bool-    -- ^ Are implicit 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 r = case r of-  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__+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/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,74 +1,77 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.SearchAbout (findMentions) where -import Control.Applicative import Control.Monad-import Control.Monad.State+ import qualified Data.Map as Map+import qualified Data.Set as Set import Data.List (isInfixOf) import Data.Either (partitionEithers)+import Data.Foldable (toList)  import Agda.Syntax.Position (Range) import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad-import Agda.TypeChecking.Monad-import qualified Agda.Syntax.Common as Com-import Agda.Syntax.Internal-import Agda.Interaction.BasicOps (normalForm)-import qualified Agda.Syntax.Translation.ConcreteToAbstract as TCA-import qualified Agda.Syntax.Abstract as A+import Agda.TypeChecking.Monad.Signature+import Agda.TypeChecking.Monad.Env+import Agda.Syntax.Internal.Names (namesIn)+import Agda.Interaction.Base (Rewrite)+import Agda.Interaction.BasicOps (normalForm, parseName)+ import qualified Agda.Syntax.Concrete as C+import qualified Agda.Syntax.Internal as I -import Agda.Interaction.BasicOps-import Debug.Trace+import Agda.Utils.List   ( initLast1  )+import qualified Agda.Utils.List1 as List1+import Agda.Syntax.Common.Pretty ( prettyShow ) -collectNamesInType :: Type -> [A.QName]-collectNamesInType = collectNamesInTerm . unEl+findMentions :: Rewrite -> Range -> String -> ScopeM [(C.Name, I.Type)]+findMentions norm rg nm = do+  -- We start by dealing with the user's input -collectNamesInTerm :: Term -> [A.QName]-collectNamesInTerm (Var _ els)  = collectNamesInElims els-collectNamesInTerm (Lam ty t)   = collectNamesInTerm $ unAbs t-collectNamesInTerm (Def n els)  = n : collectNamesInElims els-collectNamesInTerm (Con n _ args) = conName n : collectNamesInArgs args-collectNamesInTerm (Pi dom cod) = collectNamesInType (Com.unDom dom) ++ collectNamesInType (unAbs cod)-collectNamesInTerm (Shared t)   = collectNamesInTerm $ ignoreSharing $ derefPtr t-collectNamesInTerm _            = []+  -- The users passes in `nm`, a list of identifiers and strings+  -- to match against definitions in scope. `findMentions` will+  -- select all of the definitions such that:+  -- - all of the specified identifiers appear in their type+  --   (which has been normalised according to `norm`)+  -- - all of the specified strings are substrings of their name -collectNamesInElims :: Elims -> [A.QName]-collectNamesInElims = concatMap collectNamesInElim+  -- We separate the strings from the names by a rough analysis+  -- and then parse and resolve the names in the current scope+  let (userSubStrings, nms) = partitionEithers $ isString <$> words nm+  rnms <- mapM (resolveName <=< parseName rg) nms+  let userIdentifiers = fmap (fmap anameName . anames) rnms -collectNamesInElim :: Elim -> [A.QName]-collectNamesInElim (Apply a) = collectNamesInTerm $ Com.unArg a-collectNamesInElim (Proj _ n)= [n]+  -- We then collect all the things in scope, by name.+  -- Issue #2381: We explicitly filter out pattern synonyms because they+  -- don't have a type. Looking it up makes Agda panic!+  snms <- fmap (nsNames . allThingsInScope) $ getNamedScope =<< currentModule+  let namesInScope = filter ((PatternSynName /=) . anameKind . snd)+                   $ List1.concat $ map (\ (c, as) -> fmap (c,) as) $ Map.toList snms -collectNamesInArgs :: Args -> [A.QName]-collectNamesInArgs = concatMap (collectNamesInTerm . Com.unArg)+  -- 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,+  -- we grab its type, normalise it according to `norm` and collect+  -- the identifiers in it. We then check whether it meets the user's+  -- criteria.+  ress <- forM namesInScope $ \ (x, n) -> do+    t <- normalForm norm =<< typeOfConst (anameName n)+    return $ do+      guard $ all (`isInfixOf` prettyShow x) userSubStrings+      guard $ all (any (`Set.member` namesIn t)) userIdentifiers+      return (x, t)+  return $ concat ress -findMentions :: Rewrite -> Range -> String -> TCM [(C.Name, Type)]-findMentions norm rg nm = do-  let (strs, nms) = partitionEithers $ fmap isString $ words nm-  cnms <- mapM (parseName rg) nms-  rnms <- mapM resolveName cnms-  let defs = fmap (fmap anameName . anames) rnms-  scp  <- getNamedScope =<< currentModule-  let names = nsNames $ allThingsInScope scp-  concat <$> mapM (\ (x, n) -> do-              t <- normalForm norm =<< typeOfConst (anameName n)-              let defName  = show x-              let namesInT = collectNamesInType t-              return $ do-                guard (all (`isInfixOf` defName) strs)-                guard (all (any (`elem` namesInT)) defs)-                return (x, t)-           ) (concatMap (\ (x, ns) -> map ((,) x) ns) $ Map.toList names)   where+    isString :: String -> Either String String+    isString ('"' : c : cs)+      | (str, '"') <- initLast1 c cs+      = Left $ filter (/= '"') str     isString str-      |  not (null str)-      && head str == '"'-      && last str == '"' = Left $ filter (/= '"') str-      | otherwise        = Right str+      = Right str -    anames (DefinedName _ an)     = [an]-    anames (FieldName     ans)    = ans-    anames (ConstructorName ans)  = ans-    anames (PatternSynResName an) = [an]+    anames (DefinedName _ an _)   = [an]+    anames (FieldName     ans)    = toList ans+    anames (ConstructorName _ ans)= toList ans     anames _                      = []
src/full/Agda/Main.hs view
@@ -4,185 +4,474 @@ -} module Agda.Main where -import Control.Monad.State-import Control.Applicative+import Prelude hiding (null) -import Data.Maybe+import qualified Control.Exception as E+import Control.Monad          ( void )+import Control.Monad.Except   ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.IO.Class ( MonadIO(..) ) -import System.Environment-import System.Exit+import qualified Data.List as List+import Data.Function          ( (&) )+import Data.Functor+import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Text as T -import Agda.Syntax.Position (Range)-import Agda.Syntax.Concrete.Pretty ()-import Agda.Syntax.Abstract.Name (toTopLevelModuleName)+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 as ExitCode (AgdaError(..), exitSuccess, exitAgdaWith) import Agda.Interaction.Options-import Agda.Interaction.Monad+import Agda.Interaction.Options.Help (Help (..)) import Agda.Interaction.EmacsTop (mimicGHCi)-import Agda.Interaction.Imports (MaybeWarnings'(..))+import Agda.Interaction.JSONTop (jsonREPL)+import Agda.Interaction.FindFile ( SourceFile(SourceFile) ) import qualified Agda.Interaction.Imports as Imp-import qualified Agda.Interaction.Highlighting.Dot as Dot-import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX-import Agda.Interaction.Highlighting.HTML  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Errors import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Errors+import Agda.TypeChecking.Warnings import Agda.TypeChecking.Pretty -import Agda.Compiler.Common (IsMain (..))-import Agda.Compiler.MAlonzo.Compiler as MAlonzo-import Agda.Compiler.Epic.Compiler as Epic-import Agda.Compiler.JS.Compiler as JS-import Agda.Compiler.UHC.Compiler as UHC--import Agda.Utils.Lens-import Agda.Utils.Monad-import Agda.Utils.String+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 Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.Impossible+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 -#include "undefined.h"+import Agda.Utils.Impossible  -- | The main function-runAgda :: TCM ()-runAgda = do-  progName <- liftIO getProgName-  argv     <- liftIO getArgs-  opts     <- liftIO $ runOptM $ parseStandardOptions argv-  case opts of-    Left err -> liftIO $ optionError err-    Right opts -> runAgdaWithOptions generateHTML progName opts+runAgda :: [Backend] -> IO ()+runAgda backends = runAgda' $ builtinBackends ++ backends --- | Run Agda with parsed command line options and with a custom HTML generator+-- | The main function without importing built-in backends+runAgda' :: [Backend] -> IO ()+runAgda' backends = do+  progName <- getProgName+  argv     <- getArgs+  let (z, warns) = runOptM $ parseBackendOptions backends argv defaultOptions+  conf     <- runExceptT $ do+    (bs, opts) <- ExceptT $ pure z+    -- The absolute path of the input file, if provided+    inputFile <- liftIO $ mapM absolute $ optInputFile opts+    mode      <- getInteractor bs inputFile opts+    return (bs, opts, mode)++  case conf of+    Left err -> optionError err+    Right (bs, opts, mode) -> do++      -- Setup Agda if requested+      when (optSetup opts) $ Agda.Setup.setup True++      -- 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.+    = TCM ()+    -- Type-checking action+    -> (AbsolutePath -> TCM CheckResult)+    -- Main transformed action.+    -> TCM a++-- | Major mode of operation, not including the standard mode (checking the given main module).+data FrontendType+  = FrontEndInteraction InteractionFormat+      -- ^ @--interaction@ or @--interaction-json@.+  | FrontEndRepl+      -- ^ @--interactive@.+  | FrontEndBuildLibrary+      -- ^ @--build-library@.++data InteractionFormat+  = InteractionEmacs+      -- ^ @--interaction@.+  | InteractionJson+      -- ^ @--interaction-json@.++pattern FrontEndEmacs :: FrontendType+pattern FrontEndEmacs = FrontEndInteraction InteractionEmacs++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.+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 = 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".+    isBackendEnabled (Backend b) = isEnabled b (options b)+    enabledBackends = filter isBackendEnabled configuredBackends+    enabledFrontends = concat+      [ [ 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" [ 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 $+      concat ["Must not specify an input file (", filePath inputFile, ") with ", frontendFlagName fe]++-- | Run Agda with parsed command line options runAgdaWithOptions-  :: TCM ()             -- ^ HTML generating action+  :: Interactor a       -- ^ Backend interaction   -> String             -- ^ program name   -> CommandLineOptions -- ^ parsed command line options-  -> TCM ()-runAgdaWithOptions generateHTML progName opts-      | optShowHelp opts    = liftIO printUsage-      | optShowVersion opts = liftIO printVersion-      | isNothing (optInputFile opts)-          && not (optInteractive opts)-          && not (optGHCiInteraction opts)-                            = liftIO printUsage-      | otherwise           = do+  -> TCM a+runAgdaWithOptions interactor progName opts = do           -- Main function.           -- Bill everything to root of Benchmark trie.-          UtilsBench.setBenchmarking True+          UtilsBench.setBenchmarking UtilsBench.BenchmarkOn             -- Andreas, Nisse, 2016-10-11 AIM XXIV             -- Turn benchmarking on provisionally, otherwise we lose track of time spent             -- on e.g. LaTeX-code generation.             -- Benchmarking might be turned off later by setCommandlineOptions -          Bench.billTo [] checkFile `finally_` do+          Bench.billTo [] $+            interactor initialSetup checkFile+          `finally_` do             -- Print benchmarks.             Bench.print              -- Print accumulated statistics.-            printStatistics 20 Nothing =<< use lensAccumStatistics+            printStatistics Nothing =<< useTC lensAccumStatistics   where-    checkFile :: TCM ()-    checkFile = do-      let i             = optInteractive     opts-          ghci          = optGHCiInteraction opts-          ghc           = optGhcCompile      opts-          compileNoMain = optCompileNoMain   opts-          epic          = optEpicCompile     opts-          js            = optJSCompile       opts-          uhc           = optUHCCompile      opts-      when i $ liftIO $ putStr splashScreen-      let failIfNoInt (Just i) = return i-          -- The allowed combinations of command-line-          -- options should rule out Nothing here.-          failIfNoInt Nothing  = __IMPOSSIBLE__--          failIfInt Nothing  = return ()-          failIfInt (Just _) = __IMPOSSIBLE__+    -- Options are fleshed out here so that (most) errors like+    -- "bad library path" are validated within the interactor,+    -- so that they are reported with the appropriate protocol/formatting.+    initialSetup :: TCM ()+    initialSetup = do+      opts <- addTrustedExecutables opts+      setCommandLineOptions opts -          interaction :: TCM (Maybe Interface) -> TCM ()-          interaction | i             = runIM . interactionLoop-                      | ghci          = mimicGHCi . (failIfInt =<<)-                      | ghc && compileNoMain-                                      = (MAlonzo.compilerMain NotMain =<<) . (failIfNoInt =<<)-                      | ghc           = (MAlonzo.compilerMain IsMain =<<) . (failIfNoInt =<<)-                      | epic          = (Epic.compilerMain    =<<) . (failIfNoInt =<<)-                      | js            = (JS.compilerMain      =<<) . (failIfNoInt =<<)-                      | uhc && compileNoMain-                                      = (UHC.compilerMain NotMain =<<) . (failIfNoInt =<<)-                      | uhc           = (UHC.compilerMain IsMain =<<)  . (failIfNoInt =<<)-                      | otherwise     = (() <$)-      interaction $ do-        setCommandLineOptions opts-        hasFile <- hasInputFile+    checkFile :: AbsolutePath -> TCM CheckResult+    checkFile inputFile = do         -- Andreas, 2013-10-30 The following 'resetState' kills the         -- verbosity options.  That does not make sense (see fail/Issue641).         -- 'resetState' here does not seem to serve any purpose,         -- thus, I am removing it.         -- resetState-        if not hasFile then return Nothing else do-          file    <- getInputFile-          (i, mw) <- Imp.typeCheckMain file+          let mode = if optOnlyScopeChecking opts+                     then Imp.ScopeCheck+                     else Imp.TypeCheck -          -- An interface is only generated if NoWarnings.-          result <- case mw of-            SomeWarnings ws -> do-              ws' <- applyFlagsToTCWarnings RespectFlags ws-              case ws' of-                []   -> return Nothing-                cuws -> tcWarningsToError cuws-            NoWarnings      -> return $ Just i+          src <- srcFromPath inputFile+          result <- Imp.typeCheckMain mode =<< Imp.parseSource src +          unless (crMode result == ModuleScopeChecked) $+            Imp.raiseNonFatalErrors result++          let i = crInterface result           reportSDoc "main" 50 $ pretty i -          whenM (optGenerateHTML <$> commandLineOptions) $-            generateHTML+          -- 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 -          whenM (isJust . optDependencyGraph <$> commandLineOptions) $-            Dot.generateDot $ i+          return result -          whenM (optGenerateLaTeX <$> commandLineOptions) $-            LaTeX.generateLaTeX i -          return result  -- | Print usage information.-printUsage :: IO ()-printUsage = do+printUsage :: [Backend] -> Help -> IO ()+printUsage backends hp = do   progName <- getProgName-  putStr $ usage standardOptions_ progName+  putStr $ usage standardOptions_ progName hp+  when (hp == GeneralHelp) $ mapM_ (putStr . backendUsage) backends +backendUsage :: Backend -> String+backendUsage (Backend b) =+  usageInfo ("\n" ++ T.unpack (backendName b) ++ " backend options") $+    map void (commandLineFlags b)+ -- | Print version information.-printVersion :: IO ()-printVersion = 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+    [ 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+    [] +printAgdaDataDir :: IO ()+printAgdaDataDir = putStrLn =<< getDataDir++printAgdaAppDir :: IO ()+printAgdaAppDir = putStrLn =<< getAgdaAppDir+ -- | What to do for bad options. optionError :: String -> IO () optionError err = do-  putStrLn $ "Error: " ++ err ++ "\nRun 'agda --help' for help on command line options."-  exitFailure+  prog <- getProgName+  putStrLn $ "Error: " ++ err ++ "\nRun '" ++ prog ++ " --help' for help on command line options."+  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-      s <- prettyError err-      unless (null s) (liftIO $ putStrLn s)-      throwError err-    case r of-      Right _ -> exitSuccess-      Left _  -> exitFailure-  `catchImpossible` \e -> do-    putStr $ show e-    exitFailure+  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 --- | Main-main :: IO ()-main = runTCMPrettyErrors runAgda+-- | 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
@@ -1,1108 +1,1226 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE TemplateHaskell       #-}--{-| The abstract syntax. This is what you get after desugaring and scope-    analysis of the concrete syntax. The type checker works on abstract syntax,-    producing internal syntax ("Agda.Syntax.Internal").--}-module Agda.Syntax.Abstract-    ( module Agda.Syntax.Abstract-    , module Agda.Syntax.Abstract.Name-    ) where--import Prelude-import Control.Arrow (first)-import Control.Applicative--import Data.Foldable (Foldable)-import qualified Data.Foldable as Fold-import Data.Map (Map)-import Data.Maybe-import Data.Sequence (Seq, (<|), (><))-import qualified Data.Sequence as Seq-import Data.Traversable-import Data.Typeable (Typeable)-import Data.Void--import Agda.Syntax.Concrete.Name (NumHoles(..))-import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Pretty ()-import Agda.Syntax.Info-import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Abstract.Name-import Agda.Syntax.Abstract.Name as A (QNamed)-import Agda.Syntax.Literal-import Agda.Syntax.Scope.Base-import qualified Agda.Syntax.Internal as I--import Agda.TypeChecking.Positivity.Occurrence--import Agda.Utils.Functor-import Agda.Utils.Geniplate-import Agda.Utils.Lens-import Agda.Utils.Pretty--#include "undefined.h"-import Agda.Utils.Impossible--type Args = [NamedArg Expr]---- | Expressions after scope checking (operators parsed, names resolved).-data Expr-  = Var  Name                          -- ^ Bound variable.-  | Def  QName                         -- ^ Constant: axiom, function, data or record type.-  | Proj ProjOrigin AmbiguousQName     -- ^ Projection (overloaded).-  | Con  AmbiguousQName                -- ^ Constructor (overloaded).-  | PatternSyn QName                   -- ^ Pattern synonym.-  | Macro QName                        -- ^ Macro.-  | Lit Literal                        -- ^ Literal.-  | QuestionMark MetaInfo InteractionId-    -- ^ Meta variable for interaction.-    --   The 'InteractionId' is usually identical with the-    --   'metaNumber' of 'MetaInfo'.-    --   However, if you want to print an interaction meta as-    --   just @?@ instead of @?n@, you should set the-    --   'metaNumber' to 'Nothing' while keeping the 'InteractionId'.-  | Underscore   MetaInfo-    -- ^ Meta variable for hidden argument (must be inferred locally).-  | Dot ExprInfo Expr                  -- ^ @.e@, for postfix projection.-  | App  ExprInfo Expr (NamedArg Expr) -- ^ Ordinary (binary) application.-  | WithApp ExprInfo Expr [Expr]       -- ^ With application.-  | Lam  ExprInfo LamBinding Expr      -- ^ @λ bs → e@.-  | AbsurdLam ExprInfo Hiding          -- ^ @λ()@ or @λ{}@.-  | ExtendedLam ExprInfo DefInfo QName [Clause]-  | Pi   ExprInfo Telescope Expr       -- ^ Dependent function space @Γ → A@.-  | Fun  ExprInfo (Arg Expr) Expr      -- ^ Non-dependent function space.-  | Set  ExprInfo Integer              -- ^ @Set@, @Set1@, @Set2@, ...-  | Prop ExprInfo                      -- ^ @Prop@ (no longer supported, used as dummy type).-  | Let  ExprInfo [LetBinding] Expr    -- ^ @let bs in e@.-  | ETel Telescope                     -- ^ Only used when printing telescopes.-  | Rec  ExprInfo RecordAssigns        -- ^ Record construction.-  | RecUpdate ExprInfo Expr Assigns    -- ^ Record update.-  | ScopedExpr ScopeInfo Expr          -- ^ Scope annotation.-  | QuoteGoal ExprInfo Name Expr       -- ^ Binds @Name@ to current type in @Expr@.-  | QuoteContext ExprInfo              -- ^ Returns the current context.-  | Quote ExprInfo                     -- ^ Quote an identifier 'QName'.-  | QuoteTerm ExprInfo                 -- ^ Quote a term.-  | Unquote ExprInfo                   -- ^ The splicing construct: unquote ...-  | Tactic ExprInfo Expr [NamedArg Expr] [NamedArg Expr]-                                       -- ^ @tactic e x1 .. xn | y1 | .. | yn@-  | DontCare Expr                      -- ^ For printing @DontCare@ from @Syntax.Internal@.-  deriving (Typeable, Show)---- | Record field assignment @f = e@.-type Assign  = FieldAssignment' Expr-type Assigns = [Assign]-type RecordAssign  = Either Assign ModuleName-type RecordAssigns = [RecordAssign]---- | Is a type signature a `postulate' or a function signature?-data Axiom-  = FunSig    -- ^ A function signature.-  | NoFunSig  -- ^ Not a function signature, i.e., a postulate (in user input)-              --   or another (e.g. data/record) type signature (internally).-  deriving (Typeable, Eq, Ord, Show)---- | Renaming (generic).-type Ren a = [(a, a)]--data ScopeCopyInfo = ScopeCopyInfo-  { renModules :: Ren ModuleName-  , renNames   :: Ren QName }-  deriving (Eq, Show)--initCopyInfo :: ScopeCopyInfo-initCopyInfo = ScopeCopyInfo-  { renModules = []-  , renNames   = []-  }--instance Pretty ScopeCopyInfo where-  pretty i = vcat [ prRen "renModules =" (renModules i)-                  , prRen "renNames   =" (renNames i) ]-    where-      prRen s r = sep [ text s, nest 2 $ vcat (map pr r) ]-      pr (x, y) = pretty x <+> text "->" <+> pretty y--data Declaration-  = Axiom      Axiom DefInfo ArgInfo (Maybe [Occurrence]) QName Expr-    -- ^ Type signature (can be irrelevant, but not hidden).-    ---    -- The fourth argument contains an optional assignment of-    -- polarities to arguments.-  | Field      DefInfo QName (Arg Expr)              -- ^ record field-  | Primitive  DefInfo QName Expr                    -- ^ primitive function-  | Mutual     MutualInfo [Declaration]              -- ^ a bunch of mutually recursive definitions-  | Section    ModuleInfo ModuleName [TypedBindings] [Declaration]-  | Apply      ModuleInfo 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 Telescope Expr -- ^ lone data signature-      -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.-  | DataDef    DefInfo QName [LamBinding] [Constructor]-      -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.-  | RecSig     DefInfo QName Telescope Expr -- ^ lone record signature-  | RecDef     DefInfo QName (Maybe (Ranged Induction)) (Maybe Bool) (Maybe QName) [LamBinding] Expr [Declaration]-      -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,-      --   and the optional name is the constructor's name.-  | PatternSynDef QName [Arg Name] (Pattern' Void)-      -- ^ Only for highlighting purposes-  | UnquoteDecl MutualInfo [DefInfo] [QName] Expr-  | UnquoteDef  [DefInfo] [QName] Expr-  | ScopedDecl ScopeInfo [Declaration]  -- ^ scope annotation-  deriving (Typeable, Show)--class GetDefInfo a where-  getDefInfo :: a -> Maybe DefInfo--instance GetDefInfo Declaration where-  getDefInfo (Axiom _ i _ _ _ _)    = Just i-  getDefInfo (Field i _ _)          = Just i-  getDefInfo (Primitive i _ _)      = Just i-  getDefInfo (ScopedDecl _ (d:_))   = getDefInfo d-  getDefInfo (FunDef i _ _ _)       = Just i-  getDefInfo (DataSig i _ _ _)      = Just i-  getDefInfo (DataDef i _ _ _)      = Just i-  getDefInfo (RecSig i _ _ _)       = Just i-  getDefInfo (RecDef i _ _ _ _ _ _ _) = Just i-  getDefInfo _ = Nothing--type ImportDirective = ImportDirective' QName ModuleName-type Renaming        = Renaming'        QName ModuleName-type ImportedName    = ImportedName'    QName ModuleName--data ModuleApplication-    = SectionApp Telescope ModuleName [NamedArg Expr]-      -- ^ @tel. M args@:  applies @M@ to @args@ and abstracts @tel@.-    | RecordModuleIFS ModuleName-      -- ^ @M {{...}}@-  deriving (Typeable, Show, Eq)--data Pragma-  = OptionsPragma [String]-  | BuiltinPragma String Expr-  | BuiltinNoDefPragma String QName-    -- ^ Builtins that do not come with a definition,-    --   but declare a name for an Agda concept.-  | RewritePragma QName-  | CompiledPragma QName String-  | CompiledExportPragma QName String-  | CompiledDeclareDataPragma QName String-  | CompiledTypePragma QName String-  | CompiledDataPragma QName String [String]-  | CompiledEpicPragma QName String-  | CompiledJSPragma QName String-  | CompiledUHCPragma QName String-  | CompiledDataUHCPragma QName String [String]-  | StaticPragma QName-  | InlinePragma QName-  | DisplayPragma QName [NamedArg Pattern] Expr-  deriving (Typeable, Show, Eq)---- | Bindings that are valid in a @let@.-data LetBinding-  = LetBind LetInfo ArgInfo Name Expr Expr-    -- ^ @LetBind info rel name type defn@-  | LetPatBind LetInfo Pattern Expr-    -- ^ Irrefutable pattern binding.-  | LetApply ModuleInfo 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 Name-    -- ^ Only used for highlighting. Refers to the first occurrence of-    -- @x@ in @let x : A; x = e@.-  deriving (Typeable, Show, Eq)---- | Only 'Axiom's.-type TypeSignature  = Declaration-type Constructor    = TypeSignature-type Field          = TypeSignature---- | A lambda binding is either domain free or typed.-data LamBinding-  = DomainFree ArgInfo Name   -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@-  | DomainFull TypedBindings  -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@-  deriving (Typeable, Show, Eq)---- | Typed bindings with hiding information.-data TypedBindings = TypedBindings Range (Arg TypedBinding)-            -- ^ . @(xs : e)@ or @{xs : e}@-  deriving (Typeable, Show, Eq)---- | 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)@---   before type-checking.  However, this would be slightly problematic:------     1. We would have to typecheck the type @A@ several times.------     2. If @A@ contains a meta variable or hole, it would be duplicated---        by such a translation.------   While 1. is only slightly inefficient, 2. would be an outright bug.---   Duplicating @A@ could not be done naively, we would have to make sure---   that the metas of the copy are aliases of the metas of the original.--data TypedBinding-  = TBind Range [WithHiding Name] Expr-    -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@.-  | TLet Range [LetBinding]-    -- ^ E.g. @(let x = e)@ or @(let open M)@.-  deriving (Typeable, Show, Eq)--type Telescope  = [TypedBindings]--data NamedDotPattern = NamedDot Name I.Term I.Type-  deriving (Typeable, Show)--instance Eq NamedDotPattern where-  _ == _ = True -- These are not relevant for caching purposes---- | We could throw away @where@ clauses at this point and translate them to---   @let@. It's not obvious how to remember that the @let@ was really a---   @where@ clause though, so for the time being we keep it here.-data Clause' lhs = Clause-  { clauseLHS        :: lhs-  , clauseNamedDots  :: [NamedDotPattern]-      -- ^ Only in with-clauses where we inherit some already checked dot patterns from the parent.-      --   These live in the context of the parent clause left-hand side.-  , clauseRHS        :: RHS-  , clauseWhereDecls :: [Declaration]-  , clauseCatchall   :: Bool-  } deriving (Typeable, Show, Functor, Foldable, Traversable, Eq)--type Clause = Clause' LHS-type SpineClause = Clause' SpineLHS--data RHS-  = RHS-    { rhsExpr     :: Expr-    , rhsConcrete :: Maybe C.Expr-      -- ^ We store the original concrete expression in case-      --   we have to reproduce it during interactive case splitting.-      --   'Nothing' for internally generated rhss.-    }-  | AbsurdRHS-  | WithRHS QName [Expr] [Clause]-      -- ^ The 'QName' is the name of the with function.-  | RewriteRHS-    { rewriteExprs      :: [(QName, Expr)]-      -- ^ The 'QName's are the names of the generated with functions,-      --   one for each 'Expr'.-    , rewriteRHS        :: RHS-      -- ^ The RHS should not be another @RewriteRHS@.-    , rewriteWhereDecls :: [Declaration]-      -- ^ The where clauses are attached to the @RewriteRHS@ by-      ---  the scope checker (instead of to the clause).-    }-  deriving (Typeable, Show)--instance Eq RHS where-  RHS e _          == RHS e' _            = e == e'-  AbsurdRHS        == AbsurdRHS           = True-  WithRHS a b c    == WithRHS a' b' c'    = and [ a == a', b == b', c == c' ]-  RewriteRHS a b c == RewriteRHS a' b' c' = and [ a == a', b == b', c == c' ]-  _                == _                   = False---- | The lhs of a clause in spine view (inside-out).---   Projection patterns are contained in @spLhsPats@,---   represented as @ProjP d@.-data SpineLHS = SpineLHS-  { spLhsInfo     :: LHSInfo             -- ^ Range.-  , spLhsDefName  :: QName               -- ^ Name of function we are defining.-  , spLhsPats     :: [NamedArg Pattern]  -- ^ Function parameters (patterns).-  , spLhsWithPats :: [Pattern]           -- ^ @with@ patterns (after @|@).-  }-  deriving (Typeable, Show, Eq)---instance Eq LHS where-  (LHS _ core wps) == (LHS _ core' wps') = core == core' && wps == wps'---- | The lhs of a clause in focused (projection-application) view (outside-in).---   Projection patters are represented as 'LHSProj's.-data LHS = LHS-  { lhsInfo     :: LHSInfo               -- ^ Range.-  , lhsCore     :: LHSCore               -- ^ Copatterns.-  , lhsWithPats :: [Pattern]             -- ^ @with@ patterns (after @|@).-  }-  deriving (Typeable, Show)---- | The lhs minus @with@-patterns in projection-application view.---   Parameterised over the type @e@ of dot patterns.-data LHSCore' e-    -- | The head applied to ordinary patterns.-  = LHSHead  { lhsDefName  :: QName                    -- ^ Head @f@.-             , lhsPats     :: [NamedArg (Pattern' e)]  -- ^ Applied to patterns @ps@.-             }-    -- | Projection-  | LHSProj  { lhsDestructor :: AmbiguousQName-               -- ^ Record projection identifier.-             , lhsFocus      :: NamedArg (LHSCore' e)-               -- ^ Main branch.-             , lhsPatsRight  :: [NamedArg (Pattern' e)]-               -- ^ Further applied to patterns.-             }-  deriving (Typeable, Show, Functor, Foldable, Traversable, Eq)--type LHSCore = LHSCore' Expr---- | Convert a focused lhs to spine view and back.-class LHSToSpine a b where-  lhsToSpine :: a -> b-  spineToLhs :: b -> a---- | Clause instance.-instance LHSToSpine Clause SpineClause where-  lhsToSpine = fmap lhsToSpine-  spineToLhs = fmap spineToLhs---- | List instance (for clauses).-instance LHSToSpine a b => LHSToSpine [a] [b] where-  lhsToSpine = map lhsToSpine-  spineToLhs = map spineToLhs---- | LHS instance.-instance LHSToSpine LHS SpineLHS where-  lhsToSpine (LHS i core wps) = SpineLHS i f ps wps-    where QNamed f ps = lhsCoreToSpine core-  spineToLhs (SpineLHS i f ps wps) = LHS i (spineToLhsCore $ QNamed f ps) wps--lhsCoreToSpine :: LHSCore' e -> A.QNamed [NamedArg (Pattern' e)]-lhsCoreToSpine (LHSHead f ps) = QNamed f ps-lhsCoreToSpine (LHSProj d h ps) = (++ (p : ps)) <$> lhsCoreToSpine (namedArg h)-  where p = updateNamedArg (const $ ProjP patNoRange ProjPrefix d) h--spineToLhsCore :: IsProjP e => QNamed [NamedArg (Pattern' e)] -> LHSCore' e-spineToLhsCore (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps---- | Add applicative patterns (non-projection patterns) to the right.-lhsCoreApp :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e-lhsCoreApp (LHSHead f ps)   ps' = LHSHead f   $ ps ++ ps'-lhsCoreApp (LHSProj d h ps) ps' = LHSProj d h $ ps ++ ps'---- | Add projection and applicative patterns to the right.-lhsCoreAddSpine :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e-lhsCoreAddSpine core ps = case ps2 of-    [] -> lhsCoreApp core ps-    p@(Arg info (Named n (ProjP i o d))) : ps2' | let nh = numHoles d->-      -- Andreas, 2016-06-13-      -- If the projection was written prefix by the user-      -- or it is fully applied an operator-      -- we turn it to prefix projection form.-      (if o == ProjPrefix || nh > 0 && nh <= 1 + length ps2' then-        LHSProj d (Arg info $ Named n $ lhsCoreApp core ps1) []-      else lhsCoreApp core $ ps1 ++ [p])-        `lhsCoreAddSpine` ps2'-    _ -> __IMPOSSIBLE__-  where-    (ps1, ps2) = break (isJust . isProjP) ps---- | Used for checking pattern linearity.-lhsCoreAllPatterns :: LHSCore' e -> [Pattern' e]-lhsCoreAllPatterns = map namedArg . qnamed . lhsCoreToSpine---- | Used in AbstractToConcrete.-lhsCoreToPattern :: LHSCore -> Pattern-lhsCoreToPattern lc =-  case lc of-    LHSHead f aps -> DefP noInfo (AmbQ [f]) aps-    LHSProj d lhscore aps -> DefP noInfo d $-      fmap (fmap lhsCoreToPattern) lhscore : aps-  where noInfo = patNoRange -- TODO, preserve range!--mapLHSHead :: (QName -> [NamedArg Pattern] -> LHSCore) -> LHSCore -> LHSCore-mapLHSHead f (LHSHead x ps)   = f x ps-mapLHSHead f (LHSProj d l ps) = LHSProj d (fmap (fmap (mapLHSHead f)) l) ps-------------------------------------------------------------------------------- * Patterns-------------------------------------------------------------------------------- | Parameterised over the type of dot patterns.-data Pattern' e-  = VarP Name-  | ConP ConPatInfo AmbiguousQName [NamedArg (Pattern' e)]-  | ProjP PatInfo ProjOrigin AmbiguousQName-    -- ^ Destructor pattern @d@.-  | DefP PatInfo AmbiguousQName [NamedArg (Pattern' e)]-    -- ^ Defined pattern: function definition @f ps@.-    --   It is also abused to convert destructor patterns into concrete syntax-    --   thus, we put AmbiguousQName here as well.-  | WildP PatInfo-    -- ^ Underscore pattern entered by user.-    --   Or generated at type checking for implicit arguments.-  | AsP PatInfo Name (Pattern' e)-  | DotP PatInfo Origin e-  | AbsurdP PatInfo-  | LitP Literal-  | PatternSynP PatInfo QName [NamedArg (Pattern' e)]-  | RecP PatInfo [FieldAssignment' (Pattern' e)]-  deriving (Typeable, Show, Functor, Foldable, Traversable, Eq)--type Pattern  = Pattern' Expr-type Patterns = [NamedArg Pattern]--instance IsProjP (Pattern' e) where-  isProjP (ProjP _ o d) = Just (o, d)-  isProjP _ = Nothing--instance IsProjP Expr where-  isProjP (Proj o ds)      = Just (o, ds)-  isProjP (ScopedExpr _ e) = isProjP e-  isProjP _ = Nothing--class MaybePostfixProjP a where-  maybePostfixProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)--instance IsProjP e => MaybePostfixProjP (Pattern' e) where-  maybePostfixProjP (DotP _ _ e)  = isProjP e <&> \ (_o, d) -> (ProjPostfix, d)-  maybePostfixProjP (ProjP _ o d) = Just (o, d)-  maybePostfixProjP _ = Nothing--instance MaybePostfixProjP a => MaybePostfixProjP (Arg a) where-  maybePostfixProjP = maybePostfixProjP . unArg--instance MaybePostfixProjP a => MaybePostfixProjP (Named n a) where-  maybePostfixProjP = maybePostfixProjP . namedThing--{---------------------------------------------------------------------------    Instances- --------------------------------------------------------------------------}---- | Does not compare 'ScopeInfo' fields.---   Does not distinguish between prefix and postfix projections.--instance Eq Expr where-  ScopedExpr _ a1         == ScopedExpr _ a2         = a1 == a2--  Var a1                  == Var a2                  = a1 == a2-  Def a1                  == Def a2                  = a1 == a2-  Proj _ a1               == Proj _ a2               = a1 == a2-  Con a1                  == Con a2                  = a1 == a2-  PatternSyn a1           == PatternSyn a2           = a1 == a2-  Macro a1                == Macro a2                = a1 == a2-  Lit a1                  == Lit a2                  = a1 == a2-  QuestionMark a1 b1      == QuestionMark a2 b2      = (a1, b1) == (a2, b2)-  Underscore a1           == Underscore a2           = a1 == a2-  Dot r1 e1               == Dot r2 e2               = (r1, e1) == (r2, e2)-  App a1 b1 c1            == App a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  WithApp a1 b1 c1        == WithApp a2 b2 c2        = (a1, b1, c1) == (a2, b2, c2)-  Lam a1 b1 c1            == Lam a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  AbsurdLam a1 b1         == AbsurdLam a2 b2         = (a1, b1) == (a2, b2)-  ExtendedLam a1 b1 c1 d1 == ExtendedLam a2 b2 c2 d2 = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  Pi a1 b1 c1             == Pi a2 b2 c2             = (a1, b1, c1) == (a2, b2, c2)-  Fun a1 b1 c1            == Fun a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)-  Set a1 b1               == Set a2 b2               = (a1, b1) == (a2, b2)-  Prop a1                 == Prop a2                 = a1 == a2-  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)-  QuoteGoal a1 b1 c1      == QuoteGoal a2 b2 c2      = (a1, b1, c1) == (a2, b2, c2)-  QuoteContext a1         == QuoteContext a2         = a1 == a2-  Quote a1                == Quote a2                = a1 == a2-  QuoteTerm a1            == QuoteTerm a2            = a1 == a2-  Unquote a1              == Unquote a2              = a1 == a2-  Tactic a1 b1 c1 d1      == Tactic a2 b2 c2 d2      = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  DontCare a1             == DontCare a2             = a1 == a2--  _                       == _                       = False---- | Does not compare 'ScopeInfo' fields.--instance Eq Declaration where-  ScopedDecl _ a1                == ScopedDecl _ a2                = a1 == a2--  Axiom a1 b1 c1 d1 e1 f1        == Axiom a2 b2 c2 d2 e2 f2        = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)-  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)-  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)-  DataDef a1 b1 c1 d1            == DataDef a2 b2 c2 d2            = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  RecSig a1 b1 c1 d1             == RecSig a2 b2 c2 d2             = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  RecDef a1 b1 c1 d1 e1 f1 g1 h1 == RecDef a2 b2 c2 d2 e2 f2 g2 h2 = (a1, b1, c1, d1, e1, f1, g1, h1) == (a2, b2, c2, d2, e2, f2, g2, h2)-  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)--  _                              == _                              = False--instance Underscore Expr where-  underscore   = Underscore emptyMetaInfo-  isUnderscore = __IMPOSSIBLE__--instance LensHiding TypedBindings where-  getHiding   (TypedBindings _ a) = getHiding a-  mapHiding f (TypedBindings r a) = TypedBindings r $ mapHiding f a--instance LensHiding LamBinding where-  getHiding   (DomainFree ai _) = getHiding ai-  getHiding   (DomainFull tb)   = getHiding tb-  mapHiding f (DomainFree ai x) = mapHiding f ai `DomainFree` x-  mapHiding f (DomainFull tb)   = DomainFull $ mapHiding f tb--instance HasRange LamBinding where-    getRange (DomainFree _ x) = getRange x-    getRange (DomainFull b)   = getRange b--instance HasRange TypedBindings where-    getRange (TypedBindings r _) = r--instance HasRange TypedBinding where-    getRange (TBind r _ _) = r-    getRange (TLet r _)    = r--instance HasRange Expr where-    getRange (Var x)               = getRange x-    getRange (Def x)               = getRange x-    getRange (Proj _ x)            = getRange x-    getRange (Con x)               = getRange x-    getRange (Lit l)               = getRange l-    getRange (QuestionMark i _)    = getRange i-    getRange (Underscore  i)       = getRange i-    getRange (Dot i _)             = getRange i-    getRange (App i _ _)           = getRange i-    getRange (WithApp i _ _)       = getRange i-    getRange (Lam i _ _)           = getRange i-    getRange (AbsurdLam i _)       = getRange i-    getRange (ExtendedLam i _ _ _) = getRange i-    getRange (Pi i _ _)            = getRange i-    getRange (Fun i _ _)           = getRange i-    getRange (Set i _)             = getRange i-    getRange (Prop i)              = getRange i-    getRange (Let i _ _)           = getRange i-    getRange (Rec i _)             = getRange i-    getRange (RecUpdate i _ _)     = getRange i-    getRange (ETel tel)            = getRange tel-    getRange (ScopedExpr _ e)      = getRange e-    getRange (QuoteGoal _ _ e)     = getRange e-    getRange (QuoteContext i)      = getRange i-    getRange (Quote i)             = getRange i-    getRange (QuoteTerm i)         = getRange i-    getRange (Unquote i)           = getRange i-    getRange (Tactic i _ _ _)      = getRange i-    getRange (DontCare{})          = noRange-    getRange (PatternSyn x)        = getRange x-    getRange (Macro x)             = getRange x--instance HasRange Declaration where-    getRange (Axiom    _ 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--instance HasRange (Pattern' e) where-    getRange (VarP x)            = getRange x-    getRange (ConP i _ _)        = getRange i-    getRange (ProjP i _ _)       = getRange i-    getRange (DefP i _ _)        = getRange i-    getRange (WildP i)           = getRange i-    getRange (AsP i _ _)         = getRange i-    getRange (DotP i _ _)        = getRange i-    getRange (AbsurdP i)         = getRange i-    getRange (LitP l)            = getRange l-    getRange (PatternSynP i _ _) = getRange i-    getRange (RecP i _)          = getRange i--instance HasRange SpineLHS where-    getRange (SpineLHS i _ _ _)  = getRange i--instance HasRange LHS where-    getRange (LHS i _ _)   = getRange i--instance HasRange (LHSCore' e) where-    getRange (LHSHead f ps) = fuseRange f ps-    getRange (LHSProj d lhscore ps) = d `fuseRange` lhscore `fuseRange` ps--instance HasRange a => HasRange (Clause' a) where-    getRange (Clause lhs _ rhs ds catchall) = getRange (lhs,rhs,ds)--instance HasRange RHS where-    getRange AbsurdRHS                = noRange-    getRange (RHS e _)                = getRange e-    getRange (WithRHS _ e cs)         = fuseRange e cs-    getRange (RewriteRHS xes rhs wh)  = getRange (map snd xes, rhs, wh)--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---- setRange for patterns applies the range to the outermost pattern constructor-instance SetRange (Pattern' a) where-    setRange r (VarP x)             = VarP (setRange r x)-    setRange r (ConP i ns as)       = ConP (setRange r i) ns as-    setRange r (ProjP _ o ns)       = ProjP (PatRange r) o ns-    setRange r (DefP _ ns as)       = DefP (PatRange r) ns as -- (setRange r n) as-    setRange r (WildP _)            = WildP (PatRange r)-    setRange r (AsP _ n p)          = AsP (PatRange r) (setRange r n) p-    setRange r (DotP _ o e)         = DotP (PatRange r) o e-    setRange r (AbsurdP _)          = AbsurdP (PatRange r)-    setRange r (LitP l)             = LitP (setRange r l)-    setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) (setRange r n) as-    setRange r (RecP i as)          = RecP (PatRange r) as--instance KillRange LamBinding where-  killRange (DomainFree info x) = killRange1 (DomainFree info) x-  killRange (DomainFull b)      = killRange1 DomainFull b--instance KillRange TypedBindings where-  killRange (TypedBindings r b) = TypedBindings (killRange r) (killRange b)--instance KillRange TypedBinding where-  killRange (TBind r xs e) = killRange3 TBind r xs e-  killRange (TLet r lbs)   = killRange2 TLet r lbs--instance KillRange Expr where-  killRange (Var x)                = killRange1 Var x-  killRange (Def x)                = killRange1 Def x-  killRange (Proj o x)             = killRange1 (Proj o) x-  killRange (Con x)                = killRange1 Con x-  killRange (Lit l)                = killRange1 Lit 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 d ps) = killRange4 ExtendedLam i n d ps-  killRange (Pi i a b)             = killRange3 Pi i a b-  killRange (Fun i a b)            = killRange3 Fun i a b-  killRange (Set i n)              = killRange2 Set i n-  killRange (Prop i)               = killRange1 Prop i-  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 (QuoteGoal i x e)      = killRange3 QuoteGoal i x e-  killRange (QuoteContext i)       = killRange1 QuoteContext i-  killRange (Quote i)              = killRange1 Quote i-  killRange (QuoteTerm i)          = killRange1 QuoteTerm i-  killRange (Unquote i)            = killRange1 Unquote i-  killRange (Tactic i e xs ys)     = killRange4 Tactic i e xs ys-  killRange (DontCare e)           = killRange1 DontCare e-  killRange (PatternSyn x)         = killRange1 PatternSyn x-  killRange (Macro x)              = killRange1 Macro x--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 (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 (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          ) = killRange4 DataDef i a b c-  killRange (RecSig  i a b c          ) = killRange4 RecSig  i a b c-  killRange (RecDef  i a b c d e f g  ) = killRange8 RecDef  i a b c d e f g-  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--instance KillRange ModuleApplication where-  killRange (SectionApp a b c  ) = killRange3 SectionApp a b c-  killRange (RecordModuleIFS a ) = killRange1 RecordModuleIFS a--instance KillRange ScopeCopyInfo where-  killRange (ScopeCopyInfo a b) = killRange2 ScopeCopyInfo a b--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 o a)        = killRange3 DotP i o a-  killRange (AbsurdP i)         = killRange1 AbsurdP i-  killRange (LitP l)            = killRange1 LitP l-  killRange (PatternSynP i a p) = killRange3 PatternSynP i a p-  killRange (RecP i as)         = killRange2 RecP i as--instance KillRange SpineLHS where-  killRange (SpineLHS i a b c)  = killRange4 SpineLHS i a b c--instance KillRange LHS where-  killRange (LHS i a b)   = killRange3 LHS i a b--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--instance KillRange a => KillRange (Clause' a) where-  killRange (Clause lhs dots rhs ds catchall) = killRange5 Clause lhs dots rhs ds catchall--instance KillRange NamedDotPattern where-  killRange (NamedDot a b c) = killRange3 NamedDot a b c--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 rhs wh)  = killRange3 RewriteRHS xes rhs wh--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---- See Agda.Utils.GeniPlate:--- Does not descend into ScopeInfo and renaming maps, for instance.--instanceUniverseBiT' [] [t| (Declaration, QName)          |]-instanceUniverseBiT' [] [t| (Declaration, AmbiguousQName) |]-instanceUniverseBiT' [] [t| (Declaration, Expr)           |]-instanceUniverseBiT' [] [t| (Declaration, LetBinding)     |]-instanceUniverseBiT' [] [t| (Declaration, LamBinding)     |]-instanceUniverseBiT' [] [t| (Declaration, TypedBinding)   |]-instanceUniverseBiT' [] [t| (Declaration, Pattern)        |]-instanceUniverseBiT' [] [t| (Declaration, Pattern' Void)  |]-instanceUniverseBiT' [] [t| (Declaration, Declaration)    |]-instanceUniverseBiT' [] [t| (Declaration, ModuleName)     |]-instanceUniverseBiT' [] [t| (Declaration, ModuleInfo)     |]-instanceUniverseBiT' [] [t| (Declaration, RString)        |]-  -- RString is not quite what you want but we put names on lots of things...----------------------------------------------------------------------------- Queries----------------------------------------------------------------------------- | Extracts all the names which are declared in a 'Declaration'.--- This does not include open public or let expressions, but it does--- include local modules, where clauses and the names of extended--- lambdas.--class AllNames a where-  allNames :: a -> Seq QName--instance AllNames a => AllNames [a] where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Maybe a) where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Arg a) where-  allNames = Fold.foldMap allNames--instance AllNames a => AllNames (Named name a) where-  allNames = Fold.foldMap allNames--instance (AllNames a, AllNames b) => AllNames (a,b) where-  allNames (a,b) = allNames a >< allNames b--instance AllNames QName where-  allNames q = Seq.singleton q--instance AllNames Declaration where-  allNames (Axiom   _ _ _ _ q _)      = Seq.singleton q-  allNames (Field     _   q _)        = Seq.singleton q-  allNames (Primitive _   q _)        = Seq.singleton q-  allNames (Mutual     _ defs)        = allNames defs-  allNames (DataSig _ q _ _)          = Seq.singleton q-  allNames (DataDef _ q _ decls)      = q <| allNames decls-  allNames (RecSig _ q _ _)           = Seq.singleton q-  allNames (RecDef _ q _ _ c _ _ decls) = q <| allNames c >< allNames decls-  allNames (PatternSynDef q _ _)      = Seq.singleton q-  allNames (UnquoteDecl _ _ qs _)     = Seq.fromList qs-  allNames (UnquoteDef _ qs _)        = Seq.fromList qs-  allNames (FunDef _ q _ cls)         = q <| allNames cls-  allNames (Section _ _ _ decls)      = allNames decls-  allNames Apply{}                    = Seq.empty-  allNames Import{}                   = Seq.empty-  allNames Pragma{}                   = Seq.empty-  allNames Open{}                     = Seq.empty-  allNames (ScopedDecl _ decls)       = allNames decls--instance AllNames Clause where-  allNames (Clause _ _ rhs decls _) = allNames rhs >< allNames decls--instance AllNames RHS where-  allNames (RHS e _)                 = allNames e-  allNames AbsurdRHS{}               = Seq.empty-  allNames (WithRHS q _ cls)         = q <| allNames cls-  allNames (RewriteRHS qes rhs cls) = Seq.fromList (map fst qes) >< allNames rhs >< allNames cls--instance AllNames Expr where-  allNames Var{}                   = Seq.empty-  allNames Def{}                   = Seq.empty-  allNames Proj{}                  = Seq.empty-  allNames Con{}                   = Seq.empty-  allNames Lit{}                   = Seq.empty-  allNames QuestionMark{}          = Seq.empty-  allNames Underscore{}            = Seq.empty-  allNames (Dot _ e)               = allNames e-  allNames (App _ e1 e2)           = allNames e1 >< allNames e2-  allNames (WithApp _ e es)        = allNames e >< allNames es-  allNames (Lam _ b e)             = allNames b >< allNames e-  allNames AbsurdLam{}             = Seq.empty-  allNames (ExtendedLam _ _ q cls) = q <| allNames cls-  allNames (Pi _ tel e)            = allNames tel >< allNames e-  allNames (Fun _ e1 e2)           = allNames e1 >< allNames e2-  allNames Set{}                   = Seq.empty-  allNames Prop{}                  = Seq.empty-  allNames (Let _ lbs e)           = allNames lbs >< allNames e-  allNames ETel{}                  = __IMPOSSIBLE__-  allNames (Rec _ fields)          = allNames [ a ^. exprFieldA | Left a <- fields ]-  allNames (RecUpdate _ e fs)      = allNames e >< allNames (map (view exprFieldA) fs)-  allNames (ScopedExpr _ e)        = allNames e-  allNames (QuoteGoal _ _ e)       = allNames e-  allNames (QuoteContext _)        = Seq.empty-  allNames Quote{}                 = Seq.empty-  allNames QuoteTerm{}             = Seq.empty-  allNames Unquote{}               = Seq.empty-  allNames (Tactic _ e xs ys)      = allNames e >< allNames xs >< allNames ys-  allNames DontCare{}              = Seq.empty-  allNames PatternSyn{}            = Seq.empty-  allNames Macro{}                 = Seq.empty--instance AllNames LamBinding where-  allNames DomainFree{}       = Seq.empty-  allNames (DomainFull binds) = allNames binds--instance AllNames TypedBindings where-  allNames (TypedBindings _ bs) = allNames bs--instance AllNames TypedBinding where-  allNames (TBind _ _ e) = allNames e-  allNames (TLet _ lbs)  = allNames lbs--instance AllNames LetBinding where-  allNames (LetBind _ _ _ e1 e2)   = allNames e1 >< allNames e2-  allNames (LetPatBind _ _ e)      = allNames e-  allNames (LetApply _ _ app _ _)  = allNames app-  allNames LetOpen{}               = Seq.empty-  allNames (LetDeclaredVariable _) = Seq.empty--instance AllNames ModuleApplication where-  allNames (SectionApp bindss _ es) = allNames bindss >< allNames es-  allNames RecordModuleIFS{}        = Seq.empty---- | The name defined by the given axiom.------ Precondition: The declaration has to be a (scoped) 'Axiom'.--axiomName :: Declaration -> QName-axiomName (Axiom _ _ _ _ q _)  = q-axiomName (ScopedDecl _ (d:_)) = axiomName d-axiomName _                    = __IMPOSSIBLE__---- | Are we in an abstract block?------   In that case some definition is abstract.-class AnyAbstract a where-  anyAbstract :: a -> Bool--instance AnyAbstract a => AnyAbstract [a] where-  anyAbstract = Fold.any anyAbstract--instance AnyAbstract Declaration where-  anyAbstract (Axiom _ i _ _ _ _)    = defAbstract i == AbstractDef-  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 (DataDef i _ _ _)      = defAbstract i == AbstractDef-  anyAbstract (RecDef i _ _ _ _ _ _ _) = defAbstract i == AbstractDef-  anyAbstract (DataSig i _ _ _)      = defAbstract i == AbstractDef-  anyAbstract (RecSig i _ _ _)       = defAbstract i == AbstractDef-  anyAbstract _                      = __IMPOSSIBLE__---- | Turn an 'AbstractName' to an expression.-nameExpr :: AbstractName -> Expr-nameExpr d = mk (anameKind d) $ anameName d-  where-    mk DefName        x = Def x-    mk FldName        x = Proj ProjSystem $ AmbQ [x]-    mk ConName        x = Con $ AmbQ [x]-    mk PatternSynName x = PatternSyn x-    mk MacroName      x = Macro x-    mk QuotableName   x = App i (Quote i) (defaultNamedArg $ Def x)-      where i = ExprRange (getRange x)--app :: Expr -> [NamedArg Expr] -> Expr-app = foldl (App (ExprRange noRange))--mkLet :: ExprInfo -> [LetBinding] -> Expr -> Expr-mkLet i [] e = e-mkLet i ds e = Let i ds e--patternToExpr :: Pattern -> Expr-patternToExpr (VarP x)            = Var x-patternToExpr (ConP _ c ps)       =-  Con c `app` map (fmap (fmap patternToExpr)) ps-patternToExpr (ProjP _ o ds)      = Proj o ds-patternToExpr (DefP _ (AmbQ [f]) ps) =-  Def f `app` map (fmap (fmap patternToExpr)) ps-patternToExpr (DefP _ (AmbQ _) ps) = __IMPOSSIBLE__-patternToExpr (WildP _)           = Underscore emptyMetaInfo-patternToExpr (AsP _ _ p)         = patternToExpr p-patternToExpr (DotP _ _ e)        = e-patternToExpr (AbsurdP _)         = Underscore emptyMetaInfo  -- TODO: could this happen?-patternToExpr (LitP l)            = Lit l-patternToExpr (PatternSynP _ _ _) = __IMPOSSIBLE__-patternToExpr (RecP _ as)         = Rec exprNoRange $ map (Left . fmap patternToExpr) as--type PatternSynDefn = ([Arg Name], Pattern' Void)-type PatternSynDefns = Map QName PatternSynDefn--lambdaLiftExpr :: [Name] -> Expr -> Expr-lambdaLiftExpr []     e = e-lambdaLiftExpr (n:ns) e = Lam (ExprRange noRange) (DomainFree defaultArgInfo n) $-                                     lambdaLiftExpr ns e--substPattern :: [(Name, Pattern)] -> Pattern -> Pattern-substPattern s p = case p of-  VarP z        -> fromMaybe p (lookup z s)-  ConP i q ps   -> ConP i q (map (fmap (fmap (substPattern s))) ps)-  RecP i ps     -> RecP i (map (fmap (substPattern s)) ps)-  ProjP{}       -> p-  WildP i       -> p-  DotP i o e    -> DotP i o (substExpr (map (fmap patternToExpr) s) e)-  AbsurdP i     -> p-  LitP l        -> p-  DefP{}        -> p              -- destructor pattern-  AsP i x p     -> AsP i x (substPattern s p) -- Note: cannot substitute into as-variable-  PatternSynP{} -> __IMPOSSIBLE__ -- pattern synonyms (already gone)--class SubstExpr a where-  substExpr :: [(Name, Expr)] -> a -> a--instance SubstExpr a => SubstExpr [a] where-  substExpr = fmap . substExpr--instance SubstExpr a => SubstExpr (Arg a) where-  substExpr = fmap . substExpr--instance SubstExpr a => SubstExpr (Named name a) where-  substExpr = fmap . substExpr--instance (SubstExpr a, SubstExpr b) => SubstExpr (a, b) where-  substExpr s (x, y) = (substExpr s x, substExpr s y)--instance (SubstExpr a, SubstExpr b) => SubstExpr (Either a b) where-  substExpr s (Left x)  = Left (substExpr s x)-  substExpr s (Right y) = Right (substExpr s y)--instance SubstExpr C.Name where-  substExpr _ = id--instance SubstExpr ModuleName where-  substExpr _ = id--instance SubstExpr Assign where-  substExpr s (FieldAssignment n x) = FieldAssignment n (substExpr s x)--instance SubstExpr Expr where-  substExpr s e = case e of-    Var n                 -> fromMaybe e (lookup n s)-    Def _                 -> e-    Proj{}                -> e-    Con _                 -> e-    Lit _                 -> e-    QuestionMark{}        -> e-    Underscore   _        -> e-    Dot i e               -> Dot i (substExpr s e)-    App  i e e'           -> App i (substExpr s e) (substExpr s e')-    WithApp i e es        -> WithApp i (substExpr s e) (substExpr s es)-    Lam  i lb e           -> Lam i lb (substExpr s e)-    AbsurdLam i h         -> e-    ExtendedLam i di n cs -> __IMPOSSIBLE__   -- Maybe later...-    Pi   i t e            -> Pi i (substExpr s t) (substExpr s e)-    Fun  i ae e           -> Fun i (substExpr s ae) (substExpr s e)-    Set  i n              -> e-    Prop i                -> e-    Let  i ls e           -> Let i (substExpr s ls) (substExpr s e)-    ETel t                -> e-    Rec  i nes            -> Rec i (substExpr s nes)-    RecUpdate i e nes     -> RecUpdate i (substExpr s e) (substExpr s nes)-    -- XXX: Do we need to do more with ScopedExprs?-    ScopedExpr si e       -> ScopedExpr si (substExpr s e)-    QuoteGoal i n e       -> QuoteGoal i n (substExpr s e)-    QuoteContext i        -> e-    Quote i               -> e-    QuoteTerm i           -> e-    Unquote i             -> e-    Tactic i e xs ys      -> Tactic i (substExpr s e) (substExpr s xs) (substExpr s ys)-    DontCare e            -> DontCare (substExpr s e)-    PatternSyn{}          -> e-    Macro{}               -> e--instance SubstExpr LetBinding where-  substExpr s lb = case lb of-    LetBind i r n e e' -> LetBind i r n (substExpr s e) (substExpr s e')-    LetPatBind i p e   -> LetPatBind i p (substExpr s e) -- Andreas, 2012-06-04: what about the pattern p-    _                  -> lb -- Nicolas, 2013-11-11: what about "LetApply" there is experessions in there--instance SubstExpr TypedBindings where-  substExpr s (TypedBindings r atb) = TypedBindings r (substExpr s atb)--instance SubstExpr TypedBinding where-  substExpr s tb = case tb of-    TBind r ns e -> TBind r ns $ substExpr s e-    TLet r lbs   -> TLet r $ substExpr s lbs---- TODO: more informative failure-insertImplicitPatSynArgs :: HasRange a => (Range -> a) -> Range -> [Arg Name] -> [NamedArg a] ->-                            Maybe ([(Name, a)], [Arg Name])-insertImplicitPatSynArgs wild r ns as = matchArgs r ns as-  where-    matchNextArg r n as@(~(a : as'))-      | matchNext n as           = return (namedArg a, as')-      | getHiding n == NotHidden = Nothing-      | otherwise                = return (wild r, as)--    matchNext _ [] = False-    matchNext n (a:as) = getHiding n == getHiding a && matchName-      where-        x = unranged $ C.nameToRawName $ nameConcrete $ unArg n-        matchName = maybe True (== x) (nameOf $ unArg a)--    matchArgs r [] []     = return ([], [])-    matchArgs r [] as     = Nothing-    matchArgs r (n:ns) [] | getHiding n == NotHidden = 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++{-| The abstract syntax. This is what you get after desugaring and scope+    analysis of the concrete syntax. The type checker works on abstract syntax,+    producing internal syntax ("Agda.Syntax.Internal").+-}+module Agda.Syntax.Abstract+    ( module Agda.Syntax.Abstract+    , module Agda.Syntax.Abstract.Name+    ) where++import Prelude hiding (null)++import Control.DeepSeq++import Data.Bifunctor+import qualified Data.Foldable as Fold+import Data.Function (on)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.Set (Set)+import Data.Void++import GHC.Generics (Generic)++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+import Agda.Syntax.Scope.Base++import Agda.TypeChecking.Positivity.Occurrence++import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1++import Agda.Utils.Impossible++-- | A name in a binding position: we also compare the nameConcrete+-- when comparing the binders for equality.+--+-- With @--caching@ on we compare abstract syntax to determine if we can+-- reuse previous typechecking results: during that comparison two+-- names can have the same nameId but be semantically different,+-- e.g. in @{_ : A} -> ..@ vs. @{r : A} -> ..@.++newtype BindName = BindName { unBind :: Name }+  deriving (Show, HasRange, KillRange, SetRange, NFData)++mkBindName :: Name -> BindName+mkBindName x = BindName x++instance Eq BindName where+  BindName n == BindName m+    = ((==) `on` nameId) n m+      && ((==) `on` nameConcrete) n m++instance Ord BindName where+  BindName n `compare` BindName m+    = (compare `on` nameId) n m+      `mappend` (compare `on` nameConcrete) n m++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.+  | Def'  QName Suffix                 -- ^ Constant: axiom, function, data or record type,+                                       --   with a possible suffix.+  | Proj ProjOrigin AmbiguousQName     -- ^ Projection (overloaded).+  | Con  AmbiguousQName                -- ^ Constructor (overloaded).+  | PatternSyn AmbiguousQName          -- ^ Pattern synonym.+  | Macro QName                        -- ^ Macro.+  | Lit ExprInfo Literal               -- ^ Literal.+  | QuestionMark MetaInfo InteractionId+    -- ^ Meta variable for interaction.+    --   The 'InteractionId' is usually identical with the+    --   'metaNumber' of 'MetaInfo'.+    --   However, if you want to print an interaction meta as+    --   just @?@ instead of @?n@, you should set the+    --   'metaNumber' to 'Nothing' while keeping the 'InteractionId'.+  | Underscore   MetaInfo+    -- ^ 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 (List1 Expr) -- ^ With application.+  | Lam  ExprInfo LamBinding Expr      -- ^ @λ bs → e@.+  | AbsurdLam ExprInfo Hiding          -- ^ @λ()@ or @λ{}@.+  | ExtendedLam ExprInfo DefInfo Erased QName (List1 Clause)+  | 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@.+  | 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 (Show, Generic)++-- | Pattern synonym for regular 'Def'.+pattern Def :: QName -> Expr+pattern Def x = Def' x NoSuffix++-- | 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+type Assigns = [Assign]+type RecordAssign  = Either Assign ModuleName+type RecordAssigns = [RecordAssign]++-- | Renaming (generic).+type Ren a = Map a (List1 a)++data ScopeCopyInfo = ScopeCopyInfo+  { renModules :: Ren ModuleName+  , renNames   :: Ren QName }+  deriving (Eq, Show, Generic)++initCopyInfo :: ScopeCopyInfo+initCopyInfo = ScopeCopyInfo+  { renModules = mempty+  , renNames   = mempty+  }++instance Pretty ScopeCopyInfo where+  pretty i = vcat [ prRen "renModules =" (renModules i)+                  , prRen "renNames   =" (renNames i) ]+    where+      prRen s r = sep [ text s, nest 2 $ vcat (map pr xs) ]+        where+          xs = [ (k, v) | (k, vs) <- Map.toList r, v <- List1.toList vs ]+      pr (x, y) = pretty x <+> "->" <+> pretty y++-- | 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 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 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 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+  | 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 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 [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+  | UnfoldingDecl Range [QName]+    -- ^ Only for highlighting the unfolded names+  deriving (Show, Generic)++type DefInfo = DefInfo' Expr++type ImportDirective = ImportDirective' QName ModuleName+type Renaming        = Renaming'        QName ModuleName+type ImportedName    = ImportedName'    QName ModuleName++data ModuleApplication+    = SectionApp Telescope ModuleName [NamedArg Expr]+      -- ^ @tel. M args@:  applies @M@ to @args@ and abstracts @tel@.+    | RecordModuleInstance ModuleName+      -- ^ @M {{...}}@+  deriving (Show, Eq, Generic)++data Pragma+  = OptionsPragma [String]+  | BuiltinPragma RString ResolvedName+    -- ^ 'ResolvedName' is not 'UnknownName'.+    --   Name can be ambiguous e.g. for built-in constructors.+  | BuiltinNoDefPragma RString KindOfName QName+    -- ^ Builtins that do not come with a definition,+    --   but declare a name for an Agda concept.+  | RewritePragma Range [QName]+    -- ^ Range is range of REWRITE keyword.+  | 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 (Show, Eq, Generic)++-- | Bindings that are valid in a @let@.+data LetBinding+  = 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 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+  deriving (Show, Eq, Generic)++-- | Only 'Axiom's.+type TypeSignature  = Declaration+type Constructor    = TypeSignature+type Field          = TypeSignature++type TacticAttribute = TacticAttribute' Expr++-- A Binder @x\@p@, the pattern is optional+data Binder' a = Binder+  { 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 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++-- | A lambda binding is either domain free or typed.+data LamBinding+  = 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 (Show, Eq, Generic)++mkDomainFree :: NamedArg Binder -> LamBinding+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)@+--   before type-checking.  However, this would be slightly problematic:+--+--     1. We would have to typecheck the type @A@ several times.+--+--     2. If @A@ contains a meta variable or hole, it would be duplicated+--        by such a translation.+--+--   While 1. is only slightly inefficient, 2. would be an outright bug.+--   Duplicating @A@ could not be done naively, we would have to make sure+--   that the metas of the copy are aliases of the metas of the original.++data TypedBinding+  = 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 (Show, Eq, Generic)++mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding+mkTBind r = TBind r empty++mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding+mkTLet _ []     = Nothing+mkTLet r (d:ds) = Just $ TLet r (d :| ds)++type Telescope1 = List1 TypedBinding+type Telescope  = [TypedBinding]++mkPi :: ExprInfo -> Telescope -> Type -> Type+mkPi i []     e = e+mkPi i (x:xs) e = Pi i (x :| xs) e++data GeneralizeTelescope = GeneralizeTel+  { generalizeTelVars :: Map QName Name+    -- ^ Maps generalize variables to the corresponding bound variable (to be+    --   introduced by the generalisation).+  , generalizeTel     :: Telescope }+  deriving (Show, Eq, Generic)++data DataDefParams = DataDefParams+  { dataDefGeneralizedParams :: Set Name+    -- ^ We don't yet know the position of generalized parameters from the data+    --   sig, so we keep these in a set on the side.+  , dataDefParams :: [LamBinding]+  }+  deriving (Show, Eq, Generic)++noDataDefParams :: DataDefParams+noDataDefParams = DataDefParams Set.empty []++-- | A user pattern together with an internal term that it should be equal to+--   after splitting is complete.+--   Special cases:+--    * User pattern is a variable but internal term isn't:+--      this will be turned into an as pattern.+--    * User pattern is a dot pattern:+--      this pattern won't trigger any splitting but will be checked+--      for equality after all splitting is complete and as patterns have+--      been bound.+--    * User pattern is an absurd pattern:+--      emptiness of the type will be checked after splitting is complete.+--    * User pattern is an annotated wildcard:+--      type annotation will be checked after splitting is complete.+data ProblemEq = ProblemEq+  { problemInPat :: Pattern+  , problemInst  :: I.Term+  , problemType  :: I.Dom I.Type+  } deriving (Show, Generic)++-- These are not relevant for caching purposes+instance Eq ProblemEq where _ == _ = True++-- | We could throw away @where@ clauses at this point and translate them to+--   @let@. It's not obvious how to remember that the @let@ was really a+--   @where@ clause though, so for the time being we keep it here.+data Clause' lhs = Clause+  { clauseLHS        :: lhs+  , clauseStrippedPats :: [ProblemEq]+      -- ^ Only in with-clauses where we inherit some already checked patterns from the parent.+      --   These live in the context of the parent clause left-hand side.+  , clauseRHS        :: RHS+  , clauseWhereDecls :: WhereDeclarations+  , 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+  , whereAnywhere :: Bool+      -- ^ is it an ordinary unnamed @where@?+  , whereDecls :: Maybe Declaration+      -- ^ The declaration is a 'Section'.+  } deriving (Show, Eq, Generic)++instance Null WhereDeclarations where+  empty = WhereDecls empty False empty++noWhereDecls :: WhereDeclarations+noWhereDecls = empty++type Clause = Clause' LHS+type SpineClause = Clause' SpineLHS+type RewriteEqn  = RewriteEqn' QName BindName Pattern Expr+type WithExpr' e = Named BindName (Arg e)+type WithExpr    = WithExpr' Expr++data RHS+  = RHS+    { rhsExpr     :: Expr+    , rhsConcrete :: Maybe C.Expr+      -- ^ We store the original concrete expression in case+      --   we have to reproduce it during interactive case splitting.+      --   'Nothing' for internally generated rhss.+    }+  | AbsurdRHS+  | WithRHS QName (List1 WithExpr) (List1 Clause)+      -- ^ The 'QName' is the name of the with function.+  | RewriteRHS+    { rewriteExprs      :: [RewriteEqn]+      -- ^ The 'QName's are the names of the generated with functions,+      --   one for each 'Expr'.+    , rewriteStrippedPats :: [ProblemEq]+      -- ^ The patterns stripped by with-desugaring. These are only present+      --   if this rewrite follows a with.+    , rewriteRHS        :: RHS+      -- ^ The RHS should not be another @RewriteRHS@.+    , rewriteWhereDecls :: WhereDeclarations+      -- ^ The where clauses are attached to the @RewriteRHS@ by+      ---  the scope checker (instead of to the clause).+    }+  deriving (Show, Generic)++-- | Ignore 'rhsConcrete' when comparing 'RHS's.+instance Eq RHS where+  RHS e _          == RHS e' _            = e == e'+  AbsurdRHS        == AbsurdRHS           = True+  WithRHS a b c    == WithRHS a' b' c'    = (a == a') && (b == b') && (c == c')+  RewriteRHS a b c d == RewriteRHS a' b' c' d' = and [ a == a', b == b', c == c' , d == d' ]+  _                == _                   = False++-- | The lhs of a clause in spine view (inside-out).+--   Projection patterns are contained in @spLhsPats@,+--   represented as @ProjP d@.+data SpineLHS = SpineLHS+  { spLhsInfo     :: LHSInfo             -- ^ Range.+  , spLhsDefName  :: QName               -- ^ Name of function we are defining.+  , spLhsPats     :: [NamedArg Pattern]  -- ^ Elimination by pattern, projections, with-patterns.+  }+  deriving (Show, Eq, Generic)++-- | Ignore 'Range' when comparing 'LHS's.+instance Eq LHS where+  LHS _ core == LHS _ core' = core == core'++-- | The lhs of a clause in focused (projection-application) view (outside-in).+--   Projection patters are represented as 'LHSProj's.+data LHS = LHS+  { lhsInfo     :: LHSInfo               -- ^ Range.+  , lhsCore     :: LHSCore               -- ^ Copatterns.+  }+  deriving (Show, Generic)++-- | The lhs in projection-application and with-pattern view.+--   Parameterised over the type @e@ of dot patterns.+data LHSCore' e+    -- | The head applied to ordinary patterns.+  = LHSHead  { lhsDefName  :: QName+                 -- ^ Head @f@.+             , lhsPats     :: [NamedArg (Pattern' e)]+                 -- ^ Applied to patterns @ps@.+             }+    -- | Projection.+  | LHSProj  { lhsDestructor :: AmbiguousQName+                 -- ^ Record projection identifier.+             , lhsFocus      :: NamedArg (LHSCore' e)+                 -- ^ Main argument of projection.+             , lhsPats       :: [NamedArg (Pattern' e)]+                 -- ^ Further applied to patterns.+             }+    -- | With patterns.+  | LHSWith  { lhsHead         :: LHSCore' e+                 -- ^ E.g. the 'LHSHead'.+             , 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 (Show, Functor, Foldable, Traversable, Eq, Generic)++type LHSCore = LHSCore' Expr++---------------------------------------------------------------------------+-- * Patterns+---------------------------------------------------------------------------++-- | Parameterised over the type of dot patterns.+data Pattern' e+  = VarP BindName+  | ConP ConPatInfo AmbiguousQName (NAPs e)+  | ProjP PatInfo ProjOrigin AmbiguousQName+    -- ^ Destructor pattern @d@.+  | DefP PatInfo AmbiguousQName (NAPs e)+    -- ^ Defined pattern: function definition @f ps@.+    --   It is also abused to convert destructor patterns into concrete syntax+    --   thus, we put AmbiguousQName here as well.+  | WildP PatInfo+    -- ^ Underscore pattern entered by user.+    --   Or generated at type checking for implicit arguments.+  | AsP PatInfo BindName (Pattern' e)+  | DotP PatInfo e+    -- ^ Dot pattern @.e@+  | AbsurdP PatInfo+  | LitP PatInfo Literal+  | PatternSynP PatInfo AmbiguousQName (NAPs e)+  | RecP KwRange ConPatInfo [FieldAssignment' (Pattern' e)]+  | EqualP PatInfo (List1 (e, e))+  | WithP PatInfo (Pattern' e)  -- ^ @| p@, for with-patterns.+  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)++type NAPs e   = [NamedArg (Pattern' e)]+type NAPs1 e  = List1 (NamedArg (Pattern' e))+type Pattern  = Pattern' Expr+type Patterns = [NamedArg Pattern]++instance IsProjP (Pattern' e) where+  -- Andreas, 2018-06-19, issue #3130+  -- Do not interpret things like .(p) as projection pattern any more.+  -- maybePostfixProjP (DotP _ e)    = isProjP e <&> \ (_o, d) -> (ProjPostfix, d)+  isProjP (ProjP _ o d) = Just (o, d)+  isProjP _ = Nothing++instance IsProjP Expr where+  isProjP (Proj o ds)      = Just (o, ds)+  isProjP (ScopedExpr _ e) = isProjP e+  isProjP _ = Nothing++{--------------------------------------------------------------------------+    Things we parse but are not part of the Agda file syntax+ --------------------------------------------------------------------------}++type HoleContent = C.HoleContent' () BindName Pattern Expr++{--------------------------------------------------------------------------+    Instances+ --------------------------------------------------------------------------}++-- | Does not compare 'ScopeInfo' fields.+--   Does not distinguish between prefix and postfix projections.++instance Eq Expr where+  ScopedExpr _ a1            == ScopedExpr _ a2            = a1 == a2++  Var a1                     == Var a2                     = a1 == a2+  Def' a1 s1                 == Def' a2 s2                 = (a1, s1) == (a2, s2)+  Proj _ a1                  == Proj _ a2                  = a1 == a2+  Con a1                     == Con a2                     = a1 == a2+  PatternSyn a1              == PatternSyn a2              = a1 == a2+  Macro a1                   == Macro a2                   = a1 == a2+  Lit r1 a1                  == Lit r2 a2                  = (r1, a1) == (r2, a2)+  QuestionMark a1 b1         == QuestionMark a2 b2         = (a1, b1) == (a2, b2)+  Underscore a1              == Underscore a2              = a1 == a2+  Dot r1 e1                  == Dot r2 e2                  = (r1, e1) == (r2, e2)+  App a1 b1 c1               == App a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  WithApp a1 b1 c1           == WithApp a2 b2 c2           = (a1, b1, c1) == (a2, b2, c2)+  Lam a1 b1 c1               == Lam a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)+  AbsurdLam a1 b1            == AbsurdLam a2 b2            = (a1, b1) == (a2, b2)+  ExtendedLam a1 b1 c1 d1 e1 == ExtendedLam a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) ==+                                                             (a2, b2, c2, d2, e2)+  Pi a1 b1 c1                == Pi a2 b2 c2                = (a1, b1, c1) == (a2, b2, c2)+  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)+  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+  DontCare a1                == DontCare a2                = a1 == a2++  _                          == _                          = False++-- | Does not compare 'ScopeInfo' fields.++instance Eq Declaration where+  ScopedDecl _ a1                == ScopedDecl _ a2                = a1 == a2++  Axiom a1 b1 c1 d1 e1 f1        == Axiom a2 b2 c2 d2 e2 f2        = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)+  Generalize a1 b1 c1 d1 e1      == Generalize a2 b2 c2 d2 e2      = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)+  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 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                == 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 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 = \case+    Underscore _ -> True+    _ -> False++instance LensHiding LamBinding where+  getHiding   (DomainFree _ x) = getHiding x+  getHiding   (DomainFull tb)  = getHiding tb+  mapHiding f (DomainFree t x) = DomainFree t $ mapHiding f x+  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++instance HasRange a => HasRange (Binder' a) where+  getRange (Binder p _ n) = fuseRange p n++instance HasRange LamBinding where+    getRange (DomainFree _ x) = getRange x+    getRange (DomainFull b)   = getRange b++instance HasRange TypedBinding where+    getRange (TBind r _ _ _) = r+    getRange (TLet r _)    = r++instance HasRange Expr where+    getRange (Var x)                 = getRange x+    getRange (Def' x _)              = getRange x+    getRange (Proj _ x)              = getRange x+    getRange (Con x)                 = getRange x+    getRange (Lit i _)               = getRange i+    getRange (QuestionMark i _)      = getRange i+    getRange (Underscore  i)         = getRange i+    getRange (Dot i _)               = getRange i+    getRange (App i _ _)             = getRange i+    getRange (WithApp i _ _)         = getRange i+    getRange (Lam i _ _)             = getRange i+    getRange (AbsurdLam i _)         = getRange i+    getRange (ExtendedLam i _ _ _ _) = getRange i+    getRange (Pi i _ _)              = getRange i+    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 (ScopedExpr _ e)        = getRange e+    getRange (Quote i)               = getRange i+    getRange (QuoteTerm i)           = getRange i+    getRange (Unquote i)             = getRange i+    getRange (DontCare{})            = noRange+    getRange (PatternSyn x)          = getRange x+    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 (UnquoteData i _ _ j _ _) = getRange (i, j)+    getRange (UnfoldingDecl r _)       = r++instance HasRange (Pattern' e) where+    getRange (VarP x)            = getRange x+    getRange (ConP i _ _)        = getRange i+    getRange (ProjP i _ _)       = getRange i+    getRange (DefP i _ _)        = getRange i+    getRange (WildP i)           = getRange i+    getRange (AsP i _ _)         = getRange i+    getRange (DotP i _)          = getRange i+    getRange (AbsurdP i)         = getRange i+    getRange (LitP i l)          = getRange i+    getRange (PatternSynP i _ _) = getRange i+    getRange (RecP _kwr i _)     = getRange i+    getRange (EqualP i _)        = getRange i+    getRange (WithP i _)         = getRange i++instance HasRange SpineLHS where+    getRange (SpineLHS i _ _)  = getRange i++instance HasRange LHS where+    getRange (LHS i _)   = getRange i++instance HasRange (LHSCore' e) where+    getRange (LHSHead f ps)         = fuseRange f ps+    getRange (LHSProj d lhscore ps) = d `fuseRange` lhscore `fuseRange` ps+    getRange (LHSWith h wps ps)     = h `fuseRange` wps `fuseRange` ps++instance HasRange a => HasRange (Clause' a) where+    getRange (Clause lhs _ rhs ds catchall) = getRange (lhs, rhs, ds)++instance HasRange RHS where+    getRange AbsurdRHS                 = noRange+    getRange (RHS e _)                 = getRange e+    getRange (WithRHS _ e cs)          = fuseRange e cs+    getRange (RewriteRHS xes _ rhs wh) = getRange (xes, rhs, wh)++instance HasRange WhereDeclarations where+  getRange (WhereDecls _ _ ds) = getRange ds++instance HasRange LetBinding where+  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+    setRange r (VarP x)            = VarP (setRange r x)+    setRange r (ConP i ns as)       = ConP (setRange r i) ns as+    setRange r (ProjP _ o ns)       = ProjP (PatRange r) o ns+    setRange r (DefP _ ns as)       = DefP (PatRange r) ns as -- (setRange r n) as+    setRange r (WildP _)            = WildP (PatRange r)+    setRange r (AsP _ n p)          = AsP (PatRange r) (setRange r n) p+    setRange r (DotP _ e)           = DotP (PatRange r) e+    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 empty (setRange r i) as+    setRange r (EqualP _ es)        = EqualP (PatRange r) es+    setRange r (WithP i p)          = WithP (setRange r i) p+++instance KillRange a => KillRange (Binder' a) where+  killRange (Binder a o b) = killRangeN Binder a o b++instance KillRange LamBinding where+  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)++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) = killRangeN TBind r t xs e+  killRange (TLet r lbs)     = killRangeN TLet r lbs++instance KillRange Expr where+  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     ) = 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       ) = 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  ) = killRangeN SectionApp a b c+  killRange (RecordModuleInstance a) = killRangeN RecordModuleInstance a++instance KillRange ScopeCopyInfo where+  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)           = 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)  = killRangeN SpineLHS i a b++instance KillRange LHS where+  killRange (LHS i a)   = killRangeN LHS i a++instance KillRange e => KillRange (LHSCore' e) where+  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) = killRangeN Clause lhs spats rhs ds catchall++instance KillRange ProblemEq where+  killRange (ProblemEq p v a) = killRangeN ProblemEq p v a++instance KillRange RHS where+  killRange AbsurdRHS                = AbsurdRHS+  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 c) = killRangeN WhereDecls a b c++instance KillRange LetBinding where+  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+instance NFData LetBinding+instance NFData a => NFData (Binder' a)+instance NFData LamBinding+instance NFData TypedBinding+instance NFData TypedBindingInfo+instance NFData GeneralizeTelescope+instance NFData DataDefParams+instance NFData ProblemEq+instance NFData lhs => NFData (Clause' lhs)+instance NFData WhereDeclarations+instance NFData RHS+instance NFData SpineLHS+instance NFData LHS+instance NFData e => NFData (LHSCore' e)+instance NFData e => NFData (Pattern' e)++------------------------------------------------------------------------+-- Queries+------------------------------------------------------------------------++-- class AllNames moved to Abstract.Views.DeclaredNames++-- | The name defined by the given axiom.+--+-- Precondition: The declaration has to be a (scoped) 'Axiom'.++axiomName :: Declaration -> QName+axiomName (Axiom _ _ _ _ q _)  = q+axiomName (ScopedDecl _ (d:_)) = axiomName d+axiomName _                    = __IMPOSSIBLE__++-- | Are we in an abstract block?+--+--   In that case some definition is abstract.+class AnyAbstract a where+  anyAbstract :: a -> Bool++instance AnyAbstract a => AnyAbstract [a] where+  anyAbstract = Fold.any anyAbstract++instance AnyAbstract Declaration where+  anyAbstract (Axiom _ i _ _ _ _)    = defAbstract i == AbstractDef+  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 (DataDef i _ _ _ _)    = defAbstract i == AbstractDef+  anyAbstract (RecDef i _ _ _ _ _ _) = defAbstract i == AbstractDef+  anyAbstract (DataSig i _ _ _ _)    = defAbstract i == AbstractDef+  anyAbstract (RecSig i _ _ _ _)     = defAbstract i == AbstractDef+  anyAbstract _                      = __IMPOSSIBLE__++-- | Turn a name into an expression.++class NameToExpr a where+  nameToExpr :: a -> Expr++-- | Turn an 'AbstractName' into an expression.++instance NameToExpr AbstractName where+  nameToExpr d =+    case anameKind d of+      DataName                 -> Def x+      RecName                  -> Def x+      AxiomName                -> Def x+      PrimName                 -> Def x+      FunName                  -> Def x+      OtherDefName             -> Def x+      GeneralizeName           -> Def x+      DisallowedGeneralizeName -> Def x+      FldName                  -> Proj ProjSystem ux+      ConName                  -> Con ux+      CoConName                -> Con ux+      PatternSynName           -> PatternSyn ux+      MacroName                -> Macro x+      QuotableName             -> App (defaultAppInfo r) (Quote i) (defaultNamedArg $ Def x)+    where+    x  = anameName d+    ux = unambiguous x+    r  = getRange x+    i  = ExprRange r++-- | Turn a 'ResolvedName' into an expression.+--+--   Assumes name is not 'UnknownName'.++instance NameToExpr ResolvedName where+  nameToExpr = \case+    VarName x _          -> Var x+    DefinedName _ x s    -> withSuffix s $ nameToExpr x  -- Can be 'isDefName', 'MacroName', 'QuotableName'.+    FieldName xs         -> Proj ProjSystem . AmbQ . fmap anameName $ xs+    ConstructorName _ xs -> Con . AmbQ . fmap anameName $ xs+    PatternSynResName xs -> PatternSyn . AmbQ . fmap anameName $ xs+    UnknownName          -> __IMPOSSIBLE__+    where+      withSuffix NoSuffix   e       = e+      withSuffix s@Suffix{} (Def x) = Def' x s+      withSuffix _          _       = __IMPOSSIBLE__++app :: Expr -> [NamedArg Expr] -> Expr+app = foldl (App defaultAppInfo_)++mkLet :: ExprInfo -> [LetBinding] -> Expr -> Expr+mkLet _ []     e = e+mkLet i (d:ds) e = Let i (d :| ds) e++type PatternSynDefn = ([WithHiding Name], Pattern' Void)+type PatternSynDefns = Map QName PatternSynDefn++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+  substExpr :: [(Name, Expr)] -> a -> a++  default substExpr+    :: (Functor t, SubstExpr b, t b ~ a)+    => [(Name, Expr)] -> a -> a+  substExpr = fmap . substExpr++instance SubstExpr a => SubstExpr (Maybe a)+instance SubstExpr a => SubstExpr [a]+instance SubstExpr a => SubstExpr (List1 a)+instance SubstExpr a => SubstExpr (Arg a)+instance SubstExpr a => SubstExpr (Named name a)+instance SubstExpr a => SubstExpr (FieldAssignment' a)++instance (SubstExpr a, SubstExpr b) => SubstExpr (a, b) where+  substExpr s (x, y) = (substExpr s x, substExpr s y)++instance (SubstExpr a, SubstExpr b) => SubstExpr (Either a b) where+  substExpr s (Left x)  = Left (substExpr s x)+  substExpr s (Right y) = Right (substExpr s y)++instance SubstExpr C.Name where+  substExpr _ = id++instance SubstExpr ModuleName where+  substExpr _ = id++instance SubstExpr Expr where+  substExpr s e = case e of+    Var n           -> fromMaybe e (lookup n s)+    Con _           -> e+    Proj{}          -> e+    Def' _ _        -> e+    PatternSyn{}    -> e+    Lit _ _         -> e+    Underscore   _  -> e+    App  i e e'     -> App i (substExpr s e) (substExpr s e')+    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__+    Dot{}           -> __IMPOSSIBLE__+    WithApp{}       -> __IMPOSSIBLE__+    Lam{}           -> __IMPOSSIBLE__+    AbsurdLam{}     -> __IMPOSSIBLE__+    ExtendedLam{}   -> __IMPOSSIBLE__+    Pi{}            -> __IMPOSSIBLE__+    Generalized{}   -> __IMPOSSIBLE__+    Fun{}           -> __IMPOSSIBLE__+    Let{}           -> __IMPOSSIBLE__+    RecUpdate{}     -> __IMPOSSIBLE__+    Quote{}         -> __IMPOSSIBLE__+    QuoteTerm{}     -> __IMPOSSIBLE__+    Unquote{}       -> __IMPOSSIBLE__+    DontCare{}      -> __IMPOSSIBLE__+    Macro{}         -> __IMPOSSIBLE__++-- TODO: more informative failure+insertImplicitPatSynArgs :: forall a. HasRange a+  => (Hiding -> Range -> a)+       -- ^ Thing to insert (wildcard).+  -> Range+       -- ^ Range of the whole pattern synonym expression/pattern.+  -> [WithHiding Name]+       -- ^ The parameters of the pattern synonym (from its definition).+  -> [NamedArg a]+       -- ^ 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'))+      | not (null as)+      , matchNext n a  = return (namedArg a, as')+      | visible n      = Nothing+      | otherwise      = return (wild (getHiding n) r, as)++    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 $ 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 ((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/Copatterns.hs 
@@ -1,410 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where--import Prelude hiding (mapM)--import Control.Applicative-import Control.Monad hiding (mapM)-import Control.Monad.Writer hiding (mapM)--import Data.Function-import Data.List--import Data.Traversable as T--import Agda.Syntax.Abstract-import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Concrete (FieldAssignment'(..))-import Agda.Syntax.Info-import Agda.Syntax.Position-import Agda.Syntax.Scope.Monad--import Agda.TypeChecking.Monad.Base (TypeError(..), typeError)-import Agda.Utils.Either-import Agda.Utils.Maybe-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible--{- Andreas 2012-04-07, 2012-05-08--   Translating copatterns into record expressions--This is a preliminary solution until we have proper copattern type-checking and evaluation.--Example 1:--  record Stream (A : Set) : Set where-    field-      head : A-      tail : Stream A-  open Stream--  alternate : Stream Nat-  (      head alternate ) = zero-  (head (tail alternate)) = suc zero-  (tail (tail alternate)) = alternate--with pathes--  Path [head]      zero-  Path [tail,head] (suc zero)-  Path [tail,tail] alternate--is translated into--  alternate = record-    { head = zero-    ; tail = record-      { head = suc zero-      ; tail = alternate-      }-    }--Example 2:--  record State (S A : Set) : Set where-    constructor state-    field-      runState : S → A × S-  open State--  record Monad (M : Set → Set) : Set1 where-    constructor monad-    field-      return : {A : Set}   → A → M A-      _>>=_  : {A B : Set} → M A → (A → M B) → M B-  open Monad--  stateMonad : {S : Set} → Monad (State S)-  runState (return stateMonad a  ) s  = a , s-  runState (_>>=_  stateMonad m k) s₀ =-    let as₁ = runState m s₀-    in  runState (k (proj₁ as₁)) (proj₂ as₁)--with pathes--  Path [(return,[a]  ), (runstate,[s ])] (a,s)-  Path [(_>>=_, [m,k]), (runstate,[s₀])] (let...)--is translated to--  stateMonad = record-    { return = λ a → record { runState = λ s → a , s }-    ; _>>=_  = λ m k → record { runState = λ s₀ →-        let as₁ = runState m s₀-        in  runState (k (proj₁ as₁)) (proj₂ as₁)-    }--Example 3:--  swap3 : {A B C X : Set} → (X → A) × ((X → B) × C) → (X → C) × (X → (B × A))-  fst (swap3 t) x       = snd (snd t)-  fst (snd (swap3 t) y) = fst (snd t) y-  snd (snd (swap3 t) z) = fst t z--with pathes--  Path [(fst,[x])]            (snd (snd t))-  Path [(snd,[y]), (fst,[])]  (fst (snd t) y)-  Path [(snd,[z]), (snd,[])]  (fst t z)--ist translated to--  swap3 t = record-    { fst = λ x → snd (snd t)-    ; snd = λ y → record-      { fst = fst (snd t) y-      ; snd = (fst t z){z := y}-      }-    }--How to translate:-- group clauses into those with same LHSCore and same withpatterns---}--translateCopatternClauses :: [Clause] -> ScopeM (Delayed, [Clause])-translateCopatternClauses cs = if all noCopats cs then return (NotDelayed, cs) else (Delayed,) <$> do-  pcs :: [ProjPath Clause] <- mapM clauseToPath cs-  let cps :: [(Clause, [ProjPath Expr])]-      cps = groupClauses pcs-  ces <- mapM (mapSndM pathToRecord) $-    map (mapSnd $ sortBy (compare `on` thePath)) cps-  return $ map (\ (c, e) -> c { clauseRHS = RHS e Nothing }) ces  -- TODO: preserve C.Expr-  where-    noCopats Clause{ clauseLHS = LHS _ LHSHead{} _ } = True-    noCopats _                                       = False---- | A sequence of decisions @b@ leading to a head @a@.-data Path a b = Path-  { thePath    :: [a] -- ^ the list of choices-  , theContent :: b-  } deriving (Functor)  -- NB: this means @Path a@ is a functor for any @a@--mapContent :: (b -> c) -> Path a b -> Path a c-mapContent f (Path p c) = Path p (f c)--data ProjEntry = ProjEntry-  { projPE :: AmbiguousQName-  , patsPE :: [NamedArg Name] -- ^ currently we only support variable patterns-  } deriving (Eq, Ord)--type ProjPath = Path ProjEntry--instance HasRange ProjEntry where-  getRange (ProjEntry p ps) = getRange (p,ps)---- | This is a n^2 grouping algorithm which uses only alpha-equality-groupClauses :: [ProjPath Clause] -> [(Clause, [ProjPath Expr])]-groupClauses [] = []-groupClauses (pc@(Path p c) : pcs) = (c, Path p (rhs c) : grp) : groupClauses rest-  where-    (grp, rest) = collect pcs-    -- Collect l splits l into pc's group and the remainder-    -- If the lhs of the next clause is alpha-equivalent to the current lhs-    -- then add the next clause to this group, performing the alpha-conversion-    collect (Path p' c' : pcs) | Just rho <- alpha (clauseLHS c') (clauseLHS c) =-      mapFst (Path p' (rename' rho (rhs c')) :) $ collect pcs-    -- we go through all the clauses, since they could be in random order...-    collect (pc : pcs) = mapSnd (pc :) $ collect pcs-    collect []         = ([], [])--    rhs             = rhsExpr . clauseRHS-    rhsExpr (RHS e _ ) = e  -- TODO: preserve C.Expr-    rhsExpr _       = __IMPOSSIBLE__--clauseToPath :: Clause -> ScopeM (ProjPath Clause)-clauseToPath (Clause (LHS i lhs wps) dots (RHS e c) [] catchall) =-  fmap (\ lhs -> Clause (LHS i lhs wps) dots (RHS e c) [] catchall) <$> lhsToPath [] lhs-clauseToPath (Clause lhs _ (RHS e _) (_:_) _) = typeError $ NotImplemented $ "copattern clauses with where declarations"-clauseToPath (Clause lhs _ _ wheredecls _) = typeError $ NotImplemented $ "copattern clauses with absurd, with or rewrite right hand side"--lhsToPath :: [ProjEntry] -> LHSCore -> ScopeM (ProjPath LHSCore)-lhsToPath acc lhs@LHSHead{}         = return $ Path acc lhs-lhsToPath acc (LHSProj f lhs ps) = do-    let xs = fromMaybe __IMPOSSIBLE__ $ mapM (T.mapM (T.mapM fromVarP)) ps-    lhsToPath (ProjEntry f xs : acc) $ namedArg lhs-  where fromVarP :: Pattern -> Maybe Name-        fromVarP (VarP n) = Just n-        fromVarP _        = Nothing---- | Expects a sorted list.-pathToRecord :: [ProjPath Expr] -> ScopeM Expr-pathToRecord []          = __IMPOSSIBLE__-pathToRecord [Path [] e] = return e-pathToRecord pps =-  case pathHeads pps of-    Nothing  -> typeError $ GenericError $ "overlapping copattern clauses"-    Just pps -> do-      pes <- mapM (mapSndM pathToRecord) $ groupPathes pps-      let ei = ExprRange $ getRange $ map fst pes-      Rec ei <$> mapM abstractions pes--        where-          abstractions :: (ProjEntry, Expr) -> ScopeM RecordAssign-          abstractions (ProjEntry (AmbQ []) xs, e) = __IMPOSSIBLE__-          abstractions (ProjEntry (AmbQ (p:_)) xs, e) = Left . FieldAssignment (C.unqualify $ qnameToConcrete p) <$>-            foldr abstract (return e) xs--          abstract :: NamedArg Name -> ScopeM Expr -> ScopeM Expr-          abstract (Arg info (Named Nothing x)) me =-            Lam (ExprRange noRange) (DomainFree info x) <$> me-          abstract (Arg _ (Named Just{} _)) me = typeError $ NotImplemented $-            "named arguments in projection patterns"---- | Similar to 'groupClauses'.-groupPathes :: [(ProjEntry, ProjPath Expr)] -> [(ProjEntry, [ProjPath Expr])]-groupPathes [] = []-groupPathes ((pe@(ProjEntry p xs), path) : pps) = (pe, path : grp) : groupPathes rest-  -- Now group all following pps that have the same projection p-  -- We expect that they have alpha-equivalent xs-  where-    (grp, rest) = collect pps-    collect l@((ProjEntry p' xs', path) : pps) | p == p', Just rho <- alpha xs' xs =-      -- add the alpha-converted path to the group-      -- NOTE: because the path contains only projections and pattern vars-      -- we only alpha-convert the content (rhs Expr)-      -- When the path will contain dot patterns, we have to rename in them-      mapFst (mapContent (rename' rho) path :) $ collect pps-    collect l = ([], l) -- null or different projection: close group--pathHeads :: [Path a b] -> Maybe [(a, Path a b)]-pathHeads = mapM pathSplit--pathSplit :: Path a b -> Maybe (a, Path a b)-pathSplit (Path []     b) = Nothing-pathSplit (Path (a:as) b) = Just (a, Path as b)----- * Alpha conversion--type NameMap = [(Name,Name)]--class Rename e where-  rename :: (Name -> Maybe Name) -> e -> e-  rename' :: NameMap -> e -> e-  rename' rho = rename (flip lookup rho)---- | 'QName's are not renamed.-instance Rename QName where-  rename _ q = q--instance Rename Name where-  rename rho x = fromMaybe x (rho x)--instance Rename Expr where-  rename rho e =-    case e of-      Var x                 -> Var (rename rho x)-      Def f                 -> e-      Proj{}                -> e-      Con c                 -> e-      Lit l                 -> e-      QuestionMark{}        -> e-      Underscore i          -> e-      Dot i e               -> Dot i (rename rho e)-      App i e es            -> App i (rename rho e) (rename rho es)-      WithApp i e es        -> WithApp i (rename rho e) (rename rho es)-      Lam i lb e            -> Lam i (rename rho lb) (rename rho e)-      AbsurdLam{}           -> e-      ExtendedLam i i' n cs -> ExtendedLam i i' n (rename rho cs)-      Pi i tel e            -> Pi i (rename rho tel) (rename rho e)-      Fun i a e             -> Fun i (rename rho a) (rename rho e)-      Set{}                 -> e-      Prop{}                -> e-      Let i bs e            -> Let i (rename rho bs) (rename rho e)-      ETel tel              -> ETel (rename rho tel)-      Rec i fes             -> Rec i $ rename rho fes-      RecUpdate i e fes     -> RecUpdate i (rename rho e) (rename rho fes)-      ScopedExpr i e        -> ScopedExpr i (rename rho e)-      QuoteGoal i n e       -> QuoteGoal i n (rename rho e)-      QuoteContext i        -> e-      Quote i               -> e-      QuoteTerm i           -> e-      Unquote i             -> e-      Tactic i e xs ys      -> Tactic i (rename rho e) (rename rho xs) (rename rho ys)-      DontCare e            -> DontCare (rename rho e)-      PatternSyn{}          -> e-      Macro{}               -> e--instance Rename ModuleName where-  rename rho x = x--instance Rename a => Rename (FieldAssignment' a) where-  rename rho = fmap (rename rho)--instance Rename LetBinding where-  rename rho e =-      case e of-        LetBind i r n e e'    -> LetBind i r n (rename rho e) (rename rho e')-        LetPatBind i p e      -> LetPatBind i (rename rho p) (rename rho e)-        LetApply{}            -> e-        LetOpen{}             -> e-        LetDeclaredVariable x -> LetDeclaredVariable (rename rho x)--instance Rename LamBinding where-  rename rho e =-      case e of-        DomainFree{} -> e-        DomainFull tb -> DomainFull (rename rho tb)--instance Rename TypedBindings where-  rename rho (TypedBindings r tb) = TypedBindings r (rename rho tb)--instance Rename TypedBinding where-  rename rho (TBind r ns e) = TBind r ns (rename rho e)-  rename rho (TLet r lbs)   = TLet r (rename rho lbs)--instance Rename Clause where-  rename rho (Clause lhs dots rhs wheredecls catchall) =-    Clause (rename rho lhs) (rename rho dots) (rename rho rhs) (rename rho wheredecls) catchall--instance Rename NamedDotPattern where-  rename rho (NamedDot x v t) = NamedDot (rename rho x) v t--instance Rename RHS where-  rename rho e = case e of-      RHS e c               -> RHS (rename rho e) c-      AbsurdRHS             -> e-      WithRHS n es cs       -> WithRHS n (rename rho es) (rename rho cs)-      RewriteRHS nes r ds   -> RewriteRHS (rename rho nes) (rename rho r) (rename rho ds)--instance Rename LHS where-  rename rho (LHS i core ps) = LHS i (rename rho core) (rename rho ps)--instance Rename LHSCore where-  rename rho = fmap (rename rho) -- only rename in dot patterns--instance Rename Pattern where-  rename rho = fmap (rename rho) -- only rename in dot patterns--instance Rename Declaration where-  rename rho d = __IMPOSSIBLE__--instance Rename a => Rename (Arg a) where-  rename rho = fmap (rename rho)--instance Rename a => Rename (Named n a) where-  rename rho = fmap (rename rho)--instance Rename a => Rename [a] where-  rename rho = map (rename rho)--instance (Rename a, Rename b) => Rename (Either a b) where-  rename rho = mapEither (rename rho) (rename rho)--instance (Rename a, Rename b) => Rename (a, b) where-  rename rho (a,b) = (rename rho a, rename rho b)----- | Alpha-Equivalence of patterns, ignoring dot patterns-class Alpha t where-  alpha :: t -> t -> Maybe NameMap-  alpha t t' = fmap snd $ runWriterT $ alpha' t t'--  alpha' :: t -> t -> WriterT NameMap Maybe ()-  alpha' t t' = WriterT $ fmap ((),) $ alpha t t'--instance Alpha Name where-  alpha' x x' = tell1 (x, x')--instance Alpha (Pattern' e) where-  alpha' p p' =-    case (p,p') of-      ((VarP x)             , (VarP x')             ) -> tell1 (x, x')-      ((ConP _ x ps)        , (ConP _ x' ps')       ) -> guard (x == x') >> alpha' ps ps'-      ((DefP _ x ps)        , (DefP _ x' ps')       ) -> guard (x == x') >> alpha' ps ps'-      ((WildP _)            , (WildP _)             ) -> return ()-      ((AsP _ x p)          , (AsP _ x' p')         ) -> tell1 (x, x') >> alpha' p p'-      ((DotP _ _ _)         , (DotP _ _ _)          ) -> return ()-      (AbsurdP{}            , AbsurdP{}             ) -> return ()-      ((LitP l)             , (LitP l')             ) -> guard (l == l')-      ((PatternSynP _ x ps) , (PatternSynP _ x' ps')) -> guard (x == x') >> alpha' ps ps'-      (_                    , _                     ) -> fail "not alpha equivalent"--tell1 :: (MonadWriter [a] m) => a -> m ()-tell1 a = tell [a]--instance Alpha (LHSCore' e) where-  alpha' (LHSHead f ps) (LHSHead f' ps') = guard (f == f') >> alpha' ps ps'-  alpha' (LHSProj d lhs ps) (LHSProj d' lhs' ps') =-     guard (d == d') >> alpha' lhs lhs' >> alpha' ps ps'-  alpha' _ _ = fail "not alpha equivalent"--instance Alpha LHS where-  alpha' (LHS _ core wps) (LHS _ core' wps') = alpha' core core' >> alpha' wps wps'--instance Alpha a => Alpha (Arg a) where-  alpha' a a' = alpha' (unArg a) (unArg a')--instance (Eq n, Alpha a) => Alpha (Named n a) where-  alpha' a a' = guard (nameOf a == nameOf a') >> alpha' (namedThing a) (namedThing a')--instance Alpha a => Alpha [a] where-  alpha' l l' = guard (length l == length l') >> zipWithM_ alpha' l l'
src/full/Agda/Syntax/Abstract/Name.hs view
@@ -1,49 +1,57 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| Abstract names carry unique identifiers and stuff. -} module Agda.Syntax.Abstract.Name   ( module Agda.Syntax.Abstract.Name   , IsNoName(..)+  , FreshNameMode(..)   ) where +import Prelude hiding (length, null)+ import Control.DeepSeq -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.Typeable (Typeable)-import Data.List-import Data.Function-import Data.Hashable+import Data.Foldable (length)+import Data.Function (on)+import Data.Hashable (Hashable(..))+import qualified Data.List as List+import Data.Maybe+import Data.Void  import Agda.Syntax.Position import Agda.Syntax.Common-import {-# SOURCE #-} Agda.Syntax.Fixity-import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..))+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..), NameInScope(..), LensInScope(..), FreshNameMode(..)) import qualified Agda.Syntax.Concrete.Name as C -import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Utils.Functor+import Agda.Utils.Lens+import qualified Agda.Utils.List as L+import Agda.Utils.List1 (List1, pattern (:|), (<|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null import Agda.Utils.Size-import Agda.Utils.Suffix -#include "undefined.h" import Agda.Utils.Impossible  -- | A name is a unique identifier and a suggestion for a concrete name. The --   concrete name contains the source location (if any) of the name. The --   source location of the binding site is also recorded.-data Name = Name { nameId          :: !NameId-                 , nameConcrete    :: C.Name-                 , nameBindingSite :: Range-                 , nameFixity      :: Fixity'-                 }-    deriving (Typeable)+data Name = Name+  { nameId           :: !NameId+  , nameConcrete     :: C.Name  -- ^ The concrete name used for this instance+  , nameCanonical    :: C.Name  -- ^ The concrete name in the original definition (needed by primShowQName, see #4735)+  , nameBindingSite  :: Range+  , nameFixity       :: Fixity'+  , nameIsRecordName :: Bool+      -- ^ Is this the name of the invisible record variable `self`?+      --   Should not be printed or displayed in the context, see issue #3584.+  } +-- | Useful for debugging scoping problems+uglyShowName :: Name -> String+uglyShowName x = show (nameId x, nameConcrete x)+ -- | Qualified names are non-empty lists of names. Equality on qualified names --   are just equality on the last name, i.e. the module part is just --   for show.@@ -53,43 +61,77 @@ data QName = QName { qnameModule :: ModuleName                    , qnameName   :: Name                    }-    deriving (Typeable)  -- | Something preceeded by a qualified name. data QNamed a = QNamed   { qname  :: QName   , qnamed :: a   }-  deriving (Typeable, Functor, Foldable, Traversable)+  deriving (Functor, Foldable, Traversable)  -- | A module name is just a qualified name. -- -- The 'SetRange' instance for module names sets all individual ranges -- to the given one. newtype ModuleName = MName { mnameToList :: [Name] }-  deriving (Eq, Ord, Typeable)+  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 :: [QName] }-  deriving (Eq, Ord, Typeable)+newtype AmbiguousQName = AmbQ { unAmbQ :: List1 QName }+  deriving (Eq, Ord, NFData) +-- | A singleton "ambiguous" name.+unambiguous :: QName -> AmbiguousQName+unambiguous x = AmbQ (x :| [])++-- | Get the first of the ambiguous names.+headAmbQ :: AmbiguousQName -> QName+headAmbQ (AmbQ xs) = List1.head xs++-- | Is a name ambiguous.+isAmbiguous :: AmbiguousQName -> Bool+isAmbiguous (AmbQ (_ :| xs)) = not (null xs)++-- | Get the name if unambiguous.+getUnambiguous :: AmbiguousQName -> Maybe QName+getUnambiguous (AmbQ (x :| [])) = Just x+getUnambiguous _                = Nothing++-- | A name suffix+data Suffix+  = NoSuffix+  | Suffix !Integer+  deriving (Show, Eq, Ord)++instance Null Suffix where+  empty = NoSuffix++instance NFData Suffix where+  rnf NoSuffix   = ()+  rnf (Suffix _) = ()+ -- | Check whether we are a projection pattern. class IsProjP a where   isProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)  instance IsProjP a => IsProjP (Arg a) where-  isProjP = isProjP . unArg+  isProjP p = case isProjP $ unArg p of+    Just (ProjPostfix , f)+     | getHiding p /= NotHidden -> Nothing+    x -> x  instance IsProjP a => IsProjP (Named n a) where   isProjP = isProjP . namedThing +instance IsProjP Void where+  isProjP _ = __IMPOSSIBLE__+ -- | A module is anonymous if the qualification path ends in an underscore. isAnonymousModuleName :: ModuleName -> Bool-isAnonymousModuleName (MName []) = False-isAnonymousModuleName (MName ms) = isNoName $ last ms+isAnonymousModuleName (MName mms) = maybe False isNoName $ L.lastMaybe mms  -- | Sets the ranges of the individual names in the module name to -- match those of the corresponding concrete names. If the concrete@@ -108,9 +150,9 @@ -- Precondition: The number of module name name parts has to be at -- least as large as the length of the list. -withRangesOf :: ModuleName -> [C.Name] -> ModuleName+withRangesOf :: ModuleName -> List1 C.Name -> ModuleName MName ms `withRangesOf` ns = if m < n then __IMPOSSIBLE__ else MName $-      zipWith setRange (replicate (m - n) noRange ++ map getRange ns) ms+      zipWith setRange (replicate (m - n) noRange ++ map getRange (List1.toList ns)) ms   where     m = length ms     n = length ns@@ -124,12 +166,18 @@ mnameFromList :: [Name] -> ModuleName mnameFromList = MName +mnameFromList1 :: List1 Name -> ModuleName+mnameFromList1 = MName . List1.toList++mnameToList1 :: ModuleName -> List1 Name+mnameToList1 (MName ns) = List1.ifNull ns __IMPOSSIBLE__ id+ noModuleName :: ModuleName noModuleName = mnameFromList []  commonParentModule :: ModuleName -> ModuleName -> ModuleName commonParentModule m1 m2 =-  mnameFromList $ commonPrefix (mnameToList m1) (mnameToList m2)+  mnameFromList $ L.commonPrefix (mnameToList m1) (mnameToList m2)  -- | Make a 'Name' from some kind of string. class MkName a where@@ -140,55 +188,49 @@   mkName_ = mkName noRange  instance MkName String where-  mkName r i s = Name i (C.Name noRange (C.stringNameParts s)) r noFixity'+  mkName r i s = makeName i (C.Name noRange InScope (C.stringNameParts s)) r noFixity' False +makeName :: NameId -> C.Name -> Range -> Fixity' -> Bool -> Name+makeName i c r f rec = Name i c c r f rec -qnameToList :: QName -> [Name]-qnameToList (QName m x) = mnameToList m ++ [x]+qnameToList0 :: QName -> [Name]+qnameToList0 = List1.toList . qnameToList -qnameFromList :: [Name] -> QName-qnameFromList [] = __IMPOSSIBLE__-qnameFromList xs = QName (mnameFromList $ init xs) (last xs)+qnameToList :: QName -> List1 Name+qnameToList (QName m x) = mnameToList m `List1.snoc` x +qnameFromList :: List1 Name -> QName+qnameFromList xs = QName (mnameFromList $ List1.init xs) (List1.last xs)+ qnameToMName :: QName -> ModuleName-qnameToMName = mnameFromList . qnameToList+qnameToMName = mnameFromList1 . qnameToList  mnameToQName :: ModuleName -> QName-mnameToQName = qnameFromList . mnameToList+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. qnameToConcrete :: QName -> C.QName-qnameToConcrete (QName m x) =-  foldr C.Qual (C.QName $ nameConcrete x) $ map nameConcrete $ mnameToList m+qnameToConcrete (QName m x) =       -- Use the canonical name here (#5048)+   foldr (C.Qual . nameConcrete) (C.QName $ nameCanonical x) (mnameToList m)  mnameToConcrete :: ModuleName -> C.QName mnameToConcrete (MName []) = __IMPOSSIBLE__ -- C.QName C.noName_  -- should never happen?-mnameToConcrete (MName xs) = foldr C.Qual (C.QName $ last cs) $ init cs+mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs   where-    cs = map nameConcrete 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) = C.TopLevelModuleName $ map (C.nameToRawName . nameConcrete) ms+    cs = fmap nameConcrete (x :| xs)  qualifyM :: ModuleName -> ModuleName -> ModuleName qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2  qualifyQ :: ModuleName -> QName -> QName-qualifyQ m x = qnameFromList $ mnameToList m ++ qnameToList x+qualifyQ m x = qnameFromList $ mnameToList m `List1.prependList` qnameToList x  qualify :: ModuleName -> Name -> QName qualify = QName@@ -200,31 +242,36 @@ -- | Is the name an operator?  isOperator :: QName -> Bool-isOperator q = C.isOperator (nameConcrete (qnameName q))+isOperator = C.isOperator . nameConcrete . qnameName -isSubModuleOf :: ModuleName -> ModuleName -> Bool-isSubModuleOf x y = xs /= ys && isPrefixOf ys xs-  where-    xs = mnameToList x-    ys = mnameToList y+-- | Is the first module a weak parent of the second?+isLeParentModuleOf :: ModuleName -> ModuleName -> Bool+isLeParentModuleOf = List.isPrefixOf `on` mnameToList +-- | Is the first module a proper parent of the second?+isLtParentModuleOf :: ModuleName -> ModuleName -> Bool+isLtParentModuleOf x y =+  isJust $ (L.stripPrefixBy (==) `on` mnameToList) x y++-- | Is the first module a weak child of the second?+isLeChildModuleOf :: ModuleName -> ModuleName -> Bool+isLeChildModuleOf = flip isLeParentModuleOf++-- | Is the first module a proper child of the second?+isLtChildModuleOf :: ModuleName -> ModuleName -> Bool+isLtChildModuleOf = flip isLtParentModuleOf+ isInModule :: QName -> ModuleName -> Bool-isInModule q m = mnameToList m `isPrefixOf` qnameToList q+isInModule q m = mnameToList m `List.isPrefixOf` qnameToList0 q  -- | Get the next version of the concrete name. For instance, @nextName "x" = "x₁"@. --   The name must not be a 'NoName'.-nextName :: Name -> Name-nextName x = x { nameConcrete = C.Name noRange $ nextSuf ps }-    where-        C.Name _ ps = nameConcrete x-        -- NoName cannot appear here-        nextSuf [C.Id s]         = [C.Id $ nextStr s]-        nextSuf [C.Id s, C.Hole] = [C.Id $ nextStr s, C.Hole]-        nextSuf (p : ps)         = p : nextSuf ps-        nextSuf []               = __IMPOSSIBLE__-        nextStr s = case suffixView s of-            (s0, suf) -> addSuffix s0 (nextSuffix suf)+nextName :: C.FreshNameMode -> Name -> Name+nextName freshNameMode x = x { nameConcrete = C.nextName freshNameMode (nameConcrete x) } +sameRoot :: Name -> Name -> Bool+sameRoot = C.sameRoot `on` nameConcrete+ ------------------------------------------------------------------------ -- * Important instances: Eq, Ord, Hashable --@@ -259,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 @@ -267,36 +317,64 @@  -- | We can have an instance for ambiguous names as all share a common concrete name. instance NumHoles AmbiguousQName where-  numHoles (AmbQ qs) = numHoles $ fromMaybe __IMPOSSIBLE__ $ headMaybe qs+  numHoles = numHoles . headAmbQ  --------------------------------------------------------------------------- * Show instances+-- * name lenses ------------------------------------------------------------------------ --- deriving instance Show Name--- deriving instance Show ModuleName--- deriving instance Show QName+lensQNameName :: Lens' QName Name+lensQNameName f (QName m n) = QName m <$> f n++------------------------------------------------------------------------+-- * LensFixity' instances+------------------------------------------------------------------------++instance LensFixity' Name where+  lensFixity' f n = f (nameFixity n) <&> \ fix' -> n { nameFixity = fix' }++instance LensFixity' QName where+  lensFixity' = lensQNameName . lensFixity'++------------------------------------------------------------------------+-- * LensFixity instances+------------------------------------------------------------------------++instance LensFixity Name where+  lensFixity = lensFixity' . lensFixity++instance LensFixity QName where+  lensFixity = lensFixity' . lensFixity++------------------------------------------------------------------------+-- * LensInScope instances+------------------------------------------------------------------------++instance LensInScope Name where+  lensInScope f n@Name{ nameConcrete = x } =+    (\y -> n { nameConcrete = y }) <$> lensInScope f x++instance LensInScope QName where+  lensInScope f q@QName{ qnameName = n } =+    (\n' -> q { qnameName = n' }) <$> lensInScope f n++------------------------------------------------------------------------+-- * Show instances (only for debug printing!)+--+-- | Use 'prettyShow' to print names to the user.+------------------------------------------------------------------------++deriving instance Show Name+deriving instance Show ModuleName+deriving instance Show QName deriving instance Show a => Show (QNamed a) deriving instance Show AmbiguousQName --- | Only use this @show@ function in debugging!  To convert an---   abstract 'Name' into a string use @prettyShow@.-instance Show Name where-  -- Andreas, 2014-10-02: Reverted to nice printing.-  -- Reason: I do not have time just now to properly fix the-  -- use of Show Name for pretty printing everywhere, e.g. in-  -- the Epic backend.  But I want to push the fix for Issue 836 now.-  show = prettyShow---- | Only use this @show@ function in debugging!  To convert an---   abstract 'ModuleName' into a string use @prettyShow@.-instance Show ModuleName where-  show = prettyShow+nameToArgName :: Name -> ArgName+nameToArgName = stringToArgName . prettyShow --- | Only use this @show@ function in debugging!  To convert an---   abstract 'QName' into a string use @prettyShow@.-instance Show QName where-  show = prettyShow+namedArgName :: NamedArg Name -> ArgName+namedArgName x = fromMaybe (nameToArgName $ namedArg x) $ bareNameOf x  ------------------------------------------------------------------------ -- * Pretty instances@@ -306,16 +384,20 @@   pretty = pretty . nameConcrete  instance Pretty ModuleName where-  pretty = hcat . punctuate (text ".") . map pretty . mnameToList+  pretty = hcat . punctuate "." . map pretty . mnameToList  instance Pretty QName where-  pretty = hcat . punctuate (text ".") . map pretty . qnameToList+  pretty = hcat . punctuate "." . map pretty . qnameToList0 . useCanonical+    where+      -- #4735: When printing a fully qualified name (as done by primShowQName) we need to+      -- use the origincal concrete name, not the possibly renamed concrete name in 'nameConcrete'.+      useCanonical q = q { qnameName = (qnameName q) { nameConcrete = nameCanonical (qnameName q) } }  instance Pretty AmbiguousQName where-  pretty (AmbQ qs) = hcat $ punctuate (text " | ") $ map pretty qs+  pretty (AmbQ qs) = hcat $ punctuate " | " $ map pretty $ List1.toList qs  instance Pretty a => Pretty (QNamed a) where-  pretty (QNamed a b) = pretty a <> text "." <> pretty b+  pretty (QNamed a b) = pretty a <> "." <> pretty b  ------------------------------------------------------------------------ -- * Range instances@@ -336,8 +418,7 @@ -- | The range of an @AmbiguousQName@ is the range of any of its --   disambiguations (they are the same concrete name). instance HasRange AmbiguousQName where-  getRange (AmbQ [])    = noRange-  getRange (AmbQ (c:_)) = getRange c+  getRange (AmbQ (c :| _)) = getRange c  -- ** SetRange @@ -350,27 +431,36 @@                    }  instance SetRange ModuleName where-  setRange r (MName ns) = MName (map (setRange r) ns)+  setRange r (MName ns) = MName (zipWith setRange rs ns)+    where+      -- Put the range only on the last name. Otherwise+      -- we get overlapping jump-to-definition links for all+      -- the parts (See #2666).+      rs = replicate (length ns - 1) noRange ++ [r]  -- ** KillRange  instance KillRange Name where-  killRange (Name a b c d) = killRange4 Name a b c d-  -- killRange x = x { nameConcrete = killRange $ nameConcrete x-  --                 -- Andreas, 2014-03-30-  --                 -- An experiment: what happens if we preserve-  --                 -- the range of the binding site, but kill all-  --                 -- other ranges before serialization?-  --                 -- Andreas, Makoto, 2014-10-18 AIM XX-  --                 -- Kill all ranges in signature, including nameBindingSite.-  --                 , nameBindingSite = noRange-  --                 }+  killRange (Name a b c d e f) =+    (killRangeN Name a b c d e f) { nameBindingSite = d }+    -- Andreas, 2017-07-25, issue #2649+    -- Preserve the nameBindingSite for error message.+    --+    -- Older remarks:+    --+    -- Andreas, 2014-03-30+    -- An experiment: what happens if we preserve+    -- the range of the binding site, but kill all+    -- other ranges before serialization?+    --+    -- Andreas, Makoto, 2014-10-18 AIM XX+    -- Kill all ranges in signature, including nameBindingSite.  instance KillRange ModuleName where   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   --                 }@@ -384,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@@ -395,10 +487,7 @@ -- | The range is not forced.  instance NFData Name where-  rnf (Name _ a _ b) = rnf a `seq` rnf b+  rnf (Name _ a b _ c d) = rnf (a, b, c, d)  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
@@ -0,0 +1,512 @@++-- | Auxiliary functions to handle patterns in the abstract syntax.+--+--   Generic and specific traversals.++module Agda.Syntax.Abstract.Pattern where++import Prelude hiding (null)++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+import Agda.Syntax.Concrete (FieldAssignment')+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Pattern (IsWithP(..))+import Agda.Syntax.Info+import Agda.Syntax.Position++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++-- * Generic traversals+------------------------------------------------------------------------++type NAP = NamedArg Pattern++class MapNamedArgPattern a  where+  mapNamedArgPattern :: (NAP -> NAP) -> a -> a++  default mapNamedArgPattern+     :: (Functor f, MapNamedArgPattern a', a ~ f a') => (NAP -> NAP) -> a -> a+  mapNamedArgPattern = fmap . mapNamedArgPattern++instance MapNamedArgPattern NAP where+  mapNamedArgPattern f p =+    case namedArg p of+      -- no sub patterns:+      VarP{}    -> f p+      WildP{}   -> f p+      DotP{}    -> f p+      EqualP{}  -> f p+      LitP{}    -> f p+      AbsurdP{} -> f p+      ProjP{}   -> f p+      -- list of NamedArg subpatterns:+      ConP i qs ps       -> f $ setNamedArg p $ ConP i qs $ mapNamedArgPattern f ps+      DefP i qs ps       -> f $ setNamedArg p $ DefP i qs $ mapNamedArgPattern f ps+      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 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++instance MapNamedArgPattern a => MapNamedArgPattern [a]                  where+instance MapNamedArgPattern a => MapNamedArgPattern (FieldAssignment' a) where+instance MapNamedArgPattern a => MapNamedArgPattern (Maybe a)            where++instance (MapNamedArgPattern a, MapNamedArgPattern b) => MapNamedArgPattern (a,b) where+  mapNamedArgPattern f (a, b) = (mapNamedArgPattern f a, mapNamedArgPattern f b)++-- | Generic pattern traversal.++class APatternLike p where+  type ADotT p++  -- | Fold pattern.+  foldrAPattern+    :: Monoid m+    => (Pattern' (ADotT p) -> m -> m)+         -- ^ Combine a pattern and the value computed from its subpatterns.+    -> p -> m++  default foldrAPattern+    :: (Monoid m, Foldable f, APatternLike b, (ADotT p) ~ (ADotT b), f b ~ p)+    => (Pattern' (ADotT p) -> m -> m) -> p -> m+  foldrAPattern = foldMap . foldrAPattern++  -- | Traverse pattern.+  traverseAPatternM+    :: Monad m+    => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @pre@: Modification before recursion.+    -> (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @post@: Modification after recursion.+    -> p -> m p++  default traverseAPatternM+    :: (Traversable f, APatternLike q, (ADotT p) ~ (ADotT q), f q ~ p, Monad m)+    => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))+    -> (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))+    -> p -> m p+  traverseAPatternM pre post = traverse $ traverseAPatternM pre post++-- | Compute from each subpattern a value and collect them all in a monoid.++foldAPattern :: (APatternLike p, Monoid m) => (Pattern' (ADotT p) -> m) -> p -> m+foldAPattern f = foldrAPattern $ \ p m -> f p `mappend` m++-- | Traverse pattern(s) with a modification before the recursive descent.++preTraverseAPatternM+  :: (APatternLike p, Monad m )+  => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @pre@: Modification before recursion.+  -> p -> m p+preTraverseAPatternM pre p = traverseAPatternM pre return p++-- | Traverse pattern(s) with a modification after the recursive descent.++postTraverseAPatternM+  :: (APatternLike p, Monad m )+  => (Pattern' (ADotT p) -> m (Pattern' (ADotT p)))  -- ^ @post@: Modification after recursion.+  -> p -> m p+postTraverseAPatternM post p = traverseAPatternM return post p++-- | Map pattern(s) with a modification after the recursive descent.++mapAPattern :: APatternLike p => (Pattern' (ADotT p) -> Pattern' (ADotT p)) -> p -> p+mapAPattern f = runIdentity . postTraverseAPatternM (Identity . f)++-- Interesting instance:++instance APatternLike (Pattern' a) where+  type ADotT (Pattern' a) = a++  foldrAPattern f p = f p $+    case p of+      AsP _ _ p          -> foldrAPattern f p+      ConP _ _ ps        -> foldrAPattern f ps+      DefP _ _ ps        -> foldrAPattern f ps+      RecP _ _ ps        -> foldrAPattern f ps+      PatternSynP _ _ ps -> foldrAPattern f ps+      WithP _ p          -> foldrAPattern f p+      VarP _             -> mempty+      ProjP _ _ _        -> mempty+      WildP _            -> mempty+      DotP _ _           -> mempty+      AbsurdP _          -> mempty+      LitP _ _           -> mempty+      EqualP _ _         -> mempty++  traverseAPatternM pre post = pre >=> recurse >=> post+    where+    recurse = \case+      -- Non-recursive cases:+      p@A.VarP{}            -> return p+      p@A.WildP{}           -> return p+      p@A.DotP{}            -> return p+      p@A.LitP{}            -> return p+      p@A.AbsurdP{}         -> return p+      p@A.ProjP{}           -> return p+      p@A.EqualP{}          -> return p+      -- Recursive cases:+      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    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++instance APatternLike a => APatternLike (Arg a) where+  type ADotT (Arg a) = ADotT a++instance APatternLike a => APatternLike (Named n a) where+  type ADotT (Named n a) = ADotT a++instance APatternLike a => APatternLike [a] where+  type ADotT [a] = ADotT a++instance APatternLike a => APatternLike (Maybe a) where+  type ADotT (Maybe a) = ADotT a++instance APatternLike a => APatternLike (FieldAssignment' a) where+  type ADotT (FieldAssignment' a) = ADotT a++instance (APatternLike a, APatternLike b, ADotT a ~ ADotT b) => APatternLike (a, b) where+  type ADotT (a, b) = ADotT a++  foldrAPattern f (p, p') =+    foldrAPattern f p `mappend` foldrAPattern f p'++  traverseAPatternM pre post (p, p') =+    liftA2 (,)+      (traverseAPatternM pre post p)+      (traverseAPatternM pre post p')+++-- * Specific folds+------------------------------------------------------------------------++-- | Collect pattern variables in left-to-right textual order.++patternVars :: APatternLike p => p -> [A.Name]+patternVars p = foldAPattern f p `appEndo` []+  where+  -- We use difference lists @[A.Name] -> [A.Name]@ to avoid reconcatenation.+  f :: Pattern' a -> Endo [A.Name]+  f = \case+    A.VarP x         -> Endo (unBind x :)+    A.AsP _ x _      -> Endo (unBind x :)+    A.LitP        {} -> mempty+    A.ConP        {} -> mempty+    A.RecP        {} -> mempty+    A.DefP        {} -> mempty+    A.ProjP       {} -> mempty+    A.WildP       {} -> mempty+    A.DotP        {} -> mempty+    A.AbsurdP     {} -> mempty+    A.EqualP      {} -> mempty+    A.PatternSynP {} -> mempty+    A.WithP _ _      -> mempty++-- | Check if a pattern contains a specific (sub)pattern.++containsAPattern :: APatternLike p => (Pattern' (ADotT p) -> Bool) -> p -> Bool+containsAPattern f = getAny . foldAPattern (Any . f)++-- | Check if a pattern contains an absurd pattern.+--   For instance, @suc ()@, does so.+--+--   Precondition: contains no pattern synonyms.++containsAbsurdPattern :: APatternLike p => p -> Bool+containsAbsurdPattern = containsAPattern $ \case+    A.PatternSynP{} -> __IMPOSSIBLE__+    A.AbsurdP{}     -> True+    _               -> False++-- | Check if a pattern contains an @-pattern.+--+containsAsPattern :: APatternLike p => p -> Bool+containsAsPattern = containsAPattern $ \case+    A.AsP{}         -> True+    _               -> False++-- | 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 -> (List1 C.Name -> m ()) -> m ()+checkPatternLinearity =+  List1.unlessNull . duplicates . map nameConcrete . patternVars+++-- * Specific traversals+------------------------------------------------------------------------++-- | Pattern substitution.+--+-- For the embedded expression, the given pattern substitution is turned into+-- an expression substitution.++substPattern :: [(Name, Pattern)] -> Pattern -> Pattern+substPattern s = substPattern' (substExpr $ map (second patternToExpr) s) s++-- | Pattern substitution, parametrized by substitution function for embedded expressions.++substPattern'+  :: (e -> e)              -- ^ Substitution function for expressions.+  -> [(Name, Pattern' e)]  -- ^ (Parallel) substitution.+  -> Pattern' e            -- ^ Input pattern.+  -> Pattern' e+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 $ fmap (subE *** subE) es+  -- No action on the other patterns (besides the recursion):+  ConP _ _ _        -> p+  RecP _ _ _        -> p+  ProjP _ _ _       -> p+  WildP _           -> p+  AbsurdP _         -> p+  LitP _ _          -> p+  DefP _ _ _        -> p+  AsP _ _ _         -> p -- Note: cannot substitute into as-variable+  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+------------------------------------------------------------------------++-- | Check for with-pattern.+instance IsWithP (Pattern' e) where+  isWithP = \case+    WithP _ p -> Just p+    _ -> Nothing++-- | Split patterns into (patterns, trailing with-patterns).+splitOffTrailingWithPatterns :: A.Patterns -> (A.Patterns, A.Patterns)+splitOffTrailingWithPatterns = spanEnd (isJust . isWithP)++-- | Get the tail of with-patterns of a pattern spine.+trailingWithPatterns :: Patterns -> Patterns+trailingWithPatterns = snd . splitOffTrailingWithPatterns++-- | The next patterns are ...+--+-- (This view discards 'PatInfo'.)+data LHSPatternView e+  = LHSAppP  (NAPs1 e)+      -- ^ Application patterns (non-empty list).+  | LHSProjP ProjOrigin AmbiguousQName (NamedArg (Pattern' e))+      -- ^ A projection pattern.  Is also stored unmodified here.+  | LHSWithP (List1 (Pattern' e))+      -- ^ With patterns (non-empty list).+      --   These patterns are not prefixed with 'WithP'.+  deriving (Show)++-- | Construct the 'LHSPatternView' of the given list (if not empty).+--+-- Return the view and the remaining patterns.++lhsPatternView :: IsProjP e => NAPs e -> Maybe (LHSPatternView e, NAPs e)+lhsPatternView [] = Nothing+lhsPatternView (p0 : ps) =+  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)+      where+      (ps1, ps2) = spanJust isWithP ps+    -- If the next pattern is an application pattern, collect more of these+    _ -> Just (LHSAppP (p0 :| ps1), ps2)+      where+      (ps1, ps2) = span (\ p -> isNothing (isProjP p) && isNothing (isWithP p)) ps++-- * Left-hand-side manipulation+------------------------------------------------------------------------++-- | Convert a focused lhs to spine view and back.+class LHSToSpine a b where+  lhsToSpine :: a -> b+  spineToLhs :: b -> a++-- | Clause instance.+instance LHSToSpine Clause SpineClause where+  lhsToSpine = fmap lhsToSpine+  spineToLhs = fmap spineToLhs++-- | List instance (for clauses).+instance LHSToSpine a b => LHSToSpine [a] [b] where+  lhsToSpine = map lhsToSpine+  spineToLhs = map spineToLhs++-- | LHS instance.+instance LHSToSpine LHS SpineLHS where+  lhsToSpine (LHS i core) = SpineLHS i f ps+    where QNamed f ps = lhsCoreToSpine core+  spineToLhs (SpineLHS i f ps) = LHS i (spineToLhsCore $ QNamed f ps)++lhsCoreToSpine :: LHSCore' e -> A.QNamed [NamedArg (Pattern' e)]+lhsCoreToSpine = \case+  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 (List1.toList wps) ++ ps)+    where+      fromWithPat :: Arg (Pattern' e) -> NamedArg (Pattern' e)+      fromWithPat = fmap (unnamed . mkWithP)+      mkWithP p   = WithP (PatRange $ getRange p) p++spineToLhsCore :: IsProjP e => QNamed [NamedArg (Pattern' e)] -> LHSCore' e+spineToLhsCore (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps++-- | Add applicative patterns (non-projection / non-with patterns) to the right.+lhsCoreApp :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e+lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps }++-- | Add with-patterns to the right.+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 $ 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 (singleton np)      -- Postfix projection pattern.++-- | Add projection, with, and applicative patterns to the right.+lhsCoreAddSpine :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e+lhsCoreAddSpine core ps =+  -- Recurse on lhsPatternView until no patterns left.+  case lhsPatternView ps of+    Nothing       -> core+    Just (v, ps') -> lhsCoreAddChunk core chunk `lhsCoreAddSpine` ps'+      where+      -- Andreas, 2016-06-13+      -- If the projection was written prefix by the user+      -- or it is a fully applied operator+      -- we turn it to prefix projection form.+      chunk = case v of+        LHSProjP ProjPrefix _ _+          -> v+        LHSProjP _ d np | let nh = C.numHoles d, nh > 0, nh <= 1 + length ps'+          -> LHSProjP ProjPrefix d np+        _ -> v++-- | Used for checking pattern linearity.+lhsCoreAllPatterns :: LHSCore' e -> [Pattern' e]+lhsCoreAllPatterns = map namedArg . qnamed . lhsCoreToSpine++-- | Used in ''Agda.Syntax.Translation.AbstractToConcrete''.+--   Returns a 'DefP'.+lhsCoreToPattern :: LHSCore -> Pattern+lhsCoreToPattern lc =+  case lc of+    LHSHead f aps         -> DefP noInfo (unambiguous f) aps+    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 (List1.toList wps) ++ aps+        where+          fromWithPat :: Arg Pattern -> NamedArg Pattern+          fromWithPat = fmap (unnamed . mkWithP)+          mkWithP p   = WithP (PatRange $ getRange p) p+      _ -> __IMPOSSIBLE__+  where noInfo = empty -- TODO, preserve range!++mapLHSHead :: (QName -> [NamedArg Pattern] -> LHSCore) -> LHSCore -> LHSCore+mapLHSHead f = \case+  LHSHead x ps     -> f x ps+  LHSProj d h ps   -> LHSProj d (fmap (fmap (mapLHSHead f)) h) ps+  LHSWith h wps ps -> LHSWith (mapLHSHead f h) wps ps
+ src/full/Agda/Syntax/Abstract/PatternSynonyms.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Pattern synonym utilities: folding pattern synonym definitions for+--   printing and merging pattern synonym definitions to handle overloaded+--   pattern synonyms.+module Agda.Syntax.Abstract.PatternSynonyms+  ( matchPatternSyn+  , matchPatternSynP+  , mergePatternSynDefs+  ) where++import Control.Applicative  ( Alternative(empty) )+import Control.Monad        ( foldM, guard, zipWithM, zipWithM_ )+import Control.Monad.Writer ( MonadWriter(..), WriterT, execWriterT )++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Traversable (forM)+import Data.Void++import Agda.Syntax.Common+import Agda.Syntax.Abstract+import Agda.Syntax.Abstract.Views++import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1++-- | Merge a list of pattern synonym definitions. Fails unless all definitions+--   have the same shape (i.e. equal up to renaming of variables and constructor+--   names).+mergePatternSynDefs :: List1 PatternSynDefn -> Maybe PatternSynDefn+mergePatternSynDefs (def :| defs) = foldM mergeDef def defs++mergeDef :: PatternSynDefn -> PatternSynDefn -> Maybe PatternSynDefn+mergeDef (xs, p) (ys, q) = do+  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)+    merge ren p@(LitP _ l) (LitP _ l') = p <$ guard (l == l')+    merge ren p@(WildP _) (WildP _) = return p+    merge ren (ConP i (AmbQ cs) ps) (ConP _ (AmbQ cs') qs) = do+      guard $ map getArgInfo ps == map getArgInfo qs+      ConP i (AmbQ $ List1.union cs cs') <$> zipWithM (mergeArg ren) ps qs+    merge _ _ _ = empty++    mergeArg ren p q = setNamedArg p <$> merge ren (namedArg p) (namedArg q)++-- | Match an expression against a pattern synonym.+matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [WithHiding Expr]+matchPatternSyn = runMatch match+  where+    match (VarP x) e = unBind x ==> e+    match (LitP _ l) (Lit _ l') = guard (l == l')+    match (ConP _ (AmbQ cs) ps) e = do+      Application (Con (AmbQ cs')) args <- return (appView e)+      guard $ all (`elem` cs) cs'                       -- check all possible constructors appear in the synonym+      guard $ map getArgInfo ps == map getArgInfo args  -- check that we agree on the hiding (TODO: too strict?)+      zipWithM_ match (map namedArg ps) (map namedArg args)+    match _ _ = empty++-- | Match a pattern against a pattern synonym.+matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)]+matchPatternSynP = runMatch match+  where+    match (VarP x) q = unBind x ==> q+    match (LitP _ l) (LitP _ l') = guard (l == l')+    match (WildP _) (WildP _) = return ()+    match (ConP _ (AmbQ cs) ps) (ConP _ (AmbQ cs') qs) = do+      guard $ all (`elem` cs) cs'+      guard $ map getArgInfo ps == map getArgInfo qs+      zipWithM_ match (map namedArg ps) (map namedArg qs)+    match _ _ = empty++type Match e = WriterT (Map Name e) Maybe++(==>) :: Name -> e -> Match e ()+x ==> e = tell (Map.singleton x 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 (whThing x) sub
src/full/Agda/Syntax/Abstract/Pretty.hs view
@@ -1,29 +1,31 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Abstract.Pretty where -import Control.Applicative--import Agda.Syntax.Concrete.Pretty () import Agda.Syntax.Fixity import Agda.Syntax.Translation.AbstractToConcrete-import Agda.TypeChecking.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty -showA :: (Show c, ToConcrete a c) => a -> TCM String+showA :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String showA x = show <$> abstractToConcrete_ x -prettyA :: (Pretty c, ToConcrete a c) => a -> TCM Doc+prettyA :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc prettyA x = pretty <$> abstractToConcrete_ x -prettyAs :: (Pretty c, ToConcrete a [c]) => a -> TCM Doc+prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], Pretty ce, MonadAbsToCon m) => a -> m Doc prettyAs x = fsep . map pretty <$> abstractToConcrete_ x  -- | Variant of 'showA' which does not insert outermost parentheses. -showATop :: (Show c, ToConcrete a c) => a -> TCM String+showATop :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String showATop x = show <$> abstractToConcreteCtx TopCtx x  -- | Variant of 'prettyA' which does not insert outermost parentheses. -prettyATop :: (Pretty c, ToConcrete a c) => a -> TCM Doc+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
@@ -1,46 +1,56 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE NoMonoLocalBinds          #-}-{-# LANGUAGE NoMonomorphismRestriction #-}  module Agda.Syntax.Abstract.Views where -import Control.Applicative-import Control.Arrow (first)+import Prelude hiding (null)++import Control.Applicative ( Const(Const), getConst ) import Control.Monad.Identity  import Data.Foldable (foldMap)-import Data.Monoid-import Data.Traversable+import qualified Data.DList as DL+import Data.Semigroup ((<>)) import Data.Void -import Agda.Syntax.Position 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 (emptyScopeInfo)+import Agda.Syntax.Scope.Base (KindOfName(..), conKindOfName, WithKind(..))  import Agda.Utils.Either-import Agda.Utils.Lens+import Agda.Utils.List1 (List1)+import Agda.Utils.Null+import Agda.Utils.Singleton -data AppView = Application Expr [NamedArg Expr]+import Agda.Utils.Impossible ++data AppView' arg = Application Expr [NamedArg arg]+  deriving (Functor)++type AppView = AppView' Expr+ -- | Gather applications to expose head and spine. -- --   Note: everything is an application, possibly of itself to 0 arguments appView :: Expr -> AppView-appView e =-  case e of-    App _ e1 e2+appView = fmap snd . appView'++appView' :: Expr -> AppView' (AppInfo, Expr)+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'-                   -> Application f [defaultNamedArg e1]-    App i e1 arg-      | Application hd es <- appView e1-                   -> Application hd $ es ++ [arg]-    ScopedExpr _ e -> appView e-    _              -> Application e []+      , getHiding e2 == NotHidden -- Jesper, 2018-12-13: postfix projections shouldn't be hidden+      -> (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 =@@ -51,25 +61,39 @@  unAppView :: AppView -> Expr unAppView (Application h es) =-  foldl (App (ExprRange noRange)) h es+  foldl (App defaultAppInfo_) h es +-- | Collects plain lambdas.+data LamView = LamView [LamBinding] Expr++lamView :: Expr -> LamView+lamView (Lam i b e) = cons b $ lamView e+  where cons b (LamView bs e) = LamView (b : bs) e+lamView (ScopedExpr _ e) = lamView e+lamView e = LamView [] e++-- | 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) = first (x :) $ asView p-asView p             = ([], p)---- | Check whether we are dealing with a universe.-isSet :: Expr -> Bool-isSet (ScopedExpr _ e) = isSet e-isSet (App _ e _)      = isSet e-isSet (Set{})          = True-isSet _                = False+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-unScope (QuestionMark i ii)  = QuestionMark (i {metaScope = emptyScopeInfo}) ii-unScope (Underscore i)       = Underscore (i {metaScope = emptyScopeInfo})+unScope (QuestionMark i ii)  = QuestionMark (i {metaScope = empty}) ii+unScope (Underscore i)       = Underscore (i {metaScope = empty}) unScope e                    = e  -- | Remove 'ScopedExpr' wrappers everywhere.@@ -83,150 +107,156 @@ 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 ind eta c bs e ds) = [A.RecDef i x ind eta c (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+--------------------------------------------------------------------------- +-- Type aliases to abbreviate the quantified foralls which we use to avoid+-- giving in to NoMonoLocalBinds.+type RecurseExprFn m a = Applicative m => (Expr -> m Expr -> m Expr) -> a -> m a+type RecurseExprRecFn m = forall a. ExprLike a => a -> m a++type FoldExprFn m a = Monoid m => (Expr -> m) -> a -> m+type FoldExprRecFn m = forall a. ExprLike a => a -> m++type TraverseExprFn m a = (Applicative m, Monad m) => (Expr -> m Expr) -> a -> m a+type TraverseExprRecFn m = forall a. ExprLike a => a -> m a+ -- | Apply an expression rewriting to every subexpression, inside-out. --   See "Agda.Syntax.Internal.Generic". class ExprLike a where   -- | The first expression is pre-traversal, the second one post-traversal.-  recurseExpr :: (Applicative m) => (Expr -> m Expr -> m Expr) -> a -> m a+  recurseExpr :: RecurseExprFn m a   default recurseExpr :: (Traversable f, ExprLike a', a ~ f a', Applicative m)                       => (Expr -> m Expr -> m Expr) -> a -> m a   recurseExpr = traverse . recurseExpr -  foldExpr :: Monoid m => (Expr -> m) -> a -> m+  foldExpr :: FoldExprFn m a   foldExpr f = getConst . recurseExpr (\ pre post -> Const (f pre) <* post) -  traverseExpr-#if __GLASGOW_HASKELL__ <= 708-    :: (Applicative m, Monad m)-#else-    :: Monad m-#endif-    => (Expr -> m Expr) -> a -> m a+  traverseExpr :: TraverseExprFn m a   traverseExpr f = recurseExpr (\ pre post -> f =<< post)    mapExpr :: (Expr -> Expr) -> (a -> a)   mapExpr f = runIdentity . traverseExpr (Identity . f)  instance ExprLike Expr where+  recurseExpr :: forall m. RecurseExprFn m Expr   recurseExpr f e0 = f e0 $ do-    let recurse e = recurseExpr f e+    let+      recurse :: RecurseExprRecFn m+      recurse e = recurseExpr f e     case e0 of-      Var{}                   -> pure e0-      Def{}                   -> pure e0-      Proj{}                  -> pure e0-      Con{}                   -> pure e0-      Lit{}                   -> pure e0-      QuestionMark{}          -> pure e0-      Underscore{}            -> pure e0-      Dot ei e                -> Dot ei <$> recurse e-      App ei e arg            -> App ei <$> recurse e <*> recurse arg-      WithApp ei e es         -> WithApp ei <$> recurse e <*> recurse es-      Lam ei b e              -> Lam ei <$> recurse b <*> recurse e-      AbsurdLam{}             -> pure e0-      ExtendedLam ei di x cls -> ExtendedLam ei di x <$> recurse cls-      Pi ei tel e             -> Pi ei <$> recurse tel <*> recurse e-      Fun ei arg e            -> Fun ei <$> recurse arg <*> recurse e-      Set{}                   -> pure e0-      Prop{}                  -> pure e0-      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-      ScopedExpr sc e         -> ScopedExpr sc <$> recurse e-      QuoteGoal ei n e        -> QuoteGoal ei n <$> recurse e-      QuoteContext ei         -> pure e0-      Quote{}                 -> pure e0-      QuoteTerm{}             -> pure e0-      Unquote{}               -> pure e0-      DontCare e              -> DontCare <$> recurse e-      PatternSyn{}            -> pure e0-      Tactic ei e xs ys       -> Tactic ei <$> recurse e <*> recurse xs <*> recurse ys-      Macro{}                 -> pure e0+      Var{}                      -> pure e0+      Def'{}                     -> pure e0+      Proj{}                     -> pure e0+      Con{}                      -> pure e0+      Lit{}                      -> pure e0+      QuestionMark{}             -> pure e0+      Underscore{}               -> pure e0+      Dot ei e                   -> Dot ei <$> recurse e+      App ei e arg               -> App ei <$> recurse e <*> recurse arg+      WithApp ei e es            -> WithApp ei <$> recurse e <*> recurse es+      Lam ei b e                 -> Lam ei <$> recurse b <*> recurse e+      AbsurdLam{}                -> pure e0+      ExtendedLam ei di er x cls -> ExtendedLam ei di er x <$> recurse cls+      Pi ei tel e                -> Pi ei <$> recurse tel <*> recurse e+      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+      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+      Unquote{}                  -> pure e0+      DontCare e                 -> DontCare <$> recurse e+      PatternSyn{}               -> pure e0+      Macro{}                    -> pure e0 +  foldExpr :: forall m. FoldExprFn m Expr   foldExpr f e =     case e of-      Var{}                -> m-      Def{}                -> m-      Proj{}               -> m-      Con{}                -> m-      PatternSyn{}         -> m-      Macro{}              -> m-      Lit{}                -> m-      QuestionMark{}       -> m-      Underscore{}         -> m-      Dot _ e              -> m `mappend` fold e-      App _ e e'           -> m `mappend` fold e `mappend` fold e'-      WithApp _ e es       -> m `mappend` fold e `mappend` fold es-      Lam _ b e            -> m `mappend` fold b `mappend` fold e-      AbsurdLam{}          -> m-      ExtendedLam _ _ _ cs -> m `mappend` fold cs-      Pi _ tel e           -> m `mappend` fold tel `mappend` fold e-      Fun _ e e'           -> m `mappend` fold e `mappend` fold e'-      Set{}                -> m-      Prop{}               -> m-      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-      ScopedExpr _ e       -> m `mappend` fold e-      QuoteGoal _ _ e      -> m `mappend` fold e-      QuoteContext _       -> m-      Quote{}              -> m-      QuoteTerm{}          -> m-      Unquote{}            -> m-      Tactic _ e xs ys     -> m `mappend` fold e `mappend` fold xs `mappend` fold ys-      DontCare e           -> m `mappend` fold e+      Var{}                  -> m+      Def'{}                 -> m+      Proj{}                 -> m+      Con{}                  -> m+      PatternSyn{}           -> m+      Macro{}                -> m+      Lit{}                  -> m+      QuestionMark{}         -> m+      Underscore{}           -> m+      Dot _ e                -> m `mappend` fold e+      App _ e e'             -> m `mappend` fold e `mappend` fold e'+      WithApp _ e es         -> m `mappend` fold e `mappend` fold es+      Lam _ b e              -> m `mappend` fold b `mappend` fold e+      AbsurdLam{}            -> m+      ExtendedLam _ _ _ _ cs -> m `mappend` fold cs+      Pi _ tel e             -> m `mappend` fold tel `mappend` fold e+      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+      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+      Unquote{}              -> m+      DontCare e             -> m `mappend` fold e    where-     m    = f e+     m = f e+     fold :: FoldExprRecFn m      fold = foldExpr f +  traverseExpr :: forall m. TraverseExprFn m Expr   traverseExpr f e = do-    let trav e = traverseExpr f e+    let+      trav :: TraverseExprRecFn m+      trav e = traverseExpr f e     case e of-      Var{}                   -> f e-      Def{}                   -> f e-      Proj{}                  -> f e-      Con{}                   -> f e-      Lit{}                   -> f e-      QuestionMark{}          -> f e-      Underscore{}            -> f e-      Dot ei e                -> f =<< Dot ei <$> trav e-      App ei e arg            -> f =<< App ei <$> trav e <*> trav arg-      WithApp ei e es         -> f =<< WithApp ei <$> trav e <*> trav es-      Lam ei b e              -> f =<< Lam ei <$> trav b <*> trav e-      AbsurdLam{}             -> f e-      ExtendedLam ei di x cls -> f =<< ExtendedLam ei di x <$> trav cls-      Pi ei tel e             -> f =<< Pi ei <$> trav tel <*> trav e-      Fun ei arg e            -> f =<< Fun ei <$> trav arg <*> trav e-      Set{}                   -> f e-      Prop{}                  -> f 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-      ScopedExpr sc e         -> f =<< ScopedExpr sc <$> trav e-      QuoteGoal ei n e        -> f =<< QuoteGoal ei n <$> trav e-      QuoteContext{}          -> f e-      Quote{}                 -> f e-      QuoteTerm{}             -> f e-      Unquote{}               -> f e-      Tactic ei e xs ys       -> f =<< Tactic ei <$> trav e <*> trav xs <*> trav ys-      DontCare e              -> f =<< DontCare <$> trav e-      PatternSyn{}            -> f e-      Macro{}                 -> f e+      Var{}                      -> f e+      Def'{}                     -> f e+      Proj{}                     -> f e+      Con{}                      -> f e+      Lit{}                      -> f e+      QuestionMark{}             -> f e+      Underscore{}               -> f e+      Dot ei e                   -> f =<< Dot ei <$> trav e+      App ei e arg               -> f =<< App ei <$> trav e <*> trav arg+      WithApp ei e es            -> f =<< WithApp ei <$> trav e <*> trav es+      Lam ei b e                 -> f =<< Lam ei <$> trav b <*> trav e+      AbsurdLam{}                -> f e+      ExtendedLam ei di re x cls -> f =<< ExtendedLam ei di re x <$> trav cls+      Pi ei tel e                -> f =<< Pi ei <$> trav tel <*> trav e+      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+      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+      Unquote{}                  -> f e+      DontCare e                 -> f =<< DontCare <$> trav e+      PatternSyn{}               -> f e+      Macro{}                    -> f e -instance ExprLike a => ExprLike (Arg a)     where-instance ExprLike a => ExprLike (Named x a) where-instance ExprLike a => ExprLike [a]         where+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@@ -241,6 +271,9 @@   recurseExpr f = traverseEither (recurseExpr f)                                  (recurseExpr f) +instance ExprLike BindName where+  recurseExpr f = pure+ instance ExprLike ModuleName where   recurseExpr f = pure @@ -250,134 +283,355 @@ instance ExprLike LamBinding where   recurseExpr f e =     case e of-      DomainFree{}  -> pure e-      DomainFull bs -> DomainFull <$> recurseExpr f bs+      DomainFree t x -> DomainFree <$> recurseExpr f t <*> pure x+      DomainFull bs  -> DomainFull <$> recurseExpr f bs   foldExpr f e =     case e of-      DomainFree{}  -> mempty+      DomainFree t _ -> foldExpr f t       DomainFull bs -> foldExpr f bs   traverseExpr f e =     case e of-      DomainFree{}  -> pure e-      DomainFull bs -> DomainFull <$> traverseExpr f bs+      DomainFree t x -> DomainFree <$> traverseExpr f t <*> pure x+      DomainFull bs  -> DomainFull <$> traverseExpr f bs -instance ExprLike TypedBindings where-  recurseExpr  f (TypedBindings r b) = TypedBindings r <$> recurseExpr f b-  foldExpr     f (TypedBindings r b) = foldExpr f b-  traverseExpr f (TypedBindings r b) = TypedBindings r <$> traverseExpr f b+instance ExprLike GeneralizeTelescope where+  recurseExpr  f (GeneralizeTel s tel) = GeneralizeTel s <$> recurseExpr f tel+  foldExpr     f (GeneralizeTel s tel) = foldExpr f tel+  traverseExpr f (GeneralizeTel s tel) = GeneralizeTel s <$> traverseExpr f tel +instance ExprLike DataDefParams where+  recurseExpr  f (DataDefParams s tel) = DataDefParams s <$> recurseExpr f tel+  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-      TBind r xs e -> TBind r xs <$> recurseExpr f e-      TLet r ds    -> TLet r <$> recurseExpr f ds+      TBind r t xs e -> TBind r <$> recurseExpr f t <*> pure xs <*> recurseExpr f e+      TLet r ds      -> TLet r <$> recurseExpr f ds   foldExpr f e =     case e of-      TBind _ _ e  -> foldExpr f e-      TLet _ ds    -> foldExpr f ds+      TBind _ t _ e -> foldExpr f t `mappend` foldExpr f e+      TLet _ ds     -> foldExpr f ds   traverseExpr f e =     case e of-      TBind r xs e -> TBind r xs <$> traverseExpr f e-      TLet r ds    -> TLet r <$> traverseExpr f ds+      TBind r t xs e -> TBind r <$> traverseExpr f t <*> pure xs <*> traverseExpr f e+      TLet r ds      -> TLet r <$> traverseExpr f ds  instance ExprLike LetBinding where+  recurseExpr :: forall m. RecurseExprFn m LetBinding   recurseExpr f e = do-    let recurse e = recurseExpr f e+    let+      recurse :: RecurseExprRecFn m+      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 e = foldExpr f e+    where+      fold :: FoldExprRecFn m+      fold e = foldExpr f e +  traverseExpr :: forall m. TraverseExprFn m LetBinding   traverseExpr f e = do-    let trav e = traverseExpr f e+    let+      trav :: TraverseExprRecFn m+      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  instance ExprLike a => ExprLike (Clause' a) where-  recurseExpr f (Clause lhs dots rhs ds ca) = Clause <$> rec lhs <*> pure dots <*> rec rhs <*> rec ds <*> pure ca-    where rec = recurseExpr f+  recurseExpr :: forall m. RecurseExprFn m (Clause' a)+  recurseExpr f (Clause lhs spats rhs ds ca) = Clause <$> rec lhs <*> pure spats <*> rec rhs <*> rec ds <*> pure ca+    where+      rec :: RecurseExprRecFn m+      rec = recurseExpr f  instance ExprLike RHS where+  recurseExpr :: forall m. RecurseExprFn m RHS   recurseExpr f rhs =     case rhs of       RHS e c                 -> RHS <$> rec e <*> pure c       AbsurdRHS{}             -> pure rhs       WithRHS x es cs         -> WithRHS x <$> rec es <*> rec cs-      RewriteRHS xes rhs ds   -> RewriteRHS <$> rec xes <*> rec rhs <*> rec ds-    where rec e = recurseExpr f e+      RewriteRHS xes spats rhs ds -> RewriteRHS <$> rec xes <*> pure spats <*> rec rhs <*> rec ds+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e +instance (ExprLike qn, ExprLike nm, ExprLike p, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where+  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 c) = WhereDecls a b <$> recurseExpr f c+ instance ExprLike ModuleApplication where+  recurseExpr :: forall m. RecurseExprFn m ModuleApplication   recurseExpr f a =     case a of       SectionApp tel m es -> SectionApp <$> rec tel <*> rec m <*> rec es-      RecordModuleIFS{}   -> pure a-    where rec e = recurseExpr f e+      RecordModuleInstance{} -> pure a+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e  instance ExprLike Pragma where+  recurseExpr :: forall m. RecurseExprFn m Pragma   recurseExpr f p =     case p of-      BuiltinPragma s e           -> BuiltinPragma s <$> rec e+      BuiltinPragma s x           -> pure p       OptionsPragma{}             -> pure p       BuiltinNoDefPragma{}        -> pure p       RewritePragma{}             -> pure p-      CompiledPragma{}            -> pure p-      CompiledExportPragma{}      -> pure p-      CompiledDeclareDataPragma{} -> pure p-      CompiledTypePragma{}        -> pure p-      CompiledDataPragma{}        -> pure p-      CompiledEpicPragma{}        -> pure p-      CompiledJSPragma{}          -> pure p-      CompiledUHCPragma{}         -> pure p-      CompiledDataUHCPragma{}     -> pure p+      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 e = recurseExpr f e+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e  instance ExprLike LHS where-  recurseExpr f (LHS i c ps) = LHS i <$> recurseExpr f c <*> recurseExpr f ps+  recurseExpr f (LHS i p) = LHS i <$> recurseExpr f p -instance ExprLike a => ExprLike (LHSCore' a) where+instance ExprLike a => ExprLike (LHSCore' a)   where+instance ExprLike a => ExprLike (WithHiding a) where  instance ExprLike SpineLHS where-  recurseExpr f (SpineLHS i x ps wps) = SpineLHS i x <$> recurseExpr f ps <*> recurseExpr f wps+  recurseExpr f (SpineLHS i x ps) = SpineLHS i x <$> recurseExpr f ps  instance ExprLike Declaration where+  recurseExpr :: forall m. RecurseExprFn m Declaration   recurseExpr f d =     case d of       Axiom a d i mp x e        -> Axiom a d i mp x <$> rec e+      Generalize s i j x e      -> Generalize s i j x <$> rec e       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-      DataDef i d bs cs         -> DataDef i d <$> rec bs <*> rec cs-      RecSig i r tel e          -> RecSig i r <$> rec tel <*> rec e-      RecDef i r n co c bs e ds -> RecDef i r n co c <$> rec bs <*> rec e <*> rec ds+      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 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-    where rec e = recurseExpr f e+      UnfoldingDecl r ds        -> UnfoldingDecl r <$> rec ds+    where+      rec :: RecurseExprRecFn m+      rec e = recurseExpr f e+++-- * Getting all declared names+---------------------------------------------------------------------------++type KName = WithKind QName++-- | Extracts "all" names which are declared in a 'Declaration'.+--+-- Includes: local modules and @where@ clauses.+-- Excludes: @open public@, @let@, @with@ function names, extended lambdas.++class DeclaredNames a where+  declaredNames :: Collection KName m => a -> m++  default declaredNames+     :: (Foldable t, DeclaredNames b, t b ~ a)+     => Collection KName m => a -> m+  declaredNames = foldMap declaredNames++instance DeclaredNames a => DeclaredNames [a]+instance DeclaredNames a => DeclaredNames (List1 a)+instance DeclaredNames a => DeclaredNames (Maybe a)+instance DeclaredNames a => DeclaredNames (Arg a)+instance DeclaredNames a => DeclaredNames (Named name a)+instance DeclaredNames a => DeclaredNames (FieldAssignment' a)++instance (DeclaredNames a, DeclaredNames b) => DeclaredNames (Either a b) where+  declaredNames = either declaredNames declaredNames++instance (DeclaredNames a, DeclaredNames b) => DeclaredNames (a,b) where+  declaredNames (a,b) = declaredNames a <> declaredNames b++instance DeclaredNames KName where+  declaredNames = singleton++instance DeclaredNames RecordDirectives where+  declaredNames (RecordDirectives i _ _ c) = kc where+    kc = case c of+      NamedRecCon c -> singleton $ WithKind k c+      FreshRecCon{} -> mempty+    k  = maybe ConName (conKindOfName . rangedThing) i++instance DeclaredNames Declaration where+  declaredNames = \case+      Axiom _ di _ _ q _           -> singleton . (`WithKind` q) $+                                      case defMacro di of+                                        MacroDef    -> MacroName+                                        NotMacroDef -> AxiomName+      Generalize _ _ _ q _         -> singleton (WithKind GeneralizeName q)+      Field _ q _                  -> singleton (WithKind FldName q)+      Primitive _ q _              -> singleton (WithKind PrimName q)+      Mutual _ decls               -> declaredNames decls+      DataSig _ _ q _ _            -> singleton (WithKind DataName q)+      DataDef _ q _ _ decls        -> singleton (WithKind DataName q) <> foldMap con decls+      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+      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+      Pragma _ pragma              -> declaredNames pragma+      Apply{}                      -> mempty+      Import{}                     -> mempty+      Open{}                       -> mempty+      UnfoldingDecl{}              -> mempty+    where+    con = \case+      Axiom _ _ _ _ q _ -> singleton $ WithKind ConName q+      _ -> __IMPOSSIBLE__++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+    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++instance DeclaredNames RHS where+  declaredNames = \case+    RHS _ _                   -> mempty+    AbsurdRHS                 -> mempty+    WithRHS _q _es cls        -> declaredNames cls+    RewriteRHS _qes _ rhs cls -> declaredNames rhs <> declaredNames cls++-- Andreas, 2020-04-13: Migration from Agda.Syntax.Abstract.AllNames+--+-- Since we are not interested in names of extended lambdas, we do not+-- traverse into expression.+--+-- However, we keep this code (originally Agda.Syntax.Abstract.AllNames) around+-- should arise a need to collect extended lambda names.++-- instance (DeclaredNames a, DeclaredNames b, DeclaredNames c) => DeclaredNames (a,b,c) where+--   declaredNames (a,b,c) = declaredNames a <> declaredNames b <> declaredNames c++-- instance DeclaredNames RHS where+--   declaredNames = \case+--     RHS e _                  -> declaredNames e+--     AbsurdRHS{}              -> mempty+--     WithRHS q _ cls          -> singleton (WithKind FunName q) <> declaredNames cls+--     RewriteRHS qes _ rhs cls -> declaredNames (qes, rhs, cls)++-- instance DeclaredNames ModuleName where+--   declaredNames _ = mempty++-- instance (DeclaredNames qn, DeclaredNames e) => DeclaredNames (RewriteEqn' qn p e) where+--   declaredNames = \case+--     Rewrite es    -> declaredNames es+--     Invert qn pes -> declaredNames qn <> declaredNames pes++-- instance DeclaredNames Expr where+--   declaredNames = \case+--     Var{}                 -> mempty+--     Def{}                 -> mempty+--     Proj{}                -> mempty+--     Con{}                 -> mempty+--     Lit{}                 -> mempty+--     QuestionMark{}        -> mempty+--     Underscore{}          -> mempty+--     Dot _ e               -> declaredNames e+--     App _ e1 e2           -> declaredNames e1 <> declaredNames e2+--     WithApp _ e es        -> declaredNames e <> declaredNames es+--     Lam _ b e             -> declaredNames b <> declaredNames e+--     AbsurdLam{}           -> mempty+--     ExtendedLam _ _ q cls -> singleton (WithKind FunName q) <> declaredNames cls+--     Pi _ tel e            -> declaredNames tel <> declaredNames e+--     Generalized s e       -> declaredNames e  -- NOT: fromList (map (WithKind GeneralizeName) $ Set.toList s) <> declaredNames e+--     Fun _ e1 e2           -> declaredNames e1 <> declaredNames e2+--     Set{}                 -> mempty+--     Prop{}                -> mempty+--     Let _ lbs e           -> declaredNames lbs <> declaredNames e+--     Rec _ fields          -> declaredNames fields+--     RecUpdate _ e fs      -> declaredNames e <> declaredNames fs+--     ScopedExpr _ e        -> declaredNames e+--     Quote{}               -> mempty+--     QuoteTerm{}           -> mempty+--     Unquote{}             -> mempty+--     DontCare{}            -> mempty+--     PatternSyn{}          -> mempty+--     Macro{}               -> mempty++-- instance DeclaredNames LamBinding where+--   declaredNames DomainFree{}       = mempty+--   declaredNames (DomainFull binds) = declaredNames binds++-- instance DeclaredNames TypedBinding where+--   declaredNames (TBind _ t _ e) = declaredNames (t, e)+--   declaredNames (TLet _ lbs)    = declaredNames lbs++-- instance DeclaredNames LetBinding where+--   declaredNames (LetBind _ _ _ e1 e2)   = declaredNames e1 <> declaredNames e2+--   declaredNames (LetPatBind _ _ e)      = declaredNames e+--   declaredNames (LetApply _ _ app _ _)  = declaredNames app+--   declaredNames LetOpen{}               = mempty++-- instance DeclaredNames ModuleApplication where+--   declaredNames (SectionApp bindss _ es) = declaredNames bindss <> declaredNames es+--   declaredNames RecordModuleInstance{}   = mempty
+ src/full/Agda/Syntax/Builtin.hs view
@@ -0,0 +1,1087 @@+{-# 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,1029 +1,4022 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-| Some common syntactic entities are defined in this module.--}-module Agda.Syntax.Common where--import Control.Applicative-import Control.DeepSeq--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as ByteString-import Data.Foldable-import Data.Hashable-import qualified Data.Strict.Maybe as Strict-import Data.Semigroup hiding (Arg)-import Data.Traversable-import Data.Typeable (Typeable)-import Data.Word--import GHC.Generics (Generic)--import Agda.Syntax.Position--import Agda.Utils.Functor-import Agda.Utils.Pretty hiding ((<>))--#include "undefined.h"-import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Delayed-------------------------------------------------------------------------------- | Used to specify whether something should be delayed.-data Delayed = Delayed | NotDelayed-  deriving (Typeable, Show, Eq, Ord)--instance KillRange Delayed where-  killRange = id-------------------------------------------------------------------------------- * Induction------------------------------------------------------------------------------data Induction = Inductive | CoInductive-  deriving (Typeable, Eq, Ord)--instance Show Induction where-  show Inductive   = "inductive"-  show CoInductive = "coinductive"--instance HasRange Induction where-  getRange _ = noRange--instance KillRange Induction where-  killRange = id--instance NFData Induction where-  rnf Inductive   = ()-  rnf CoInductive = ()-------------------------------------------------------------------------------- * Hiding------------------------------------------------------------------------------data Hiding  = Hidden | Instance | NotHidden-  deriving (Typeable, Show, Eq, Ord)---- | '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  <> Instance  = Instance-  _         <> _         = __IMPOSSIBLE__--instance Monoid Hiding where-  mempty = NotHidden-  mappend = (<>)--instance KillRange Hiding where-  killRange = id--instance NFData Hiding where-  rnf Hidden    = ()-  rnf Instance  = ()-  rnf NotHidden = ()---- | Decorating something with 'Hiding' information.-data WithHiding a = WithHiding !Hiding a-  deriving (Typeable, 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 one of @setHiding@ or @mapHiding@.-class LensHiding a where--  getHiding :: a -> Hiding--  setHiding :: Hiding -> a -> a-  setHiding h = mapHiding (const h)--  mapHiding :: (Hiding -> Hiding) -> a -> a-  mapHiding f a = setHiding (f $ getHiding a) a--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---- | Monoidal composition of 'Hiding' information in some data.-mergeHiding :: LensHiding a => WithHiding a -> a-mergeHiding (WithHiding h a) = mapHiding (mappend h) a---- | Visible ('NotHidden') arguments are @notHidden@. (DEPRECATED, use 'visible'.)-notHidden :: LensHiding a => a -> Bool-notHidden a = getHiding a == NotHidden---- | '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--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 = setHiding Instance-------------------------------------------------------------------------------- * Relevance-------------------------------------------------------------------------------- | An constructor argument is big if the sort of its type is bigger than---   the sort of the data type.  Only parameters (and maybe forced arguments)---   are allowed to be big.---   @---      List : Set -> Set---      nil  : (A : Set) -> List A---   @---   @A@ is big in constructor @nil@ as the sort @Set1@ of its type @Set@---   is bigger than the sort @Set@ of the data type @List@.-data Big = Big | Small-  deriving (Typeable, Show, Eq, Enum, Bounded)--instance Ord Big where-  Big <= Small = False-  _   <= _     = True--instance NFData Big where-  rnf Big   = ()-  rnf Small = ()---- | 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.-  | Forced Big  -- ^ The argument can be skipped during equality checking-                --   because its value is already determined by the type.-                --   If a constructor argument is big, it has to be regarded-                --   absent, otherwise we get into paradoxes.-  | UnusedArg   -- ^ The polarity checker has determined that this argument-                --   is unused in the definition.  It can be skipped during-                --   equality checking but should be mined for solutions-                --   of meta-variables with relevance 'UnusedArg'-    deriving (Typeable, Show, Eq)--allRelevances :: [Relevance]-allRelevances =-  [ Relevant-  , NonStrict-  , Irrelevant-  , Forced Small-  , Forced Big-  , UnusedArg-  ]--instance KillRange Relevance where-  killRange rel = rel -- no range to kill--instance Ord Relevance where-  (<=) = moreRelevant--instance NFData Relevance where-  rnf Relevant   = ()-  rnf NonStrict  = ()-  rnf Irrelevant = ()-  rnf (Forced a) = rnf a-  rnf UnusedArg  = ()---- | A lens to access the 'Relevance' attribute in data structures.---   Minimal implementation: @getRelevance@ and one of @setRelevance@ or @mapRelevance@.-class LensRelevance a where--  getRelevance :: a -> Relevance--  setRelevance :: Relevance -> a -> a-  setRelevance h = mapRelevance (const h)--  mapRelevance :: (Relevance -> Relevance) -> a -> a-  mapRelevance f a = setRelevance (f $ getRelevance a) a--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---- | Information ordering.--- @Relevant  \`moreRelevant\`---  UnusedArg \`moreRelevant\`---  Forced    \`moreRelevant\`---  NonStrict \`moreRelevant\`---  Irrelevant@-moreRelevant :: Relevance -> Relevance -> Bool-moreRelevant r r' =-  case (r, r') of-    -- top-    (_, Irrelevant) -> True-    (Irrelevant, _) -> False-    -- bottom-    (Relevant, _)   -> True-    (_, Relevant)   -> False-    -- second bottom-    (UnusedArg, _)  -> True-    (_, UnusedArg)  -> False-    -- third bottom-    (Forced{}, _)   -> True-    (_, Forced{})   -> False-    -- remaining case-    (NonStrict,NonStrict) -> True--irrelevantOrUnused :: Relevance -> Bool-irrelevantOrUnused r =-  case r of-    Irrelevant -> True-    UnusedArg  -> True-    NonStrict  -> False-    Relevant   -> False-    Forced{}   -> False---- | @unusableRelevance rel == True@ iff we cannot use a variable of @rel@.-unusableRelevance :: Relevance -> Bool-unusableRelevance rel = NonStrict `moreRelevant` rel---- | 'Relevance' composition.---   'Irrelevant' is dominant, 'Relevant' is neutral.-composeRelevance :: Relevance -> Relevance -> Relevance-composeRelevance r r' =-  case (r, r') of-    (Irrelevant, _) -> Irrelevant-    (_, Irrelevant) -> Irrelevant-    (NonStrict, _)  -> NonStrict-    (_, NonStrict)  -> NonStrict-    (Forced b, Forced b') -> Forced (max b b')  -- prefer Big over Small-    (Forced b, _)     -> Forced b-    (_, Forced b)     -> Forced b-    (UnusedArg, _)  -> UnusedArg-    (_, UnusedArg)  -> UnusedArg-    (Relevant, Relevant) -> Relevant---- | @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-    _ | r == x           -> Relevant   -- because Relevant is comp.-neutral-    (Forced{}, Forced{}) -> Relevant   -- same, but (==) does not ignore Big-    (UnusedArg, x)       -> x-    (Forced{}, UnusedArg)  -> Relevant-    (Forced{}, x)          -> x-    (Irrelevant, x)      -> Relevant   -- going irrelevant: every thing usable-    (_, Irrelevant)      -> Irrelevant -- otherwise: irrelevant things remain unusable-    (NonStrict, _)       -> Relevant   -- but @NonStrict@s become usable---- | For comparing @Relevance@ ignoring @Forced@ and @UnusedArg@.-ignoreForced :: Relevance -> Relevance-ignoreForced Forced{}   = Relevant-ignoreForced UnusedArg  = Relevant-ignoreForced Relevant   = Relevant-ignoreForced NonStrict  = NonStrict-ignoreForced Irrelevant = Irrelevant---- | Irrelevant function arguments may appear non-strictly in the codomain type.-irrToNonStrict :: Relevance -> Relevance-irrToNonStrict Irrelevant = NonStrict--- irrToNonStrict NonStrict  = Relevant -- TODO: this is bad if we apply irrToNonStrict several times!-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-------------------------------------------------------------------------------- * Origin of arguments (user-written, inserted or reflected)------------------------------------------------------------------------------data Origin = UserWritten | Inserted | Reflected-  deriving (Typeable, Show, Eq, Ord)--instance KillRange Origin where-  killRange = id--instance NFData Origin where-  rnf UserWritten = ()-  rnf Inserted = ()-  rnf Reflected = ()--class LensOrigin a where--  getOrigin :: a -> Origin--  setOrigin :: Origin -> a -> a-  setOrigin o = mapOrigin (const o)--  mapOrigin :: (Origin -> Origin) -> a -> a-  mapOrigin f a = setOrigin (f $ getOrigin a) a--instance LensOrigin Origin where-  getOrigin = id-  setOrigin = const-  mapOrigin = id-------------------------------------------------------------------------------- * Argument decoration-------------------------------------------------------------------------------- | A function argument can be hidden and/or irrelevant.--data ArgInfo = ArgInfo-  { argInfoHiding       :: Hiding-  , argInfoRelevance    :: Relevance-  , argInfoOrigin       :: Origin-  , argInfoOverlappable :: Bool-  } deriving (Typeable, Eq, Ord, Show)--instance KillRange ArgInfo where-  killRange (ArgInfo h r o v) = killRange3 ArgInfo h r o v--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) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d--instance LensHiding ArgInfo where-  getHiding = argInfoHiding-  setHiding h ai = ai { argInfoHiding = h }-  mapHiding f ai = ai { argInfoHiding = f (argInfoHiding ai) }--instance LensRelevance ArgInfo where-  getRelevance = argInfoRelevance-  setRelevance h ai = ai { argInfoRelevance = h }-  mapRelevance f ai = ai { argInfoRelevance = f (argInfoRelevance ai) }--instance LensOrigin ArgInfo where-  getOrigin = argInfoOrigin-  setOrigin o ai = ai { argInfoOrigin = o }-  mapOrigin f ai = ai { argInfoOrigin = f (argInfoOrigin ai) }--defaultArgInfo :: ArgInfo-defaultArgInfo =  ArgInfo { argInfoHiding       = NotHidden-                          , argInfoRelevance    = Relevant-                          , argInfoOrigin       = UserWritten-                          , argInfoOverlappable = False }--------------------------------------------------------------------------------- * Arguments------------------------------------------------------------------------------data Arg e  = Arg-  { argInfo :: ArgInfo-  , unArg :: e-  } deriving (Typeable, Ord, 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--instance Eq a => Eq (Arg a) where-  Arg (ArgInfo h1 _ _ _) x1 == Arg (ArgInfo h2 _ _ _) x2 = (h1, x1) == (h2, x2)--instance Show a => Show (Arg a) where-    show (Arg (ArgInfo h r o v) x) = showR r $ showO o $ showH h $ show x-      where-        showH Hidden     s = "{" ++ s ++ "}"-        showH NotHidden  s = "(" ++ s ++ ")"-        showH Instance   s = (if v then "overlap " else "") ++ "{{" ++ s ++ "}}"-        showR r s = case r of-          Irrelevant   -> "." ++ s-          NonStrict    -> "?" ++ s-          Forced Big   -> "!b" ++ s-          Forced Small -> "!" ++ s-          UnusedArg    -> "k" ++ s -- constant-          Relevant     -> "r" ++ s -- Andreas: I want to see it explicitly-        showO o s = case o of-          UserWritten -> "u" ++ s-          Inserted    -> "i" ++ s-          Reflected   -> "g" ++ s -- generated by reflection--instance NFData e => NFData (Arg e) where-  rnf (Arg a b) = rnf a `seq` rnf b--instance LensHiding (Arg e) where-  getHiding = getHiding . argInfo-  mapHiding = mapArgInfo . mapHiding--instance LensRelevance (Arg e) where-  getRelevance = getRelevance . argInfo-  mapRelevance = mapArgInfo . mapRelevance--instance LensOrigin (Arg e) where-  getOrigin = getOrigin . argInfo-  mapOrigin = mapArgInfo . mapOrigin--instance LensArgInfo (Arg a) where-  getArgInfo        = argInfo-  mapArgInfo f arg  = arg { argInfo = f $ argInfo arg }--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-------------------------------------------------------------------------------- * Function type domain-------------------------------------------------------------------------------- | Similar to 'Arg', but we need to distinguish---   an irrelevance annotation in a function domain---   (the domain itself is not irrelevant!)---   from an irrelevant argument.------   @Dom@ is used in 'Pi' of internal syntax, in 'Context' and 'Telescope'.---   'Arg' is used for actual arguments ('Var', 'Con', 'Def' etc.)---   and in 'Abstract' syntax and other situations.-data Dom e = Dom-  { domInfo   :: ArgInfo-  , unDom     :: e-  } deriving (Typeable, Ord, Functor, Foldable, Traversable)--instance Decoration Dom where-  traverseF f (Dom ai a) = Dom ai <$> f a--instance HasRange a => HasRange (Dom a) where-  getRange = getRange . unDom--instance KillRange a => KillRange (Dom a) where-  killRange (Dom info a) = killRange2 Dom info a--instance Eq a => Eq (Dom a) where-  Dom (ArgInfo h1 r1 _ _) x1 == Dom (ArgInfo h2 r2 _ _) x2 =-    (h1, ignoreForced r1, x1) == (h2, ignoreForced r2, x2)--instance Show a => Show (Dom a) where-  show = show . argFromDom--instance LensHiding (Dom e) where-  getHiding = getHiding . domInfo-  mapHiding = mapArgInfo . mapHiding--instance LensRelevance (Dom e) where-  getRelevance = getRelevance . domInfo-  mapRelevance = mapArgInfo . mapRelevance--instance LensArgInfo (Dom e) where-  getArgInfo = domInfo-  mapArgInfo f arg = arg { domInfo = f $ domInfo arg }--argFromDom :: Dom a -> Arg a-argFromDom (Dom i a) = Arg i a--domFromArg :: Arg a -> Dom a-domFromArg (Arg i a) = Dom i a--defaultDom :: a -> Dom a-defaultDom = Dom defaultArgInfo-------------------------------------------------------------------------------- * Named arguments-------------------------------------------------------------------------------- | Something potentially carrying a name.-data Named name a =-    Named { nameOf     :: Maybe name-          , namedThing :: a-          }-    deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)---- | Standard naming.-type Named_ = Named RString--unnamed :: a -> Named name a-unnamed = Named Nothing--named :: name -> a -> Named name a-named = Named . Just--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 x)  = show x-    show (Named (Just n) x) = rawNameToString (rangedThing n) ++ " = " ++ show x--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 = defaultArg . 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-------------------------------------------------------------------------------- * Range decoration.-------------------------------------------------------------------------------- | Thing with range info.-data Ranged a = Ranged-  { rangeOf     :: Range-  , rangedThing :: a-  }-  deriving (Typeable, Functor, Foldable, Traversable)---- | Thing with no range info.-unranged :: a -> Ranged a-unranged = Ranged noRange--instance Show a => Show (Ranged a) where-  show = show . rangedThing--instance Eq a => Eq (Ranged a) where-  Ranged _ x == Ranged _ y = x == y--instance Ord a => Ord (Ranged a) where-  compare (Ranged _ x) (Ranged _ y) = compare x y--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).-  deriving (Typeable, Show, Eq, Ord, Enum, Bounded)--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 (Typeable, Show, Eq, Ord, Enum, Bounded)--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 (Typeable, Show, Eq, Ord)---- | 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-  | OnlyQualified  -- ^ Visible from outside, but not exported when opening the module-                             --   Used for qualified constructors.-    deriving (Typeable, Show, Eq, Ord)--instance NFData Access where-  rnf _ = ()--instance HasRange Access where-  getRange _ = noRange--instance KillRange Access where-  killRange = id---- | Abstract or concrete-data IsAbstract = AbstractDef | ConcreteDef-    deriving (Typeable, Show, Eq, Ord)--instance KillRange IsAbstract where-  killRange = id---- | Is this definition eligible for instance search?-data IsInstance = InstanceDef | NotInstanceDef-    deriving (Typeable, Show, Eq, Ord)--instance KillRange IsInstance where-  killRange = id--instance HasRange IsInstance where-  getRange _ = noRange--instance NFData IsInstance where-  rnf InstanceDef    = ()-  rnf NotInstanceDef = ()---- | Is this a macro definition?-data IsMacro = MacroDef | NotMacroDef-  deriving (Typeable, Show, Eq, Ord)--instance KillRange IsMacro where killRange = id-instance HasRange  IsMacro where getRange _ = noRange--type Nat    = Int-type Arity  = Nat-------------------------------------------------------------------------------- * NameId-------------------------------------------------------------------------------- | The unique identifier of a name. Second argument is the top-level module---   identifier.-data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-    deriving (Eq, Ord, Typeable, Generic)--instance KillRange NameId where-  killRange = id--instance Show NameId where-  show (NameId x i) = show x ++ "@" ++ show i--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 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, Typeable)--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--newtype Constr a = Constr a----------------------------------------------------------------------------- * 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 (Typeable, 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,Num,Integral,Real,Enum)--instance Show InteractionId where-    show (InteractionId x) = "?" ++ show x--instance KillRange InteractionId where killRange = 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' a b = ImportDirective-  { importDirRange :: Range-  , using          :: Using' a b-  , hiding         :: [ImportedName' a b]-  , impRenaming    :: [Renaming' a b]-  , publicOpen     :: Bool -- ^ Only for @open@. Exports the opened names from the current module.-  }-  deriving (Typeable, Eq)--data Using' a b = UseEverything | Using [ImportedName' a b]-  deriving (Typeable, Eq)--instance Semigroup (Using' a b) where-  UseEverything <> u = u-  u <> UseEverything = u-  Using xs <> Using ys = Using (xs ++ ys)--instance Monoid (Using' a b) where-  mempty = UseEverything-  mappend = (<>)---- | Default is directive is @private@ (use everything, but do not export).-defaultImportDir :: ImportDirective' a b-defaultImportDir = ImportDirective noRange UseEverything [] [] False--isDefaultImportDir :: ImportDirective' a b -> Bool-isDefaultImportDir (ImportDirective _ UseEverything [] [] False) = True-isDefaultImportDir _                                             = False---- | An imported name can be a module or a defined name-data ImportedName' a b-  = ImportedModule  b-  | ImportedName    a-  deriving (Typeable, Eq, Ord)--setImportedName :: ImportedName' a a -> a -> ImportedName' a a-setImportedName (ImportedName   x) y = ImportedName   y-setImportedName (ImportedModule x) y = ImportedModule y--instance (Show a, Show b) => Show (ImportedName' a b) where-  show (ImportedModule x) = "module " ++ show x-  show (ImportedName   x) = show x--data Renaming' a b = Renaming-  { renFrom    :: ImportedName' a b-    -- ^ Rename from this name.-  , renTo      :: ImportedName' a b-    -- ^ To this one.  Must be same kind as 'renFrom'.-  , renToRange :: Range-    -- ^ The range of the \"to\" keyword.  Retained for highlighting purposes.-  }-  deriving (Typeable, 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 _) = killRange2 (\i n -> Renaming i n noRange) i n--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 _) = rnf a `seq` rnf b--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 (Typeable, 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).-type PositivityCheck = Bool+{-| 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
@@ -1,1026 +1,1501 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}--{-| The concrete syntax is a raw representation of the program text-    without any desugaring at all.  This is what the parser produces.-    The idea is that if we figure out how to keep the concrete syntax-    around, it can be printed exactly as the user wrote it.--}-module Agda.Syntax.Concrete-  ( -- * Expressions-    Expr(..)-  , OpApp(..), fromOrdinary-  , module Agda.Syntax.Concrete.Name-  , appView, AppView(..)-    -- * Bindings-  , LamBinding-  , LamBinding'(..)-  , TypedBindings-  , TypedBindings'(..)-  , TypedBinding-  , TypedBinding'(..)-  , RecordAssignment-  , RecordAssignments-  , FieldAssignment, FieldAssignment'(..), nameFieldA, exprFieldA-  , ModuleAssignment(..)-  , BoundName(..), mkBoundName_, mkBoundName-  , Telescope -- (..)-  , countTelVars-    -- * Declarations-  , Declaration(..)-  , ModuleApplication(..)-  , TypeSignature-  , TypeSignatureOrInstanceBlock-  , ImportDirective, Using, ImportedName-  , Renaming-  , AsName(..)-  , OpenShortHand(..), RewriteEqn, WithExpr-  , LHS(..), Pattern(..), LHSCore(..)-  , RHS, RHS'(..), WhereClause, WhereClause'(..), ExprWhere(..)-  , Pragma(..)-  , Module-  , ThingWithFixity(..)-  , topLevelModuleName-  , spanAllowedBeforeModule-    -- * Pattern tools-  , patternNames, patternQNames-    -- * Lenses-  , mapLhsOriginalPattern-  )-  where--import Prelude hiding (null)--import Control.DeepSeq-import Data.Typeable (Typeable)-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.List hiding (null)-import Data.Set (Set)-import Data.Monoid--import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Literal--import Agda.Syntax.Concrete.Name-import qualified Agda.Syntax.Abstract.Name as A--import Agda.TypeChecking.Positivity.Occurrence--import Agda.Utils.Lens-import Agda.Utils.Null--#include "undefined.h"-import Agda.Utils.Impossible--data OpApp e-  = SyntaxBindingLambda Range [LamBinding] e-    -- ^ An abstraction inside a special syntax declaration-    --   (see Issue 358 why we introduce this).-  | Ordinary e-  deriving (Typeable, Functor, Foldable, Traversable)--fromOrdinary :: e -> OpApp e -> e-fromOrdinary d (Ordinary e) = e-fromOrdinary d _            = d--data FieldAssignment' a = FieldAssignment { _nameFieldA :: Name, _exprFieldA :: a }-  deriving (Typeable, Functor, Foldable, Traversable, Show, Eq)--type FieldAssignment = FieldAssignment' Expr--data ModuleAssignment  = ModuleAssignment-                           { _qnameModA     :: QName-                           , _exprModA      :: [Expr]-                           , _importDirModA :: ImportDirective-                           }-  deriving (Typeable)-type RecordAssignment  = Either FieldAssignment ModuleAssignment-type RecordAssignments = [RecordAssignment]--nameFieldA :: Lens' Name (FieldAssignment' a)-nameFieldA f r = f (_nameFieldA r) <&> \x -> r { _nameFieldA = x }--exprFieldA :: Lens' a (FieldAssignment' a)-exprFieldA f r = f (_exprFieldA r) <&> \x -> r { _exprFieldA = x }--qnameModA :: Lens' QName ModuleAssignment-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 f r = f (_importDirModA r) <&> \x -> r { _importDirModA = x }---- | Concrete expressions. Should represent exactly what the user wrote.-data Expr-  = Ident QName                                -- ^ ex: @x@-  | Lit Literal                                -- ^ ex: @1@ or @\"foo\"@-  | QuestionMark Range (Maybe Nat)             -- ^ ex: @?@ or @{! ... !}@-  | Underscore Range (Maybe String)            -- ^ ex: @_@ or @_A_5@-  | RawApp Range [Expr]                        -- ^ before parsing operators-  | App Range Expr (NamedArg Expr)             -- ^ ex: @e e@, @e {e}@, or @e {x = e}@-  | OpApp Range QName (Set A.Name)-          [NamedArg-             (MaybePlaceholder (OpApp Expr))]  -- ^ 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@-  | HiddenArg Range (Named_ Expr)              -- ^ ex: @{e}@ or @{x=e}@-  | InstanceArg Range (Named_ Expr)            -- ^ ex: @{{e}}@ or @{{x=e}}@-  | Lam Range [LamBinding] Expr                -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@-  | AbsurdLam Range Hiding                     -- ^ ex: @\\ ()@-  | ExtendedLam Range [(LHS,RHS,WhereClause,Bool)]  -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@-  | Fun Range Expr Expr                        -- ^ ex: @e -> e@ or @.e -> e@ (NYI: @{e} -> e@)-  | Pi Telescope Expr                          -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@-  | Set Range                                  -- ^ ex: @Set@-  | Prop Range                                 -- ^ ex: @Prop@-  | SetN Range Integer                         -- ^ ex: @Set0, Set1, ..@-  | 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}@-  | Let Range [Declaration] Expr               -- ^ ex: @let Ds in e@-  | Paren Range Expr                           -- ^ ex: @(e)@-  | IdiomBrackets Range Expr                   -- ^ ex: @(| e |)@-  | 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-  | ETel Telescope                             -- ^ only used for printing telescopes-  | QuoteGoal Range Name Expr                  -- ^ ex: @quoteGoal x in e@-  | QuoteContext Range                         -- ^ ex: @quoteContext@-  | Quote Range                                -- ^ ex: @quote@, should be applied to a name-  | QuoteTerm Range                            -- ^ ex: @quoteTerm@, should be applied to a term-  | Tactic Range Expr [Expr]                   -- ^ @tactic solve | subgoal1 | .. | subgoalN@-  | Unquote Range                              -- ^ ex: @unquote@, should be applied to a term of type @Term@-  | DontCare Expr                              -- ^ to print irrelevant things-  | Equal Range Expr Expr                      -- ^ ex: @a = b@, used internally in the parser-  deriving (Typeable)---- | Concrete patterns. No literals in patterns at the moment.-data Pattern-  = IdentP QName                           -- ^ @c@ or @x@-  | QuoteP Range                           -- ^ @quote@-  | AppP Pattern (NamedArg Pattern)        -- ^ @p p'@ or @p {x = p'}@-  | RawAppP Range [Pattern]                -- ^ @p1..pn@ before parsing operators-  | OpAppP Range QName (Set A.Name)-           [NamedArg Pattern]              -- ^ eg: @p => p'@ for operator @_=>_@-                                           -- The 'QName' is possibly-                                           -- ambiguous, but it must-                                           -- correspond to one of-                                           -- the names in the set.-  | HiddenP Range (Named_ Pattern)         -- ^ @{p}@ or @{x = p}@-  | InstanceP Range (Named_ Pattern)       -- ^ @{{p}}@ or @{{x = p}}@-  | ParenP Range Pattern                   -- ^ @(p)@-  | WildP Range                            -- ^ @_@-  | AbsurdP Range                          -- ^ @()@-  | AsP Range Name Pattern                 -- ^ @x\@p@ unused-  | DotP Range Origin Expr                 -- ^ @.e@-  | LitP Literal                           -- ^ @0@, @1@, etc.-  | RecP Range [FieldAssignment' Pattern]  -- ^ @record {x = p; y = q}@-  deriving (Typeable)---- | A lambda binding is either domain free or typed.-type LamBinding = LamBinding' TypedBindings-data LamBinding' a-  = DomainFree ArgInfo BoundName  -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@-  | DomainFull a                  -- ^ . @(xs : e)@ or @{xs : e}@-  deriving (Typeable, Functor, Foldable, Traversable)----- | A sequence of typed bindings with hiding information. Appears in dependent---   function spaces, typed lambdas, and telescopes.------   If the individual binding contains hiding information as well, the---   'Hiding' in @TypedBindings@ must be the unit 'NotHidden'.--type TypedBindings = TypedBindings' TypedBinding--data TypedBindings' a = TypedBindings Range (Arg a)-     -- ^ . @(xs : e)@ or @{xs : e}@ or something like @(x {y} _ : e)@.-  deriving (Typeable, Functor, Foldable, Traversable)--data BoundName = BName-  { boundName   :: Name-  , boundLabel  :: Name    -- ^ for implicit function types the label matters and can't be alpha-renamed-  , bnameFixity :: Fixity'-  }-  deriving (Typeable)--mkBoundName_ :: Name -> BoundName-mkBoundName_ x = mkBoundName x noFixity'--mkBoundName :: Name -> Fixity' -> BoundName-mkBoundName x f = BName x x f---- | A typed binding.--type TypedBinding = TypedBinding' Expr--data TypedBinding' e-  = TBind Range [WithHiding BoundName] e  -- ^ Binding @(x1 ... xn : A)@.-  | TLet  Range [Declaration]  -- ^ Let binding @(let Ds)@ or @(open M args)@.-  deriving (Typeable, Functor, Foldable, Traversable)---- | A telescope is a sequence of typed bindings. Bound variables are in scope---   in later types.-type Telescope = [TypedBindings]--countTelVars :: Telescope -> Nat-countTelVars tel =-  sum [ case unArg b of-          TBind _ xs _ -> genericLength xs-          TLet{}       -> 0-      | TypedBindings _ b <- tel ]--{-| Left hand sides can be written in infix style. For example:--    > n + suc m = suc (n + m)-    > (f ∘ g) x = f (g x)--   We use fixity information to see which name is actually defined.--}-data LHS-  = LHS { lhsOriginalPattern :: Pattern       -- ^ @f ps@-        , lhsWithPattern     :: [Pattern]     -- ^ @| p@ (many)-        , lhsRewriteEqn      :: [RewriteEqn]  -- ^ @rewrite e@ (many)-        , lhsWithExpr        :: [WithExpr]    -- ^ @with e@ (many)-        }-    -- ^ original pattern, with-patterns, rewrite equations and with-expressions-  | Ellipsis Range [Pattern] [RewriteEqn] [WithExpr]-    -- ^ new with-patterns, rewrite equations and with-expressions-  deriving (Typeable)--type RewriteEqn = Expr-type WithExpr   = Expr---- | Processed (scope-checked) intermediate form of the core @f ps@ of 'LHS'.---   Corresponds to 'lhsOriginalPattern'.-data LHSCore-  = LHSHead  { lhsDefName  :: QName               -- ^ @f@-             , lhsPats     :: [NamedArg Pattern]  -- ^ @ps@-             }-  | LHSProj  { lhsDestructor :: QName      -- ^ record projection identifier-             , lhsPatsLeft   :: [NamedArg Pattern]  -- ^ side patterns-             , lhsFocus      :: NamedArg LHSCore    -- ^ main branch-             , lhsPatsRight  :: [NamedArg Pattern]  -- ^ side patterns-             }-  deriving (Typeable)--type RHS = RHS' Expr-data RHS' e-  = AbsurdRHS -- ^ No right hand side because of absurd match.-  | RHS e-  deriving (Typeable, Functor, Foldable, Traversable)---type WhereClause = WhereClause' [Declaration]-data WhereClause' decls-  = NoWhere               -- ^ No @where@ clauses.-  | AnyWhere decls        -- ^ Ordinary @where@.-  | SomeWhere Name Access decls-    -- ^ Named where: @module M where@.-    --   The 'Access' flag applies to the 'Name' (not the module contents!)-    --   and is propagated from the parent function.-  deriving (Typeable, Functor, Foldable, Traversable)---- | An expression followed by a where clause.---   Currently only used to give better a better error message in interaction.-data ExprWhere = ExprWhere Expr WhereClause---- | The things you are allowed to say when you shuffle names between name---   spaces (i.e. in @import@, @namespace@, or @open@ declarations).-type ImportDirective = ImportDirective' Name Name-type Using           = Using'           Name Name-type Renaming        = Renaming'        Name Name---- | An imported name can be a module or a defined name.-type ImportedName = ImportedName' Name Name--data AsName = AsName-  { asName  :: Name-    -- ^ The \"as\" name.-  , asRange :: Range-    -- ^ The range of the \"as\" keyword.  Retained for highlighting purposes.-  }-  deriving (Typeable, Show)--{---------------------------------------------------------------------------    Declarations- --------------------------------------------------------------------------}---- | Just type signatures.-type TypeSignature = Declaration---- | Just type signatures or instance blocks.-type TypeSignatureOrInstanceBlock = Declaration--{-| The representation type of a declaration. The comments indicate-    which type in the intended family the constructor targets.--}--data Declaration-  = TypeSig ArgInfo Name Expr-  -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)-  | Field IsInstance Name (Arg Expr) -- ^ Record field, can be hidden and/or irrelevant.-  | FunClause LHS RHS WhereClause Bool-  | DataSig     Range Induction Name [LamBinding] Expr -- ^ lone data signature in mutual block-  | Data        Range Induction Name [LamBinding] (Maybe Expr) [TypeSignatureOrInstanceBlock]-  | RecordSig   Range Name [LamBinding] Expr -- ^ lone record signature in mutual block-  | Record      Range Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (Name, IsInstance)) [LamBinding] (Maybe Expr) [Declaration]-    -- ^ The optional name is a name for the record constructor.-  | Infix Fixity [Name]-  | Syntax      Name Notation -- ^ notation declaration for a name-  | PatternSyn  Range Name [Arg Name] Pattern-  | Mutual      Range [Declaration]-  | Abstract    Range [Declaration]-  | Private     Range 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]-  | Macro       Range [Declaration]-  | Postulate   Range [TypeSignatureOrInstanceBlock]-  | Primitive   Range [TypeSignature]-  | Open        Range QName ImportDirective-  | Import      Range QName (Maybe AsName) !OpenShortHand ImportDirective-  | ModuleMacro Range  Name ModuleApplication !OpenShortHand ImportDirective-  | Module      Range QName [TypedBindings] [Declaration]-  | UnquoteDecl Range [Name] Expr-  | UnquoteDef  Range [Name] Expr-  | Pragma      Pragma-  deriving (Typeable)--data ModuleApplication-  = SectionApp Range [TypedBindings] Expr-    -- ^ @tel. M args@-  | RecordModuleIFS Range QName-    -- ^ @M {{...}}@-  deriving (Typeable)--data OpenShortHand = DoOpen | DontOpen-  deriving (Typeable, Eq, Show)---- Pragmas ------------------------------------------------------------------data Pragma-  = OptionsPragma             Range [String]-  | BuiltinPragma             Range String Expr-  | RewritePragma             Range [QName]-  | CompiledDataPragma        Range QName String [String]-  | CompiledDeclareDataPragma Range QName String-  | CompiledTypePragma        Range QName String-  | CompiledPragma            Range QName String-  | CompiledExportPragma      Range QName String-  | CompiledEpicPragma        Range QName String-  | CompiledJSPragma          Range QName String-  | CompiledUHCPragma         Range QName String-  | CompiledDataUHCPragma     Range QName String [String]-  | HaskellCodePragma         Range String-  | StaticPragma              Range QName-  | InlinePragma              Range QName-  | ImportPragma              Range String-    -- ^ Invariant: The string must be a valid Haskell module name.-  | ImportUHCPragma           Range String-    -- ^ same as above, but for the UHC backend-  | ImpossiblePragma          Range-  | TerminationCheckPragma    Range (TerminationCheck Name)-  | CatchallPragma            Range-  | DisplayPragma             Range Pattern Expr-  | NoPositivityCheckPragma   Range-  | PolarityPragma            Range Name [Occurrence]-  deriving (Typeable)--------------------------------------------------------------------------------- | Modules: Top-level pragmas plus other top-level declarations.--type Module = ([Pragma], [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 (_, []) = __IMPOSSIBLE__-topLevelModuleName (_, 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---   should be a module declaration.-spanAllowedBeforeModule :: [Declaration] -> ([Declaration], [Declaration])-spanAllowedBeforeModule = span isAllowedBeforeModule-  where-    isAllowedBeforeModule (Pragma OptionsPragma{}) = True-    isAllowedBeforeModule (Private _ _ ds) = all isAllowedBeforeModule ds-    isAllowedBeforeModule Import{}       = True-    isAllowedBeforeModule ModuleMacro{}  = True-    isAllowedBeforeModule Open{}         = True-    isAllowedBeforeModule _              = False--{---------------------------------------------------------------------------    Lenses- --------------------------------------------------------------------------}--mapLhsOriginalPattern :: (Pattern -> Pattern) -> LHS -> LHS-mapLhsOriginalPattern f lhs@Ellipsis{}                    = lhs-mapLhsOriginalPattern f lhs@LHS{ lhsOriginalPattern = p } =-  lhs { lhsOriginalPattern = f p }--{---------------------------------------------------------------------------    Views- --------------------------------------------------------------------------}---- | The 'Expr' is not an application.-data AppView = AppView Expr [NamedArg Expr]--appView :: Expr -> AppView-appView e =-  case e of-    App r e1 e2     -> vApp (appView e1) e2-    RawApp _ (e:es) -> AppView e $ map arg es-    _               ->  AppView e []-  where-    vApp (AppView e es) arg = AppView e (es ++ [arg])--    arg (HiddenArg   _ e) = setHiding Hidden   $ defaultArg e-    arg (InstanceArg _ e) = setHiding Instance $ defaultArg e-    arg e                 = defaultArg (unnamed e)--{---------------------------------------------------------------------------    Patterns- --------------------------------------------------------------------------}---- | Get all the identifiers in a pattern in left-to-right order.-patternQNames :: Pattern -> [QName]-patternQNames p =-  case p of-    IdentP x               -> [x]-    AppP p p'              -> concatMap patternQNames [p, namedArg p']-    RawAppP _ ps           -> concatMap patternQNames  ps-    OpAppP _ x _ ps        -> x : concatMap (patternQNames . namedArg) ps-    HiddenP _ (namedPat)   -> patternQNames (namedThing namedPat)-    ParenP _ p             -> patternQNames p-    WildP _                -> []-    AbsurdP _              -> []-    AsP _ x p              -> patternQNames p-    DotP{}                 -> []-    LitP _                 -> []-    QuoteP _               -> []-    InstanceP _ (namedPat) -> patternQNames (namedThing namedPat)-    RecP _ fs              -> concatMap (patternQNames . (^. exprFieldA)) fs---- | Get all the identifiers in a pattern in left-to-right order.-patternNames :: Pattern -> [Name]-patternNames = map unqualify . patternQNames--{---------------------------------------------------------------------------    Instances- --------------------------------------------------------------------------}---- Null----------------------------------------------------------------------------- | A 'WhereClause' is 'null' when the @where@ keyword is absent.---   An empty list of declarations does not count as 'null' here.--instance Null (WhereClause' a) where-  empty = NoWhere-  null NoWhere = True-  null AnyWhere{} = False-  null SomeWhere{} = False---- Lenses---------------------------------------------------------------------------instance LensRelevance TypedBindings where-  getRelevance   (TypedBindings _ b) = getRelevance b-  mapRelevance f (TypedBindings r b) = TypedBindings r $ mapRelevance f b--instance LensHiding TypedBindings where-  getHiding   (TypedBindings _ b) = getHiding b-  mapHiding f (TypedBindings r b) = TypedBindings r $ mapHiding f b--instance LensHiding LamBinding where-  getHiding   (DomainFree ai _) = getHiding ai-  getHiding   (DomainFull a)    = getHiding a-  mapHiding f (DomainFree ai x) = DomainFree (mapHiding f ai) x-  mapHiding f (DomainFull a)    = DomainFull $ mapHiding f a---- HasRange instances---------------------------------------------------------------------------instance HasRange e => HasRange (OpApp e) where-  getRange e = case e of-    Ordinary e -> getRange e-    SyntaxBindingLambda r _ _ -> r--instance HasRange Expr where-  getRange e =-    case e of-      Ident x            -> getRange x-      Lit x              -> getRange x-      QuestionMark r _   -> r-      Underscore r _     -> r-      App r _ _          -> r-      RawApp r _         -> r-      OpApp r _ _ _      -> r-      WithApp r _ _      -> r-      Lam r _ _          -> r-      AbsurdLam r _      -> r-      ExtendedLam r _    -> r-      Fun r _ _          -> r-      Pi b e             -> fuseRange b e-      Set r              -> r-      Prop r             -> r-      SetN r _           -> r-      Let r _ _          -> r-      Paren r _          -> r-      IdiomBrackets r _  -> r-      As r _ _           -> r-      Dot r _            -> r-      Absurd r           -> r-      HiddenArg r _      -> r-      InstanceArg r _    -> r-      Rec r _            -> r-      RecUpdate r _ _    -> r-      ETel tel           -> getRange tel-      QuoteGoal r _ _    -> r-      QuoteContext r     -> r-      Quote r            -> r-      QuoteTerm r        -> r-      Unquote r          -> r-      Tactic r _ _       -> r-      DontCare{}         -> noRange-      Equal r _ _        -> r---- instance HasRange Telescope where---     getRange (TeleBind bs) = getRange bs---     getRange (TeleFun x y) = fuseRange x y--instance HasRange TypedBindings where-  getRange (TypedBindings r _) = r--instance HasRange TypedBinding where-  getRange (TBind r _ _) = r-  getRange (TLet r _)    = r--instance HasRange LamBinding where-  getRange (DomainFree _ x) = getRange x-  getRange (DomainFull b)   = getRange b--instance HasRange BoundName where-  getRange = getRange . boundName--instance HasRange WhereClause where-  getRange  NoWhere         = noRange-  getRange (AnyWhere ds)    = getRange ds-  getRange (SomeWhere _ _ ds) = getRange ds--instance HasRange ModuleApplication where-  getRange (SectionApp r _ _) = r-  getRange (RecordModuleIFS r _) = r--instance HasRange a => HasRange (FieldAssignment' a) where-  getRange (FieldAssignment a b) = fuseRange a b--instance HasRange ModuleAssignment where-  getRange (ModuleAssignment a b c) = fuseRange a b `fuseRange` c--instance HasRange Declaration where-  getRange (TypeSig _ x t)         = fuseRange x t-  getRange (Field _ x t)           = fuseRange x t-  getRange (FunClause lhs rhs wh _) = fuseRange lhs rhs `fuseRange` wh-  getRange (DataSig r _ _ _ _)     = r-  getRange (Data r _ _ _ _ _)      = r-  getRange (RecordSig r _ _ _)     = r-  getRange (Record r _ _ _ _ _ _ _)  = r-  getRange (Mutual r _)            = r-  getRange (Abstract r _)          = r-  getRange (Open 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 (Infix f _)             = getRange f-  getRange (Syntax n _)            = getRange n-  getRange (PatternSyn r _ _ _)    = r-  getRange (UnquoteDecl r _ _)     = r-  getRange (UnquoteDef r _ _)      = r-  getRange (Pragma p)              = getRange p--instance HasRange LHS where-  getRange (LHS p ps eqns ws) = fuseRange p (fuseRange ps (eqns ++ ws))-  getRange (Ellipsis r _ _ _) = r--instance HasRange LHSCore where-  getRange (LHSHead f ps)              = fuseRange f ps-  getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2--instance HasRange RHS where-  getRange AbsurdRHS = noRange-  getRange (RHS e)   = getRange e--instance HasRange Pragma where-  getRange (OptionsPragma r _)               = r-  getRange (BuiltinPragma r _ _)             = r-  getRange (RewritePragma r _)               = r-  getRange (CompiledDataPragma r _ _ _)      = r-  getRange (CompiledDeclareDataPragma r _ _) = r-  getRange (CompiledTypePragma r _ _)        = r-  getRange (CompiledPragma r _ _)            = r-  getRange (CompiledExportPragma r _ _)      = r-  getRange (CompiledEpicPragma r _ _)        = r-  getRange (CompiledJSPragma r _ _)          = r-  getRange (CompiledUHCPragma r _ _)         = r-  getRange (CompiledDataUHCPragma r _ _ _)   = r-  getRange (HaskellCodePragma r _)           = r-  getRange (StaticPragma r _)                = r-  getRange (InlinePragma r _)                = r-  getRange (ImportPragma r _)                = r-  getRange (ImportUHCPragma r _)             = r-  getRange (ImpossiblePragma r)              = r-  getRange (TerminationCheckPragma r _)      = r-  getRange (CatchallPragma r)                = r-  getRange (DisplayPragma r _ _)             = r-  getRange (NoPositivityCheckPragma r)       = r-  getRange (PolarityPragma r _ _)            = r--instance HasRange AsName where-  getRange a = getRange (asRange a, asName a)--instance HasRange Pattern where-  getRange (IdentP x)         = getRange x-  getRange (AppP p q)         = fuseRange p q-  getRange (OpAppP r _ _ _)   = r-  getRange (RawAppP r _)      = r-  getRange (ParenP r _)       = r-  getRange (WildP r)          = r-  getRange (AsP r _ _)        = r-  getRange (AbsurdP r)        = r-  getRange (LitP l)           = getRange l-  getRange (QuoteP r)         = r-  getRange (HiddenP r _)      = r-  getRange (InstanceP r _)    = r-  getRange (DotP r _ _)       = r-  getRange (RecP r _)         = r---- SetRange instances---------------------------------------------------------------------------instance SetRange TypedBindings where-  setRange r (TypedBindings _ b) = TypedBindings r b--instance SetRange Pattern where-  setRange r (IdentP x)         = IdentP (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-  setRange r (ParenP _ p)       = ParenP r p-  setRange r (WildP _)          = WildP r-  setRange r (AsP _ x p)        = AsP r (setRange r x) p-  setRange r (AbsurdP _)        = AbsurdP r-  setRange r (LitP l)           = LitP (setRange r l)-  setRange r (QuoteP _)         = QuoteP r-  setRange r (HiddenP _ p)      = HiddenP r p-  setRange r (InstanceP _ p)    = InstanceP r p-  setRange r (DotP _ o e)       = DotP r o e-  setRange r (RecP _ fs)        = RecP r fs---- KillRange instances---------------------------------------------------------------------------instance KillRange a => KillRange (FieldAssignment' a) where-  killRange (FieldAssignment a b) = killRange2 FieldAssignment a b--instance KillRange ModuleAssignment where-  killRange (ModuleAssignment a b c) = killRange3 ModuleAssignment a b c--instance KillRange AsName where-  killRange (AsName n _) = killRange1 (flip AsName noRange) n--instance KillRange BoundName where-  killRange (BName n l f) = killRange3 BName n l f--instance KillRange Declaration where-  killRange (TypeSig i n e)         = killRange2 (TypeSig i) n e-  killRange (Field i n a)           = killRange2 (Field i) n a-  killRange (FunClause l r w ca)    = killRange4 FunClause l r w ca-  killRange (DataSig _ i n l e)     = killRange4 (DataSig noRange) i n l e-  killRange (Data _ i n l e c)      = killRange4 (Data noRange i) n l e c-  killRange (RecordSig _ n l e)     = killRange3 (RecordSig noRange) n l e-  killRange (Record _ n mi mb mn k e d)= killRange7 (Record noRange) n mi mb mn 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 (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--instance KillRange Expr where-  killRange (Ident q)            = killRange1 Ident q-  killRange (Lit l)              = killRange1 Lit 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 _ lrw)  = killRange1 (ExtendedLam noRange) lrw-  killRange (Fun _ e1 e2)        = killRange2 (Fun noRange) e1 e2-  killRange (Pi t e)             = killRange2 Pi t e-  killRange (Set _)              = Set noRange-  killRange (Prop _)             = Prop noRange-  killRange (SetN _ n)           = SetN noRange n-  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 _ e)  = killRange1 (IdiomBrackets noRange) e-  killRange (Absurd _)           = Absurd noRange-  killRange (As _ n e)           = killRange2 (As noRange) n e-  killRange (Dot _ e)            = killRange1 (Dot noRange) e-  killRange (ETel t)             = killRange1 ETel t-  killRange (QuoteGoal _ n e)    = killRange2 (QuoteGoal noRange) n e-  killRange (QuoteContext _)     = QuoteContext noRange-  killRange (Quote _)            = Quote noRange-  killRange (QuoteTerm _)        = QuoteTerm noRange-  killRange (Unquote _)          = Unquote noRange-  killRange (Tactic _ t es)      = killRange2 (Tactic noRange) t es-  killRange (DontCare e)         = killRange1 DontCare e-  killRange (Equal _ x y)        = Equal noRange x y--instance KillRange LamBinding where-  killRange (DomainFree i b) = killRange2 DomainFree i b-  killRange (DomainFull t)   = killRange1 DomainFull t--instance KillRange LHS where-  killRange (LHS p ps r w)     = killRange4 LHS p ps r w-  killRange (Ellipsis _ p r w) = killRange3 (Ellipsis noRange) p r w--instance KillRange ModuleApplication where-  killRange (SectionApp _ t e)    = killRange2 (SectionApp noRange) t e-  killRange (RecordModuleIFS _ q) = killRange1 (RecordModuleIFS noRange) q--instance KillRange e => KillRange (OpApp e) where-  killRange (SyntaxBindingLambda _ l e) = killRange2 (SyntaxBindingLambda noRange) l e-  killRange (Ordinary e)                = killRange1 Ordinary e--instance KillRange Pattern where-  killRange (IdentP q)        = killRange1 IdentP q-  killRange (AppP p n)        = killRange2 AppP p n-  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 (WildP _)         = WildP noRange-  killRange (AbsurdP _)       = AbsurdP noRange-  killRange (AsP _ n p)       = killRange2 (AsP noRange) n p-  killRange (DotP _ o e)      = killRange1 (DotP noRange) o e-  killRange (LitP l)          = killRange1 LitP l-  killRange (QuoteP _)        = QuoteP noRange-  killRange (RecP _ fs)       = killRange1 (RecP noRange) fs--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) qs-  killRange (CompiledDataPragma _ q s ss)     = killRange1 (\q -> CompiledDataPragma noRange q s ss) q-  killRange (CompiledDeclareDataPragma _ q s) = killRange1 (\q -> CompiledDeclareDataPragma noRange q s) q-  killRange (CompiledTypePragma _ q s)        = killRange1 (\q -> CompiledTypePragma noRange q s) q-  killRange (CompiledPragma _ q s)            = killRange1 (\q -> CompiledPragma noRange q s) q-  killRange (CompiledExportPragma _ q s)      = killRange1 (\q -> CompiledExportPragma noRange q s) q-  killRange (CompiledEpicPragma _ q s)        = killRange1 (\q -> CompiledEpicPragma noRange q s) q-  killRange (CompiledJSPragma _ q s)          = killRange1 (\q -> CompiledJSPragma noRange q s) q-  killRange (CompiledUHCPragma _ q s)         = killRange1 (\q -> CompiledUHCPragma noRange q s) q-  killRange (CompiledDataUHCPragma _ q s ss)  = killRange1 (\q -> CompiledDataUHCPragma noRange q s ss) q-  killRange (HaskellCodePragma _ s)           = HaskellCodePragma noRange s-  killRange (StaticPragma _ q)                = killRange1 (StaticPragma noRange) q-  killRange (InlinePragma _ q)                = killRange1 (InlinePragma noRange) q-  killRange (ImportPragma _ s)                = ImportPragma noRange s-  killRange (ImportUHCPragma _ s)             = ImportUHCPragma noRange s-  killRange (ImpossiblePragma _)              = ImpossiblePragma noRange-  killRange (TerminationCheckPragma _ t)      = TerminationCheckPragma noRange (killRange t)-  killRange (CatchallPragma _)                = CatchallPragma noRange-  killRange (DisplayPragma _ lhs rhs)         = killRange2 (DisplayPragma noRange) lhs rhs-  killRange (NoPositivityCheckPragma _)       = NoPositivityCheckPragma noRange-  killRange (PolarityPragma _ q occs)         = killRange1 (\q -> PolarityPragma noRange q occs) q--instance KillRange RHS where-  killRange AbsurdRHS = AbsurdRHS-  killRange (RHS e)   = killRange1 RHS e--instance KillRange TypedBinding where-  killRange (TBind _ b e) = killRange2 (TBind noRange) b e-  killRange (TLet r ds)   = killRange2 TLet r ds--instance KillRange TypedBindings where-  killRange (TypedBindings _ t) = killRange1 (TypedBindings noRange) t--instance KillRange WhereClause where-  killRange NoWhere         = NoWhere-  killRange (AnyWhere d)    = killRange1 AnyWhere d-  killRange (SomeWhere n a d) = killRange3 SomeWhere n a d----------------------------------------------------------------------------- NFData instances---- | Ranges are not forced.--instance NFData Expr where-  rnf (Ident a)          = rnf a-  rnf (Lit a)            = rnf a-  rnf (QuestionMark _ a) = rnf a-  rnf (Underscore _ a)   = rnf a-  rnf (RawApp _ a)       = rnf a-  rnf (App _ a b)        = rnf a `seq` rnf b-  rnf (OpApp _ a b c)    = rnf a `seq` rnf b `seq` rnf c-  rnf (WithApp _ a b)    = rnf a `seq` rnf b-  rnf (HiddenArg _ a)    = rnf a-  rnf (InstanceArg _ a)  = rnf a-  rnf (Lam _ a b)        = rnf a `seq` rnf b-  rnf (AbsurdLam _ a)    = rnf a-  rnf (ExtendedLam _ a)  = rnf a-  rnf (Fun _ a b)        = rnf a `seq` rnf b-  rnf (Pi a b)           = rnf a `seq` rnf b-  rnf (Set _)            = ()-  rnf (Prop _)           = ()-  rnf (SetN _ a)         = rnf a-  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-  rnf (Absurd _)         = ()-  rnf (As _ a b)         = rnf a `seq` rnf b-  rnf (Dot _ a)          = rnf a-  rnf (ETel a)           = rnf a-  rnf (QuoteGoal _ a b)  = rnf a `seq` rnf b-  rnf (QuoteContext _)   = ()-  rnf (Quote _)          = ()-  rnf (QuoteTerm _)      = ()-  rnf (Tactic _ a b)     = rnf a `seq` rnf b-  rnf (Unquote _)        = ()-  rnf (DontCare a)       = rnf a-  rnf (Equal _ a b)      = rnf a `seq` rnf b---- | Ranges are not forced.--instance NFData Pattern where-  rnf (IdentP a) = rnf a-  rnf (QuoteP _) = ()-  rnf (AppP a b) = rnf a `seq` rnf b-  rnf (RawAppP _ a) = rnf a-  rnf (OpAppP _ a b c) = rnf a `seq` rnf b `seq` rnf c-  rnf (HiddenP _ a) = rnf a-  rnf (InstanceP _ a) = rnf a-  rnf (ParenP _ a) = rnf a-  rnf (WildP _) = ()-  rnf (AbsurdP _) = ()-  rnf (AsP _ a b) = rnf a `seq` rnf b-  rnf (DotP _ a b) = rnf a `seq` rnf b-  rnf (LitP a) = rnf a-  rnf (RecP _ a) = rnf a---- | Ranges are not forced.--instance NFData Declaration where-  rnf (TypeSig a b c)         = rnf a `seq` rnf b `seq` rnf c-  rnf (Field a b c)           = rnf a `seq` rnf b `seq` rnf c-  rnf (FunClause 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 (RecordSig _ a b c)     = rnf a `seq` rnf b `seq` rnf c-  rnf (Record _ a b c d e f g)  = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f `seq` rnf g-  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-  rnf (Mutual _ a)            = rnf a-  rnf (Abstract _ a)          = rnf a-  rnf (Private _ _ a)         = rnf a-  rnf (InstanceB _ a)         = rnf a-  rnf (Macro _ a)             = rnf a-  rnf (Postulate _ a)         = rnf a-  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 (UnquoteDecl _ a b)     = rnf a `seq` rnf b-  rnf (UnquoteDef _ a b)      = rnf a `seq` rnf b-  rnf (Pragma a)              = rnf a---- | Ranges are not forced.--instance NFData Pragma where-  rnf (OptionsPragma _ a)               = rnf a-  rnf (BuiltinPragma _ a b)             = rnf a `seq` rnf b-  rnf (RewritePragma _ a)               = rnf a-  rnf (CompiledDataPragma _ a b c)      = rnf a `seq` rnf b `seq` rnf c-  rnf (CompiledDeclareDataPragma _ a b) = rnf a `seq` rnf b-  rnf (CompiledTypePragma _ a b)        = rnf a `seq` rnf b-  rnf (CompiledPragma _ a b)            = rnf a `seq` rnf b-  rnf (CompiledExportPragma _ a b)      = rnf a `seq` rnf b-  rnf (CompiledEpicPragma _ a b)        = rnf a `seq` rnf b-  rnf (CompiledJSPragma _ a b)          = rnf a `seq` rnf b-  rnf (CompiledUHCPragma _ a b)         = rnf a `seq` rnf b-  rnf (CompiledDataUHCPragma _ a b c)   = rnf a `seq` rnf b `seq` rnf c-  rnf (HaskellCodePragma _ s)           = rnf s-  rnf (StaticPragma _ a)                = rnf a-  rnf (InlinePragma _ a)                = rnf a-  rnf (ImportPragma _ a)                = rnf a-  rnf (ImportUHCPragma _ a)             = rnf a-  rnf (ImpossiblePragma _)              = ()-  rnf (TerminationCheckPragma _ a)      = rnf a-  rnf (CatchallPragma _)                = ()-  rnf (DisplayPragma _ a b)             = rnf a `seq` rnf b-  rnf (NoPositivityCheckPragma _)       = ()-  rnf (PolarityPragma _ a b)            = rnf a `seq` rnf b---- | Ranges are not forced.--instance NFData a => NFData (TypedBindings' a) where-  rnf (TypedBindings _ a) = rnf a---- | Ranges are not forced.--instance NFData AsName where-  rnf (AsName a _) = rnf a---- | Ranges are not forced.--instance NFData a => NFData (TypedBinding' a) where-  rnf (TBind _ a b) = rnf a `seq` rnf b-  rnf (TLet _ a)    = rnf a---- | Ranges are not forced.--instance NFData ModuleApplication where-  rnf (SectionApp _ a b)    = rnf a `seq` rnf b-  rnf (RecordModuleIFS _ a) = rnf a---- | Ranges are not forced.--instance NFData a => NFData (OpApp a) where-  rnf (SyntaxBindingLambda _ a b) = rnf a `seq` rnf b-  rnf (Ordinary a)                = rnf a---- | Ranges are not forced.--instance NFData LHS where-  rnf (LHS a b c d)      = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-  rnf (Ellipsis _ a b c) = rnf a `seq` rnf b `seq` rnf c--instance NFData a => NFData (FieldAssignment' a) where-  rnf (FieldAssignment a b) = rnf a `seq` rnf b--instance NFData ModuleAssignment where-  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--instance NFData a => NFData (LamBinding' a) where-  rnf (DomainFree a b) = rnf a `seq` rnf b-  rnf (DomainFull a)   = rnf a--instance NFData BoundName where-  rnf (BName a b c) = rnf a `seq` rnf b `seq` rnf c--instance NFData a => NFData (RHS' a) where-  rnf AbsurdRHS = ()-  rnf (RHS a)   = rnf a+{-# LANGUAGE CPP #-}+{-# LANGUAGE ApplicativeDo #-}  -- see exprToPattern++{-| The concrete syntax is a raw representation of the program text+    without any desugaring at all.  This is what the parser produces.+    The idea is that if we figure out how to keep the concrete syntax+    around, it can be printed exactly as the user wrote it.+-}+module Agda.Syntax.Concrete+  ( -- * Expressions+    Expr(..)+  , OpApp(..), fromOrdinary+  , 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+  , Binder'(..)+  , Binder+  , mkBinder_+  , mkBinder+  , LamBinding+  , LamBinding'(..)+  , dropTypeAndModality+  , TypedBinding+  , TypedBinding'(..)+  , RecordAssignment+  , RecordAssignments+  , FieldAssignment, FieldAssignment'(..), nameFieldA, exprFieldA+  , ModuleAssignment(..)+  , BoundName(..), mkBoundName_, mkBoundName+  , TacticAttribute+  , TacticAttribute'(..)+  , Telescope, Telescope1+  , lamBindingsToTelescope+  , makePi+  , mkLam, mkLet, mkTLet+    -- * Declarations+  , Declaration(..)+  , isPragma+  , RecordDirective(..)+  , RecordDirectives+  , ModuleApplication(..)+  , TypeSignature+  , TypeSignatureOrInstanceBlock+  , ImportDirective, Using, ImportedName+  , Renaming, RenamingDirective, HidingDirective+  , AsName'(..), AsName+  , OpenShortHand(..), RewriteEqn, WithExpr+  , LHS(..), Pattern(..), LHSCore(..)+  , LamClause(..)+  , RHS, RHS'(..)+  , WhereClause, WhereClause'(..), WhereClause_(..), ExprWhere(..)+  , whereClause_+  , DoStmt(..)+  , Pragma(..)+  , Module(..)+  , ThingWithFixity(..)+  , HoleContent, HoleContent'(..)+  , spanAllowedBeforeModule+  , ungatherRecordDirectives+  )+  where++import Prelude hiding (null)++import Control.DeepSeq++import Data.Bifunctor   ( second )+import Data.DList       ( DList )+import qualified Data.DList as DL+import Data.Function    ( (&) )+import Data.Functor.Identity+import Data.Maybe+import Data.Text        ( Text )+-- import Data.Traversable ( forM )++import GHC.Generics     ( Generic )++import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Common.Aspect (NameKind)+import Agda.Syntax.Fixity+import Agda.Syntax.Literal++import Agda.Syntax.Concrete.Name+import qualified Agda.Syntax.Abstract.Name as A++import Agda.TypeChecking.Positivity.Occurrence++import Agda.Utils.Applicative ( forA )+import Agda.Utils.Either      ( maybeLeft )+import Agda.Utils.Lens+import Agda.Utils.List1       ( List1, pattern (:|) )+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++data OpApp e+  = SyntaxBindingLambda Range (List1 LamBinding) e+    -- ^ An abstraction inside a special syntax declaration+    --   (see Issue 358 why we introduce this).+  | Ordinary e+  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 (Functor, Foldable, Traversable, Show, Eq)++type FieldAssignment = FieldAssignment' Expr++data ModuleAssignment  = ModuleAssignment+                           { _qnameModA     :: QName+                           , _exprModA      :: [Expr]+                           , _importDirModA :: ImportDirective+                           }+  deriving Eq++type RecordAssignment  = Either FieldAssignment ModuleAssignment+type RecordAssignments = [RecordAssignment]++nameFieldA :: Lens' (FieldAssignment' a) Name+nameFieldA f r = f (_nameFieldA r) <&> \x -> r { _nameFieldA = x }++exprFieldA :: Lens' (FieldAssignment' a) a+exprFieldA f r = f (_exprFieldA r) <&> \x -> r { _exprFieldA = x }++-- UNUSED Liang-Ting Chen 2019-07-16+--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' ModuleAssignment ImportDirective+--importDirModA f r = f (_importDirModA r) <&> \x -> r { _importDirModA = x }++-- | Concrete expressions. Should represent exactly what the user wrote.+data Expr+  = Ident QName                                -- ^ ex: @x@+  | Lit Range Literal                          -- ^ ex: @1@ or @\"foo\"@+  | QuestionMark Range (Maybe Nat)             -- ^ ex: @?@ or @{! ... !}@+  | 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 (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 (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@+  | AbsurdLam Range Hiding                     -- ^ ex: @\\ ()@+  | ExtendedLam Range Erased+      (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 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 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+  | Unquote Range                              -- ^ ex: @unquote@, should be applied to a term of type @Term@+  | 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 Eq++type OpAppArgs = OpAppArgs' Expr+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 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 (Set1 A.Name)+      (List1 (NamedArg Pattern))           -- ^ eg: @p => p'@ for operator @_=>_@+                                           -- The 'QName' is possibly+                                           -- ambiguous, but it must+                                           -- correspond to one of+                                           -- the names in the set.+  | HiddenP Range (Named_ Pattern)         -- ^ @{p}@ or @{x = p}@+  | InstanceP Range (Named_ Pattern)       -- ^ @{{p}}@ or @{{x = p}}@+  | ParenP Range Pattern                   -- ^ @(p)@+  | WildP Range                            -- ^ @_@+  | AbsurdP Range                          -- ^ @()@+  | 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 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 Eq++data DoStmt+  = DoBind Range Pattern Expr [LamClause]   -- ^ @p ← e where cs@+  | DoThen Expr+  | DoLet Range (List1 Declaration)+  deriving Eq++-- | A Binder @x\@p@, the pattern is optional+data Binder' a = Binder+  { binderPattern    :: Maybe Pattern+  , binderNameOrigin :: BinderNameOrigin+  , binderName       :: a+  } deriving (Eq, Functor, Foldable, Traversable)++type Binder = Binder' BoundName++mkBinder_ :: Name -> Binder+mkBinder_ = mkBinder . mkBoundName_++mkBinder :: a -> Binder' a+mkBinder = Binder Nothing UserBinderName++-- | A lambda binding is either domain free or typed.++type LamBinding = LamBinding' TypedBinding+data LamBinding' a+  = DomainFree (NamedArg Binder)+    -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@ or @x\@p@ or @(p)@+  | DomainFull a+    -- ^ . @(xs : e)@ or @{xs : e}@+  deriving (Functor, Foldable, Traversable, Eq)++-- | Drop type annotations and lets from bindings.+dropTypeAndModality :: LamBinding -> [LamBinding]+dropTypeAndModality (DomainFull (TBind _ xs _)) =+  map (DomainFree . setModality defaultModality) $ List1.toList xs+dropTypeAndModality (DomainFull TLet{}) = []+dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x]++data BoundName = BName+  { boundName       :: Name+  , bnameFixity     :: Fixity'+  , bnameTactic     :: TacticAttribute+      -- ^ From @\@tactic@ attribute.+  , bnameIsFinite   :: Bool+      -- ^ The @\@finite@ cannot be parsed, it comes from the builtin @Partial@ only.+  }+  deriving Eq++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 empty False++-- | A typed binding.++type TypedBinding = TypedBinding' Expr++data TypedBinding' e+  = TBind Range (List1 (NamedArg Binder)) e+    -- ^ Binding @(x1\@p1 ... xn\@pn : A)@.+  | TLet  Range (List1 Declaration)+    -- ^ Let binding @(let Ds)@ or @(open M args)@.+  deriving (Functor, Foldable, Traversable, Eq)++-- | A telescope is a sequence of typed bindings. Bound variables are in scope+--   in later types.+type Telescope1 = List1 TypedBinding+type Telescope  = [TypedBinding]++-- | We can try to get a @Telescope@ from a @[LamBinding]@.+--   If we have a type annotation already, we're happy.+--   Otherwise we manufacture a binder with an underscore for the type.+lamBindingsToTelescope :: Range -> [LamBinding] -> Telescope+lamBindingsToTelescope r = fmap $ \case+  DomainFull ty -> ty+  DomainFree nm -> TBind r (List1.singleton nm) $ Underscore r Nothing++-- | Smart constructor for @Pi@: check whether the @Telescope@ is empty++makePi :: Telescope -> Expr -> Expr+makePi []     = id+makePi (b:bs) = Pi (b :| bs)++-- | Smart constructor for @Lam@: check for non-zero bindings.++mkLam :: Range -> [LamBinding] -> Expr -> Expr+mkLam r []     e = e+mkLam r (x:xs) e = Lam r (x :| xs) e++-- | Smart constructor for @Let@: check for non-zero let bindings.++mkLet :: Range -> [Declaration] -> Expr -> Expr+mkLet r []     e = e+mkLet r (d:ds) e = Let r (d :| ds) (Just e)++-- | Smart constructor for @TLet@: check for non-zero let bindings.++mkTLet :: Range -> [Declaration] -> Maybe (TypedBinding' e)+mkTLet r []     = Nothing+mkTLet r (d:ds) = Just $ TLet r (d :| ds)++{-| Left hand sides can be written in infix style. For example:++    > n + suc m = suc (n + m)+    > (f ∘ g) x = f (g x)++   We use fixity information to see which name is actually defined.+-}+data LHS = LHS  -- ^ Original pattern (including with-patterns), rewrite equations and with-expressions.+  { lhsOriginalPattern :: Pattern+    -- ^ e.g. @f ps | wps@+  , lhsRewriteEqn      :: [RewriteEqn]+    -- ^ @(rewrite e | with p <- e in eq)@ (many)+  , lhsWithExpr        :: [WithExpr]+    -- ^ @with e1 in eq | {e2} | ...@ (many)+  }+  deriving Eq++type RewriteEqn = RewriteEqn' () Name Pattern Expr+type WithExpr   = Named Name (Arg Expr)++-- | Processed (operator-parsed) intermediate form of the core @f ps@ of 'LHS'.+--   Corresponds to 'lhsOriginalPattern'.+data LHSCore+  = LHSHead  { lhsDefName      :: QName               -- ^ @f@+             , lhsPats         :: [NamedArg Pattern]  -- ^ @ps@+             }+  | LHSProj  { lhsDestructor   :: QName               -- ^ Record projection.+             , lhsPatsLeft     :: [NamedArg Pattern]  -- ^ Patterns for record indices (currently none).+             , lhsFocus        :: NamedArg LHSCore    -- ^ Main argument.+             , lhsPats         :: [NamedArg Pattern]  -- ^ More application patterns.+             }+  | LHSWith  { lhsHead         :: LHSCore+             , 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 Eq++type RHS = RHS' Expr+data RHS' e+  = AbsurdRHS -- ^ No right hand side because of absurd match.+  | RHS e+  deriving (Functor, Foldable, Traversable, Eq)++-- | @where@ block following a clause.+type WhereClause = WhereClause' [Declaration]++-- | 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 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 (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 :: Catchall+  }+  deriving Eq++-- | An expression followed by a where clause.+--   Currently only used to give better a better error message in interaction.+data ExprWhere = ExprWhere Expr WhereClause++-- | The things you are allowed to say when you shuffle names between name+--   spaces (i.e. in @import@, @namespace@, or @open@ declarations).+type ImportDirective = ImportDirective' Name Name+type Using           = Using'           Name Name+type Renaming        = Renaming'        Name Name+type RenamingDirective = RenamingDirective' Name Name+type HidingDirective   = HidingDirective'   Name Name  -- 'Hiding' is already taken++-- | An imported name can be a module or a defined name.+type ImportedName = ImportedName' Name Name++-- | The content of the @as@-clause of the import statement.+data AsName' a = AsName+  { asName  :: a+    -- ^ The \"as\" name.+  , asRange :: Range+    -- ^ The range of the \"as\" keyword.  Retained for highlighting purposes.+  }+  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'.+type AsName = AsName' (Either Expr Name)++{--------------------------------------------------------------------------+    Declarations+ --------------------------------------------------------------------------}++-- | Just type signatures.+type TypeSignature = Declaration++-- | Just field signatures+type FieldSignature = Declaration++-- | Just type signatures or instance blocks.+type TypeSignatureOrInstanceBlock = Declaration++-- | Isolated record directives parsed as Declarations+data RecordDirective+   = Induction (Ranged Induction)+       -- ^ Range of keyword @[co]inductive@.+   | Constructor Name IsInstance+   | Eta         (Ranged HasEta0)+       -- ^ Range of @[no-]eta-equality@ keyword.+   | PatternOrCopattern Range+       -- ^ If declaration @pattern@ is present, give its range.+   deriving (Eq, Show)++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.+-}++data Declaration+  = TypeSig ArgInfo TacticAttribute Name Expr+      -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)+  | FieldSig IsInstance TacticAttribute Name (Arg Expr)+  | 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 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 [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   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 KwRange [Declaration]+  | Macro       KwRange [Declaration]+  | Postulate   KwRange [TypeSignatureOrInstanceBlock]+  | Primitive   KwRange [TypeSignature]+  | Open        Range QName ImportDirective+  | Import      Range QName (Maybe AsName) !OpenShortHand ImportDirective+  | 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+  | Opaque      KwRange [Declaration]+    -- ^ @opaque ...@+  | Unfolding   KwRange [QName]+    -- ^ @unfolding ...@+  deriving Eq++-- | 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 QName [Expr]+    -- ^ @tel M exprs@ where @M exprs@ is a 'RawApp' just after parsing.+  | RecordModuleInstance Range QName+    -- ^ @M {{...}}@+  deriving Eq++data OpenShortHand = DoOpen | DontOpen+  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 (Ranged BackendName) String+  | CompilePragma               Range (Ranged BackendName) QName String+  | StaticPragma                Range QName+  | InlinePragma                Range Bool QName  -- ^ INLINE or NOINLINE++  | 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+    -- ^ For coinductive records, use pragma instead of regular+    --   @eta-equality@ definition (as it is might make Agda loop).+  | WarningOnUsage              Range QName Text+    -- ^ Applies to the named function+  | WarningOnImport             Range Text+    -- ^ Applies to the current module+  | InjectivePragma             Range QName+    -- ^ Mark a definition as injective for the pattern matching unifier.+  | 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+    -- ^ Applies to the following function clause.+  | 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+    -- ^ Applies to the following function (and all that are mutually recursive with it)+    --   or to the functions in the following mutual block.+  | NoPositivityCheckPragma     Range+    -- ^ Applies to the following data/record type or mutual block.+  | PolarityPragma              Range Name [Ranged Occurrence]+  | NoUniverseCheckPragma       Range+    -- ^ Applies to the following data/record type.+  | 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++---------------------------------------------------------------------------++-- | Modules: Top-level pragmas plus other top-level declarations.++data Module = Mod+  { modPragmas :: [Pragma]+  , modDecls   :: [Declaration]+  }++-- | Splits off allowed (= import) declarations before the first+--   non-allowed declaration.+--   After successful parsing, the first non-allowed declaration+--   should be a module declaration.+spanAllowedBeforeModule :: [Declaration] -> ([Declaration], [Declaration])+spanAllowedBeforeModule = span isAllowedBeforeModule+  where+    isAllowedBeforeModule (Pragma OptionsPragma{}) = True+    isAllowedBeforeModule (Pragma BuiltinPragma{}) = True+    isAllowedBeforeModule (Private _ _ ds) = all isAllowedBeforeModule ds+    isAllowedBeforeModule Import{}       = True+    isAllowedBeforeModule ModuleMacro{}  = True+    isAllowedBeforeModule Open{}         = True+    isAllowedBeforeModule _              = False++{--------------------------------------------------------------------------+    Things we parse but are not part of the Agda file syntax+ --------------------------------------------------------------------------}++-- | Extended content of an interaction hole.+data HoleContent' qn nm p e+  = HoleContentExpr    e                       -- ^ @e@+  | HoleContentRewrite [RewriteEqn' qn nm p e] -- ^ @(rewrite | invert) e0 | ... | en@+  deriving (Functor, Foldable, Traversable)++type HoleContent = HoleContent' () Name Pattern Expr++---------------------------------------------------------------------------+-- * Smart constructors+---------------------------------------------------------------------------++rawApp :: List1 Expr -> Expr+rawApp es@(e1 :| e2 : rest) = RawApp (getRange es) $ List2 e1 e2 rest+rawApp (e :| []) = e++rawAppP :: List1 Pattern -> Pattern+rawAppP ps@(p1 :| p2 : rest) = RawAppP (getRange ps) $ List2 p1 p2 rest+rawAppP (p :| []) = p++{--------------------------------------------------------------------------+    Views+ --------------------------------------------------------------------------}++-- | The 'Expr' is not an application.+data AppView = AppView Expr [NamedArg Expr]++appView :: Expr -> AppView+appView e = f (DL.toList ess)+  where+    (f, ess) = appView' 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)++-- | 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++removeParenP :: Pattern -> Pattern+removeParenP = \case+    ParenP _ p -> removeParenP p+    p -> p++-- | Observe the hiding status of an expression+observeHiding :: Expr -> WithHiding Expr+observeHiding = \case+  HiddenArg _   (Named Nothing e) -> WithHiding Hidden e+  InstanceArg _ (Named Nothing e) -> WithHiding (Instance NoOverlap) e+  e                               -> WithHiding NotHidden e++-- | Observe the relevance status of an expression+observeRelevance :: Expr -> (Relevance, Expr)+observeRelevance = \case+  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+observeModifiers e =+  let (rel, WithHiding hid e') = fmap observeHiding (observeRelevance e) in+  setRelevance rel $ setHiding hid $ defaultArg e'++returnExpr :: Expr -> Maybe Expr+returnExpr (Pi _ e)        = returnExpr e+returnExpr (Fun _ _  e)    = returnExpr e+returnExpr (Let _ _ e)     = returnExpr =<< e+returnExpr (Paren _ e)     = returnExpr e+returnExpr (Generalized e) = returnExpr e+returnExpr e               = pure e++-- | Turn an expression into a pattern. Fails if the expression is not a+--   valid pattern.++isPattern :: Expr -> Maybe Pattern+isPattern = exprToPattern (const Nothing)++-- | Turn an expression into a pattern, turning non-pattern subexpressions into 'WildP'.++exprToPatternWithHoles :: Expr -> Pattern+exprToPatternWithHoles = runIdentity . exprToPattern (Identity . WildP . getRange)++-- | Generic expression to pattern conversion.++exprToPattern :: Applicative m+  => (Expr -> m Pattern)  -- ^ Default result for non-pattern things.+  -> Expr                 -- ^ The expression to translate.+  -> m Pattern            -- ^ The translated pattern (maybe).+exprToPattern fallback = loop+  where+  loop = \case+    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+    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.+    e@(Lit _ LitFloat{}) -> fallback e+    Lit         r l      -> pure $ LitP r l+    HiddenArg   r e      -> HiddenP   r <$> traverse loop e+    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 $ singleton (e1, e2)+    Ellipsis    r        -> pure $ EllipsisP r Nothing+    e@(Rec kwr r es)+        -- We cannot translate record expressions with module parts.+      | 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+      p  <- loop e+      ps <- forA es $ \ e -> do -- ApplicativeDo+        p <- loop e+        pure $ defaultNamedArg $ WithP (getRange e) p   -- TODO #2822: Range!+      pure $ foldl AppP p ps+    e -> fallback e++  pushUnderBracesP :: Range -> (Pattern -> Pattern) -> (Pattern -> Pattern)+  pushUnderBracesP r f = \case+    HiddenP   _ p   -> HiddenP   r $ fmap f p+    InstanceP _ p   -> InstanceP r $ fmap f p+    p               -> f p++  pushUnderBracesE :: Range -> (Expr -> Pattern) -> (Expr -> Pattern)+  pushUnderBracesE r f = \case+    HiddenArg   _ p -> HiddenP   r $ fmap f p+    InstanceArg _ p -> InstanceP r $ fmap f p+    p               -> f p++isAbsurdP :: Pattern -> Maybe (Range, Hiding)+isAbsurdP = \case+  AbsurdP r      -> pure (r, NotHidden)+  AsP _ _      p -> isAbsurdP p+  ParenP _     p -> isAbsurdP p+  HiddenP   _ np -> (Hidden <$)              <$> isAbsurdP (namedThing np)+  InstanceP _ np -> (Instance YesOverlap <$) <$> isAbsurdP (namedThing np)+  _ -> Nothing++isBinderP :: Pattern -> Maybe Binder+isBinderP = \case+  IdentP _ qn+             -> mkBinder_ <$> isUnqualified qn+  WildP r    -> pure $ mkBinder_ $ 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++{--------------------------------------------------------------------------+    Instances+ --------------------------------------------------------------------------}++-- Null+------------------------------------------------------------------------++-- | A 'WhereClause' is 'null' when the @where@ keyword is absent.+--   An empty list of declarations does not count as 'null' here.++instance Null (WhereClause' a) where+  empty = NoWhere+  null NoWhere = True+  null AnyWhere{} = False+  null SomeWhere{} = False++instance Null WhereClause_ where+  empty = NoWhere_+  null NoWhere_ = True+  null AnyWhere_ = False+  null SomeWhere_ = False++-- Lenses+------------------------------------------------------------------------++instance LensHiding LamBinding where+  getHiding   (DomainFree x) = getHiding x+  getHiding   (DomainFull a) = getHiding a+  mapHiding f (DomainFree x) = DomainFree $ mapHiding f x+  mapHiding f (DomainFull a) = DomainFull $ mapHiding f a++instance LensHiding TypedBinding where+  getHiding (TBind _ (x :| _) _) = getHiding x   -- Slightly dubious+  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+  mapRelevance f (TBind r xs e) = TBind r (fmap (mapRelevance f) xs) e+  mapRelevance f b@TLet{}       = b++-- HasRange instances+------------------------------------------------------------------------++instance HasRange e => HasRange (OpApp e) where+  getRange = \case+    Ordinary e -> getRange e+    SyntaxBindingLambda r _ _ -> r++instance HasRange Expr where+  getRange = \case+      Ident x            -> getRange x+      Lit r _            -> r+      QuestionMark r _   -> r+      Underscore r _     -> r+      App r _ _          -> r+      RawApp r _         -> r+      OpApp r _ _ _      -> r+      WithApp r _ _      -> r+      Lam r _ _          -> r+      AbsurdLam r _      -> r+      ExtendedLam r _ _  -> r+      Fun r _ _          -> r+      Pi b e             -> fuseRange b e+      Let r _ _          -> r+      Paren r _          -> r+      IdiomBrackets r _  -> r+      DoBlock r _        -> r+      As 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+      Quote r            -> r+      QuoteTerm r        -> r+      Unquote r          -> r+      Tactic r _         -> r+      DontCare{}         -> noRange+      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++instance HasRange (TacticAttribute' a) where+  getRange = maybe noRange getRange . theTacticAttribute++instance HasRange TypedBinding where+  getRange (TBind r _ _) = r+  getRange (TLet r _)    = r++instance HasRange LamBinding where+  getRange (DomainFree x) = getRange x+  getRange (DomainFull b) = getRange b++instance HasRange BoundName where+  getRange = getRange . boundName++instance HasRange WhereClause where+  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 (RecordModuleInstance r _) = r++instance HasRange a => HasRange (FieldAssignment' a) where+  getRange (FieldAssignment a b) = fuseRange a b++instance HasRange ModuleAssignment where+  getRange (ModuleAssignment a b c) = fuseRange a b `fuseRange` c++instance HasRange RecordDirective where+  getRange (Induction a)          = getRange a+  getRange (Eta a    )            = getRange a+  getRange (Constructor a b)      = getRange (a, b)+  getRange (PatternOrCopattern r) = r++instance HasRange Declaration where+  getRange (TypeSig _ _ x t)       = fuseRange x t+  getRange (FieldSig _ _ x t)      = fuseRange x t+  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 (DataDef r _ _ _)       = r+  getRange (RecordSig r _ _ _ _)   = r+  getRange (RecordDef 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 (Import 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++instance HasRange LHSCore where+  getRange (LHSHead f ps)              = fuseRange f ps+  getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2+  getRange (LHSWith f wps ps)          = f `fuseRange` wps `fuseRange` ps+  getRange (LHSEllipsis r p)           = r++instance HasRange RHS where+  getRange AbsurdRHS = noRange+  getRange (RHS e)   = getRange e++instance HasRange LamClause where+  getRange (LamClause lhs rhs _) = getRange (lhs, rhs)++instance HasRange DoStmt where+  getRange (DoBind r _ _ _) = r+  getRange (DoThen e)       = getRange e+  getRange (DoLet r _)      = r++instance HasRange Pragma where+  getRange (OptionsPragma r _)               = r+  getRange (BuiltinPragma r _ _)             = r+  getRange (RewritePragma r _ _)             = r+  getRange (CompilePragma r _ _ _)           = r+  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+  getRange (TerminationCheckPragma r _)      = r+  getRange (NoCoverageCheckPragma r)         = r+  getRange (WarningOnUsage r _ _)            = r+  getRange (WarningOnImport r _)             = r+  getRange (CatchallPragma r)                = r+  getRange (DisplayPragma r _ _)             = r+  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 (AppP p q)         = fuseRange p q+  getRange (OpAppP r _ _ _)   = r+  getRange (RawAppP r _)      = r+  getRange (ParenP r _)       = r+  getRange (WildP r)          = r+  getRange (AsP r _ _)        = r+  getRange (AbsurdP r)        = r+  getRange (LitP r _)         = r+  getRange (QuoteP r)         = r+  getRange (HiddenP r _)      = r+  getRange (InstanceP r _)    = r+  getRange (DotP _kwr r _)    = r+  getRange (RecP _kwr r _)    = r+  getRange (EqualP r _)       = r+  getRange (EllipsisP r _)    = r+  getRange (WithP r _)        = r++-- SetRange instances+------------------------------------------------------------------------++instance SetRange Pattern where+  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+  setRange r (ParenP _ p)       = ParenP r p+  setRange r (WildP _)          = WildP r+  setRange r (AsP _ x p)        = AsP r (setRange r x) p+  setRange r (AbsurdP _)        = AbsurdP r+  setRange r (LitP _ l)         = LitP r l+  setRange r (QuoteP _)         = QuoteP r+  setRange r (HiddenP _ p)      = HiddenP r p+  setRange r (InstanceP _ p)    = InstanceP r p+  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++instance SetRange TypedBinding where+  setRange r (TBind _ xs e) = TBind r xs e+  setRange r (TLet _ ds)    = TLet r ds++-- KillRange instances+------------------------------------------------------------------------++instance KillRange a => KillRange (FieldAssignment' a) where+  killRange (FieldAssignment a b) = killRangeN FieldAssignment a b++instance KillRange ModuleAssignment where+  killRange (ModuleAssignment a b c) = killRangeN ModuleAssignment a b c++instance KillRange AsName where+  killRange (AsName n _) = killRangeN (flip AsName noRange) n++instance KillRange Binder where+  killRange (Binder a o b) = killRangeN Binder a o b++instance KillRange BoundName where+  killRange (BName n f t b) = killRangeN BName n f t b++instance KillRange RecordDirective where+  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)       = 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)              = 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) = killRangeN DomainFree b+  killRange (DomainFull t) = killRangeN DomainFull t++instance KillRange LHS where+  killRange (LHS p r w)  = killRangeN LHS p r w++instance KillRange LamClause where+  killRange (LamClause a b c) = killRangeN LamClause a b c++instance KillRange DoStmt where+  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 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) = killRangeN (SyntaxBindingLambda noRange) l e+  killRange (Ordinary e)                = killRangeN Ordinary e++instance KillRange Pattern where+  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)       = 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)     = 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)             = 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)+  killRange (NoCoverageCheckPragma _)         = NoCoverageCheckPragma noRange+  killRange (WarningOnUsage _ nm str)         = WarningOnUsage noRange (killRange nm) str+  killRange (WarningOnImport _ str)           = WarningOnImport noRange str+  killRange (CatchallPragma _)                = CatchallPragma noRange+  killRange (DisplayPragma _ lhs rhs)         = killRangeN (DisplayPragma noRange) lhs rhs+  killRange (EtaPragma _ q)                   = killRangeN (EtaPragma noRange) q+  killRange (NoPositivityCheckPragma _)       = NoPositivityCheckPragma noRange+  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)   = killRangeN RHS e++instance KillRange TypedBinding where+  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)        = killRangeN (AnyWhere noRange) d+  killRange (SomeWhere r e n a d) =+    killRangeN (SomeWhere noRange) e n a d++------------------------------------------------------------------------+-- NFData instances++-- | Ranges are not forced.++instance NFData Expr where+  rnf (Ident a)           = rnf a+  rnf (Lit _ a)           = rnf a+  rnf (QuestionMark _ a)  = rnf a+  rnf (Underscore _ a)    = rnf a+  rnf (RawApp _ a)        = rnf a+  rnf (App _ a b)         = rnf a `seq` rnf b+  rnf (OpApp _ a b c)     = rnf a `seq` rnf b `seq` rnf c+  rnf (WithApp _ a b)     = rnf a `seq` rnf b+  rnf (HiddenArg _ a)     = rnf a+  rnf (InstanceArg _ a)   = rnf a+  rnf (Lam _ a b)         = rnf a `seq` rnf b+  rnf (AbsurdLam _ a)     = rnf a+  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 (Let _ a b)         = rnf a `seq` rnf b+  rnf (Paren _ a)         = rnf a+  rnf (IdiomBrackets _ a) = rnf a+  rnf (DoBlock _ a)       = rnf a+  rnf (Absurd _)          = ()+  rnf (As _ a b)          = rnf a `seq` rnf b+  rnf (Dot _ a)           = rnf a+  rnf (DoubleDot _ a)     = rnf a+  rnf (Quote _)           = ()+  rnf (QuoteTerm _)       = ()+  rnf (Tactic _ a)        = rnf a+  rnf (Unquote _)         = ()+  rnf (DontCare a)        = rnf a+  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 b)     = rnf a `seq` rnf b+  rnf (QuoteP _)       = ()+  rnf (AppP a b)       = rnf a `seq` rnf b+  rnf (RawAppP _ a)    = rnf a+  rnf (OpAppP _ a b c) = rnf a `seq` rnf b `seq` rnf c+  rnf (HiddenP _ a)    = rnf a+  rnf (InstanceP _ a)  = rnf a+  rnf (ParenP _ a)     = rnf a+  rnf (WildP _)        = ()+  rnf (AbsurdP _)      = ()+  rnf (AsP _ a b)      = rnf a `seq` rnf b+  rnf (DotP _ _ a)     = rnf a+  rnf (LitP _ a)       = rnf a+  rnf (RecP _ _ a)     = rnf a+  rnf (EqualP _ es)    = rnf es+  rnf (EllipsisP _ mp) = rnf mp+  rnf (WithP _ a)      = rnf a++-- | Ranges are not forced.++instance NFData RecordDirective where+  rnf (Induction a)          = rnf a+  rnf (Eta a    )            = rnf a+  rnf (Constructor a b)      = rnf (a, b)+  rnf (PatternOrCopattern _) = ()++instance NFData Declaration where+  rnf (TypeSig a b c d)       = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (FieldSig a b c d)      = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  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 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 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 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+  rnf (Mutual _ a)            = rnf a+  rnf (InterleavedMutual _ a) = rnf a+  rnf (LoneConstructor _ a)   = rnf a+  rnf (Abstract _ a)          = rnf a+  rnf (Private _ _ a)         = rnf a+  rnf (InstanceB _ a)         = rnf a+  rnf (Macro _ a)             = rnf a+  rnf (Postulate _ a)         = rnf a+  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 _ 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++-- | Ranges are not forced.++instance NFData Pragma where+  rnf (OptionsPragma _ a)               = rnf a+  rnf (BuiltinPragma _ a b)             = rnf a `seq` rnf b+  rnf (RewritePragma _ _ a)             = rnf a+  rnf (CompilePragma _ a b c)           = rnf a `seq` rnf b `seq` rnf c+  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+  rnf (TerminationCheckPragma _ a)      = rnf a+  rnf (NoCoverageCheckPragma _)         = ()+  rnf (WarningOnUsage _ a b)            = rnf a `seq` rnf b+  rnf (WarningOnImport _ a)             = rnf a+  rnf (CatchallPragma _)                = ()+  rnf (DisplayPragma _ a b)             = rnf a `seq` rnf b+  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.++instance NFData AsName where+  rnf (AsName a _) = rnf a++-- | Ranges are not forced.++instance NFData a => NFData (TypedBinding' a) where+  rnf (TBind _ a b) = rnf a `seq` rnf b+  rnf (TLet _ a)    = rnf a++-- | Ranges are not forced.++instance NFData ModuleApplication where+  rnf (SectionApp _ a b c)       = rnf a `seq` rnf b `seq` rnf c+  rnf (RecordModuleInstance _ a) = rnf a++-- | Ranges are not forced.++instance NFData a => NFData (OpApp a) where+  rnf (SyntaxBindingLambda _ a b) = rnf a `seq` rnf b+  rnf (Ordinary a)                = rnf a++-- | Ranges are not forced.++instance NFData LHS where+  rnf (LHS a b c) = rnf a `seq` rnf b `seq` rnf c++instance NFData a => NFData (FieldAssignment' a) where+  rnf (FieldAssignment a b) = rnf a `seq` rnf b++instance NFData ModuleAssignment where+  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 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)++instance NFData a => NFData (LamBinding' a) where+  rnf (DomainFree a) = rnf a+  rnf (DomainFull a) = rnf a++instance NFData Binder where+  rnf (Binder a o b) = rnf (a, o, b)++instance NFData BoundName where+  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 = ()+  rnf (RHS a)   = rnf a++instance NFData DoStmt where+  rnf (DoBind _ p e w) = rnf (p, e, w)+  rnf (DoThen e)       = rnf e+  rnf (DoLet _ ds)     = rnf ds
+ src/full/Agda/Syntax/Concrete/Attribute.hs view
@@ -0,0 +1,277 @@++-- | Attributes: concrete syntax for ArgInfo, esp. modalities.++module Agda.Syntax.Concrete.Attribute where++import Prelude hiding (null)++import Control.Arrow (second)+import Control.Monad (foldM)++import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe++import Agda.Syntax.Common+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.Null++import Agda.Utils.Impossible++-- | An attribute is a modifier for `ArgInfo`.++data Attribute+  = RelevanceAttribute Relevance+  | QuantityAttribute  Quantity+  | TacticAttribute (Ranged Expr)+  | CohesionAttribute Cohesion+  | PolarityAttribute PolarityModality+  | LockAttribute      Lock+  deriving (Show)++instance HasRange Attribute where+  getRange = \case+    RelevanceAttribute r -> getRange r+    QuantityAttribute q  -> getRange q+    CohesionAttribute c  -> getRange c+    PolarityAttribute p  -> getRange p+    TacticAttribute e    -> getRange e+    LockAttribute l      -> NoRange++instance SetRange Attribute where+  setRange r = \case+    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++instance KillRange Attribute where+  killRange = \case+    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, LensModalPolarity a, LensLock a)++-- | Modifiers for 'Relevance'.++relevanceAttributeTable :: [(String, Relevance)]+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'.++quantityAttributeTable :: [(String, Quantity)]+quantityAttributeTable =+  [ ("0"      , Quantity0 $ Q0       noRange)+  , ("erased" , Quantity0 $ Q0Erased noRange)+  -- TODO: linearity+  -- , ("1"      , Quantity1 $ Q1       noRange)+  -- , ("linear" , Quantity1 $ Q1Linear noRange)+  , ("ω"      , Quantityω $ Qω       noRange)+  , ("plenty" , Quantityω $ QωPlenty noRange)+  ]+-- quantityAttributeTable = concat+--   [ map (, Quantity0) [ "0", "erased" ] -- , "static", "compile-time" ]+--   , map (, Quantityω) [ "ω", "plenty" ] -- , "dynamic", "runtime", "unrestricted", "abundant" ]+--   -- , map (, Quantity1)  [ "1", "linear" ]+--   -- , map (, Quantity01) [ "01", "affine" ]+--   ]++cohesionAttributeTable :: [(String, Cohesion)]+cohesionAttributeTable =+  [ ("♭"    , Flat)+  , ("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 LockOTick) [ "tick" ] -- @tick+  , map (, IsLock LockOLock) [ "lock" ] -- @lock+  ]+++-- | Concrete syntax for all attributes.++attributesMap :: Map String Attribute+attributesMap = Map.fromListWith __IMPOSSIBLE__ $ concat+  [ map (second RelevanceAttribute) relevanceAttributeTable+  , map (second QuantityAttribute)  quantityAttributeTable+  , map (second CohesionAttribute)  cohesionAttributeTable+  , map (second PolarityAttribute)  polarityAttributeTable+  , map (second LockAttribute)      lockAttributeTable+  ]++-- | Parsing a string into an attribute.++stringToAttribute :: String -> Maybe Attribute+stringToAttribute = (`Map.lookup` attributesMap)++-- | Parsing an expression into an attribute.++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.++setAttribute :: (LensAttribute a) => Attribute -> a -> a+setAttribute = \case+  RelevanceAttribute r -> setRelevance r+  QuantityAttribute  q -> setQuantity  q+  CohesionAttribute  c -> setCohesion  c+  PolarityAttribute  p -> setModalPolarity p+  LockAttribute      l -> setLock      l+  TacticAttribute t    -> id+++-- | Setting some attributes in left-to-right order.+--   Blindly overwrites previous settings.++setAttributes :: (LensAttribute a) => [Attribute] -> a -> a+setAttributes attrs arg = foldl' (flip setAttribute) arg attrs++---------------------------------------------------------------------------+-- * Applying attributes only if they have not been set already.+--   No overwriting.+---------------------------------------------------------------------------++-- | Setting 'Relevance' if unset.++setPristineRelevance :: (LensRelevance a) => Relevance -> a -> Maybe a+setPristineRelevance r a+  | null (getRelevance a) = Just $ setRelevance r a+  | otherwise = Nothing++-- | Setting 'Quantity' if unset.++setPristineQuantity :: (LensQuantity a) => Quantity -> a -> Maybe a+setPristineQuantity q a+  | noUserQuantity a = Just $ setQuantity q a+  | otherwise = Nothing++-- | Setting 'Cohesion' if unset.++setPristineCohesion :: (LensCohesion a) => Cohesion -> a -> Maybe a+setPristineCohesion 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+setPristineLock q a+  | getLock a == defaultLock = Just $ setLock q a+  | otherwise = Nothing++-- | Setting an unset attribute (to e.g. an 'Arg').++setPristineAttribute :: (LensAttribute a) => Attribute -> a -> Maybe a+setPristineAttribute = \case+  RelevanceAttribute r -> setPristineRelevance r+  QuantityAttribute  q -> setPristineQuantity  q+  CohesionAttribute  c -> setPristineCohesion  c+  PolarityAttribute  p -> setPristinePolarity  p+  LockAttribute      l -> setPristineLock      l+  TacticAttribute{}    -> Just++-- | Setting a list of unset attributes.++setPristineAttributes :: (LensAttribute a) => [Attribute] -> a -> Maybe a+setPristineAttributes attrs arg = foldM (flip setPristineAttribute) arg attrs++---------------------------------------------------------------------------+-- * Filtering attributes+---------------------------------------------------------------------------++isRelevanceAttribute :: Attribute -> Maybe Relevance+isRelevanceAttribute = \case+  RelevanceAttribute q -> Just q+  _ -> Nothing++isQuantityAttribute :: Attribute -> Maybe Quantity+isQuantityAttribute = \case+  QuantityAttribute q -> Just q+  _ -> Nothing++isTacticAttribute :: Attribute -> TacticAttribute+isTacticAttribute = C.TacticAttribute . \case+  TacticAttribute t -> Just t+  _ -> Nothing++relevanceAttributes :: [Attribute] -> [Attribute]+relevanceAttributes = filter $ isJust . isRelevanceAttribute++quantityAttributes :: [Attribute] -> [Attribute]+quantityAttributes = filter $ isJust . isQuantityAttribute++tacticAttributes :: [Attribute] -> [Attribute]+tacticAttributes = filter $ isJust . C.theTacticAttribute . isTacticAttribute
src/full/Agda/Syntax/Concrete/Definitions.hs view
@@ -1,1553 +1,1568 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.------   * Attach fixity and syntax declarations to the definition they refer to.------   * Distribute the following attributes to the individual definitions:---       @abstract@,---       @instance@,---       @postulate@,---       @primitive@,---       @private@,---       termination pragmas.------   * Gather the function clauses belonging to one function definition.------   * Expand ellipsis @...@ in function clauses following @with@.------   * Infer mutual blocks.---     A block starts when a lone signature is encountered, and ends when---     all lone signatures have seen their definition.------   * Report basic well-formedness error,---     when one of the above transformation fails.--module Agda.Syntax.Concrete.Definitions-    ( NiceDeclaration(..)-    , NiceConstructor, NiceTypeSignature-    , Clause(..)-    , DeclarationException(..)-    , Nice, runNice-    , niceDeclarations-    , notSoNiceDeclarations-    , niceHasAbstract-    , Measure-    ) where--import Prelude hiding (null)--import Control.Arrow ((***))-import Control.Applicative hiding (empty)-import Control.Monad.State--#if __GLASGOW_HASKELL__ <= 708-import Data.Foldable ( foldMap )-#endif--import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe-import Data.Semigroup ( Semigroup, Monoid, (<>), mempty, mappend )-import Data.List as List hiding (null)-import qualified Data.Set as Set-import Data.Traversable (Traversable, traverse)-import Data.Typeable (Typeable)--import Agda.Syntax.Concrete-import Agda.Syntax.Common hiding (TerminationCheck())-import qualified Agda.Syntax.Common as Common-import Agda.Syntax.Position-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Concrete.Pretty ()--import Agda.TypeChecking.Positivity.Occurrence--import Agda.Utils.Except ( Error(strMsg), MonadError(throwError) )-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List (caseList, headMaybe, isSublistOf)-import Agda.Utils.Monad-import Agda.Utils.Null-import qualified Agda.Utils.Pretty as Pretty-import Agda.Utils.Pretty hiding ((<>))-import Agda.Utils.Singleton-import Agda.Utils.Tuple-import Agda.Utils.Update--#include "undefined.h"-import Agda.Utils.Impossible--{---------------------------------------------------------------------------    Types- --------------------------------------------------------------------------}--{-| The nice declarations. No fixity declarations and function definitions are-    contained in a single constructor instead of spread out between type-    signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@-    modifiers have been distributed to the individual declarations.--    Observe the order of components:--      Range-      Fixity'-      Access-      IsAbstract-      IsInstance-      TerminationCheck-      PositivityCheck--      further attributes--      (Q)Name--      content (Expr, Declaration ...)--}-data NiceDeclaration-  = Axiom Range Fixity' Access IsAbstract IsInstance ArgInfo (Maybe [Occurrence]) Name Expr-      -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.-      ---      --   'ArgInfo' argument: Axioms and functions can be declared irrelevant.-      --   ('Hiding' should be 'NotHidden'.)-      ---      --   @Maybe [Occurrence]@ argument: Polarities can be assigned to identifiers.-  | NiceField Range Fixity' Access IsAbstract IsInstance Name (Arg Expr)-  | PrimitiveFunction Range Fixity' Access IsAbstract Name Expr-  | NiceMutual Range TerminationCheck PositivityCheck [NiceDeclaration]-  | NiceModule Range Access IsAbstract QName Telescope [Declaration]-  | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective-  | NiceOpen Range QName ImportDirective-  | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective-  | NicePragma Range Pragma-  | NiceRecSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr-  | NiceDataSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr-  | NiceFunClause Range Access IsAbstract TerminationCheck Catchall Declaration-    -- ^ An uncategorized function clause, could be a function clause-    --   without type signature or a pattern lhs (e.g. for irrefutable let).-    --   The 'Declaration' is the actual 'FunClause'.-  | FunSig Range Fixity' Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck Name Expr-  | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]-      -- ^ Block of function clauses (we have seen the type signature before).-      --   The 'Declaration's are the original declarations that were processed-      --   into this 'FunDef' and are only used in 'notSoNiceDeclaration'.-  | DataDef Range Fixity' IsAbstract PositivityCheck Name [LamBinding] [NiceConstructor]-  | RecDef Range Fixity' IsAbstract PositivityCheck Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (ThingWithFixity Name, IsInstance)) [LamBinding] [NiceDeclaration]-  | NicePatternSyn Range Fixity' Name [Arg Name] Pattern-  | NiceUnquoteDecl Range [Fixity'] Access IsAbstract IsInstance TerminationCheck [Name] Expr-  | NiceUnquoteDef Range [Fixity'] Access IsAbstract TerminationCheck [Name] Expr-  deriving (Typeable, Show)--type TerminationCheck = Common.TerminationCheck Measure---- | Termination measure is, for now, a variable name.-type Measure = Name--type Catchall = Bool---- | Only 'Axiom's.-type NiceConstructor = NiceTypeSignature---- | Only 'Axiom's.-type NiceTypeSignature  = NiceDeclaration---- | 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 (Typeable, Show)---- | The exception type.-data DeclarationException-        = MultipleFixityDecls [(Name, [Fixity'])]-        | MultiplePolarityPragmas [Name]-        | InvalidName Name-        | DuplicateDefinition Name-        | MissingDefinition Name-        | MissingWithClauses Name-        | MissingTypeSignature LHS -- Andreas 2012-06-02: currently unused, remove after a while -- Fredrik 2012-09-20: now used, can we keep it?-        | MissingDataSignature Name-        | WrongDefinition Name DataRecOrFun DataRecOrFun-        | WrongParameters Name-        | NotAllowedInMutual NiceDeclaration-        | UnknownNamesInFixityDecl [Name]-        | UnknownNamesInPolarityPragmas [Name]-        | PolarityPragmasButNotPostulates [Name]-        | Codata Range-        | DeclarationPanic String-        | UselessPrivate Range-        | UselessAbstract Range-        | UselessInstance Range-        | WrongContentBlock KindOfBlock Range-        | AmbiguousFunClauses LHS [Name] -- ^ in a mutual block, a clause could belong to any of the @[Name]@ type signatures-        | InvalidTerminationCheckPragma Range-        | InvalidMeasureMutual Range-          -- ^ In a mutual block, all or none need a MEASURE pragma.-          --   Range is of mutual block.-        | PragmaNoTerminationCheck Range-          -- ^ Pragma @{-# NO_TERMINATION_CHECK #-}@ has been replaced-          --   by {-# TERMINATING #-} and {-# NON_TERMINATING #-}.-        | InvalidCatchallPragma Range-        | UnquoteDefRequiresSignature [Name]-        | BadMacroDef NiceDeclaration-        | InvalidNoPositivityCheckPragma Range--    deriving (Typeable)---- | Several declarations expect only type signatures as sub-declarations.  These are:-data KindOfBlock-  = PostulateBlock  -- ^ @postulate@-  | PrimitiveBlock  -- ^ @primitive@.  Ensured by parser.-  | InstanceBlock   -- ^ @instance@.  Actually, here all kinds of sub-declarations are allowed a priori.-  | FieldBlock      -- ^ @field@.  Ensured by parser.-  | DataBlock       -- ^ @data ... where@.  Here we got a bad error message for Agda-2.5 (Issue 1698).-  deriving (Typeable, Eq, Ord, Show)---instance HasRange DeclarationException where-  getRange (MultipleFixityDecls xs)             = getRange (fst $ head xs)-  getRange (MultiplePolarityPragmas xs)         = getRange (head xs)-  getRange (InvalidName x)                      = getRange x-  getRange (DuplicateDefinition x)              = getRange x-  getRange (MissingDefinition x)                = getRange x-  getRange (MissingWithClauses x)               = getRange x-  getRange (MissingTypeSignature x)             = getRange x-  getRange (MissingDataSignature x)             = getRange x-  getRange (WrongDefinition x k k')             = getRange x-  getRange (WrongParameters x)                  = getRange x-  getRange (AmbiguousFunClauses lhs xs)         = getRange lhs-  getRange (NotAllowedInMutual x)               = getRange x-  getRange (UnknownNamesInFixityDecl xs)        = getRange . head $ xs-  getRange (UnknownNamesInPolarityPragmas xs)   = getRange . head $ xs-  getRange (PolarityPragmasButNotPostulates xs) = getRange . head $ xs-  getRange (Codata r)                           = r-  getRange (DeclarationPanic _)                 = noRange-  getRange (UselessPrivate r)                   = r-  getRange (UselessAbstract r)                  = r-  getRange (UselessInstance r)                  = r-  getRange (WrongContentBlock _ r)              = r-  getRange (InvalidTerminationCheckPragma r)    = r-  getRange (InvalidMeasureMutual r)             = r-  getRange (PragmaNoTerminationCheck r)         = r-  getRange (InvalidCatchallPragma r)            = r-  getRange (UnquoteDefRequiresSignature x)      = getRange x-  getRange (BadMacroDef d)                      = getRange d-  getRange (InvalidNoPositivityCheckPragma r)   = r--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 (NiceOpen r _ _)                  = r-  getRange (NiceImport r _ _ _ _)            = r-  getRange (NicePragma r _)                  = r-  getRange (PrimitiveFunction r _ _ _ _ _)   = r-  getRange (FunSig r _ _ _ _ _ _ _ _ _)      = r-  getRange (FunDef r _ _ _ _ _ _)            = r-  getRange (DataDef r _ _ _ _ _ _)           = r-  getRange (RecDef r _ _ _ _ _ _ _ _ _)      = r-  getRange (NiceRecSig r _ _ _ _ _ _ _)      = r-  getRange (NiceDataSig r _ _ _ _ _ _ _)     = r-  getRange (NicePatternSyn r _ _ _ _)        = r-  getRange (NiceFunClause r _ _ _ _ _)       = r-  getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r-  getRange (NiceUnquoteDef r _ _ _ _ _ _)    = r--instance Error DeclarationException where-  strMsg = DeclarationPanic---- These error messages can (should) be terminated by a dot ".",--- there is no error context printed after them.-instance Pretty DeclarationException where-  pretty (MultipleFixityDecls xs) =-    sep [ fsep $ pwords "Multiple fixity or syntax declarations for"-        , vcat $ map f xs-        ]-      where-        f (x, fs) = pretty x Pretty.<> text ": " <+> fsep (map pretty fs)-  pretty (MultiplePolarityPragmas xs) = fsep $-    pwords "Multiple polarity pragmas for" ++ map pretty xs-  pretty (InvalidName x) = fsep $-    pwords "Invalid name:" ++ [pretty x]-  pretty (DuplicateDefinition x) = fsep $-    pwords "Duplicate definition of" ++ [pretty x]-  pretty (MissingDefinition x) = fsep $-    pwords "Missing definition for" ++ [pretty x]-  pretty (MissingWithClauses x) = fsep $-    pwords "Missing with-clauses for function" ++ [pretty x]-  pretty (MissingTypeSignature x) = fsep $-    pwords "Missing type signature for left hand side" ++ [pretty x]-  pretty (MissingDataSignature x) = fsep $-    pwords "Missing type signature for " ++ [pretty x]-  pretty (WrongDefinition x k k') = fsep $ pretty x :-    pwords ("has been declared as a " ++ show k ++-      ", but is being defined as a " ++ show k')-  pretty (WrongParameters x) = fsep $-    pwords "List of parameters does not match previous signature for" ++ [pretty x]-  pretty (AmbiguousFunClauses lhs xs) = sep-    [ fsep $-        pwords "More than one matching type signature for left hand side " ++ [pretty lhs] ++-        pwords "it could belong to any of:"-    , vcat $ map (pretty . PrintRange) xs-    ]-  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):" ++ 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):" ++ map pretty xs-  pretty (PolarityPragmasButNotPostulates xs) = fsep $-    pwords "Polarity pragmas have been given for the following identifiers which are not postulates:" ++ 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 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 (WrongContentBlock b _)      = fsep . pwords $-    case b of-      PostulateBlock -> "A postulate block can only contain type signatures, possibly under keyword instance"-      DataBlock -> "A data definition can only contain type signatures, possibly under keyword instance"-      _ -> __IMPOSSIBLE__-  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 (InvalidTerminationCheckPragma _) = fsep $-    pwords "Termination checking pragmas can only precede a mutual block or a function definition."-  pretty (InvalidMeasureMutual _) = fsep $-    pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."-  pretty (InvalidCatchallPragma _) = fsep $-    pwords "The CATCHALL pragma can only preceed a function clause."-  pretty (UnquoteDefRequiresSignature xs) = fsep $-    pwords "Missing type signatures for unquoteDef" ++ map pretty xs-  pretty (BadMacroDef nd) = fsep $-    [text $ declName nd] ++ pwords "are not allowed in macro blocks"-  pretty (NotAllowedInMutual nd) = fsep $-    [text $ declName nd] ++ pwords "are not allowed in mutual blocks"-  pretty (Codata _) = text $-    "The codata construction has been removed. " ++-    "Use the INFINITY builtin instead."-  pretty (DeclarationPanic s) = text s-  pretty (InvalidNoPositivityCheckPragma _) = fsep $-    pwords "No positivity checking pragmas can only precede a mutual block or a data/record definition."--declName :: NiceDeclaration -> String-declName Axiom{}             = "Postulates"-declName NiceField{}         = "Fields"-declName NiceMutual{}        = "Mutual blocks"-declName NiceModule{}        = "Modules"-declName NiceModuleMacro{}   = "Modules"-declName NiceOpen{}          = "Open declarations"-declName NiceImport{}        = "Import statements"-declName NicePragma{}        = "Pragmas"-declName PrimitiveFunction{} = "Primitive declarations"-declName NicePatternSyn{}    = "Pattern synonyms"-declName NiceUnquoteDecl{}   = "Unquoted declarations"-declName NiceUnquoteDef{}    = "Unquoted definitions"-declName NiceRecSig{}        = "Records"-declName NiceDataSig{}       = "Data types"-declName NiceFunClause{}     = "Functions without a type signature"-declName FunSig{}            = "Type signatures"-declName FunDef{}            = "Function definitions"-declName RecDef{}            = "Records"-declName DataDef{}           = "Data types"--{---------------------------------------------------------------------------    The niceifier- --------------------------------------------------------------------------}--data InMutual-  = InMutual    -- ^ we are nicifying a mutual block-  | NotInMutual -- ^ we are nicifying decls not in a mutual block-    deriving (Eq, Show)---- | The kind of the forward declaration, remembering the parameters.--data DataRecOrFun-  = DataName PositivityCheck Params  -- ^ name of a data with parameters-  | RecName  PositivityCheck Params  -- ^ name of a record with parameters-  | FunName  TerminationCheck        -- ^ name of a function---- Ignore pragmas when checking equality-instance Eq DataRecOrFun where-  DataName _ p == DataName _ q = p == q-  RecName  _ p == RecName  _ q = p == q-  FunName  _   == FunName  _   = True-  _            == _            = False--type Params = [Hiding]--instance Show DataRecOrFun where-  show (DataName _ n) = "data type" --  "with " ++ show n ++ " visible parameters"-  show (RecName _ n)  = "record type" -- "with " ++ show n ++ " visible parameters"-  show (FunName{})    = "function"--isFunName :: DataRecOrFun -> Bool-isFunName (FunName{}) = True-isFunName _           = False--sameKind :: DataRecOrFun -> DataRecOrFun -> Bool-sameKind DataName{} DataName{} = True-sameKind RecName{} RecName{} = True-sameKind FunName{} FunName{} = True-sameKind _ _ = False--terminationCheck :: DataRecOrFun -> TerminationCheck-terminationCheck (FunName tc) = tc-terminationCheck _            = TerminationCheck--positivityCheck :: DataRecOrFun -> PositivityCheck-positivityCheck (DataName pc _) = pc-positivityCheck (RecName pc _)  = pc-positivityCheck _               = True---- | Check that declarations in a mutual block are consistently---   equipped with MEASURE pragmas, or whether there is a---   NO_TERMINATION_CHECK pragma.-combineTermChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck-combineTermChecks r tcs = loop tcs where-  loop []         = return TerminationCheck-  loop (tc : tcs) = do-    let failure r = throwError $ InvalidMeasureMutual r-    tc' <- loop tcs-    case (tc, tc') of-      (TerminationCheck      , tc'                   ) -> return tc'-      (tc                    , TerminationCheck      ) -> return tc-      (NonTerminating        , NonTerminating        ) -> return NonTerminating-      (NoTerminationCheck    , NoTerminationCheck    ) -> return NoTerminationCheck-      (NoTerminationCheck    , Terminating           ) -> return Terminating-      (Terminating           , NoTerminationCheck    ) -> return Terminating-      (Terminating           , Terminating           ) -> return Terminating-      (TerminationMeasure{}  , TerminationMeasure{}  ) -> return tc-      (TerminationMeasure r _, NoTerminationCheck    ) -> failure r-      (TerminationMeasure r _, Terminating           ) -> failure r-      (NoTerminationCheck    , TerminationMeasure r _) -> failure r-      (Terminating           , TerminationMeasure r _) -> failure r-      (TerminationMeasure r _, NonTerminating        ) -> failure r-      (NonTerminating        , TerminationMeasure r _) -> failure r-      (NoTerminationCheck    , NonTerminating        ) -> failure r-      (Terminating           , NonTerminating        ) -> failure r-      (NonTerminating        , NoTerminationCheck    ) -> failure r-      (NonTerminating        , Terminating           ) -> failure r----- | Nicifier monad.--type Nice = StateT NiceEnv (Either DeclarationException)---- | Nicifier state.--data NiceEnv = NiceEnv-  { _loneSigs :: LoneSigs-    -- ^ Lone type signatures that wait for their definition.-  , _termChk  :: TerminationCheck-    -- ^ Termination checking pragma waiting for a definition.-  , _posChk   :: PositivityCheck-    -- ^ Positivity checking pragma waiting for a definition.-  , _catchall :: Catchall-    -- ^ Catchall pragma waiting for a function clause.-  , fixs     :: Fixities-  , pols     :: Polarities-  }--type LoneSigs   = Map Name DataRecOrFun-type Fixities   = Map Name Fixity'-type Polarities = Map Name [Occurrence]---- | Initial nicifier state.--initNiceEnv :: NiceEnv-initNiceEnv = NiceEnv-  { _loneSigs = empty-  , _termChk  = TerminationCheck-  , _posChk   = True-  , _catchall = False-  , fixs      = empty-  , pols      = empty-  }---- * Handling the lone signatures, stored to infer mutual blocks.---- | Lens for field '_loneSigs'.--loneSigs :: Lens' LoneSigs NiceEnv-loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }---- | Adding a lone signature to the state.--addLoneSig :: Name -> DataRecOrFun -> Nice ()-addLoneSig x k = loneSigs %== \ s -> do-   let (mr, s') = Map.insertLookupWithKey (\ k new old -> new) x k s-   case mr of-     Nothing -> return s'-     Just{}  -> throwError $ DuplicateDefinition x---- | Remove a lone signature from the state.--removeLoneSig :: Name -> Nice ()-removeLoneSig x = loneSigs %= Map.delete x---- | Search for forward type signature.--getSig :: Name -> Nice (Maybe DataRecOrFun)-getSig x = Map.lookup x <$> use loneSigs---- | Check that no lone signatures are left in the state.--noLoneSigs :: Nice Bool-noLoneSigs = null <$> use loneSigs---- | Ensure that all forward declarations have been given a definition.--checkLoneSigs :: [(Name, a)] -> Nice ()-checkLoneSigs xs =-  case xs of-    []       -> return ()-    (x, _):_ -> throwError $ MissingDefinition x---- | Lens for field '_termChk'.--terminationCheckPragma :: Lens' TerminationCheck NiceEnv-terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }--withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a-withTerminationCheckPragma tc f = do-  tc_old <- use terminationCheckPragma-  terminationCheckPragma .= tc-  result <- f-  terminationCheckPragma .= tc_old-  return result---- | Lens for field '_posChk'.--positivityCheckPragma :: Lens' PositivityCheck NiceEnv-positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }--withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a-withPositivityCheckPragma pc f = do-  pc_old <- use positivityCheckPragma-  positivityCheckPragma .= pc-  result <- f-  positivityCheckPragma .= pc_old-  return result---- | Lens for field '_catchall'.--catchallPragma :: Lens' Catchall NiceEnv-catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }---- | Get current catchall pragma, and reset it for the next clause.--popCatchallPragma :: Nice Catchall-popCatchallPragma = do-  ca <- use catchallPragma-  catchallPragma .= False-  return ca--withCatchallPragma :: Catchall -> Nice a -> Nice a-withCatchallPragma ca f = do-  ca_old <- use catchallPragma-  catchallPragma .= ca-  result <- f-  catchallPragma .= ca_old-  return result---- | Check whether name is not "_" and return its fixity.-getFixity :: Name -> Nice Fixity'-getFixity x = Map.findWithDefault noFixity' x <$> gets fixs -- WAS: defaultFixity'---- | Fail if the name is @_@. Otherwise the name's polarity, if any,--- is removed from the state and returned.-getPolarity :: Name -> Nice (Maybe [Occurrence])-getPolarity x = do-  p <- gets (Map.lookup x . pols)-  modify (\s -> s { pols = Map.delete x (pols s) })-  return p--runNice :: Nice a -> Either DeclarationException a-runNice nice = nice `evalStateT` initNiceEnv--data DeclKind-    = LoneSig DataRecOrFun Name-    | LoneDefs DataRecOrFun [Name]-    | OtherDecl-  deriving (Eq, Show)--declKind :: NiceDeclaration -> DeclKind-declKind (FunSig _ _ _ _ _ _ _ tc x _)    = LoneSig (FunName tc) x-declKind (NiceRecSig _ _ _ _ pc x pars _) = LoneSig (RecName pc $ parameters pars) x-declKind (NiceDataSig _ _ _ _ pc x pars _)= LoneSig (DataName pc $ parameters pars) x-declKind (FunDef _ _ _ _ tc x _)          = LoneDefs (FunName tc) [x]-declKind (DataDef _ _ _ pc x pars _)      = LoneDefs (DataName pc $ parameters pars) [x]-declKind (RecDef _ _ _ pc x _ _ _ pars _) = LoneDefs (RecName pc $ parameters pars) [x]-declKind (NiceUnquoteDef _ _ _ _ tc xs _) = LoneDefs (FunName tc) 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 NiceUnquoteDecl{}                = OtherDecl---- | Compute visible parameters of a data or record signature or definition.-parameters :: [LamBinding] -> Params-parameters = List.concat . List.map numP where-  numP (DomainFree i _) = [argInfoHiding i]-  numP (DomainFull (TypedBindings _ (Arg i (TBind _ xs _)))) = List.replicate (length xs) $ argInfoHiding i-  numP (DomainFull (TypedBindings _ (Arg _ TLet{})))         = []---- | Main.-niceDeclarations :: [Declaration] -> Nice [NiceDeclaration]-niceDeclarations ds = do-  -- Get fixity and syntax declarations.-  (fixs, polarities) <- fixitiesAndPolarities ds-  let declared    = Set.fromList (concatMap declaredNames ds)-      unknownFixs = Map.keysSet fixs       Set.\\ declared-      unknownPols = Map.keysSet polarities Set.\\ declared-  case (Set.null unknownFixs, Set.null unknownPols) of-    -- If we have fixity/syntax decls for names not declared-    -- in the current scope, fail.-    (False, _)   -> throwError $ UnknownNamesInFixityDecl-                                   (Set.toList unknownFixs)-    -- Fail if there are polarity pragmas with undeclared names.-    (_, False)   -> throwError $ UnknownNamesInPolarityPragmas-                                   (Set.toList unknownPols)-    (True, True) -> localState $ do-      -- Run the nicifier in an initial environment of fixity decls-      -- and polarities.-      put $ initNiceEnv { fixs = fixs, pols = polarities }-      ds <- nice ds-      -- Check that every polarity pragma was used.-      unusedPolarities <- gets (Map.keys . pols)-      unless (null unusedPolarities) $ do-        throwError $ PolarityPragmasButNotPostulates unusedPolarities-      -- Check that every signature got its definition.-      checkLoneSigs . Map.toList =<< use loneSigs-      -- Note that loneSigs is ensured to be empty.-      -- (Important, since inferMutualBlocks also uses loneSigs state).-      inferMutualBlocks ds-  where-    -- Compute the names defined in a declaration.-    -- We stay in the current scope, i.e., do not go into modules.-    declaredNames :: Declaration -> [Name]-    declaredNames d = case d of-      TypeSig _ x _        -> [x]-      Field _ x _          -> [x]-      FunClause (LHS p [] [] []) _ _ _-        | IdentP (QName x) <- removeSingletonRawAppP p-                           -> [x]-      FunClause{}          -> []-      DataSig _ _ x _ _    -> [x]-      Data _ _ x _ _ cs    -> x : concatMap declaredNames cs-      RecordSig _ x _ _    -> [x]-      Record _ x _ _ c _ _ _ -> x : foldMap (:[]) (fst <$> c)-      Infix _ _            -> []-      Syntax _ _           -> []-      PatternSyn _ x _ _   -> [x]-      Mutual    _ ds       -> concatMap declaredNames ds-      Abstract  _ ds       -> concatMap declaredNames ds-      Private _ _ ds       -> concatMap declaredNames ds-      InstanceB _ ds       -> concatMap declaredNames ds-      Macro     _ ds       -> concatMap declaredNames ds-      Postulate _ ds       -> concatMap declaredNames ds-      Primitive _ ds       -> concatMap declaredNames ds-      Open{}               -> []-      Import{}             -> []-      ModuleMacro{}        -> []-      Module{}             -> []-      UnquoteDecl _ xs _   -> xs-      UnquoteDef{}         -> []-      Pragma{}             -> []--    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]-    inferMutualBlocks [] = return []-    inferMutualBlocks (d : ds) =-      case declKind d of-        OtherDecl    -> (d :) <$> inferMutualBlocks ds-        LoneDefs _ xs -> __IMPOSSIBLE__-        LoneSig k x  -> do-          addLoneSig x k-          ((tcs, pcs), (ds0, ds1)) <- untilAllDefined ([terminationCheck k], [positivityCheck k]) ds-          tc <- combineTermChecks (getRange d) tcs--          -- Record modules are, for performance reasons, not always-          -- placed in mutual blocks.--          -- ASR (01 January 2016): If the record module has a-          -- NO_POSITIVITY_CHECK pragma, it is placed in a mutual-          -- block. See Issue 1760.-          let prefix :: [NiceDeclaration] -> [NiceDeclaration]-              prefix = case (d, ds0) of-                (NiceRecSig{}, [r@(RecDef _ _ _ True _ _ _ _ _ _)]) -> ([d, r] ++)-                _                                                   ->-                  (NiceMutual (getRange (d : ds0)) tc (and pcs) (d : ds0) :)--          prefix <$> inferMutualBlocks ds1-      where-        untilAllDefined :: ([TerminationCheck], [PositivityCheck])-                        -> [NiceDeclaration]-                        -> Nice (([TerminationCheck], [PositivityCheck]), ([NiceDeclaration], [NiceDeclaration]))-        untilAllDefined (tc, pc) ds = do-          done <- noLoneSigs-          if done then return ((tc, pc), ([], ds)) else-            case ds of-              []     -> __IMPOSSIBLE__ <$ (checkLoneSigs . Map.toList =<< use loneSigs)-              d : ds -> case declKind d of-                LoneSig k x ->-                  addLoneSig x k >> cons d (untilAllDefined (terminationCheck k : tc, positivityCheck k : pc) ds)-                LoneDefs k xs -> do-                  mapM_ removeLoneSig xs-                  cons d (untilAllDefined (terminationCheck k : tc, positivityCheck k : pc) ds)-                OtherDecl   -> cons d (untilAllDefined (tc, pc) ds)-          where-            -- ASR (26 December 2015): Type annotated version of the @cons@ function.-            -- cons d = fmap $-            --            (id :: (([TerminationCheck], [PositivityCheck]) -> ([TerminationCheck], [PositivityCheck])))-            --            *** (d :)-            --            *** (id :: [NiceDeclaration] -> [NiceDeclaration])-            cons d = fmap (id *** (d :) *** id)--    notMeasure TerminationMeasure{} = False-    notMeasure _ = True--    nice :: [Declaration] -> Nice [NiceDeclaration]-    nice [] = return []-    nice ds = do-      (xs , ys) <- nice1 ds-      (xs ++) <$> nice ys--    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])-    nice1 []     = __IMPOSSIBLE__-    nice1 (d:ds) = case d of--        (TypeSig info x t)            -> do-          termCheck <- use terminationCheckPragma-          fx <- getFixity x-          -- register x as lone type signature, to recognize clauses later-          addLoneSig x (FunName termCheck)-          return ([FunSig (getRange d) fx PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t] , ds)--        (FunClause lhs _ _ _)         -> do-          termCheck <- use terminationCheckPragma-          catchall  <- popCatchallPragma-          xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs-          -- for each type signature 'x' waiting for clauses, we try-          -- if we have some clauses for 'x'-          fixs <- gets fixs-          case [ (x, (fits, rest))-               | x <- xs-               , let (fits, rest) =-                      -- Anonymous declarations only have 1 clause each!-                      if isNoName x then ([d], ds)-                      else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)-               , not (null fits)-               ] of--            -- case: clauses match none of the sigs-            [] -> case lhs of-              -- 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 defaultArgInfo termCheck x Nothing [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.-              -- A missing type signature error might be raise in ConcreteToAbstract-              _ -> do-                return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck catchall d] , ds)--            -- case: clauses match exactly one of the sigs-            [(x,(fits,rest))] -> do-               removeLoneSig x-               cs  <- mkClauses x (expandEllipsis fits) False-               fx  <- getFixity x-               return ([FunDef (getRange fits) fits fx ConcreteDef termCheck x cs] , rest)--            -- case: clauses match more than one sigs (ambiguity)-            l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"--        Field{}                       -> (,ds) <$> niceAxioms FieldBlock [ d ]-        DataSig r CoInductive _ _ _   -> throwError (Codata r)-        Data r CoInductive _ _ _ _    -> throwError (Codata r)--        (DataSig r Inductive x tel t) -> do-          pc <- use positivityCheckPragma-          addLoneSig x (DataName pc $ parameters tel)-          (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel (Just t) Nothing-              <*> return ds--        (Data r Inductive x tel t cs) -> do-          pc <- use positivityCheckPragma-          t <- defaultTypeSig (DataName pc $ parameters tel) x t-          (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel t (Just cs)-              <*> return ds--        (RecordSig r x tel t)         -> do-          pc <- use positivityCheckPragma-          addLoneSig x (RecName pc $ parameters tel)-          fx <- getFixity x-          return ([NiceRecSig r fx PublicAccess ConcreteDef pc x tel t] , ds)--        (Record r x i e c tel t cs)   -> do-          pc <- use positivityCheckPragma-          t <- defaultTypeSig (RecName pc $ parameters tel) x t-          c <- traverse (\(cname, cinst) -> do fix <- getFixity cname; return (ThingWithFixity cname fix, cinst)) c-          (,) <$> dataOrRec pc (\ r f a pc x tel cs -> RecDef r f a pc x i e c tel cs) NiceRecSig-                    niceDeclarations r x tel t (Just cs)-              <*> return ds--        Mutual r ds' ->-          (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))--        Abstract r ds' ->-          (,ds) <$> (abstractBlock r =<< nice ds')--        Private r o ds' ->-          (,ds) <$> (privateBlock r o =<< nice ds')--        InstanceB r ds' ->-          (,ds) <$> (instanceBlock r =<< nice ds')--        Macro r ds' ->-          (,ds) <$> (macroBlock r =<< nice ds')--        Postulate _ ds' ->-          (,ds) <$> (mapM setPolarity =<< niceAxioms PostulateBlock ds')-          where-          setPolarity (Axiom r f acc a i arg Nothing x e) = do-            mp <- getPolarity x-            return (Axiom r f acc a i arg mp x e)-          setPolarity (Axiom _ _ _ _ _ _ (Just _) _ _) = __IMPOSSIBLE__-          setPolarity d = return d--        Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')--        Module r x tel ds' -> return $-          ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)--        ModuleMacro r x modapp op is -> return $-          ([NiceModuleMacro r PublicAccess x modapp op is] , ds)--        -- Fixity and syntax declarations and polarity pragmas have-        -- already been processed.-        Infix _ _  -> return ([], ds)-        Syntax _ _ -> return ([], ds)--        PatternSyn r n as p -> do-          fx <- getFixity n-          return ([NicePatternSyn r fx n as p] , ds)-        Open r x is         -> return ([NiceOpen r x is] , ds)-        Import r x as op is -> return ([NiceImport r x as op is] , ds)--        UnquoteDecl r xs e -> do-          fxs <- mapM getFixity xs-          tc  <- use terminationCheckPragma-          return ([NiceUnquoteDecl r fxs PublicAccess ConcreteDef NotInstanceDef tc xs e] , ds)--        UnquoteDef r xs e -> do-          fxs  <- mapM getFixity xs-          sigs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs-          let missing = filter (`notElem` sigs) xs-          if null missing-            then do-              mapM_ removeLoneSig xs-              return ([NiceUnquoteDef r fxs PublicAccess ConcreteDef TerminationCheck xs e] , ds)-            else throwError $ UnquoteDefRequiresSignature missing--        Pragma p -> nicePragma p ds--    nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])--    nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =-      if canHaveTerminationMeasure ds then-        withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds-      else-        throwError $ InvalidTerminationCheckPragma r--    nicePragma (TerminationCheckPragma r NoTerminationCheck) ds =-      throwError $ PragmaNoTerminationCheck r--    nicePragma (TerminationCheckPragma r tc) ds =-      if canHaveTerminationCheckPragma ds then-        withTerminationCheckPragma tc $ nice1 ds-      else-        throwError $ InvalidTerminationCheckPragma r--    nicePragma (CatchallPragma r) ds =-      if canHaveCatchallPragma ds then-        withCatchallPragma True $ nice1 ds-      else-        throwError $ InvalidCatchallPragma r--    nicePragma (NoPositivityCheckPragma r) ds =-      if canHaveNoPositivityCheckPragma ds then-        withPositivityCheckPragma False $ nice1 ds-      else-        throwError $ InvalidNoPositivityCheckPragma r--    nicePragma (PolarityPragma{}) ds = return ([], ds)--    nicePragma p ds = return ([NicePragma (getRange p) p], ds)--    canHaveTerminationMeasure :: [Declaration] -> Bool-    canHaveTerminationMeasure [] = False-    canHaveTerminationMeasure (d:ds) = case d of-      TypeSig{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds-      _         -> False--    canHaveTerminationCheckPragma :: [Declaration] -> Bool-    canHaveTerminationCheckPragma []     = False-    canHaveTerminationCheckPragma (d:ds) = case d of-      Mutual{}      -> True-      TypeSig{}     -> True-      FunClause{}   -> True-      UnquoteDecl{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds-      _             -> False--    canHaveCatchallPragma :: [Declaration] -> Bool-    canHaveCatchallPragma []     = False-    canHaveCatchallPragma (d:ds) = case d of-      FunClause{} -> True-      (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds-      _           -> False--    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool-    canHaveNoPositivityCheckPragma []     = False-    canHaveNoPositivityCheckPragma (d:ds) = case d of-      Mutual{}                    -> True-      (Data _ Inductive _ _ _ _)  -> True-      (DataSig _ Inductive _ _ _) -> True-      Record{}                    -> True-      RecordSig{}                 -> True-      (Pragma p) | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds-      _                           -> False--    isAttachedPragma :: Pragma -> Bool-    isAttachedPragma p = case p of-      TerminationCheckPragma{}  -> True-      CatchallPragma{}          -> True-      NoPositivityCheckPragma{} -> True-      _                         -> False--    -- We could add a default type signature here, but at the moment we can't-    -- infer the type of a record or datatype, so better to just fail here.-    defaultTypeSig :: DataRecOrFun -> Name -> Maybe Expr -> Nice (Maybe Expr)-    defaultTypeSig k x t@Just{} = return t-    defaultTypeSig k x Nothing  = do-      mk <- getSig x-      case mk of-        Nothing -> throwError $ MissingDataSignature x-        Just k' | k == k'       -> Nothing <$ removeLoneSig x-                | sameKind k k' -> throwError $ WrongParameters x-                | otherwise     -> throwError $ WrongDefinition x k' k--    dataOrRec :: forall a .-                 PositivityCheck ->-                 (Range -> Fixity' -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] ->-                   [NiceConstructor] -> NiceDeclaration) ->-                 (Range -> Fixity' -> Access -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] -> Expr ->-                   NiceDeclaration) ->-                 ([a] -> Nice [NiceDeclaration]) ->-                 Range ->-                 Name ->-                 [LamBinding] ->-                 Maybe Expr ->-                 Maybe [a] ->-                 Nice [NiceDeclaration]-    dataOrRec pc mkDef mkSig niceD r x tel mt mcs = do-      mds <- traverse niceD mcs-      f   <- getFixity x-      return $ catMaybes $-        [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess ConcreteDef pc x tel t-        , mkDef r f ConcreteDef pc x (concatMap dropType tel) <$> mds-        ]-      where-        dropType :: LamBinding -> [LamBinding]-        dropType (DomainFull (TypedBindings _r (Arg ai (TBind _ xs _)))) =-          map (mergeHiding . fmap (DomainFree ai)) xs-        dropType (DomainFull (TypedBindings _r (Arg _ TLet{}))) = []-        dropType b@DomainFree{} = [b]--    -- Translate axioms-    niceAxioms :: KindOfBlock -> [TypeSignatureOrInstanceBlock] -> Nice [NiceDeclaration]-    niceAxioms b ds = liftM List.concat $ mapM (niceAxiom b) ds--    niceAxiom :: KindOfBlock -> TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]-    niceAxiom b d = case d of-      TypeSig rel x t -> do-        fx <- getFixity x-        return [ Axiom (getRange d) fx PublicAccess ConcreteDef NotInstanceDef rel Nothing x t ]-      Field i x argt -> do-        fx <- getFixity x-        return [ NiceField (getRange d) fx PublicAccess ConcreteDef i x argt ]-      InstanceB r decls -> do-        instanceBlock r =<< niceAxioms InstanceBlock decls-      Pragma p@(RewritePragma r _) -> do-        return [ NicePragma r p ]-      _ -> throwError $ WrongContentBlock b $ getRange d--    toPrim :: NiceDeclaration -> NiceDeclaration-    toPrim (Axiom r f p a i rel Nothing x t) = PrimitiveFunction r f p a x t-    toPrim _                               = __IMPOSSIBLE__--    -- Create a function definition.-    mkFunDef info termCheck x mt ds0 = do-      cs <- mkClauses x (expandEllipsis ds0) False-      f  <- getFixity x-      return [ FunSig (fuseRange x t) f PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t-             , FunDef (getRange ds0) ds0 f ConcreteDef termCheck x cs ]-        where-          t = case mt of-                Just t  -> t-                Nothing -> underscore (getRange x)--    underscore r = Underscore r Nothing---    expandEllipsis :: [Declaration] -> [Declaration]-    expandEllipsis [] = []-    expandEllipsis (d@(FunClause Ellipsis{} _ _ _) : ds) =-      d : expandEllipsis ds-    expandEllipsis (d@(FunClause lhs@(LHS p ps _ _) _ _ _) : ds) =-      d : expand (setInserted p) (map setInserted ps) ds-      where-        expand _ _ [] = []-        expand p ps (d@(Pragma (CatchallPragma r)) : ds) = d : expand p ps ds-        expand p ps (FunClause (Ellipsis r ps' eqs []) rhs wh ca : ds) =-          FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs []) rhs wh ca : expand p ps ds-        expand p ps (FunClause (Ellipsis r ps' eqs es) rhs wh ca : ds) =-          FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs es) rhs wh ca : expand p (ps ++ ps') ds-        expand p ps (d@(FunClause (LHS _ _ _ []) _ _ _) : ds) =-          d : expand p ps ds-        expand _ _ (d@(FunClause (LHS p ps _ (_ : _)) _ _ _) : ds) =-          d : expand p ps ds-        expand _ _ (_ : ds) = __IMPOSSIBLE__-    expandEllipsis (_ : ds) = __IMPOSSIBLE__--    setInserted :: Pattern -> Pattern-    setInserted p = case p of-      IdentP{} -> p-      QuoteP{} -> p-      AppP p q -> AppP (setInserted p) (fmap (fmap setInserted) q)-      RawAppP r ps -> RawAppP r (map setInserted ps)-      OpAppP r c ns ps -> OpAppP r c ns (map (fmap $ fmap setInserted) ps)-      HiddenP r p -> HiddenP r (fmap setInserted p)-      InstanceP r p -> InstanceP r (fmap setInserted p)-      ParenP r p -> ParenP r (setInserted p)-      WildP{} -> p-      AbsurdP{} -> p-      AsP r n p -> AsP r n (setInserted p)-      DotP r _ e -> DotP r Inserted e-      LitP{} -> p-      RecP r fs -> RecP r (map (fmap setInserted) fs)--    -- Turn function clauses into nice function clauses.-    mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]-    mkClauses _ [] _ = return []-    mkClauses x (Pragma (CatchallPragma r) : cs) True  = throwError $ InvalidCatchallPragma r-    mkClauses x (Pragma (CatchallPragma r) : cs) False = do-      when (null cs) $ throwError $ InvalidCatchallPragma r-      mkClauses x cs True-    mkClauses x (FunClause lhs@(LHS _ _ _ []) rhs wh ca : cs) catchall =-      (Clause x (ca || catchall) lhs rhs wh [] :) <$> mkClauses x cs False-    mkClauses x (FunClause lhs@(LHS _ ps _ es) rhs wh ca : cs) catchall = do-      when (null with) $ throwError $ MissingWithClauses x-      wcs <- mkClauses x with False-      (Clause x (ca || catchall) lhs rhs wh wcs :) <$> mkClauses x cs' False-      where-        (with, cs') = subClauses cs--        -- A clause is a subclause if the number of with-patterns is-        -- greater or equal to the current number of with-patterns plus the-        -- number of with arguments.-        subClauses :: [Declaration] -> ([Declaration],[Declaration])-        subClauses (c@(FunClause (LHS _ ps' _ _) _ _ _) : cs)-         | length ps' >= length ps + length es = mapFst (c:) (subClauses cs)-         | otherwise                           = ([], c:cs)-        subClauses (c@(FunClause (Ellipsis _ ps' _ _) _ _ _) : cs)-         = mapFst (c:) (subClauses cs)-        subClauses (c@(Pragma (CatchallPragma r)) : cs) = case subClauses cs of-          ([], cs') -> ([], c:cs')-          (cs, cs') -> (c:cs, cs')-        subClauses [] = ([],[])-        subClauses _  = __IMPOSSIBLE__-    mkClauses x (FunClause lhs@Ellipsis{} rhs wh ca : cs) catchall =-      (Clause x (ca || catchall) lhs rhs wh [] :) <$> mkClauses x cs False   -- Will result in an error later.-    mkClauses _ _ _ = __IMPOSSIBLE__--    -- for finding clauses for a type sig in mutual blocks-    couldBeFunClauseOf :: Maybe Fixity' -> Name -> Declaration -> Bool-    couldBeFunClauseOf mFixity x (Pragma (CatchallPragma{})) = True-    couldBeFunClauseOf mFixity x (FunClause Ellipsis{} _ _ _) = True-    couldBeFunClauseOf mFixity x (FunClause (LHS p _ _ _) _ _ _) =-      let-      pns        = patternNames p-      xStrings   = nameStringParts x-      patStrings = concatMap nameStringParts pns-      in---          trace ("x = " ++ show x) $---          trace ("pns = " ++ show pns) $---          trace ("xStrings = " ++ show xStrings) $---          trace ("patStrings = " ++ show patStrings) $---          trace ("mFixity = " ++ show mFixity) $-      case (headMaybe pns, mFixity) of-        -- first identifier in the patterns is the fun.symbol?-        (Just y, _) | x == y -> True -- trace ("couldBe since y = " ++ show y) $ True-        -- are the parts of x contained in p-        _ | xStrings `isSublistOf` patStrings -> True -- trace ("couldBe since isSublistOf") $ 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 a notation, not first id: give up-        _ -> False -- trace ("couldBe not (case default)") $ False-    couldBeFunClauseOf _ _ _ = False -- trace ("couldBe not (fun default)") $ False--    -- ASR (27 May 2014). Commented out unused code.-    -- @isFunClauseOf@ is for non-mutual blocks where clauses must follow the-    -- type sig immediately-    -- isFunClauseOf :: Name -> Declaration -> Bool-    -- isFunClauseOf x (FunClause Ellipsis{} _ _) = True-    -- isFunClauseOf x (FunClause (LHS p _ _ _) _ _) =-    --  -- p is the whole left hand side, excluding "with" patterns and clauses-    --   case removeSingletonRawAppP p of-    --     IdentP (QName q)    -> x == q  -- lhs is just an identifier-    --     _                   -> True-    --         -- more complicated lhss must come with type signatures, so we just assume-    --         -- it's part of the current definition-    -- isFunClauseOf _ _ = False--    isSingleIdentifierP :: Pattern -> Maybe Name-    isSingleIdentifierP p = case removeSingletonRawAppP p of-      IdentP (QName x) -> Just x-      WildP r          -> Just $ noName r-      _                -> Nothing--    removeSingletonRawAppP :: Pattern -> Pattern-    removeSingletonRawAppP p = case p of-        RawAppP _ [p'] -> removeSingletonRawAppP p'-        ParenP _ p'    -> removeSingletonRawAppP p'-        _ -> p--    -- Make an old style mutual block from a list of mutual declarations-    mkOldMutual :: Range -> [NiceDeclaration] -> Nice NiceDeclaration-    mkOldMutual r ds = do-        -- Check that there aren't any missing definitions-        checkLoneSigs loneNames-        -- Check that there are no declarations that aren't allowed in old style mutual blocks-        case filter notAllowedInMutual ds of-          []  -> return ()-          (NiceFunClause _ _ _ _ s_ (FunClause lhs _ _ _)):_ -> throwError $ MissingTypeSignature lhs-          d:_ -> throwError $ NotAllowedInMutual d-        tc0 <- use terminationCheckPragma-        let tcs = map termCheck ds-        tc <- combineTermChecks r (tc0:tcs)--        pc0 <- use positivityCheckPragma-        let pc :: PositivityCheck-            pc = pc0 && all positivityCheckOldMutual ds--        return $ NiceMutual r tc pc $ sigs ++ other-      where-        -- Andreas, 2013-11-23 allow postulates in mutual blocks-        notAllowedInMutual Axiom{} = False-        notAllowedInMutual d       = declKind d == OtherDecl-        -- Pull type signatures to the top-        (sigs, other) = partition isTypeSig ds-        isTypeSig Axiom{}                     = True-        isTypeSig d | LoneSig{} <- declKind d = True-        isTypeSig _                           = False--        sigNames  = [ (x, k) | LoneSig 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-        loneNames = [ (x, k) | (x, k) <- sigNames, List.all ((x /=) . fst) defNames ]--        -- Andreas, 2013-02-28 (issue 804):-        -- do not termination check a mutual block if any of its-        -- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}-        termCheck (FunSig _ _ _ _ _ _ _ tc _ _)      = tc-        termCheck (FunDef _ _ _ _ tc _ _)            = tc-        -- ASR (28 December 2015): Is this equation necessary?-        termCheck (NiceMutual _ tc _ _)              = __IMPOSSIBLE__-        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 DataDef{}                          = TerminationCheck-        termCheck RecDef{}                           = TerminationCheck-        termCheck NicePatternSyn{}                   = TerminationCheck--        -- 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 (DataDef _ _ _ pc _ _ _)      = pc-        positivityCheckOldMutual (NiceDataSig _ _ _ _ pc _ _ _)= pc-        positivityCheckOldMutual (NiceMutual _ _ pc _)         = __IMPOSSIBLE__-        positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _) = pc-        positivityCheckOldMutual (RecDef _ _ _ pc _ _ _ _ _ _) = pc-        positivityCheckOldMutual _                             = True--        -- A mutual block cannot have a measure,-        -- but it can skip termination check.--    abstractBlock _ [] = return []-    abstractBlock r ds = do-      let (ds', anyChange) = runChange $ mkAbstract ds-          inherited        = r == noRange-          -- hack to avoid failing on inherited abstract blocks in where clauses-      if anyChange || inherited then return ds' else throwError $ UselessAbstract r--    privateBlock _ _ [] = return []-    privateBlock r o ds = do-      let (ds', anyChange) = runChange $ mkPrivate o ds-      if anyChange then return ds' else-        if o == UserWritten then throwError $ UselessPrivate r else return ds -- no change!--    instanceBlock _ [] = return []-    instanceBlock r ds = do-      let (ds', anyChange) = runChange $ mapM mkInstance ds-      if anyChange then return ds' else throwError $ UselessInstance r--    -- Make a declaration eligible for instance search.-    mkInstance :: Updater NiceDeclaration-    mkInstance d =-      case d of-        Axiom r f p a i rel mp x e       -> (\ i -> Axiom r f p a i rel mp x e) <$> setInstance i-        FunSig r f p a i m rel tc x e    -> (\ i -> FunSig r f p a i m rel tc x e) <$> setInstance i-        NiceUnquoteDecl r f p a i tc x e -> (\ i -> NiceUnquoteDecl r f p a i tc x e) <$> setInstance i-        NiceMutual{}                     -> return d-        NiceFunClause{}                  -> return d-        FunDef{}                         -> return d-        NiceField{}                      -> return d  -- Field instance are handled by the parser-        PrimitiveFunction{}              -> return d-        NiceUnquoteDef{}                 -> return d-        NiceRecSig{}                     -> return d-        NiceDataSig{}                    -> return d-        NiceModuleMacro{}                -> return d-        NiceModule{}                     -> return d-        NicePragma{}                     -> return d-        NiceOpen{}                       -> return d-        NiceImport{}                     -> return d-        DataDef{}                        -> return d-        RecDef{}                         -> return d-        NicePatternSyn{}                 -> return d--    setInstance :: Updater IsInstance-    setInstance i = case i of-      InstanceDef -> return i-      _           -> dirty $ InstanceDef--    macroBlock r ds = mapM mkMacro ds--    mkMacro :: NiceDeclaration -> Nice NiceDeclaration-    mkMacro d =-      case d of-        FunSig r f p a i _ rel tc x e -> return $ FunSig r f p a i MacroDef rel tc x e-        FunDef{}                    -> return d-        _                           -> throwError (BadMacroDef d)---- | Make a declaration abstract.------ Mark computation as 'dirty' if there was a declaration that could be made abstract.--- If no abstraction is taking place, we want to complain about 'UselessAbstract'.------ Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.--- Then, nested @abstract@s would sometimes also be complained about.--class MakeAbstract a where-  mkAbstract :: Updater a-  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => Updater a-  mkAbstract = traverse mkAbstract--instance MakeAbstract a => MakeAbstract [a] where-  -- Default definition kicks in here!-  -- But note that we still have to declare the instance!---- Leads to overlap with 'WhereClause':--- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where---   mkAbstract = traverse mkAbstract--instance MakeAbstract IsAbstract where-  mkAbstract a = case a of-    AbstractDef -> return a-    ConcreteDef -> dirty $ AbstractDef--instance MakeAbstract NiceDeclaration where-  mkAbstract d =-    case d of-      NiceMutual r termCheck pc ds     -> NiceMutual r termCheck pc <$> mkAbstract ds-      FunDef r ds f a tc x cs          -> (\ a -> FunDef r ds f a tc x) <$> mkAbstract a <*> mkAbstract cs-      DataDef r f a pc x ps cs         -> (\ a -> DataDef r f a pc x ps) <$> mkAbstract a <*> mkAbstract cs-      RecDef r f a pc x i e c ps cs    -> (\ a -> RecDef r f a pc x i e c ps) <$> mkAbstract a <*> mkAbstract cs-      NiceFunClause r p a termCheck catchall d  -> (\ a -> NiceFunClause r p a termCheck 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 f p a i rel mp x e       -> return $ Axiom             r f p AbstractDef i rel mp x e-      FunSig r f p a i m rel tc x e    -> return $ FunSig            r f p AbstractDef i m rel tc x e-      NiceRecSig r f p a pc x ls t     -> return $ NiceRecSig        r f p AbstractDef pc x ls t-      NiceDataSig r f p a pc x ls t    -> return $ NiceDataSig       r f p AbstractDef pc x ls t-      NiceField r f p _ i x e          -> return $ NiceField         r f p AbstractDef i x e-      PrimitiveFunction r f p _ x e    -> return $ PrimitiveFunction r f p AbstractDef x e-      -- Andreas, 2016-07-17 it does have effect on unquoted defs.-      -- Need to set updater state to dirty!-      NiceUnquoteDecl r f p _ i t x e  -> dirty $ NiceUnquoteDecl r f p AbstractDef i t x e-      NiceUnquoteDef r f p _ t x e     -> dirty $ NiceUnquoteDef r f p AbstractDef t x e-      NiceModule{}                     -> return d-      NiceModuleMacro{}                -> return d-      NicePragma{}                     -> return d-      NiceOpen{}                       -> return d-      NiceImport{}                     -> return d-      NicePatternSyn{}                 -> return d--instance MakeAbstract Clause where-  mkAbstract (Clause x catchall lhs rhs wh with) = do-    Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with---- | Contents of a @where@ clause are abstract if the parent is.-instance MakeAbstract WhereClause where-  mkAbstract  NoWhere           = return $ NoWhere-  mkAbstract (AnyWhere ds)      = dirty $ AnyWhere [Abstract noRange ds]-  mkAbstract (SomeWhere m a ds) = dirty $ SomeWhere m a [Abstract noRange ds]---- | Make a declaration private.------ Andreas, 2012-11-17:--- Mark computation as 'dirty' if there was a declaration that could be privatized.--- If no privatization is taking place, we want to complain about 'UselessPrivate'.------ Alternatively, we could only flag 'dirty' if a non-private thing was privatized.--- Then, nested @private@s would sometimes also be complained about.--class MakePrivate a where-  mkPrivate :: Origin -> Updater a-  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> Updater a-  mkPrivate o = traverse $ mkPrivate o--instance MakePrivate a => MakePrivate [a] where-  -- Default definition kicks in here!-  -- But note that we still have to declare the instance!---- Leads to overlap with 'WhereClause':--- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where---   mkPrivate = traverse mkPrivate--instance MakePrivate Access where-  mkPrivate o p = case p of-    PrivateAccess{} -> return p  -- OR? return $ PrivateAccess o-    _               -> dirty $ PrivateAccess o--instance MakePrivate NiceDeclaration where-  mkPrivate o d =-    case d of-      Axiom r f p a i rel mp x e               -> (\ p -> Axiom r f p a i rel mp x e)               <$> mkPrivate o p-      NiceField r f p a i x e                  -> (\ p -> NiceField r f p a i x e)                  <$> mkPrivate o p-      PrimitiveFunction r f p a x e            -> (\ p -> PrimitiveFunction r f p a x e)            <$> mkPrivate o p-      NiceMutual r termCheck pc ds             -> (\ p -> NiceMutual r termCheck pc p)              <$> 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 f p a i m rel tc x e            -> (\ p -> FunSig r f p a i m rel tc x e)            <$> mkPrivate o p-      NiceRecSig r f p a pc x ls t             -> (\ p -> NiceRecSig r f p a pc x ls t)             <$> mkPrivate o p-      NiceDataSig r f p a pc x ls t            -> (\ p -> NiceDataSig r f p a pc x ls t)            <$> mkPrivate o p-      NiceFunClause r p a termCheck catchall d -> (\ p -> NiceFunClause r p a termCheck catchall d) <$> mkPrivate o p-      NiceUnquoteDecl r f p a i t x e          -> (\ p -> NiceUnquoteDecl r f p a i t x e)          <$> mkPrivate o p-      NiceUnquoteDef r f p a t x e             -> (\ p -> NiceUnquoteDef r f p a t x e)             <$> mkPrivate o p-      NicePragma _ _                           -> return $ d-      NiceOpen _ _ _                           -> return $ d-      NiceImport _ _ _ _ _                     -> return $ d-      -- Andreas, 2016-07-08, issue #2089-      -- we need to propagate 'private' to the named where modules-      FunDef r ds f a tc x cls                 -> FunDef r ds f a tc x <$> mkPrivate o cls-      DataDef{}                                -> return $ d-      RecDef{}                                 -> return $ d-      NicePatternSyn _ _ _ _ _                 -> 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--instance MakePrivate WhereClause where-  mkPrivate o  NoWhere         = return $ NoWhere-  -- @where@-declarations are protected behind an anonymous module,-  -- thus, they are effectively private by default.-  mkPrivate o (AnyWhere ds)    = return $ AnyWhere ds-  -- Andreas, 2016-07-08-  -- A @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).-  mkPrivate o (SomeWhere m a ds) = mkPrivate o a <&> \ a' -> SomeWhere m a' ds---- | Add more fixities. Throw an exception for multiple fixity declarations.---   OR:  Disjoint union of fixity maps.  Throws exception if not disjoint.--plusFixities :: Fixities -> Fixities -> Nice Fixities-plusFixities m1 m2-    -- If maps are not disjoint, report conflicts as exception.-    | not (null isect) = throwError $ MultipleFixityDecls isect-    -- Otherwise, do the union.-    | otherwise        = return $ Map.unionWithKey mergeFixites m1 m2-  where-    --  Merge two fixities, assuming there is no conflict-    mergeFixites name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s $ fuseRange r1 r2-              where f | f1 == noFixity = f2-                      | f2 == noFixity = f1-                      | otherwise = __IMPOSSIBLE__-                    s | s1 == noNotation = s2-                      | s2 == noNotation = s1-                      | otherwise = __IMPOSSIBLE__--    -- Compute a list of conflicts in a format suitable for error reporting.-    isect = [ (x, map (Map.findWithDefault __IMPOSSIBLE__ x) [m1,m2])-            | (x, False) <- Map.assocs $ Map.intersectionWith compatible m1 m2 ]--    -- Check for no conflict.-    compatible (Fixity' f1 s1 _) (Fixity' f2 s2 _) =-      (f1 == noFixity   || f2 == noFixity  ) &&-      (s1 == noNotation || s2 == noNotation)---- | While 'Fixities' and Polarities are not semigroups under disjoint---   union (which might fail), we get a semigroup instance for the---   monadic @Nice (Fixities, Polarities)@ which propagates the first---   error.-instance Semigroup (Nice (Fixities, Polarities)) where-  c1 <> c2 = do-    (f1, p1) <- c1-    (f2, p2) <- c2-    f <- plusFixities f1 f2-    p <- mergePolarities p1 p2-    return (f, p)-    where-    mergePolarities p1 p2-      | Set.null i = return (Map.union p1 p2)-      | otherwise  = throwError $ MultiplePolarityPragmas (Set.toList i)-      where-      i = Set.intersection (Map.keysSet p1) (Map.keysSet p2)--instance Monoid (Nice (Fixities, Polarities)) where-  mempty  = return (Map.empty, Map.empty)-  mappend = (<>)---- | Get the fixities and polarity pragmas from the current block.---   Doesn't go inside modules and where blocks.---   The reason for this is that these declarations have to appear at the same---   level (or possibly outside an abstract or mutual block) as their target---   declaration.-fixitiesAndPolarities :: [Declaration] -> Nice (Fixities, Polarities)-fixitiesAndPolarities = foldMap $ \ d -> case d of-  -- These declarations define polarities:-  Pragma (PolarityPragma _ x occs) -> return (Map.empty, Map.singleton x occs)-  -- These declarations define fixities:-  Syntax x syn    -> return ( Map.singleton x (Fixity' noFixity syn $ getRange x)-                            , Map.empty-                            )-  Infix  f xs     -> return ( Map.fromList $ for xs $ \ x -> (x, Fixity' f noNotation$ getRange x)-                            , Map.empty-                            )-  -- We look into these blocks:-  Mutual    _ ds' -> fixitiesAndPolarities ds'-  Abstract  _ ds' -> fixitiesAndPolarities ds'-  Private _ _ ds' -> fixitiesAndPolarities ds'-  InstanceB _ ds' -> fixitiesAndPolarities ds'-  Macro     _ 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.-  TypeSig     {}  -> mempty-  Field       {}  -> mempty-  FunClause   {}  -> mempty-  DataSig     {}  -> mempty-  Data        {}  -> mempty-  RecordSig   {}  -> mempty-  Record      {}  -> mempty-  PatternSyn  {}  -> mempty-  Postulate   {}  -> mempty-  Primitive   {}  -> mempty-  Open        {}  -> mempty-  Import      {}  -> mempty-  ModuleMacro {}  -> mempty-  Module      {}  -> mempty-  UnquoteDecl {}  -> mempty-  UnquoteDef  {}  -> mempty-  Pragma      {}  -> mempty----- 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 d =-  case d of-    Axiom _ _ _ _ i rel mp x e       -> (case mp of-                                           Nothing   -> []-                                           Just occs -> [Pragma (PolarityPragma noRange x occs)]) ++-                                        inst i [TypeSig rel x e]-    NiceField _ _ _ _ i x argt       -> [Field i x argt]-    PrimitiveFunction r _ _ _ x e    -> [Primitive r [TypeSig defaultArgInfo x e]]-    NiceMutual r _ _ ds              -> [Mutual 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 Inductive x bs e]-    NiceFunClause _ _ _ _ _ d        -> [d]-    FunSig _ _ _ _ i _ rel tc x e    -> inst i [TypeSig rel x e]-    FunDef _r ds _ _ _ _ _           -> ds-    DataDef r _ _ _ x bs cs          -> [Data r Inductive x bs Nothing $ concatMap notSoNiceDeclarations cs]-    RecDef r _ _ _ x i e c bs ds     -> [Record r x i e (unThing <$> c) bs Nothing $ concatMap notSoNiceDeclarations ds]-      where unThing (ThingWithFixity c _, inst) = (c, inst)-    NicePatternSyn r _ n as p        -> [PatternSyn r n as p]-    NiceUnquoteDecl r _ _ _ i _ x e  -> inst i [UnquoteDecl r x e]-    NiceUnquoteDef r _ _ _ _ x e     -> [UnquoteDef r x e]-  where-    inst InstanceDef    ds = [InstanceB (getRange ds) ds]-    inst NotInstanceDef ds = ds---- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?-niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract-niceHasAbstract d =-  case d of-    Axiom{}                         -> Nothing-    NiceField _ _ _ a _ _ _         -> Just a-    PrimitiveFunction _ _ _ a _ _   -> Just a-    NiceMutual{}                    -> Nothing-    NiceModule _ _ a _ _ _          -> Just a-    NiceModuleMacro{}               -> Nothing-    NiceOpen{}                      -> Nothing-    NiceImport{}                    -> Nothing-    NicePragma{}                    -> Nothing-    NiceRecSig{}                    -> Nothing-    NiceDataSig{}                   -> Nothing-    NiceFunClause _ _ a _ _ _       -> Just a-    FunSig{}                        -> Nothing-    FunDef _ _ _ a _ _ _            -> Just a-    DataDef _ _ a _ _ _ _           -> Just a-    RecDef _ _ a _ _ _ _ _ _ _      -> Just a-    NicePatternSyn{}                -> Nothing-    NiceUnquoteDecl _ _ _ a _ _ _ _ -> Just a-    NiceUnquoteDef _ _ _ a _ _ _    -> Just a+-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.+--+--   * Attach fixity and syntax declarations to the definition they refer to.+--+--   * Distribute the following attributes to the individual definitions:+--       @abstract@,+--       @instance@,+--       @postulate@,+--       @primitive@,+--       @private@,+--       termination pragmas.+--+--   * Gather the function clauses belonging to one function definition.+--+--   * Expand ellipsis @...@ in function clauses following @with@.+--+--   * Infer mutual blocks.+--     A block starts when a lone signature is encountered, and ends when+--     all lone signatures have seen their definition.+--+--   * Handle interleaved mutual blocks.+--     In an `interleaved mutual' block we:+--     * leave the data and fun sigs in place+--     * classify signatures in `constructor' block based on their return type+--       and group them all as a data def at the position in the block where the+--       first constructor for the data sig in question occured+--     * classify fun clauses based on the declared function used and group them+--       all as a fundef at the position in the block where the first such fun+--       clause appeared+--+--   * Report basic well-formedness error,+--     when one of the above transformation fails.+--     When possible, errors should be deferred to the scope checking phase+--     (ConcreteToAbstract), where we are in the TCM and can produce more+--     informative error messages.+++module Agda.Syntax.Concrete.Definitions+    ( NiceDeclaration(..)+    , NiceConstructor, NiceTypeSignature+    , Clause(..)+    , DeclarationException(..)+    , DeclarationWarning(..), DeclarationWarning'(..), unsafeDeclarationWarning+    , Nice, NiceEnv(..), runNice+    , niceDeclarations+    , notSoNiceDeclarations+    , niceHasAbstract+    , Measure+    , declarationWarningName+    ) where+++import Prelude hiding (null)++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.Either (isLeft, isRight)+import Data.Function (on)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe+import Data.Semigroup ( Semigroup(..) )+import qualified Data.List as List+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import Agda.Syntax.Concrete+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Common hiding (TerminationCheck())+import qualified Agda.Syntax.Common as Common+import Agda.Syntax.Position+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.Utils.AffineHole+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.Functor+import Agda.Utils.Lens+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.Singleton+import Agda.Utils.Three+import Agda.Utils.Tuple+import Agda.Utils.Update++import Agda.Utils.Impossible++{--------------------------------------------------------------------------+    The niceifier+ --------------------------------------------------------------------------}++-- | Check that declarations in a mutual block are consistently+--   equipped with MEASURE pragmas, or whether there is a+--   NO_TERMINATION_CHECK pragma.+combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck+combineTerminationChecks r = loop+  where+  loop :: [TerminationCheck] -> Nice TerminationCheck+  loop []         = return TerminationCheck+  loop (tc : tcs) = do+    tc' <- loop tcs+    case (tc, tc') of+      (TerminationCheck      , tc'                   ) -> return tc'+      (tc                    , TerminationCheck      ) -> return tc+      (NonTerminating        , NonTerminating        ) -> return NonTerminating+      (NoTerminationCheck    , NoTerminationCheck    ) -> return NoTerminationCheck+      (NoTerminationCheck    , Terminating           ) -> return Terminating+      (Terminating           , NoTerminationCheck    ) -> return Terminating+      (Terminating           , Terminating           ) -> return Terminating+      (TerminationMeasure{}  , TerminationMeasure{}  ) -> return tc+      (TerminationMeasure r _, NoTerminationCheck    ) -> failure r+      (TerminationMeasure r _, Terminating           ) -> failure r+      (NoTerminationCheck    , TerminationMeasure r _) -> failure r+      (Terminating           , TerminationMeasure r _) -> failure r+      (TerminationMeasure r _, NonTerminating        ) -> failure r+      (NonTerminating        , TerminationMeasure r _) -> failure r+      (NoTerminationCheck    , NonTerminating        ) -> failure r+      (Terminating           , NonTerminating        ) -> failure r+      (NonTerminating        , NoTerminationCheck    ) -> failure r+      (NonTerminating        , Terminating           ) -> failure r+  failure r = declarationException $ InvalidMeasureMutual r++combineCoverageChecks :: [CoverageCheck] -> CoverageCheck+combineCoverageChecks = Fold.fold++combinePositivityChecks :: [PositivityCheck] -> PositivityCheck+combinePositivityChecks = Fold.fold++data DeclKind+    = LoneSigDecl Range DataRecOrFun Name+    | LoneDefs DataRecOrFun [Name]+    | OtherDecl+  deriving (Eq, Show)++declKind :: NiceDeclaration -> DeclKind+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 NiceOpaque{}                        = OtherDecl++-- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names+--   The first argument is a list of axioms only.+replaceSigs+  :: LoneSigs               -- ^ Lone signatures to be turned into Axioms+  -> [NiceDeclaration]      -- ^ Declarations containing them+  -> [NiceDeclaration]      -- ^ In the output, everything should be defined+replaceSigs ps = if Map.null ps then id else \case+  []     -> __IMPOSSIBLE__+  (d:ds) ->+    case replaceable d of+      -- If declaration d of x is mentioned in the map of lone signatures then replace+      -- it with an axiom+      Just (x, axiom)+        | (Just (LoneSig _ x' _), ps') <- Map.updateLookupWithKey (\ _ _ -> Nothing) x ps+        , getRange x == getRange x'+            -- Use the range as UID to ensure we do not replace the wrong signature.+            -- This could happen if the user wrote a duplicate definition.+        -> axiom : replaceSigs ps' ds+      _ -> d     : replaceSigs ps  ds++  where++    -- A @replaceable@ declaration is a signature. It has a name and we can make an+    -- @Axiom@ out of it.+    replaceable :: NiceDeclaration -> Maybe (Name, NiceDeclaration)+    replaceable = \case+      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 (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+                   (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+                   (setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)) x e)+      _ -> Nothing++-- | Main. Fixities (or more precisely syntax declarations) are needed when+--   grouping function clauses.+niceDeclarations :: Fixities -> [Declaration] -> Nice [NiceDeclaration]+niceDeclarations fixs ds = do++  -- Run the nicifier in an initial environment. But keep the warnings.+  st <- get+  put $ initNiceState { niceWarn = niceWarn st }+  nds <- nice ds++  -- Check that every signature got its definition.+  ps <- use loneSigs+  checkLoneSigs ps+  -- We postulate the missing ones and insert them in place of the corresponding @FunSig@+  let ds = replaceSigs ps nds++  -- Note that loneSigs is ensured to be empty.+  -- (Important, since inferMutualBlocks also uses loneSigs state).+  res <- inferMutualBlocks ds++  -- Restore the old state, but keep the warnings.+  warns <- gets niceWarn+  put $ st { niceWarn = warns }+  return res++  where++    inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]+    inferMutualBlocks [] = return []+    inferMutualBlocks (d : ds) =+      case declKind d of+        OtherDecl    -> (d :) <$> inferMutualBlocks ds+        LoneDefs{}   -> (d :) <$> inferMutualBlocks ds  -- Andreas, 2017-10-09, issue #2576: report error in ConcreteToAbstract+        LoneSigDecl r k x  -> do+          _ <- addLoneSig r x k+          InferredMutual checks nds0 ds1 <- untilAllDefined (mutualChecks k) ds+          -- If we still have lone signatures without any accompanying definition,+          -- we postulate the definition and substitute the axiom for the lone signature+          ps <- use loneSigs+          checkLoneSigs ps+          let ds0 = replaceSigs ps (d : nds0) -- NB: don't forget the LoneSig the block started with!+          -- We then keep processing the rest of the block+          tc <- combineTerminationChecks (getRange d) (mutualTermination checks)+          let cc = combineCoverageChecks              (mutualCoverage checks)+          let pc = combinePositivityChecks            (mutualPositivity checks)+          (NiceMutual empty tc cc pc ds0 :) <$> inferMutualBlocks ds1+      where+        untilAllDefined :: MutualChecks -> [NiceDeclaration] -> Nice InferredMutual+        untilAllDefined checks ds = do+          done <- noLoneSigs+          if done then return (InferredMutual checks [] ds) else+            case ds of+              []     -> return (InferredMutual checks [] ds)+              d : ds -> case declKind d of+                LoneSigDecl r k x -> do+                  void $ addLoneSig r x k+                  extendInferredBlock  d <$> untilAllDefined (mutualChecks k <> checks) ds+                LoneDefs k xs -> do+                  mapM_ removeLoneSig xs+                  extendInferredBlock  d <$> untilAllDefined (mutualChecks k <> checks) ds+                OtherDecl -> extendInferredBlock d <$> untilAllDefined checks ds++    nice :: [Declaration] -> Nice [NiceDeclaration]+    nice [] = return []+    nice ds = do+      (xs , ys) <- nice1 ds+      (xs ++) <$> nice ys++    nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])+    nice1 []     = return ([], []) -- Andreas, 2017-09-16, issue #2759: no longer __IMPOSSIBLE__+    nice1 (d:ds) = do+      let justWarning :: HasCallStack => DeclarationWarning' -> Nice ([NiceDeclaration], [Declaration])+          justWarning w = do+            -- NOTE: This is the location of the invoker of justWarning, not here.+            withCallerCallStack $ declarationWarning' w+            nice1 ds++      case d of++        TypeSig info _tac x t -> do+          termCheck <- use terminationCheckPragma+          covCheck  <- use coverageCheckPragma+          -- Andreas, 2020-09-28, issue #4950: take only range of identifier,+          -- since parser expands type signatures with several identifiers+          -- (like @x y z : A@) into several type signatures (with imprecise ranges).+          let r = getRange x+          -- register x as lone type signature, to recognize clauses later+          x' <- addLoneSig r x $ FunName termCheck covCheck+          return ([FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck covCheck x' t] , ds)++        -- Should not show up: all FieldSig are part of a Field block+        FieldSig{} -> __IMPOSSIBLE__++        Generalize r [] -> justWarning $ EmptyGeneralize r+        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)++        (FunClause lhs _ _ _)         -> do+          termCheck <- use terminationCheckPragma+          covCheck  <- use coverageCheckPragma+          catchall  <- popCatchallPragma+          xs <- loneFuns <$> use loneSigs+          -- for each type signature 'x' waiting for clauses, we try+          -- if we have some clauses for 'x'+          case [ (x, (x', fits, rest))+               | (x, x') <- xs+               , let (fits, rest) =+                      -- Anonymous declarations only have 1 clause each!+                      if isNoName x then ([d], ds)+                      else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)+               , not (null fits)+               ] of++            -- case: clauses match none of the sigs+            [] -> case lhs of+              -- 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 $ 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.+              -- A missing type signature error might be raise in ConcreteToAbstract+              _ -> do+                return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck covCheck catchall d] , ds)++            -- case: clauses match exactly one of the sigs+            [(x,(x',fits,rest))] -> do+               -- The x'@NoName{} is the unique version of x@NoName{}.+               removeLoneSig x+               ds  <- expandEllipsis fits+               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)+            xf:xfs -> declarationException $ AmbiguousFunClauses lhs $ List1.reverse $ fmap fst $ xf :| xfs+                 -- "ambiguous function clause; cannot assign it uniquely to one type signature"++        Field r [] -> justWarning $ EmptyField r+        Field _ fs -> (,ds) <$> niceAxioms FieldBlock fs++        DataSig r erased x tel t -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          _ <- addLoneSig r x $ DataName pc uc+          (,ds) <$> dataOrRec pc uc NiceDataDef+                      (flip NiceDataSig erased) (niceAxioms DataBlock) r+                      x (Just (tel, t)) Nothing++        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.+          -- Universe check is performed if both the current value of+          -- 'universeCheckPragma' AND the one from the signature say so.+          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+                      (flip NiceDataSig erased) (niceAxioms DataBlock) r+                      x ((tel,) <$> mt) (Just (tel, cs))++        DataDef r x tel cs -> do+          pc <- use positivityCheckPragma+          -- Andreas, 2018-10-27, issue #3327+          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.+          -- Universe check is performed if both the current value of+          -- 'universeCheckPragma' AND the one from the signature say so.+          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+                      (flip NiceDataSig defaultErased)+                      (niceAxioms DataBlock) r x ((tel,) <$> mt)+                      (Just (tel, cs))++        RecordSig r erased x tel t -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          _ <- addLoneSig r x $ RecName pc uc+          return ( [NiceRecSig r erased PublicAccess ConcreteDef pc uc x+                      tel t]+                 , ds+                 )++        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.+          -- Universe check is performed if both the current value of+          -- 'universeCheckPragma' AND the one from the signature say so.+          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)+                      (flip NiceRecSig erased) return r x+                      ((tel,) <$> mt) (Just (tel, cs))++        RecordDef r x dir tel cs   -> do+          pc <- use positivityCheckPragma+          -- Andreas, 2018-10-27, issue #3327+          -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.+          -- Universe check is performed if both the current value of+          -- 'universeCheckPragma' AND the one from the signature say so.+          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)+                      (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+          breakImplicitMutualBlock r "`mutual` blocks"+          case ds' of+            [] -> justWarning $ EmptyMutual r+            _  -> (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))++        InterleavedMutual r ds' -> do+          -- The lone signatures encountered so far are not in scope+          -- for the mutual definition+          breakImplicitMutualBlock r "`interleaved mutual` blocks"+          case ds' of+            [] -> justWarning $ EmptyMutual r+            _  -> (,ds) <$> (singleton <$> (mkInterleavedMutual r =<< nice ds'))++        LoneConstructor r [] -> justWarning $ EmptyConstructor r+        LoneConstructor r ds' ->+          ((,ds) . singleton . NiceLoneConstructor r) <$> niceAxioms ConstructorBlock ds'+++        Abstract r []  -> justWarning $ EmptyAbstract r+        Abstract r ds' ->+          (,ds) <$> (abstractBlock r =<< nice ds')++        Private r UserWritten []  -> justWarning $ EmptyPrivate r+        Private r o ds' ->+          (,ds) <$> (privateBlock r o =<< nice ds')++        InstanceB r []  -> justWarning $ EmptyInstance r+        InstanceB r ds' ->+          (,ds) <$> (instanceBlock r =<< nice ds')++        Macro r []  -> justWarning $ EmptyMacro r+        Macro r ds' ->+          (,ds) <$> (macroBlock r =<< nice ds')++        Postulate r []  -> justWarning $ EmptyPostulate r+        Postulate _ ds' ->+          (,ds) <$> niceAxioms PostulateBlock ds'++        Primitive r []  -> justWarning $ EmptyPrimitive r+        Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')++        Module r erased x tel ds' -> return $+          ([NiceModule r PublicAccess ConcreteDef erased x tel ds'], 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.+        Infix _ _  -> return ([], ds)+        Syntax _ _ -> return ([], ds)++        PatternSyn r n as p -> do+          return ([NicePatternSyn r PublicAccess n as p] , ds)+        Open r x is         -> return ([NiceOpen r x is] , ds)+        Import r x as op is -> return ([NiceImport r x as op is] , ds)++        UnquoteDecl r xs e -> do+          tc <- use terminationCheckPragma+          cc <- use coverageCheckPragma+          return ([NiceUnquoteDecl r PublicAccess ConcreteDef NotInstanceDef tc cc xs e] , ds)++        UnquoteDef r xs e -> do+          sigs <- map fst . loneFuns <$> use loneSigs+          List1.ifNotNull (filter (`notElem` sigs) xs)+            {-then-} (declarationException . UnquoteDefRequiresSignature)+            {-else-} $ do+              mapM_ removeLoneSig xs+              return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , 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 =+      if canHaveTerminationMeasure ds then+        withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds+      else do+        declarationWarning $ InvalidTerminationCheckPragma r+        nice1 ds++    nicePragma (TerminationCheckPragma r NoTerminationCheck) ds = do+      -- This PRAGMA has been deprecated in favour of (NON_)TERMINATING+      -- We warn the user about it and then assume the function is NON_TERMINATING.+      declarationWarning $ PragmaNoTerminationCheck r+      nicePragma (TerminationCheckPragma r NonTerminating) ds++    nicePragma (TerminationCheckPragma r tc) ds =+      if canHaveTerminationCheckPragma ds then+        withTerminationCheckPragma tc $ nice1 ds+      else do+        declarationWarning $ InvalidTerminationCheckPragma r+        nice1 ds++    nicePragma (NoCoverageCheckPragma r) ds =+      if canHaveCoverageCheckPragma ds then+        withCoverageCheckPragma NoCoverageCheck $ nice1 ds+      else do+        declarationWarning $ InvalidCoverageCheckPragma r+        nice1 ds++    nicePragma (CatchallPragma r) ds =+      if canHaveCatchallPragma ds then+        withCatchallPragma (YesCatchall r) $ nice1 ds+      else do+        declarationWarning $ InvalidCatchallPragma r+        nice1 ds++    nicePragma (NoPositivityCheckPragma r) ds =+      if canHaveNoPositivityCheckPragma ds then+        withPositivityCheckPragma NoPositivityCheck $ nice1 ds+      else do+        declarationWarning $ InvalidNoPositivityCheckPragma r+        nice1 ds++    nicePragma (NoUniverseCheckPragma r) ds =+      if canHaveNoUniverseCheckPragma ds then+        withUniverseCheckPragma NoUniverseCheck $ nice1 ds+      else do+        declarationWarning $ InvalidNoUniverseCheckPragma r+        nice1 ds++    nicePragma p@CompilePragma{} ds = do+      return ([NicePragma (getRange p) p], ds)++    nicePragma (PolarityPragma{}) ds = return ([], ds)++    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+    canHaveTerminationMeasure [] = False+    canHaveTerminationMeasure (d:ds) = case d of+      TypeSig{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds+      _         -> False++    canHaveTerminationCheckPragma :: [Declaration] -> Bool+    canHaveTerminationCheckPragma []     = False+    canHaveTerminationCheckPragma (d:ds) = case d of+      Mutual _ ds   -> any (canHaveTerminationCheckPragma . singleton) ds+      TypeSig{}     -> True+      FunClause{}   -> True+      UnquoteDecl{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds+      _             -> False++    canHaveCoverageCheckPragma :: [Declaration] -> Bool+    canHaveCoverageCheckPragma = canHaveTerminationCheckPragma++    canHaveCatchallPragma :: [Declaration] -> Bool+    canHaveCatchallPragma []     = False+    canHaveCatchallPragma (d:ds) = case d of+      FunClause{} -> True+      (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds+      _           -> False++    canHaveNoPositivityCheckPragma :: [Declaration] -> Bool+    canHaveNoPositivityCheckPragma []     = False+    canHaveNoPositivityCheckPragma (d:ds) = case d of+      Mutual _ ds                   -> any (canHaveNoPositivityCheckPragma . singleton) ds+      Data{}                        -> True+      DataSig{}                     -> True+      DataDef{}                     -> True+      Record{}                      -> True+      RecordSig{}                   -> True+      RecordDef{}                   -> True+      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds+      _                             -> False++    canHaveNoUniverseCheckPragma :: [Declaration] -> Bool+    canHaveNoUniverseCheckPragma []     = False+    canHaveNoUniverseCheckPragma (d:ds) = case d of+      Data{}                        -> True+      DataSig{}                     -> True+      DataDef{}                     -> True+      Record{}                      -> True+      RecordSig{}                   -> True+      RecordDef{}                   -> True+      Pragma p | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds+      _                             -> False++    -- Pragma that attaches to the following declaration.+    isAttachedPragma :: Pragma -> Bool+    isAttachedPragma = \case+      TerminationCheckPragma{}  -> True+      CatchallPragma{}          -> True+      NoPositivityCheckPragma{} -> True+      NoUniverseCheckPragma{}   -> True+      _                         -> False++    -- We could add a default type signature here, but at the moment we can't+    -- infer the type of a record or datatype, so better to just fail here.+    defaultTypeSig :: DataRecOrFun -> Name -> Maybe Expr -> Nice (Maybe Expr)+    defaultTypeSig k x t@Just{} = return t+    defaultTypeSig k x Nothing  = do+      caseMaybeM (getSig x) (return Nothing) $ \ k' -> do+        unless (sameKind k k') $ declarationException $ WrongDefinition x k' k+        Nothing <$ removeLoneSig x++    dataOrRec+      :: forall a decl+      .  PositivityCheck+      -> UniverseCheck+      -> (Range -> Origin -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> [decl] -> NiceDeclaration)+         -- Construct definition.+      -> (Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [LamBinding] -> Expr -> NiceDeclaration)+         -- Construct signature.+      -> ([a] -> Nice [decl])        -- Constructor checking.+      -> Range+      -> Name                        -- Data/record type name.+      -> Maybe ([LamBinding], Expr)  -- Parameters and type.  If not @Nothing@ a signature is created.+      -> Maybe ([LamBinding], [a])   -- Parameters and constructors.  If not @Nothing@, a definition body is created.+      -> Nice [NiceDeclaration]+    dataOrRec pc uc mkDef mkSig niceD r x mt mcs = do+      mds <- Trav.forM mcs $ \ (tel, cs) -> (tel,) <$> niceD cs+      -- We set origin to UserWritten if the user split the data/rec herself,+      -- and to Inserted if the she wrote a single declaration that we're+      -- splitting up here. We distinguish these because the scoping rules for+      -- generalizable variables differ in these cases.+      let o | isJust mt && isJust mcs = Inserted+            | otherwise               = UserWritten+      return $ catMaybes $+        [ mt  <&> \ (tel, t)  -> mkSig (fuseRange x t) PublicAccess ConcreteDef pc uc x tel t+        , mds <&> \ (tel, ds) -> mkDef r o ConcreteDef pc uc x (caseMaybe mt tel $ const $ concatMap dropTypeAndModality tel) ds+          -- If a type is given (mt /= Nothing), we have to delete the types in @tel@+          -- for the data definition, lest we duplicate them. And also drop modalities (#1886).+        ]+    -- Translate axioms+    niceAxioms :: KindOfBlock -> [TypeSignatureOrInstanceBlock] -> Nice [NiceDeclaration]+    niceAxioms b ds = List.concat <$> mapM (niceAxiom b) ds++    niceAxiom :: KindOfBlock -> TypeSignatureOrInstanceBlock -> Nice [NiceDeclaration]+    niceAxiom b = \case+      d@(TypeSig rel _tac x t) -> do+        return [ Axiom (getRange d) PublicAccess ConcreteDef NotInstanceDef rel x t ]+      d@(FieldSig i tac x argt) | b == FieldBlock -> do+        return [ NiceField (getRange d) PublicAccess ConcreteDef i tac x argt ]+      InstanceB r decls -> do+        instanceBlock r =<< niceAxioms InstanceBlock decls+      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+    toPrim (Axiom r p a i rel x t) = PrimitiveFunction r p a x (Arg rel t)+    toPrim _                       = __IMPOSSIBLE__++    -- Create a function definition.+    mkFunDef info termCheck covCheck x mt ds0 = do+      ds <- expandEllipsis ds0+      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+          t = fromMaybe (underscore (getRange x)) mt++    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)+      | hasEllipsis p = (d :) <$> expandEllipsis ds+      | otherwise     = (d :) <$> expand (killRange p) ds+      where+        expand :: Pattern -> [Declaration] -> Nice [Declaration]+        expand _ [] = return []+        expand p (d : ds) = do+          case d of+            Pragma (CatchallPragma _) -> do+                  (d :) <$> expand p ds+            FunClause (LHS p0 eqs es) rhs wh ca -> do+              case hasEllipsis' p0 of+                ManyHoles -> declarationException $ MultipleEllipses p0+                OneHole cxt ~(EllipsisP r Nothing) -> do+                  -- Replace the ellipsis by @p@.+                  let p1 = cxt $ EllipsisP r $ Just $ setRange r p+                  let d' = FunClause (LHS p1 eqs es) rhs wh ca+                  -- If we have with-expressions (es /= []) then the following+                  -- ellipses also get the additional patterns in p0.+                  (d' :) <$> expand (if null es then p else killRange p1) ds+                ZeroHoles _ -> do+                  -- We can have ellipses after a fun clause without.+                  -- They refer to the last clause that introduced new with-expressions.+                  -- Same here: If we have new with-expressions, the next ellipses will+                  -- refer to us.+                  -- Andreas, Jesper, 2017-05-13, issue #2578+                  -- Need to update the range also on the next with-patterns.+                  (d :) <$> expand (if null es then p else killRange p0) ds+            _ -> __IMPOSSIBLE__+    expandEllipsis _ = __IMPOSSIBLE__++    -- Turn function clauses into nice function clauses.+    mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]+    mkClauses _ [] _ = return []++    -- A CATCHALL pragma after the last clause is useless.+    mkClauses x [Pragma (CatchallPragma r)] _ = [] <$ do+      declarationWarning $ InvalidCatchallPragma r++    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 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 empty+      (Clause x (ca <> catchall) lhs rhs wh wcs :) <$> mkClauses x cs' empty+      where+        (withClauses, cs') = subClauses cs++        -- A clause is a subclause if the number of with-patterns is+        -- greater or equal to the current number of with-patterns plus the+        -- number of with arguments.+        numWith = numberOfWithPatterns p + length (filter visible es) where LHS p _ es = lhs++        subClauses :: [Declaration] -> ([Declaration],[Declaration])+        subClauses (c@(FunClause (LHS p0 _ _) _ _ _) : cs)+         | isEllipsis p0 ||+           numberOfWithPatterns p0 >= numWith = mapFst (c:) (subClauses cs)+         | otherwise                           = ([], c:cs)+        subClauses (c@(Pragma (CatchallPragma r)) : cs) = case subClauses cs of+          ([], cs') -> ([], c:cs')+          (cs, cs') -> (c:cs, cs')+        subClauses [] = ([],[])+        subClauses _  = __IMPOSSIBLE__+    mkClauses _ _ _ = __IMPOSSIBLE__++    couldBeCallOf :: Maybe Fixity' -> Name -> Pattern -> Bool+    couldBeCallOf mFixity x p =+      let+      pns        = patternQNames p+      xStrings   = nameStringParts x+      patStrings = concatMap nameStringParts $ mapMaybe isUnqualified pns+      in+--          trace ("x = " ++ prettyShow x) $+--          trace ("pns = " ++ show pns) $+--          trace ("xStrings = " ++ show xStrings) $+--          trace ("patStrings = " ++ show patStrings) $+--          trace ("mFixity = " ++ show mFixity) $+      case (listToMaybe pns, mFixity) of+        -- first identifier in the patterns is the fun.symbol?+        (Just y, _) | Just x == isUnqualified y -> True -- trace ("couldBe since y = " ++ prettyShow y) $ True+        -- are the parts of x contained in p+        _ | 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 `List.isSubsequenceOf` patStrings)+        -- not a notation, not first id: give up+        _ -> False -- trace ("couldBe not (case default)") $ False+++    -- for finding nice clauses for a type sig in mutual blocks+    couldBeNiceFunClauseOf :: Maybe Fixity' -> Name -> NiceDeclaration+                           -> Maybe (MutualChecks, Declaration)+    couldBeNiceFunClauseOf mf n (NiceFunClause _ _ _ tc cc _ d)+      = (MutualChecks [tc] [cc] [], d) <$ guard (couldBeFunClauseOf mf n d)+    couldBeNiceFunClauseOf _ _ _ = Nothing++    -- for finding clauses for a type sig in mutual blocks+    couldBeFunClauseOf :: Maybe Fixity' -> Name -> Declaration -> Bool+    couldBeFunClauseOf mFixity x (Pragma (CatchallPragma{})) = True+    couldBeFunClauseOf mFixity x (FunClause (LHS p _ _) _ _ _) =+       hasEllipsis p || couldBeCallOf mFixity x p+    couldBeFunClauseOf _ _ _ = False -- trace ("couldBe not (fun default)") $ False++    -- Turn a new style `interleaved mutual' block into a new style mutual block+    -- by grouping the declarations in blocks.+    mkInterleavedMutual+      :: KwRange               -- Range of the @interleaved mutual@ keywords.+      -> [NiceDeclaration]     -- Declarations inside the block.+      -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.+    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 kwr tc cc pc decls++      where++        ------------------------------------------------------------------------------+        -- Adding Signatures+        addType :: Name -> (DeclNum -> a) -> MutualChecks+                -> StateT (Map Name a, MutualChecks, DeclNum) Nice ()+        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)++        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+          let checks = MutualChecks [] [] [pc]+          addType n (\ i -> InterleavedData i d Nothing) checks+        addDataType _ = __IMPOSSIBLE__++        ------------------------------------------------------------------------------+        -- Adding constructors & clauses++        addDataConstructors :: Maybe Range        -- Range of the `data A where` (if any)+                            -> Maybe Name         -- Data type the constructors belong to+                            -> [NiceConstructor]  -- Constructors to add+                            -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice ()+        -- if we know the type's name, we can go ahead+        addDataConstructors mr (Just n) ds = do+          (m, checks, i) <- get+          case Map.lookup n m of+            Just (InterleavedData i0 sig cs) -> do+              lift $ removeLoneSig n+              -- add the constructors to the existing ones (if any)+              let (cs', i') = case cs of+                    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 $ MissingDataDeclaration n++        addDataConstructors mr Nothing [] = pure ()++        -- Otherwise we try to guess which datasig the constructor is referring to+        addDataConstructors mr Nothing (d : ds) = do+          -- get the candidate data types that are in this interleaved mutual block+          (m, _, _) <- get+          let sigs = mapMaybe (\ (n, d) -> n <$ isInterleavedData d) $ Map.toList m+          -- check whether this constructor matches any of them+          case isConstructor sigs d of+            Right n -> do+              -- if so grab the whole block that may work and add them+              let (ds0, ds1) = span (isRight . isConstructor [n]) ds+              addDataConstructors Nothing (Just n) (d : ds0)+              -- and then repeat the process for the rest of the block+              addDataConstructors Nothing Nothing ds1+            Left (n, ns) -> lift $ declarationException $ AmbiguousConstructor (getRange d) n ns++        addFunDef :: NiceDeclaration -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice ()+        addFunDef (FunDef _ ds _ _ tc cc n cs) = do+          let check = MutualChecks [tc] [cc] []+          (m, checks, i) <- get+          case Map.lookup n m of+            Just (InterleavedFun i0 sig cs0) -> do+              let (cs', i') = case cs0 of+                    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 ::+             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+          let sigs = mapMaybe (\ (n, d) -> n <$ isInterleavedFun d) $ Map.toList m+          -- find the funsig candidates for the funclause of interest+          case [ (x, fits, rest)+               | x <- sigs+               , let (fits, rest) = spanJust (couldBeNiceFunClauseOf (Map.lookup x fixs) x) (nd : ds)+               , not (null fits)+               ] of+            -- 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)+              ((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 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)+                        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')+                _ -> __IMPOSSIBLE__+              groupByBlocks r rest+            -- more than one candidate: fail, complaining about the ambiguity!+            xf:xfs -> lift $ declarationException+                           $ AmbiguousFunClauses lhs+                           $ List1.reverse $ fmap (\ (a,_,_) -> a) $ xf :| xfs+        addFunClauses _ _ = __IMPOSSIBLE__++        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 kwr ds+          case d of+            NiceDataSig{}                -> oneOff $ [] <$ addDataType d+            NiceDataDef r _ _ _ _ n _ ds -> oneOff $ [] <$ addDataConstructors (Just r) (Just n) 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 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)+              pure [(i,d)]++    -- Extract the name of the return type (if any) of a potential constructor.+    -- In case of failure return the name of the constructor and the list of candidates+    -- for the return type.+    -- A `constructor' block should only contain NiceConstructors so we crash with+    -- an IMPOSSIBLE otherwise+    isConstructor :: [Name] -> NiceDeclaration -> Either (Name, [Name]) Name+    isConstructor ns (Axiom _ _ _ _ _ n e)+       -- extract the return type & see it as an LHS-style pattern+       | Just p <- exprToPatternWithHoles <$> returnExpr e =+         case [ x | x <- ns+                  , couldBeCallOf (Map.lookup x fixs) x p+                  ] of+           [x] -> Right x+           xs  -> Left (n, xs)+       -- which may fail (e.g. if the "return type" is a hole+       | otherwise = Left (n, [])+    isConstructor _ _ = __IMPOSSIBLE__++    -- Turn an old-style mutual block into a new style mutual block+    -- by pushing the definitions to the end.+    mkOldMutual+      :: KwRange               -- Range of the @mutual@ keyword (if any).+      -> [NiceDeclaration]     -- Declarations inside the block.+      -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.+    mkOldMutual kwr ds' = do+        -- Postulate the missing definitions+        let ps = loneSigsFromLoneNames loneNames+        checkLoneSigs ps+        let ds = replaceSigs ps ds'++        -- -- Remove the declarations that aren't allowed in old style mutual blocks+        -- ds <- fmap catMaybes $ forM ds $ \ d -> let success = pure (Just d) in case d of+        --   -- Andreas, 2013-11-23 allow postulates in mutual blocks+        --   Axiom{}          -> success+        --   -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature+        --   -- in ConcreteToAbstract rather than here.+        --   NiceFunClause{}  -> success+        --   -- Andreas, 2018-05-11, issue #3052, allow pat.syn.s in mutual blocks+        --   NicePatternSyn{} -> success+        --   -- Otherwise, only categorized signatures and definitions are allowed:+        --   -- Data, Record, Fun+        --   _ -> if (declKind d /= OtherDecl) then success+        --        else Nothing <$ declarationWarning (NotAllowedInMutual (getRange d) $ declName d)+        -- Sort the declarations in the mutual block.+        -- Declarations of names go to the top.  (Includes module definitions.)+        -- Definitions of names go to the bottom.+        -- Some declarations are forbidden, as their positioning could confuse+        -- the user.+        (top, bottom, invalid) <- forEither3M ds $ \ d -> do+          let top       = return (In1 d)+              bottom    = return (In2 d)+              invalid s = In3 d <$ do declarationWarning $ NotAllowedInMutual (getRange d) s+          case d of+            -- Andreas, 2013-11-23 allow postulates in mutual blocks+            Axiom{}             -> top+            NiceField{}         -> top+            PrimitiveFunction{} -> top+            -- Andreas, 2019-07-23 issue #3932:+            -- Nested mutual blocks are not supported.+            NiceMutual{}        -> invalid "mutual blocks"+            -- Andreas, 2018-10-29, issue #3246+            -- We could allow modules (top), but this is potentially confusing.+            NiceModule{}        -> invalid "Module definitions"+            -- Lone constructors are only allowed in new-style mutual blocks+            NiceLoneConstructor{} -> invalid "Lone constructors"+            NiceModuleMacro{}   -> top+            NiceOpen{}          -> top+            NiceImport{}        -> top+            NiceRecSig{}        -> top+            NiceDataSig{}       -> top+            -- Andreas, 2017-10-09, issue #2576, raise error about missing type signature+            -- in ConcreteToAbstract rather than here.+            NiceFunClause{}     -> bottom+            FunSig{}            -> top+            FunDef{}            -> bottom+            NiceDataDef{}       -> bottom+            NiceRecDef{}        -> bottom+            -- Andreas, 2018-05-11, issue #3051, allow pat.syn.s in mutual blocks+            -- Andreas, 2018-10-29: We shift pattern synonyms to the bottom+            -- since they might refer to constructors defined in a data types+            -- just above them.+            NicePatternSyn{}    -> bottom+            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++              -- Some builtins require a definition, and they affect type checking+              -- Thus, we do not handle BUILTINs in mutual blocks (at least for now).+              BuiltinPragma{}           -> invalid "BUILTIN pragmas"++              -- The REWRITE pragma behaves differently before or after the def.+              -- and affects type checking.  Thus, we refuse it here.+              RewritePragma{}           -> invalid "REWRITE pragmas"++              -- Compiler pragmas are not needed for type checking, thus,+              -- can go to the bottom.+              ForeignPragma{}           -> bottom+              CompilePragma{}           -> bottom++              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.+              CatchallPragma{}          -> __IMPOSSIBLE__+              TerminationCheckPragma{}  -> __IMPOSSIBLE__+              NoPositivityCheckPragma{} -> __IMPOSSIBLE__+              PolarityPragma{}          -> __IMPOSSIBLE__+              NoUniverseCheckPragma{}   -> __IMPOSSIBLE__+              NoCoverageCheckPragma{}   -> __IMPOSSIBLE__+++        -- -- Pull type signatures to the top+        -- let (sigs, other) = List.partition isTypeSig ds++        -- -- Push definitions to the bottom+        -- let (other, defs) = flip List.partition ds $ \case+        --       FunDef{}         -> False+        --       NiceDataDef{}    -> False+        --       NiceRecDef{}         -> False+        --       NiceFunClause{}  -> False+        --       NicePatternSyn{} -> False+        --       NiceUnquoteDef{} -> False+        --       _ -> True++        -- 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+        cc0 <- use coverageCheckPragma+        let ccs = map covCheck ds+        let cc = combineCoverageChecks (cc0:ccs)++        -- Compute positivity checking flag for mutual block+        pc0 <- use positivityCheckPragma+        let pcs = map positivityCheckOldMutual ds+        let pc = combinePositivityChecks (pc0:pcs)++        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+        loneNames = [ (r, x, k) | (r, x, k) <- sigNames, List.all ((x /=) . fst) defNames ]++        termCheck :: NiceDeclaration -> TerminationCheck+        -- Andreas, 2013-02-28 (issue 804):+        -- do not termination check a mutual block if any of its+        -- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}+        termCheck (FunSig _ _ _ _ _ _ tc _ _ _)      = tc+        termCheck (FunDef _ _ _ _ tc _ _ _)          = tc+        -- ASR (28 December 2015): Is this equation necessary?+        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 NiceLoneConstructor{} = TerminationCheck+        termCheck NiceUnquoteData{}     = TerminationCheck+        termCheck NiceOpaque{}          = TerminationCheck++        covCheck :: NiceDeclaration -> CoverageCheck+        covCheck (FunSig _ _ _ _ _ _ _ cc _ _)      = cc+        covCheck (FunDef _ _ _ _ _ cc _ _)          = cc+        -- ASR (28 December 2015): Is this equation necessary?+        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 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 (NiceMutual _ _ _ 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+      :: KwRange  -- Range of @abstract@ keyword.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]+    abstractBlock r ds = do+      (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+      :: KwRange  -- Range of @private@ keyword.+      -> Origin   -- Origin of the private block.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]+    privateBlock r o ds = do+      (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+      :: KwRange  -- Range of @instance@ keyword.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]+    instanceBlock r ds = do+      let (ds', anyChange) = runChange $ mapM (mkInstance r) ds+      if anyChange then return ds' else do+        declarationWarning $ UselessInstance r+        return ds -- no change!++    -- Make a declaration eligible for instance search.+    mkInstance+      :: 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+        FunSig r p a i m rel tc cc x e -> (\ i -> FunSig r p a i m rel tc cc x e) <$> setInstance r0 i+        NiceUnquoteDecl r p a i tc cc x e -> (\ i -> NiceUnquoteDecl r p a i tc cc x e) <$> setInstance r0 i+        NiceMutual r tc cc pc ds       -> NiceMutual r tc cc pc <$> mapM (mkInstance r0) ds+        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+        d@NiceRecSig{}                 -> return d+        d@NiceDataSig{}                -> return d+        d@NiceModuleMacro{}            -> return d+        d@NiceModule{}                 -> return d+        d@NicePragma{}                 -> return d+        d@NiceOpen{}                   -> return d+        d@NiceImport{}                 -> return d+        d@NiceDataDef{}                -> return d+        d@NiceRecDef{}                 -> return d+        d@NicePatternSyn{}             -> return d+        d@NiceGeneralize{}             -> return d+        d@NiceUnquoteData{}            -> return d++    setInstance+      :: KwRange  -- Range of @instance@ keyword.+      -> Updater IsInstance+    setInstance r0 = \case+      i@InstanceDef{} -> return i+      _               -> dirty $ InstanceDef r0++    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!++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.+-- If no abstraction is taking place, we want to complain about 'UselessAbstract'.+--+-- Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.+-- Then, nested @abstract@s would sometimes also be complained about.++class MakeAbstract a where+  mkAbstract ::+       KwRange+         -- ^ Range of the keyword @abstract@.+    -> UpdaterT Nice a++  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => KwRange -> UpdaterT Nice a+  mkAbstract = traverse . mkAbstract++instance MakeAbstract a => MakeAbstract [a]++-- Leads to overlap with 'WhereClause':+-- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where+--   mkAbstract = traverse mkAbstract++instance MakeAbstract IsAbstract where+  mkAbstract _ = \case+    a@AbstractDef -> return a+    ConcreteDef -> dirty $ AbstractDef++instance MakeAbstract NiceDeclaration where+  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 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 empty ds]+  mkAbstract _ (SomeWhere r e m a ds) = dirty $ SomeWhere r e m a+                                                  [Abstract empty ds]++-- | Make a declaration private.+--+-- Andreas, 2012-11-17:+-- Mark computation as 'dirty' if there was a declaration that could be privatized.+-- If no privatization is taking place, we want to complain about 'UselessPrivate'.+--+-- Alternatively, we could only flag 'dirty' if a non-private thing was privatized.+-- Then, nested @private@s would sometimes also be complained about.++class MakePrivate a where+  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') => KwRange -> Origin -> UpdaterT Nice a+  mkPrivate kwr o = traverse $ mkPrivate kwr o++instance MakePrivate a => MakePrivate [a]++-- Leads to overlap with 'WhereClause':+-- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where+--   mkPrivate = traverse mkPrivate++instance MakePrivate Access where+  mkPrivate kwr o = \case+    p@PrivateAccess{} -> return p  -- OR? return $ PrivateAccess o+    _                 -> dirty $ PrivateAccess kwr o++instance MakePrivate NiceDeclaration where+  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 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 kwr o cls+      d@NiceDataDef{}                          -> return d+      d@NiceRecDef{}                           -> return d+      d@NiceUnquoteData{}                      -> return d++instance MakePrivate Clause where+  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 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 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 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 -> List1 Declaration+notSoNiceDeclarations = \case+    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) d = singleton $ InstanceB r $ singleton d+    inst NotInstanceDef  d = singleton d++-- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?+niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract+niceHasAbstract = \case+    Axiom{}                       -> Nothing+    NiceField _ _ a _ _ _ _       -> Just a+    PrimitiveFunction _ _ a _ _   -> Just a+    NiceMutual{}                  -> Nothing+    NiceLoneConstructor{}         -> Nothing+    NiceModule _ _ a _ _ _ _      -> Just a+    NiceModuleMacro{}             -> Nothing+    NiceOpen{}                    -> Nothing+    NiceImport{}                  -> Nothing+    NicePragma{}                  -> Nothing+    NiceRecSig{}                  -> Nothing+    NiceDataSig{}                 -> Nothing+    NiceFunClause _ _ a _ _ _ _   -> Just a+    FunSig{}                      -> Nothing+    FunDef _ _ a _ _ _ _ _        -> Just a+    NiceDataDef _ _ a _ _ _ _ _   -> Just a+    NiceRecDef _ _ a _ _ _ _ _ _ -> Just a+    NicePatternSyn{}              -> Nothing+    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
@@ -0,0 +1,564 @@+module Agda.Syntax.Concrete.Definitions.Errors where++import Control.DeepSeq++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.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.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton++------------------------------------------------------------------------+-- Errors++-- | Exception with internal source code callstack+data DeclarationException = DeclarationException+  { deLocation  :: CallStack+  , deException :: DeclarationException'+  }++-- | The exception type.+data DeclarationException'+  = MultipleEllipses Pattern+  | DuplicateDefinition Name+  | DuplicateAnonDeclaration Range+  | MissingWithClauses Name LHS+  | WrongDefinition Name DataRecOrFun DataRecOrFun+  | WrongContentBlock KindOfBlock Range+  | AmbiguousFunClauses LHS (List1 Name)+      -- ^ In a mutual block, a clause could belong to any of the ≥2 type signatures ('Name').+  | AmbiguousConstructor Range Name [Name]+      -- ^ 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 the one of the offending pragma or the mutual block.+  | UnquoteDefRequiresSignature (List1 Name)+  | BadMacroDef NiceDeclaration+  | 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++data DeclarationWarning = DeclarationWarning+  { dwLocation :: CallStack+  , dwWarning  :: DeclarationWarning'+  } deriving (Show, Generic)++-- | Non-fatal errors encountered in the Nicifier.+data DeclarationWarning'+  -- 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.+  | InvalidConstructorBlock Range+      -- ^ Invalid constructor block (not inside an interleaved mutual block)+  | InvalidCoverageCheckPragma Range+      -- ^ A {-\# NON_COVERING \#-} pragma that does not apply to any function.+  | InvalidNoPositivityCheckPragma Range+      -- ^ A {-\# NO_POSITIVITY_CHECK \#-} pragma+      --   that does not apply to any data or record type.+  | InvalidNoUniverseCheckPragma Range+      -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma+      --   that does not apply to a data or record type.+  | InvalidTerminationCheckPragma Range+      -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma+      --   that does not apply to any function.+  | MissingDataDeclaration Name+      -- ^ A @data@ definition without a @data@ signature.+  | MissingDefinitions (List1 (Name, Range))+      -- ^ Declarations (e.g. type signatures) without a definition.+  | NotAllowedInMutual Range String+  | 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 \#-}@.+  | PragmaCompiled Range+      -- ^ @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 (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 KwRange+      -- ^ @instance@ block with nothing that can (newly) become an instance.+  | 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 (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++declarationWarningName' :: DeclarationWarning' -> WarningName+declarationWarningName' = \case+  -- Please keep in alphabetical order.+  EmptyAbstract{}                   -> EmptyAbstract_+  EmptyConstructor{}                -> EmptyConstructor_+  EmptyField{}                      -> EmptyField_+  EmptyGeneralize{}                 -> EmptyGeneralize_+  EmptyInstance{}                   -> EmptyInstance_+  EmptyMacro{}                      -> EmptyMacro_+  EmptyMutual{}                     -> EmptyMutual_+  EmptyPrivate{}                    -> EmptyPrivate_+  EmptyPostulate{}                  -> EmptyPostulate_+  EmptyPrimitive{}                  -> EmptyPrimitive_+  EmptyPolarityPragma{}             -> EmptyPolarityPragma_+  HiddenGeneralize{}                -> HiddenGeneralize_+  InvalidCatchallPragma{}           -> InvalidCatchallPragma_+  InvalidConstructorBlock{}         -> InvalidConstructorBlock_+  InvalidNoPositivityCheckPragma{}  -> InvalidNoPositivityCheckPragma_+  InvalidNoUniverseCheckPragma{}    -> InvalidNoUniverseCheckPragma_+  InvalidTerminationCheckPragma{}   -> InvalidTerminationCheckPragma_+  InvalidCoverageCheckPragma{}      -> InvalidCoverageCheckPragma_+  MissingDataDeclaration{}          -> MissingDataDeclaration_+  MissingDefinitions{}              -> MissingDefinitions_+  NotAllowedInMutual{}              -> NotAllowedInMutual_+  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.+unsafeDeclarationWarning :: DeclarationWarning -> Bool+unsafeDeclarationWarning = unsafeDeclarationWarning' . dwWarning++unsafeDeclarationWarning' :: DeclarationWarning' -> Bool+unsafeDeclarationWarning' = \case+  -- Please keep in alphabetical order.+  EmptyAbstract{}                   -> False+  EmptyConstructor{}                -> False+  EmptyField{}                      -> False+  EmptyGeneralize{}                 -> False+  EmptyInstance{}                   -> False+  EmptyMacro{}                      -> False+  EmptyMutual{}                     -> False+  EmptyPrivate{}                    -> False+  EmptyPostulate{}                  -> False+  EmptyPrimitive{}                  -> False+  EmptyPolarityPragma{}             -> False+  HiddenGeneralize{}                -> False+  InvalidCatchallPragma{}           -> False+  InvalidConstructorBlock{}         -> False+  InvalidNoPositivityCheckPragma{}  -> False+  InvalidNoUniverseCheckPragma{}    -> False+  InvalidTerminationCheckPragma{}   -> False+  InvalidCoverageCheckPragma{}      -> False+  MissingDataDeclaration{}          -> True  -- not safe+  MissingDefinitions{}              -> False -- not safe but deferred until after typechecking+  NotAllowedInMutual{}              -> False -- really safe?+  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++instance HasRange DeclarationException where+  getRange (DeclarationException _ err) = getRange err++instance HasRange DeclarationException' where+  getRange (MultipleEllipses d)                 = getRange d+  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 (WrongContentBlock _ r)              = r+  getRange (InvalidMeasureMutual r)             = r+  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 = \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 (DuplicateDefinition x) = fsep $+    pwords "Duplicate definition of" ++ [pretty x]+  pretty (DuplicateAnonDeclaration _) = fsep $+    pwords "Duplicate declaration of _"+  pretty (MissingWithClauses x lhs) = fsep $+    pwords "Missing with-clauses for function" ++ [pretty x]++  pretty (WrongDefinition x k k') = fsep $ pretty x :+    pwords ("has been declared as a " ++ prettyShow k +++      ", but is being defined as a " ++ prettyShow k')+  pretty (AmbiguousFunClauses lhs xs) = sep+    [ fsep $+        pwords "More than one matching type signature for left hand side " ++ [pretty lhs] +++        pwords "it could belong to any of:"+    , vcat $ fmap (pretty . PrintRange) xs+    ]+  pretty (AmbiguousConstructor _ n ns) = sep+    [ fsep (pwords "Could not find a matching data signature for constructor " ++ [pretty n])+    , vcat (case ns of+              [] -> [fsep $ pwords "There was no candidate."]+              _  -> fsep (pwords "It could be any of:") : fmap (pretty . PrintRange) ns+           )+    ]+  pretty (WrongContentBlock b _)      = fsep . pwords $+    case b of+      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 $+    pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."+  pretty (UnquoteDefRequiresSignature xs) = fsep $+    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 (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 = \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
@@ -0,0 +1,283 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Syntax.Concrete.Definitions.Monad where++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)+import Data.Map (Map)+import qualified Data.Map as Map++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 :: ReaderT NiceEnv (ExceptT DeclarationException (State NiceState)) a }+  deriving ( Functor, Applicative, Monad+           , MonadReader NiceEnv, MonadState NiceState, MonadError DeclarationException+           )++-- | Run a Nicifier computation, return result and warnings+--   (in chronological order).+runNice :: NiceEnv -> Nice a -> (Either DeclarationException a, NiceWarnings)+runNice env m = second (reverse . niceWarn) $+  runExceptT (unNice m `runReaderT` env) `runState` initNiceState++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+    -- ^ Termination checking pragma waiting for a definition.+  , _posChk   :: PositivityCheck+    -- ^ Positivity checking pragma waiting for a definition.+  , _uniChk   :: UniverseCheck+    -- ^ Universe checking pragma waiting for a data/rec signature or definition.+  , _catchall :: Catchall+    -- ^ Catchall pragma waiting for a function clause.+  , _covChk  :: CoverageCheck+    -- ^ Coverage pragma waiting for a definition.+  , niceWarn :: NiceWarnings+    -- ^ Stack of warnings. Head is last warning.+  , _nameId  :: NameId+    -- ^ We distinguish different 'NoName's (anonymous definitions) by a unique 'NameId'.+  }++data LoneSig = LoneSig+  { loneSigRange :: Range+  , loneSigName  :: Name+      -- ^ If 'isNoName', this name can have a different 'NameId'+      --   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+     --   'Name' as a key is up to @Eq Name@ which ignores the range.+     --   However, without range names are not unique in case the+     --   user gives a second definition of the same name.+     --   This causes then problems in 'replaceSigs' which might+     --   replace the wrong signature.+     --+     --   Another reason is that we want to distinguish different+     --   occurrences of 'NoName' in a mutual block (issue #4157).+     --   The 'NoName' in the codomain will have a unique 'NameId'.++type NiceWarnings = [DeclarationWarning]+     -- ^ Stack of warnings. Head is last warning.++-- | Initial nicifier state.++initNiceState :: NiceState+initNiceState = NiceState+  { _loneSigs = Map.empty+  , _termChk  = TerminationCheck+  , _posChk   = YesPositivityCheck+  , _uniChk   = YesUniverseCheck+  , _catchall = empty+  , _covChk   = YesCoverageCheck+  , niceWarn  = []+  , _nameId   = NameId 1 noModuleNameHash+  }++lensNameId :: Lens' NiceState NameId+lensNameId f e = f (_nameId e) <&> \ i -> e { _nameId = i }++nextNameId :: Nice NameId+nextNameId = do+  i <- use lensNameId+  lensNameId %= succ+  return i++-- * Handling the lone signatures, stored to infer mutual blocks.++-- | Lens for field '_loneSigs'.++loneSigs :: Lens' NiceState LoneSigs+loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }++-- | Adding a lone signature to the state.+--   Return the name (which is made unique if 'isNoName').++addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name+addLoneSig r x k = do+  -- Andreas, 2020-05-19, issue #4157, make '_' unique.+  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+      Nothing -> return s'+      Just{}  -> declarationException $+        if not $ isNoName x then DuplicateDefinition x else DuplicateAnonDeclaration r+  return x'++-- | Remove a lone signature from the state.++removeLoneSig :: Name -> Nice ()+removeLoneSig x = loneSigs %= Map.delete x++-- | Search for forward type signature.++getSig :: Name -> Nice (Maybe DataRecOrFun)+getSig x = fmap loneSigKind . Map.lookup x <$> use loneSigs++-- | Check that no lone signatures are left in the state.++noLoneSigs :: Nice Bool+noLoneSigs = null <$> use loneSigs++forgetLoneSigs :: Nice ()+forgetLoneSigs = loneSigs .= Map.empty++-- | Ensure that all forward declarations have been given a definition.+checkLoneSigs :: LoneSigs -> Nice ()+checkLoneSigs xs = do+  forgetLoneSigs+  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)]+loneFuns = map (second loneSigName) . filter (isFunName . loneSigKind . snd) . Map.toList++-- | Create a 'LoneSigs' map from an association list.++loneSigsFromLoneNames :: [(Range, Name, DataRecOrFun)] -> LoneSigs+loneSigsFromLoneNames = Map.fromListWith __IMPOSSIBLE__ . map (\(r,x,k) -> (x, LoneSig r x k))++-- | Lens for field '_termChk'.++terminationCheckPragma :: Lens' NiceState TerminationCheck+terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }++withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a+withTerminationCheckPragma tc f = do+  tc_old <- use terminationCheckPragma+  terminationCheckPragma .= tc+  result <- f+  terminationCheckPragma .= tc_old+  return result++coverageCheckPragma :: Lens' NiceState CoverageCheck+coverageCheckPragma f e = f (_covChk e) <&> \ s -> e { _covChk = s }++withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a+withCoverageCheckPragma tc f = do+  tc_old <- use coverageCheckPragma+  coverageCheckPragma .= tc+  result <- f+  coverageCheckPragma .= tc_old+  return result++-- | Lens for field '_posChk'.++positivityCheckPragma :: Lens' NiceState PositivityCheck+positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }++withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a+withPositivityCheckPragma pc f = do+  pc_old <- use positivityCheckPragma+  positivityCheckPragma .= pc+  result <- f+  positivityCheckPragma .= pc_old+  return result++-- | Lens for field '_uniChk'.++universeCheckPragma :: Lens' NiceState UniverseCheck+universeCheckPragma f e = f (_uniChk e) <&> \ s -> e { _uniChk = s }++withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a+withUniverseCheckPragma uc f = do+  uc_old <- use universeCheckPragma+  universeCheckPragma .= uc+  result <- f+  universeCheckPragma .= uc_old+  return result++-- | Get universe check pragma from a data/rec signature.+--   Defaults to 'YesUniverseCheck'.++getUniverseCheckFromSig :: Name -> Nice UniverseCheck+getUniverseCheckFromSig x = maybe YesUniverseCheck universeCheck <$> getSig x++-- | Lens for field '_catchall'.++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.++popCatchallPragma :: Nice Catchall+popCatchallPragma = do+  ca <- use catchallPragma+  catchallPragma .= empty+  return ca++withCatchallPragma :: Catchall -> Nice a -> Nice a+withCatchallPragma ca f = do+  ca_old <- use catchallPragma+  catchallPragma .= ca+  result <- f+  catchallPragma .= ca_old+  return result++-- | Add a new warning.+niceWarning :: DeclarationWarning -> Nice ()+niceWarning w = modify $ \ st -> st { niceWarn = w : niceWarn st }++declarationException :: HasCallStack => DeclarationException' -> Nice a+declarationException e = withCallerCallStack $ throwError . flip DeclarationException e++declarationWarning' :: DeclarationWarning' -> CallStack -> Nice ()+declarationWarning' w loc = niceWarning $ DeclarationWarning loc w++declarationWarning :: HasCallStack => DeclarationWarning' -> Nice ()+declarationWarning = withCallerCallStack . declarationWarning'
+ src/full/Agda/Syntax/Concrete/Definitions/Types.hs view
@@ -0,0 +1,342 @@+module Agda.Syntax.Concrete.Definitions.Types where++import Control.DeepSeq++import Data.Map (Map)+import Data.Semigroup ( Semigroup(..) )++import GHC.Generics (Generic)++import Agda.Syntax.Position+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.Common.Pretty+import Agda.Utils.Impossible+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1++{--------------------------------------------------------------------------+    Types+ --------------------------------------------------------------------------}++{-| The nice declarations. No fixity declarations and function definitions are+    contained in a single constructor instead of spread out between type+    signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@+    modifiers have been distributed to the individual declarations.++    Observe the order of components:++      Range+      Fixity'+      Access+      IsAbstract+      IsInstance+      TerminationCheck+      PositivityCheck++      further attributes++      (Q)Name++      content (Expr, Declaration ...)+-}+data NiceDeclaration+  = Axiom Range Access IsAbstract IsInstance ArgInfo Name Expr+      -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.+      --+      --   'ArgInfo' argument: Axioms and functions can be declared irrelevant.+      --   ('Hiding' should be 'NotHidden'.)+  | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr)+  | PrimitiveFunction Range Access IsAbstract Name (Arg Expr)+  | 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 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).+    --   The 'Declaration' is the actual 'FunClause'.+  | FunSig Range Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck CoverageCheck Name Expr+  | FunDef Range [Declaration] IsAbstract IsInstance TerminationCheck CoverageCheck Name [Clause]+      -- ^ Block of function clauses (we have seen the type signature before).+      --   The 'Declaration's are the original declarations that were processed+      --   into this 'FunDef' and are only used in 'notSoNiceDeclaration'.+      --   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 KwRange [NiceConstructor]+  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [RecordDirective] [LamBinding] [Declaration]+      -- ^ @(Maybe Range)@ gives range of the 'pattern' declaration.+  | 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+  | NiceUnquoteData Range Access IsAbstract PositivityCheck UniverseCheck Name [Name] Expr+  | NiceOpaque KwRange [QName] [NiceDeclaration]+  deriving (Show, Generic)++instance NFData NiceDeclaration++type TerminationCheck = Common.TerminationCheck Measure++-- | Termination measure is, for now, a variable name.+type Measure = Name++-- | Only 'Axiom's.+type NiceConstructor = NiceTypeSignature++-- | Only 'Axiom's.+type NiceTypeSignature  = NiceDeclaration++-- | 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 (Show, Generic)++instance NFData Clause++-- | When processing a mutual block we collect the various checks present in the block+--   before combining them.++data MutualChecks = MutualChecks+  { mutualTermination :: [TerminationCheck]+  , mutualCoverage    :: [CoverageCheck]+  , mutualPositivity  :: [PositivityCheck]+  }++instance Semigroup MutualChecks where+  MutualChecks a b c <> MutualChecks a' b' c'+    = MutualChecks (a <> a') (b <> b') (c <> c')++instance Monoid MutualChecks where+  mempty = MutualChecks [] [] []+  mappend = (<>)++-- | In an inferred `mutual' block we keep accumulating nice declarations until all+--   of the lone signatures have an attached definition. The type is therefore a bit+--   span-like: we return an initial segment (the inferred mutual block) together+--   with leftovers.++data InferredMutual = InferredMutual+  { inferredChecks    :: MutualChecks       -- checks for this block+  , inferredBlock     :: [NiceDeclaration]  -- mutual block+  , inferredLeftovers :: [NiceDeclaration]  -- leftovers+  }++extendInferredBlock :: NiceDeclaration -> InferredMutual -> InferredMutual+extendInferredBlock d (InferredMutual cs ds left) = InferredMutual cs (d : ds) left++-- | In an `interleaved mutual' block we collect the data signatures, function signatures,+--   as well as their associated constructors and function clauses respectively.+--   Each signature is given a position in the block (from 0 onwards) and each set+--   of constructor / clauses is given a *distinct* one. This allows for interleaved+--   forward declarations similar to what one gets in a new-style mutual block.+type InterleavedMutual = Map Name InterleavedDecl++data InterleavedDecl+  = InterleavedData+    { interleavedDeclNum  :: DeclNum+        -- ^ Internal number of the data signature.+    , interleavedDeclSig  :: NiceDeclaration+        -- ^ The data signature.+    , interleavedDataCons :: Maybe (DeclNum, List1 [NiceConstructor])+        -- ^ Constructors associated to the data signature.+    }+  | InterleavedFun+    { interleavedDeclNum  :: DeclNum+        -- ^ Internal number of the function signature.+    , interleavedDeclSig  :: NiceDeclaration+        -- ^ The function signature.+    , interleavedFunClauses :: Maybe (DeclNum, List1 ([Declaration],[Clause]))+        -- ^ Function clauses associated to the function signature.+    }++-- | Numbering declarations in an @interleaved mutual@ block.+type DeclNum = Int++isInterleavedFun :: InterleavedDecl -> Maybe ()+isInterleavedFun InterleavedFun{} = Just ()+isInterleavedFun _ = Nothing++isInterleavedData :: InterleavedDecl -> Maybe ()+isInterleavedData InterleavedData{} = Just ()+isInterleavedData _ = Nothing++interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)]+interleavedDecl k = \case+  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+                    FunDef r (sconcat dss) abs inst tc cc n (sconcat css)+    in (i,d) : maybe [] (\ (j, dcss) -> [(j, fdef (List1.reverse dcss))]) dcs+  _ -> __IMPOSSIBLE__ -- someone messed up and broke the invariant++-- | Several declarations expect only type signatures as sub-declarations.  These are:+data KindOfBlock+  = PostulateBlock  -- ^ @postulate@+  | PrimitiveBlock  -- ^ @primitive@.  Ensured by parser.+  | InstanceBlock   -- ^ @instance@.  Actually, here all kinds of sub-declarations are allowed a priori.+  | 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 (Eq, Ord, Show, Generic)++instance NFData KindOfBlock++instance HasRange NiceDeclaration where+  getRange (Axiom r _ _ _ _ _ _)           = r+  getRange (NiceField 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+  getRange (PrimitiveFunction r _ _ _ _)   = r+  getRange (FunSig r _ _ _ _ _ _ _ _ _)    = r+  getRange (FunDef r _ _ _ _ _ _ _)        = r+  getRange (NiceDataDef r _ _ _ _ _ _ _)   = r+  getRange (NiceLoneConstructor kwr ds)    = fuseRange kwr ds+  getRange (NiceRecDef 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 (NiceUnquoteData r _ _ _ _ _ _ _) = r+  getRange (NiceOpaque kwr xs ds)          = getRange (kwr, xs, ds)++instance Pretty NiceDeclaration where+  pretty = \case+    Axiom _ _ _ _ _ x _            -> text "postulate" <+> pretty x <+> colon <+> text "_"+    NiceField _ _ _ _ _ x _        -> text "field" <+> pretty x+    PrimitiveFunction _ _ _ x _    -> text "primitive" <+> pretty x+    NiceMutual{}                   -> text "mutual"+    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+    NiceFunClause{}                -> text "<function clause>"+    FunSig _ _ _ _ _ _ _ _ x _     -> pretty x <+> colon <+> text "_"+    FunDef _ _ _ _ _ _ x _         -> pretty x <+> text "= _"+    NiceDataDef _ _ _ _ _ x _ _    -> text "data" <+> pretty x <+> text "where"+    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"+declName NiceField{}         = "Fields"+declName NiceMutual{}        = "Mutual blocks"+declName NiceModule{}        = "Modules"+declName NiceModuleMacro{}   = "Modules"+declName NiceOpen{}          = "Open declarations"+declName NiceImport{}        = "Import statements"+declName NicePragma{}        = "Pragmas"+declName PrimitiveFunction{} = "Primitive declarations"+declName NicePatternSyn{}    = "Pattern synonyms"+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"+declName FunSig{}            = "Type signatures"+declName FunDef{}            = "Function definitions"+declName NiceRecDef{}        = "Records"+declName NiceDataDef{}       = "Data types"+declName NiceLoneConstructor{} = "Constructors"+declName NiceOpaque{}          = "Opaque blocks"+++data InMutual+  = InMutual    -- ^ we are nicifying a mutual block+  | NotInMutual -- ^ we are nicifying decls not in a mutual block+    deriving (Eq, Show)++-- | The kind of the forward declaration.++data DataRecOrFun+  = DataName+    { _kindPosCheck :: PositivityCheck+    , _kindUniCheck :: UniverseCheck+    }+    -- ^ Name of a data type+  | RecName+    { _kindPosCheck :: PositivityCheck+    , _kindUniCheck :: UniverseCheck+    }+    -- ^ Name of a record type+  | FunName TerminationCheck CoverageCheck+    -- ^ Name of a function.+  deriving (Show, Generic)++instance NFData DataRecOrFun++-- Ignore pragmas when checking equality+instance Eq DataRecOrFun where+  DataName{} == DataName{} = True+  RecName{}  == RecName{}  = True+  FunName{}  == FunName{}  = True+  _          == _          = False++instance Pretty DataRecOrFun where+  pretty DataName{} = "data type"+  pretty RecName{}  = "record type"+  pretty FunName{}  = "function"++isFunName :: DataRecOrFun -> Bool+isFunName (FunName{}) = True+isFunName _           = False++sameKind :: DataRecOrFun -> DataRecOrFun -> Bool+sameKind = (==)++terminationCheck :: DataRecOrFun -> TerminationCheck+terminationCheck (FunName tc _) = tc+terminationCheck _ = TerminationCheck++coverageCheck :: DataRecOrFun -> CoverageCheck+coverageCheck (FunName _ cc) = cc+coverageCheck _ = YesCoverageCheck++positivityCheck :: DataRecOrFun -> PositivityCheck+positivityCheck (DataName pc _) = pc+positivityCheck (RecName pc _)  = pc+positivityCheck (FunName _ _)   = YesPositivityCheck++mutualChecks :: DataRecOrFun -> MutualChecks+mutualChecks k = MutualChecks [terminationCheck k] [coverageCheck k] [positivityCheck k]++universeCheck :: DataRecOrFun -> UniverseCheck+universeCheck (DataName _ uc) = uc+universeCheck (RecName _ uc)  = uc+universeCheck (FunName _ _)   = YesUniverseCheck
+ src/full/Agda/Syntax/Concrete/Fixity.hs view
@@ -0,0 +1,264 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Collecting fixity declarations (and polarity pragmas) for concrete+--   declarations.++module Agda.Syntax.Concrete.Fixity+  ( Fixities, Polarities, MonadFixityError(..)+  , DoWarn(..)+  , fixitiesAndPolarities+  ) where++import Prelude hiding (null)++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++import Agda.Syntax.Builtin (builtinById, isBuiltinNoDef)+import Agda.Syntax.Common+import Agda.Syntax.Concrete+import Agda.Syntax.Position+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.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 PragmaPolarities++class Monad m => MonadFixityError m where+  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.++plusFixities :: MonadFixityError m => Fixities -> Fixities -> m Fixities+plusFixities m1 m2+    -- If maps are not disjoint, report conflicts as exception.+    | Just ds <- List1.nonEmpty isect = throwMultipleFixityDecls ds+    -- Otherwise, do the union.+    | otherwise        = return $ Map.unionWithKey mergeFixites m1 m2+  where+    --  Merge two fixities, assuming there is no conflict+    mergeFixites name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s $ fuseRange r1 r2+              where f | null f1 = f2+                      | null f2 = f1+                      | otherwise = __IMPOSSIBLE__+                    s | null s1 = s2+                      | null s2 = s1+                      | otherwise = __IMPOSSIBLE__++    -- Compute a list of conflicts in a format suitable for error reporting.+    isect = [ (x, fmap (Map.findWithDefault __IMPOSSIBLE__ x) $ Pair m1 m2)+            | (x, False) <- Map.assocs $ Map.intersectionWith compatible m1 m2 ]++    -- Check for no conflict.+    compatible (Fixity' f1 s1 _) (Fixity' f2 s2 _) =+      (null f1 || null f2) &&+      (null s1 || null s2)++-- | While 'Fixities' and Polarities are not semigroups under disjoint+--   union (which might fail), we get a semigroup instance for the+--   monadic @m (Fixities, Polarities)@ which propagates the first+--   error.+newtype MonadicFixPol m = MonadicFixPol { runMonadicFixPol :: m (Fixities, Polarities) }++returnFix :: Monad m => Fixities -> MonadicFixPol m+returnFix fx = MonadicFixPol $ return (fx, Map.empty)++returnPol :: Monad m => Polarities -> MonadicFixPol m+returnPol pol = MonadicFixPol $ return (Map.empty, pol)++instance MonadFixityError m => Semigroup (MonadicFixPol m) where+  c1 <> c2 = MonadicFixPol $ do+    (f1, p1) <- runMonadicFixPol c1+    (f2, p2) <- runMonadicFixPol c2+    f <- plusFixities f1 f2+    p <- mergePolarities p1 p2+    return (f, p)+    where+    -- 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)+  mappend = (<>)++data DoWarn = NoWarn | DoWarn+  deriving (Eq, Show)++-- | Get the fixities and polarity pragmas from the current block.+--   Doesn't go inside modules and where blocks.+--   The reason for this is that these declarations have to appear at the same+--   level (or possibly outside an abstract or mutual block) as their target+--   declaration.+fixitiesAndPolarities :: MonadFixityError m => DoWarn -> [Declaration] -> m (Fixities, Polarities)+fixitiesAndPolarities doWarn ds = do+  (fixs, pols) <- runMonadicFixPol $ fixitiesAndPolarities' ds+  let DeclaredNames declared postulates privateNames = foldMap declaredNames ds+  let publicNames = declared Set.\\ privateNames++  -- If we have names in fixity declarations which are not defined in the+  -- appropriate scope, raise a warning and delete them from fixs.+  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 <- Set1.ifNull (Map.keysSet pols Set.\\ declared) (return pols) $+    \ unknownPols -> do+      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+  Set1.unlessNull (Set.filter isOpenMixfix publicNames Set.\\ Map.keysSet fixs) $+    when (doWarn == DoWarn) . warnUnknownFixityInMixfixDecl++  -- Check that every polarity pragma is used for a postulate.+  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 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)+  -- We look into these blocks:+  Mutual    _ ds' -> fixitiesAndPolarities' ds'+  InterleavedMutual _ ds' -> fixitiesAndPolarities' ds'+  Abstract  _ ds' -> fixitiesAndPolarities' ds'+  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.+  TypeSig         {}  -> mempty+  FieldSig        {}  -> mempty+  Generalize      {}  -> mempty+  Field           {}  -> mempty+  FunClause       {}  -> mempty+  DataSig         {}  -> mempty+  DataDef         {}  -> mempty+  Data            {}  -> mempty+  RecordSig       {}  -> mempty+  RecordDef       {}  -> mempty+  Record          {}  -> mempty+  LoneConstructor {}  -> mempty+  PatternSyn      {}  -> mempty+  Postulate       {}  -> mempty+  Primitive       {}  -> mempty+  Open            {}  -> mempty+  Import          {}  -> mempty+  ModuleMacro     {}  -> mempty+  Module          {}  -> mempty+  UnquoteDecl     {}  -> mempty+  UnquoteDef      {}  -> mempty+  UnquoteData     {}  -> mempty+  Pragma          {}  -> mempty+  Unfolding       {}  -> mempty++data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name }++instance Semigroup DeclaredNames where+  DeclaredNames xs ps as <> DeclaredNames ys qs bs =+    DeclaredNames (xs <> ys) (ps <> qs) (as <> bs)++instance Monoid DeclaredNames where+  mempty  = DeclaredNames Set.empty Set.empty Set.empty+  mappend = (<>)++allPostulates :: DeclaredNames -> DeclaredNames+allPostulates (DeclaredNames xs ps as) = DeclaredNames xs (xs <> ps) as++allPrivateNames :: DeclaredNames -> DeclaredNames+allPrivateNames (DeclaredNames xs ps as) = DeclaredNames xs ps (xs <> as)++declaresNames :: [Name] -> DeclaredNames+declaresNames xs = DeclaredNames (Set.fromList xs) Set.empty Set.empty++declaresName :: Name -> DeclaredNames+declaresName x = declaresNames [x]++-- | Compute the names defined in a declaration. We stay in the current scope,+--   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+  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 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+  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))+    | 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,4 +1,4 @@-{-# LANGUAGE CPP               #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Generic traversal and reduce for concrete syntax, --   in the style of "Agda.Syntax.Internal.Generic".@@ -7,20 +7,21 @@  module Agda.Syntax.Concrete.Generic where -import Control.Applicative--import Data.Traversable-import Data.Monoid-import Data.Foldable+import Data.Bifunctor+import Data.Functor  import Agda.Syntax.Common import Agda.Syntax.Concrete  import Agda.Utils.Either+import Agda.Utils.List1 (List1)+import Agda.Utils.List2 (List2) -#include "undefined.h" import Agda.Utils.Impossible +-- Generic traversals for concrete expressions.+-- ========================================================================+ -- | Generic traversals for concrete expressions. -- --   Note: does not go into patterns!@@ -28,79 +29,73 @@   mapExpr :: (Expr -> Expr) -> a -> a   -- ^ This corresponds to 'map'. -  traverseExpr-#if __GLASGOW_HASKELL__ <= 708-    :: (Applicative m, Monad m)-#else-    :: Monad m-#endif-    => (Expr -> m Expr) -> a -> m a+  foldExpr :: Monoid m => (Expr -> m) -> a -> m+  -- ^ This corresponds to 'foldMap'.++  traverseExpr :: Monad m => (Expr -> m Expr) -> a -> m a   -- ^ This corresponds to 'mapM'. -  foldExpr :: Monoid m => (Expr -> m) -> a -> m-  -- ^ This is a reduce.+  default mapExpr :: (Functor t, ExprLike b, t b ~ a) => (Expr -> Expr) -> a -> a+  mapExpr = fmap . mapExpr -  traverseExpr = __IMPOSSIBLE__  -- TODO: implement!-  foldExpr     = __IMPOSSIBLE__  -- TODO: implement!+  default foldExpr+    :: (Monoid m, Foldable t, ExprLike b, t b ~ a)+    => (Expr -> m) -> a -> m+  foldExpr = foldMap . foldExpr --- * Instances for things that do not contain expressions.+  default traverseExpr+    :: (Monad m, Traversable t, ExprLike b, t b ~ a)+    => (Expr -> m Expr) -> a -> m a+  traverseExpr = traverse . traverseExpr ++-- Instances for things that do not contain expressions.+---------------------------------------------------------------------------++instance ExprLike () where+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return+ instance ExprLike Name where-  mapExpr f = id+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return  instance ExprLike QName where-  mapExpr f = id+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return  instance ExprLike Bool where-  mapExpr f = id---- * Instances for functors.--instance ExprLike a => ExprLike (Named name a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+  mapExpr _      = id+  foldExpr _ _   = mempty+  traverseExpr _ = return -instance ExprLike a => ExprLike (Arg a) where  -- TODO guilhem-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+-- Instances for collections and decorations.+--------------------------------------------------------------------------- -instance ExprLike a => ExprLike [a] where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+instance ExprLike a => ExprLike [a]+instance ExprLike a => ExprLike (List1 a)+instance ExprLike a => ExprLike (List2 a)+instance ExprLike a => ExprLike (Maybe a) -instance ExprLike a => ExprLike (Maybe a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+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) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr+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)  instance (ExprLike a, ExprLike b) => ExprLike (Either a b) where-  mapExpr f      = mapEither (mapExpr f) (mapExpr f)+  mapExpr f      = bimap (mapExpr f) (mapExpr f)   traverseExpr f = traverseEither (traverseExpr f) (traverseExpr f)   foldExpr f     = either (foldExpr f) (foldExpr f) -instance ExprLike a => ExprLike (TypedBinding' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr--instance ExprLike a => ExprLike (RHS' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr--instance ExprLike a => ExprLike (WhereClause' a) where-  mapExpr      = fmap     . mapExpr-  traverseExpr = traverse . traverseExpr-  foldExpr     = foldMap  . foldExpr- instance (ExprLike a, ExprLike b) => ExprLike (a, b) where   mapExpr      f (x, y) = (mapExpr f x, mapExpr f y)   traverseExpr f (x, y) = (,) <$> traverseExpr f x <*> traverseExpr f y@@ -116,47 +111,53 @@   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 cs   -> f $ ExtendedLam r          $ mapE cs-     Fun r a b          -> f $ Fun r       (mapE a)   $ mapE b-     Pi tel e           -> f $ Pi          (mapE tel) $ mapE e-     Set{}              -> f $ e0-     Prop{}             -> f $ e0-     SetN{}             -> f $ e0-     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 e  -> f $ IdiomBrackets r        $ mapE e-     Absurd{}           -> f $ e0-     As r x e           -> f $ As r x                 $ mapE e-     Dot r e            -> f $ Dot r                  $ mapE e-     ETel tel           -> f $ ETel                   $ mapE tel-     QuoteGoal r x e    -> f $ QuoteGoal r x          $ mapE e-     QuoteContext r     -> f $ e0-     Tactic r e es      -> f $ Tactic r     (mapE e)  $ mapE es-     Quote{}            -> f $ e0-     QuoteTerm{}        -> f $ e0-     Unquote{}          -> f $ e0-     DontCare e         -> f $ DontCare               $ mapE e-     Equal{}            -> f $ e0-   where mapE e = mapExpr f 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 +  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__+ instance ExprLike FieldAssignment where   mapExpr      f (FieldAssignment x e) = FieldAssignment x (mapExpr f e)   traverseExpr f (FieldAssignment x e) = (\e' -> FieldAssignment x e') <$> traverseExpr f e@@ -168,65 +169,223 @@   foldExpr     f (ModuleAssignment m es i) = foldExpr f es  instance ExprLike a => ExprLike (OpApp a) where-  mapExpr f e0 = case e0 of+  mapExpr f = \case      SyntaxBindingLambda r bs e -> SyntaxBindingLambda r (mapE bs) $ mapE e      Ordinary                 e -> Ordinary                        $ mapE e-   where mapE e = mapExpr f e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike LamBinding where-  mapExpr f e0 = case e0 of-     DomainFree{}  -> e0+  mapExpr f = \case+     e@DomainFree{}-> e      DomainFull bs -> DomainFull $ mapE bs    where mapE e = mapExpr f e--instance ExprLike TypedBindings where-  mapExpr f e0 = case e0 of-     TypedBindings r b -> TypedBindings r $ mapE b-   where mapE e = mapExpr f e+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike LHS where-  mapExpr f e0 = case e0 of-     LHS    ps wps res wes -> LHS    ps wps (mapE res) $ mapE wes-     Ellipsis r ps res wes -> Ellipsis r ps (mapE res) $ mapE wes-   where mapE e = mapExpr f e+  mapExpr f = \case+     LHS ps res wes -> LHS ps (mapE res) (mapE wes)+   where+     mapE :: ExprLike a => a -> a+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__ +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+    LeftLet pes   -> LeftLet $ (fmap . fmap . mapExpr) f pes+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__++instance ExprLike LamClause where+  mapExpr f (LamClause ps rhs ca) = LamClause ps (mapExpr f rhs) ca+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__++instance ExprLike DoStmt where+  mapExpr f (DoBind r p e cs) = DoBind r p (mapExpr f e) (mapExpr f cs)+  mapExpr f (DoThen e)        = DoThen (mapExpr f e)+  mapExpr f (DoLet r ds)      = DoLet r (mapExpr f ds)++  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__+ instance ExprLike ModuleApplication where-  mapExpr f e0 = case e0 of-     SectionApp r bs e -> SectionApp r (mapE bs) $ mapE e-     RecordModuleIFS{} -> e0-   where mapE e = mapExpr f e+  mapExpr f = \case+     SectionApp r bs x es -> SectionApp r (mapE bs) x $ mapE es+     e@RecordModuleInstance{} -> e+   where+     mapE :: ExprLike e => e -> e+     mapE = mapExpr f+  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__  instance ExprLike Declaration where-  mapExpr f e0 = case e0 of-     TypeSig ai x e            -> TypeSig ai x                         $ mapE e-     Field i x e               -> Field i x                            $ mapE e-     FunClause lhs rhs wh ca   -> FunClause (mapE lhs) (mapE rhs) (mapE wh) (mapE ca)-     DataSig r ind x bs e      -> DataSig r ind x (mapE bs)            $ mapE e-     Data r ind n bs e cs      -> Data r ind n (mapE bs) (mapE e)      $ mapE cs-     RecordSig r ind bs e      -> RecordSig r ind (mapE bs)            $ mapE e-     Record r n ind eta c tel e ds -> Record r n ind eta c (mapE tel) (mapE e) $ mapE ds-     Infix{}                   -> e0-     Syntax{}                  -> e0-     PatternSyn{}              -> e0+  mapExpr f = \case+     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) 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 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 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      Mutual    r ds            -> Mutual    r                          $ mapE ds+     InterleavedMutual r ds    -> InterleavedMutual r                  $ mapE ds+     LoneConstructor r ds      -> LoneConstructor r                    $ mapE ds      Abstract  r ds            -> Abstract  r                          $ mapE ds      Private   r o ds          -> Private   r o                        $ mapE ds      InstanceB r ds            -> InstanceB r                          $ mapE ds      Macro     r ds            -> Macro     r                          $ mapE ds      Postulate r ds            -> Postulate r                          $ mapE ds      Primitive r ds            -> Primitive r                          $ mapE ds-     Open{}                    -> e0-     Import{}                  -> e0-     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+     Generalize r ds           -> Generalize r                         $ mapE ds+     Opaque  r ds              -> Opaque r                             $ mapE ds+     e@Open{}                  -> e+     e@Import{}                -> e+     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)-     Pragma{}                  -> e0-   where mapE e = mapExpr f 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 +  foldExpr     = __IMPOSSIBLE__+  traverseExpr = __IMPOSSIBLE__++ {- Template  instance ExprLike a where-  mapExpr f e0 = case e0 of-   where mapE e = mapExpr f e+  mapExpr f = \case+    where mapE e = mapExpr f e+  foldExpr     = __IMPOSSIBLE__+  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
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-| Choice of Unicode or ASCII glyphs.+-}+module Agda.Syntax.Concrete.Glyph+  ( UnicodeOrAscii(..)+  , unsafeSetUnicodeOrAscii+  , specialCharactersForGlyphs+  , braces', dbraces+  , forallQ+  , leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt+  , arrow, lambda+  , SpecialCharacters(..)+  ) where++import Control.DeepSeq++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)++import GHC.Generics (Generic)++import Agda.Utils.Boolean+import Agda.Utils.List+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty++-- | We want to know whether we are allowed to insert unicode characters or not.+data UnicodeOrAscii+  = 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++{-# NOINLINE unsafeSetUnicodeOrAscii #-}+unsafeSetUnicodeOrAscii :: UnicodeOrAscii -> IO ()+unsafeSetUnicodeOrAscii = writeIORef unsafeUnicodeOrAsciiIORef++-- | Are we allowed to use unicode supscript characters?+unsafeUnicodeOrAscii :: UnicodeOrAscii+unsafeUnicodeOrAscii = UNSAFE.unsafePerformIO (readIORef unsafeUnicodeOrAsciiIORef)++-- | Picking the appropriate set of special characters depending on+-- whether we are allowed to use unicode or have to limit ourselves+-- to ascii.++data SpecialCharacters = SpecialCharacters+  { _dbraces :: Doc -> Doc+  , _lambda  :: Doc+  , _arrow   :: Doc+  , _forallQ :: Doc+  , _leftIdiomBrkt  :: Doc+  , _rightIdiomBrkt :: Doc+  , _emptyIdiomBrkt :: Doc+  }++specialCharactersUnicode :: SpecialCharacters+specialCharactersUnicode = SpecialCharacters+  { _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         = 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+specialCharactersForGlyphs :: UnicodeOrAscii -> SpecialCharacters+specialCharactersForGlyphs UnicodeOk = specialCharactersUnicode+specialCharactersForGlyphs AsciiOnly = specialCharactersAscii++-- | Choose the glyph set based on the unsafe IORef.+{-# NOINLINE specialCharacters #-}+specialCharacters :: SpecialCharacters+specialCharacters = specialCharactersForGlyphs unsafeUnicodeOrAscii++braces' :: Doc -> Doc+braces' d = caseList (render d) (braces d) {-else-} $ \ c cs ->+  braces (spaceIfDash c <> d <> spaceIfDash (last1 c cs))+  -- Add space to avoid starting a comment (Ulf, 2010-09-13, #269)+  -- Andreas, 2018-07-21, #3161: Also avoid ending a comment+  where+  spaceIfDash '-' = " "+  spaceIfDash _   = empty++-- double braces...+dbraces :: Doc -> Doc+dbraces = _dbraces specialCharacters++-- forall quantifier+forallQ :: Doc+forallQ = hlSymbol $ _forallQ specialCharacters++-- left, right, and empty idiom bracket+leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt :: Doc+leftIdiomBrkt  = _leftIdiomBrkt  specialCharacters+rightIdiomBrkt = _rightIdiomBrkt specialCharacters+emptyIdiomBrkt = _emptyIdiomBrkt specialCharacters++arrow, lambda :: Doc+arrow  = _arrow specialCharacters+lambda = _lambda specialCharacters
src/full/Agda/Syntax/Concrete/Name.hs view
@@ -1,32 +1,27 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- {-| Names in the concrete syntax are just strings (or lists of strings for     qualified names). -} module Agda.Syntax.Concrete.Name where  import Control.DeepSeq-import Control.Applicative  import Data.ByteString.Char8 (ByteString)-import Data.List-import Data.Typeable (Typeable)+import Data.Function (on)+import qualified Data.Foldable as Fold  import GHC.Generics (Generic) -import System.FilePath- import Agda.Syntax.Common import Agda.Syntax.Position -import Agda.Utils.FileName-import Agda.Utils.Pretty-import Agda.Utils.Size+import Agda.Utils.Lens+import Agda.Utils.List  (last1)+import Agda.Utils.List1 (List1, pattern (:|), (<|))+import qualified Agda.Utils.List1 as List1+import Agda.Syntax.Common.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Suffix -#include "undefined.h" import Agda.Utils.Impossible  {-| A name is a non-empty list of alternating 'Id's and 'Hole's. A normal name@@ -38,22 +33,38 @@     in different locations are equal. -} data Name-  = Name Range [NamePart]  -- ^ A (mixfix) identifier.-  | NoName Range NameId    -- ^ @_@.-  deriving (Typeable)+  = Name -- ^ A (mixfix) identifier.+    { nameRange     :: Range+    , nameInScope   :: NameInScope+    , nameNameParts :: NameParts+    }+  | NoName -- ^ @_@.+    { nameRange     :: Range+    , nameId        :: NameId+    } +type NameParts = List1 NamePart++-- | An open mixfix identifier is either prefix, infix, or suffix.+--   That is to say: at least one of its extremities is a @Hole@++isOpenMixfix :: Name -> Bool+isOpenMixfix = \case+  Name _ _ (x :| x' : xs) -> x == Hole || last1 x' xs == Hole+  _ -> False+ instance Underscore Name where   underscore = NoName noRange __IMPOSSIBLE__-  isUnderscore NoName{}        = True-  isUnderscore (Name _ [Id x]) = isUnderscore x-  isUnderscore _               = False+  isUnderscore NoName{} = True+  isUnderscore (Name {nameNameParts = Id x :| []}) = isUnderscore x+  isUnderscore _ = False  -- | Mixfix identifiers are composed of words and holes, --   e.g. @_+_@ or @if_then_else_@ or @[_/_]@. data NamePart   = Hole       -- ^ @_@ part.   | Id RawName  -- ^ Identifier part.-  deriving (Typeable, Generic)+  deriving Generic  -- | Define equality on @Name@ to ignore range so same names in different --   locations are equal.@@ -65,15 +76,15 @@ --   right to be able to do a lookup. -Ulf  instance Eq Name where-    Name _ xs  == Name _ ys  = xs == ys-    NoName _ i == NoName _ j = i == j-    _          == _          = False+    Name _ _ xs    == Name _ _ ys    = xs == ys+    NoName _ i     == NoName _ j     = i == j+    _              == _              = False  instance Ord Name where-    compare (Name _ xs)  (Name _ ys)  = compare xs ys-    compare (NoName _ i) (NoName _ j) = compare i j-    compare (NoName {})  (Name {})    = LT-    compare (Name {})    (NoName {})  = GT+    compare (Name _ _ xs)  (Name _ _ ys)      = compare xs ys+    compare (NoName _ i)   (NoName _ j)       = compare i j+    compare (NoName {})    (Name {})          = LT+    compare (Name {})      (NoName {})        = GT  instance Eq NamePart where   Hole  == Hole  = True@@ -96,42 +107,58 @@ data QName   = Qual  Name QName -- ^ @A.rest@.   | QName Name       -- ^ @x@.-  deriving (Typeable, 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.+------------------------------------------------------------------------+-- * Constructing simple 'Name's.+------------------------------------------------------------------------ -newtype TopLevelModuleName-  = TopLevelModuleName { moduleNameParts :: [String] }-  deriving (Show, Eq, Ord, Typeable, Sized)+-- | Create an ordinary 'InScope' name.+simpleName :: RawName -> Name+simpleName = Name noRange InScope . singleton . Id +-- | Create a binary operator name in scope.+simpleBinaryOperator :: RawName -> Name+simpleBinaryOperator s = Name noRange InScope $ Hole :| Id s : Hole : []++-- | Create an ordinary 'InScope' name containing a single 'Hole'.+simpleHole :: Name+simpleHole = Name noRange InScope $ singleton Hole+ ------------------------------------------------------------------------ -- * Operations on 'Name' and 'NamePart' ------------------------------------------------------------------------ +-- | Don't use on 'NoName{}'.+lensNameParts :: Lens' Name NameParts+lensNameParts f = \case+  n@Name{} -> f (nameNameParts n) <&> \ ps -> n { nameNameParts = ps }+  NoName{} -> __IMPOSSIBLE__+ nameToRawName :: Name -> RawName nameToRawName = prettyShow -nameParts :: Name -> [NamePart]-nameParts (Name _ ps)  = ps-nameParts (NoName _ _) = [Id "_"] -- To not return an empty list+nameParts :: Name -> NameParts+nameParts (Name _ _ ps)    = ps+nameParts (NoName _ _)     = singleton $ Id "_" -- To not return an empty list  nameStringParts :: Name -> [RawName]-nameStringParts n = [ s | Id s <- nameParts n ]+nameStringParts n = [ s | Id s <- List1.toList $ nameParts n ]  -- | Parse a string to parts of a concrete name. -- --   Note: @stringNameParts "_" == [Id "_"] == nameParts NoName{}@ -stringNameParts :: String -> [NamePart]-stringNameParts "_" = [Id "_"]   -- NoName-stringNameParts s = loop s where+stringNameParts :: String -> NameParts+stringNameParts ""  = singleton $ Id "_"  -- NoName+stringNameParts "_" = singleton $ Id "_"  -- NoName+stringNameParts s = List1.fromListSafe __IMPOSSIBLE__ $ loop s+  where   loop ""                              = []   loop ('_':s)                         = Hole : loop s   loop s | (x, s') <- break (== '_') s = Id (stringToRawName x) : loop s'@@ -140,37 +167,164 @@ class NumHoles a where   numHoles :: a -> Int -instance NumHoles [NamePart] where-  numHoles = length . filter (== Hole)+instance NumHoles NameParts where+  numHoles = length . List1.filter (== Hole)  instance NumHoles Name where-  numHoles NoName{}       = 0-  numHoles (Name _ parts) = numHoles parts+  numHoles NoName{}         = 0+  numHoles (Name { nameNameParts = parts }) = numHoles parts  instance NumHoles QName where   numHoles (QName x)  = numHoles x   numHoles (Qual _ x) = numHoles x  -- | Is the name an operator?-+--   Needs at least 2 'NamePart's. isOperator :: Name -> Bool-isOperator (NoName {}) = False-isOperator (Name _ ps) = length ps > 1+isOperator = \case+  Name _ _ (_ :| _ : _) -> True+  _ -> False  isHole :: NamePart -> Bool isHole Hole = True isHole _    = False  isPrefix, isPostfix, isInfix, isNonfix :: Name -> Bool-isPrefix  x = not (isHole (head xs)) &&      isHole (last xs)  where xs = nameParts x-isPostfix x =      isHole (head xs)  && not (isHole (last xs)) where xs = nameParts x-isInfix   x =      isHole (head xs)  &&      isHole (last xs)  where xs = nameParts x-isNonfix  x = not (isHole (head xs)) && not (isHole (last xs)) where xs = nameParts x+isPrefix  x = not (isHole (List1.head xs)) &&      isHole (List1.last xs)  where xs = nameParts x+isPostfix x =      isHole (List1.head xs)  && not (isHole (List1.last xs)) where xs = nameParts x+isInfix   x =      isHole (List1.head xs)  &&      isHole (List1.last xs)  where xs = nameParts x+isNonfix  x = not (isHole (List1.head xs)) && not (isHole (List1.last xs)) where xs = nameParts x + ------------------------------------------------------------------------+-- * Keeping track of which names are (not) in scope+------------------------------------------------------------------------++data NameInScope = InScope | NotInScope+  deriving (Eq, Show)++class LensInScope a where+  lensInScope :: Lens' a NameInScope++  isInScope :: a -> NameInScope+  isInScope x = x ^. lensInScope++  mapInScope :: (NameInScope -> NameInScope) -> a -> a+  mapInScope = over lensInScope++  setInScope :: a -> a+  setInScope = mapInScope $ const InScope++  setNotInScope :: a -> a+  setNotInScope = mapInScope $ const NotInScope++instance LensInScope NameInScope where+  lensInScope = id++instance LensInScope Name where+  lensInScope f = \case+    n@Name{ nameInScope = nis } -> (\nis' -> n { nameInScope = nis' }) <$> f nis+    n@NoName{} -> n <$ f InScope++instance LensInScope QName where+  lensInScope f = \case+    Qual x xs -> (`Qual` xs) <$> lensInScope f x+    QName x   -> QName <$> lensInScope f x++------------------------------------------------------------------------+-- * Generating fresh names+------------------------------------------------------------------------++-- | Method by which to generate fresh unshadowed names.+data FreshNameMode+  = UnicodeSubscript+  -- ^ Append an integer Unicode subscript: x, x₁, x₂, …+  | AsciiCounter+  -- ^ Append an integer ASCII counter: x, x1, x2, …++  -- Note that @Agda.Utils.Suffix@ supports an additional style, @Prime@, but+  -- we currently only encounter it when extending an existing name of that+  -- format, (x', x'', …), not for an initially-generated permutation. There's+  -- no reason we couldn't, except that we currently choose between+  -- subscript/counter styles based on the --no-unicode mode rather than any+  -- finer-grained option.+  --   | PrimeTickCount+  --   ^ Append an ASCII prime/apostrophe: x, x', x'', …++nextRawName :: FreshNameMode -> RawName -> RawName+nextRawName freshNameMode s = addSuffix root (maybe initialSuffix nextSuffix suffix)+  where+  (root, suffix) = suffixView s+  initialSuffix = case freshNameMode of+    UnicodeSubscript -> Subscript 1+    AsciiCounter -> Index 1++-- | Get the next version of the concrete name. For instance,+--   @nextName "x" = "x₁"@.  The name must not be a 'NoName'.+nextName :: FreshNameMode -> Name -> Name+nextName freshNameMode x@Name{} = setNotInScope $ over (lensNameParts . lastIdPart) (nextRawName freshNameMode) x+nextName             _ NoName{} = __IMPOSSIBLE__++-- | Zoom on the last non-hole in a name.+lastIdPart :: Lens' NameParts RawName+lastIdPart f = loop+  where+  loop = \case+    Id s :| []     -> f s <&> \ s -> Id s :| []+    Id s :| [Hole] -> f s <&> \ s -> Id s :| [Hole]+    p1 :| p2 : ps  -> (p1 <|) <$> loop (p2 :| ps)+    Hole :| []     -> __IMPOSSIBLE__++-- | Get the first version of the concrete name that does not satisfy+--   the given predicate.+firstNonTakenName :: FreshNameMode -> (Name -> Bool) -> Name -> Name+firstNonTakenName freshNameMode taken x =+  if taken x+  then firstNonTakenName freshNameMode taken (nextName freshNameMode x)+  else x++-- | 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' Name (Maybe Suffix)+nameSuffix (f :: Maybe Suffix -> f (Maybe Suffix)) = \case++  n@NoName{} -> f Nothing <&> \case+    Nothing -> n+    Just {} -> __IMPOSSIBLE__++  n@Name{} -> lensNameParts (lastIdPart idSuf) n+    where+    idSuf s =+      let (root, suffix) = suffixView s+      in maybe root (addSuffix root) <$> (f suffix)++-- | Split a name into a base name plus a suffix.+nameSuffixView :: Name -> (Maybe Suffix, Name)+nameSuffixView = nameSuffix (,Nothing)++-- | Replaces the suffix of a name. Unless the suffix is @Nothing@,+--   the name should not be @NoName@.+setNameSuffix :: Maybe Suffix -> Name -> Name+setNameSuffix = set nameSuffix++-- | Get a raw version of the name with all suffixes removed. For+--   instance, @nameRoot "x₁₂₃" = "x"@.+nameRoot :: Name -> RawName+nameRoot x = nameToRawName $ snd $ nameSuffixView x++sameRoot :: Name -> Name -> Bool+sameRoot = (==) `on` nameRoot++------------------------------------------------------------------------ -- * Operations on qualified names ------------------------------------------------------------------------ +-- | Lens for the unqualified part of a QName+lensQNameName :: Lens' QName Name+lensQNameName f (QName n)  = QName <$> f n+lensQNameName f (Qual m n) = Qual m <$> lensQNameName f n+ -- | @qualify A.B x == A.B.x@ qualify :: QName -> Name -> QName qualify (QName m) x     = Qual m (QName x)@@ -186,53 +340,19 @@   unqualify' (Qual _ x) = unqualify' x  -- | @qnameParts A.B.x = [A, B, x]@-qnameParts :: QName -> [Name]-qnameParts (Qual x q) = x : qnameParts q-qnameParts (QName x)  = [x]----------------------------------------------------------------------------- * 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 = TopLevelModuleName . map prettyShow . qnameParts---- | Turns a top level module into a qualified name with 'noRange'.--fromTopLevelModuleName :: TopLevelModuleName -> QName-fromTopLevelModuleName (TopLevelModuleName [])     = __IMPOSSIBLE__-fromTopLevelModuleName (TopLevelModuleName (x:xs)) = loop x xs-  where-  loop x []       = QName (mk x)-  loop x (y : ys) = Qual  (mk x) $ loop y ys-  mk :: String -> Name-  mk x = Name noRange [Id x]---- | Turns a top-level module name into a file name with the given--- suffix.+qnameParts :: QName -> List1 Name+qnameParts (Qual x q) = x <| qnameParts q+qnameParts (QName x)  = singleton x -moduleNameToFileName :: TopLevelModuleName -> String -> FilePath-moduleNameToFileName (TopLevelModuleName []) ext = __IMPOSSIBLE__-moduleNameToFileName (TopLevelModuleName ms) ext =-  joinPath (init ms) </> last ms <.> ext+-- | Is the name (un)qualified? --- | 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.+isQualified :: QName -> Bool+isQualified Qual{}  = True+isQualified QName{} = False -projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath-projectRoot file (TopLevelModuleName m) =-  mkAbsolute $-  foldr (.) id (replicate (length m - 1) takeDirectory) $-  takeDirectory $-  filePath file+isUnqualified :: QName -> Maybe Name+isUnqualified Qual{}    = Nothing+isUnqualified (QName n) = Just n  ------------------------------------------------------------------------ -- * No name stuff@@ -243,12 +363,15 @@ noName_ = noName noRange  noName :: Range -> Name-noName r = NoName r (NameId 0 0)+noName r = NoName r (NameId 0 noModuleNameHash)  -- | Check whether a name is the empty name "_". class IsNoName a where   isNoName :: a -> Bool +  default isNoName :: (Foldable t, IsNoName b, t b ~ a) => a -> Bool+  isNoName = Fold.all isNoName+ instance IsNoName String where   isNoName = isUnderscore @@ -256,75 +379,60 @@   isNoName = isUnderscore  instance IsNoName Name where-  isNoName (NoName _ _)    = True-  isNoName (Name _ [Hole]) = True   -- TODO: Track down where these come from-  isNoName (Name _ [])     = True-  isNoName (Name _ [Id x]) = isNoName x-  isNoName _               = False+  isNoName = \case+    NoName{}              -> True+    Name _ _ (Hole :| []) -> True+    Name _ _ (Id x :| []) -> isNoName x+    _ -> False  instance IsNoName QName where   isNoName (QName x) = isNoName x   isNoName Qual{}    = False        -- M.A._ does not qualify as empty name --- no instance for TopLevelModuleName+instance IsNoName a => IsNoName (Ranged a) where+instance IsNoName a => IsNoName (WithOrigin a) where  ------------------------------------------------------------------------ -- * Showing names ------------------------------------------------------------------------ --- deriving instance Show Name--- deriving instance Show NamePart--- deriving instance Show QName---- TODO: 'Show' should output Haskell-parseable representations.--- The following instances are deprecated, and Pretty should be used--- instead.  Later, simply derive Show for these types:--instance Show Name where-  show = prettyShow--instance Show NamePart where-  show = prettyShow--instance Show QName where-  show = prettyShow+deriving instance Show Name+deriving instance Show NamePart+deriving instance Show QName  ------------------------------------------------------------------------ -- * Printing names ------------------------------------------------------------------------  instance Pretty Name where-  pretty (Name _ xs)  = hcat $ map pretty xs-  pretty (NoName _ _) = text $ "_"+  pretty (Name _ _ xs)    = hcat $ fmap pretty xs+  pretty (NoName _ _)     = "_"  instance Pretty NamePart where-  pretty Hole   = text $ "_"+  pretty Hole   = "_"   pretty (Id s) = text $ rawNameToString s  instance Pretty QName where   pretty (Qual m x)     | isUnderscore m = pretty x -- don't print anonymous modules-    | otherwise      = pretty m <> pretty "." <> pretty x+    | otherwise      = pretty m <> "." <> pretty x   pretty (QName x)  = pretty x -instance Pretty TopLevelModuleName where-  pretty (TopLevelModuleName ms) = text $ intercalate "." ms- ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------  instance HasRange Name where-    getRange (Name r ps)  = r-    getRange (NoName r _) = r+    getRange (Name r _ _ps) = r+    getRange (NoName r _)   = r  instance HasRange QName where     getRange (QName  x) = getRange x     getRange (Qual n x) = fuseRange n x  instance SetRange Name where-  setRange r (Name _ ps)  = Name r ps-  setRange r (NoName _ i) = NoName r i+  setRange r (Name _ nis ps) = Name r nis ps+  setRange r (NoName _ i)  = NoName r i  instance SetRange QName where   setRange r (QName x)  = QName (setRange r x)@@ -335,18 +443,22 @@   killRange (Qual n x) = killRange n `Qual` killRange x  instance KillRange Name where-  killRange (Name r ps)  = Name (killRange r) ps-  killRange (NoName r i) = NoName (killRange r) i+  killRange (Name r nis ps)  = Name (killRange r) nis ps+  killRange (NoName r i)     = NoName (killRange r) i  ------------------------------------------------------------------------ -- * NFData instances ------------------------------------------------------------------------ +instance NFData NameInScope where+  rnf InScope    = ()+  rnf NotInScope = ()+ -- | Ranges are not forced.  instance NFData Name where-  rnf (Name _ ns)  = rnf ns-  rnf (NoName _ n) = rnf n+  rnf (Name _ nis ns) = rnf nis `seq` rnf ns+  rnf (NoName _ n)  = rnf n  instance NFData NamePart where   rnf Hole   = ()
src/full/Agda/Syntax/Concrete/Operators.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# 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@@ -10,59 +10,55 @@     It also contains the function that puts parenthesis back given the     precedence of the context. -}+ module Agda.Syntax.Concrete.Operators     ( parseApplication-    , parseModuleApplication+    , parseArguments     , parseLHS     , parsePattern     , parsePatternSyn     ) where -import Control.Arrow ((***), (&&&), first, second)-import Control.DeepSeq-import Control.Applicative-import Control.Monad+import Control.Applicative ( Alternative( (<|>) ) )+import Control.Monad.Except (throwError)  import Data.Either (partitionEithers)-import qualified Data.Foldable as Fold-import Data.Function-import Data.List+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 Data.Traversable (traverse) import qualified Data.Traversable as Trav -import Agda.Syntax.Concrete.Pretty () import Agda.Syntax.Common import Agda.Syntax.Concrete hiding (appView) import Agda.Syntax.Concrete.Operators.Parser import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse)-import qualified Agda.Syntax.Abstract.Name as A+import Agda.Syntax.Concrete.Pattern import Agda.Syntax.Position-import Agda.Syntax.Fixity 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(..)) import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State (getScope)-import Agda.TypeChecking.Monad.Options +import Agda.Utils.Function (applyWhen, applyWhenJust) import Agda.Utils.Either-import Agda.Utils.Pretty-#if MIN_VERSION_base(4,8,0)-import Agda.Utils.List hiding ( uncons )-#else+import Agda.Syntax.Common.Pretty import Agda.Utils.List-#endif+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.Maybe+import Agda.Utils.Monad (guardWithError) import Agda.Utils.Trie (Trie) import qualified Agda.Utils.Trie as Trie -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -71,59 +67,20 @@  -- | Bills the operator parser. -billToParser :: ScopeM a -> ScopeM a-billToParser = Bench.billTo [Bench.Parsing, Bench.Operators]+billToParser :: ExprKind -> ScopeM a -> ScopeM a+billToParser k = Bench.billTo+  [ Bench.Parsing+  , case k of+      IsExpr    -> Bench.OperatorsExpr+      IsPattern -> Bench.OperatorsPattern+  ]  --------------------------------------------------------------------------- -- * 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 :: [KindOfName] -> FlatScope -> [[NewNotation]]-getDefinedNames kinds names =-  [ mergeNotations $-      map (\d -> namesToNotation x (A.qnameName $ anameName d)) ds-  | (x, ds) <- Map.toList names-  , any ((`elem` 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.-  reportSLn "scope.operators" 50 $ unlines-    [ "flat  = " ++ show flat-    , "defs  = " ++ show defs-    , "locals= " ++ show locals-    ]-  let localNots  = map localOp locals-      localNames = Set.fromList $ map notaName localNots-      otherNots  = filter (\n -> not (Set.member (notaName n) localNames))-                          (concat defs)-  return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots-  where-    localOp (x, y) = namesToNotation (QName x) y-    split ops      = partitionEithers $ concatMap opOrNot ops-    opOrNot n      = Left (notaName n) :-                     if null (notation n) then [] else [Right n]---- | Data structure filled in by @buildParsers@.---   The top-level parser @pTop@ is of primary interest,---   but @pArgs@ is used to convert module application---   from concrete to abstract syntax.-data Parsers e = Parsers+-- | A data structure used internally by 'buildParsers'.+data InternalParsers e = InternalParsers   { pTop    :: Parser e e   , pApp    :: Parser e e   , pArgs   :: Parser e [NamedArg e]@@ -131,16 +88,30 @@   , pAtom   :: Parser e e   } -data ExprKind = IsPattern | IsExpr-  deriving (Eq, Show)+-- | The data returned by 'buildParsers'. --- | Builds a parser for operator applications from all the operators+data Parsers e = Parsers+  { parser :: [e] -> [e]+    -- ^ A parser for expressions or patterns (depending on the+    -- 'ExprKind' argument given to 'buildParsers').+  , argsParser :: [e] -> [[NamedArg e]]+    -- ^ A parser for sequences of arguments.+  , operators :: [NotationSection]+    -- ^ All operators/notations/sections that were used to generate+    -- the grammar.+  , flattenedScope :: FlatScope+    -- ^ A flattened scope that only contains those names that are+    -- unqualified or qualified by qualifiers that occur in the list+    -- of names given to 'buildParsers'.+  }++-- | Builds parsers for operator applications from all the operators -- and function symbols in scope. -- -- When parsing a pattern we do not use bound names. The effect is--- that operator parts (that are not constructor parts) can be used as--- atomic names in the pattern (so they can be rebound). See--- @test/succeed/OpBind.agda@ for an example.+-- that unqualified operator parts (that are not constructor parts)+-- can be used as atomic names in the pattern (so they can be+-- rebound). See @test/succeed/OpBind.agda@ for an example. -- -- When parsing a pattern we also disallow the use of sections, mainly -- because there is little need for sections in patterns. Note that@@ -148,29 +119,35 @@ -- (@_+_@ is replaced by @_@, @+@ and @_@), and if we were to support -- sections in patterns, then we would have to accept certain such -- sequences of tokens as single pattern variables.------ The list of names must include every name part in the--- expression/pattern to be parsed (excluding name parts inside things--- like parenthesised subexpressions that are treated as atoms). The--- list is used to optimise the parser. For instance, a given notation--- is only included in the generated grammar if all of the notation's--- name parts are present in the list of names.------ The returned list contains all operators/notations/sections that--- were used to generate the grammar. -buildParsers ::-  forall e. IsExpr e =>-  Range -> FlatScope -> ExprKind -> [QName] ->-  ScopeM (ParseSections, [NotationSection], Parsers e)-buildParsers r flat kind exprNames = do-    (names, ops) <- localNames flat+buildParsers+  :: 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+     -- things like parenthesised subexpressions that are treated as+     -- atoms). The list is used to optimise the parser. For+     -- instance, a given notation is only included in the generated+     -- grammar if all of the notation's name parts are present in+     -- the list of names.+  -> ScopeM (Parsers e)+buildParsers kind top exprNames0 = do+    let exprNames = applyWhenJust top (:) exprNames0+    flat         <- flattenScope (qualifierModules exprNames) <$>+                      getScope+    (names, ops0) <- localNames kind top flat+    let ops | kind == IsPattern = filter (not . isLambdaNotation) ops0+            | otherwise         = ops0      let -- All names.         namesInExpr :: Set QName         namesInExpr = Set.fromList exprNames -        partListsInExpr' = map (nameParts . unqualify) $+        partListsInExpr' = map (List1.toList . nameParts . unqualify) $                            Set.toList namesInExpr          partListTrie f =@@ -207,9 +184,9 @@           Trie.member (addHole withHole p) partListsInExpr           where           p = case n of-            NormalHole{} : IdPart p : _ -> p-            IdPart p : _                -> 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@@ -218,11 +195,11 @@           Trie.member (addHole withHole p) reversedPartListsInExpr           where           p = case reverse n of-            NormalHole{} : IdPart p : _ -> p-            IdPart p : _                -> p-            _                           -> __IMPOSSIBLE__+            HolePart{} : IdPart p : _ -> rangedThing p+            IdPart p : _              -> rangedThing p+            _                         -> __IMPOSSIBLE__ -        -- | Are the initial and final identifier parts present with+        -- Are the initial and final identifier parts present with         -- the right mix of leading and trailing underscores?         correctUnderscores :: Bool -> Bool -> Notation -> Bool         correctUnderscores withInitialHole withFinalHole n =@@ -258,16 +235,17 @@         -- resulting in a confusing error message claiming that "if"         -- is not in scope. -        (non, fix) = partition nonfix (filter (and . partsPresent) ops)+        (non, fix) = List.partition nonfix (filter (and . partsPresent) ops) -        cons       = getDefinedNames [ConName, PatternSynName] flat+        cons       = getDefinedNames+                       (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@@ -276,9 +254,11 @@                         concatMap notationNames $                         filter (or . partsPresent) ops) -        isAtom   x = case kind of-                       IsExpr    -> not (Set.member x allParts) || Set.member x allNames-                       IsPattern -> not (Set.member x conParts) || Set.member x conNames+        isAtom x+          | kind == IsPattern && not (isQualified x) =+            not (Set.member x conParts) || Set.member x conNames+          | otherwise =+            not (Set.member x allParts) || Set.member x allNames         -- If string is a part of notation, it cannot be used as an identifier,         -- unless it is also used as an identifier. See issue 307. @@ -321,11 +301,10 @@          -- The triples have the form (level, operators). The lowest         -- level comes first.-        relatedOperators :: [(Integer, [NotationSection])]+        relatedOperators :: [(PrecedenceLevel, [NotationSection])]         relatedOperators =-          map (\((l, ns) : rest) -> (l, ns ++ concat (map snd rest))) .-          groupBy ((==) `on` fst) .-          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) ->@@ -339,30 +318,28 @@           unrelatedOperators ++           nonWithSections -    reportSLn "scope.operators" 50 $ unlines-      [ "unrelatedOperators = " ++ show unrelatedOperators-      , "nonWithSections    = " ++ show nonWithSections-      , "relatedOperators   = " ++ show relatedOperators+    reportS "scope.operators" 50+      [ "unrelatedOperators = " ++ prettyShow unrelatedOperators+      , "nonWithSections    = " ++ prettyShow nonWithSections+      , "relatedOperators   = " ++ prettyShow relatedOperators       ] -    let g = Data.Function.fix $ \p -> Parsers+    let g = Data.Function.fix $ \p -> InternalParsers               { pTop    = memoise TopK $-                          Fold.asum $-                            foldr ($) (pApp p)-                              (map (\(l, ns) higher ->+                          Agda.Utils.List.asum $+                            foldr (\(l, ns) higher ->                                        mkP (Right l) parseSections-                                           (pTop p) ns higher True)-                                   relatedOperators) :-                            map (\(k, n) ->+                                           (pTop p) ns higher True) (pApp p)+                                   relatedOperators :+                            zipWith (\ k n ->                                     mkP (Left k) parseSections-                                        (pTop p) [n] (pApp p) False)-                                (zip [0..] unrelatedOperators)+                                        (pTop p) [n] (pApp p) False) [0..] unrelatedOperators               , pApp    = memoise AppK $ appP (pNonfix p) (pArgs p)               , pArgs   = argsP (pNonfix p)               , pNonfix = memoise NonfixK $-                          Fold.asum $+                          Agda.Utils.List.asum $                             pAtom p :-                            flip map nonWithSections (\sect ->+                            map (\sect ->                               let n = sectNotation sect                                    inner :: forall k. NK k ->@@ -380,16 +357,23 @@                                   flip ($) <$> placeholder Beginning                                            <*> inner Post                                 NonfixNotation -> inner Non-                                NoNotation     -> __IMPOSSIBLE__)+                                NoNotation     -> __IMPOSSIBLE__) nonWithSections               , pAtom   = atomP isAtom               } -    reportSDoc "scope.grammar" 10 $ return $-      text "Operator grammar:" $$ nest 2 (grammar (pTop g))+    -- Andreas, 2020-06-03 #4712+    -- 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 (parseSections, everything, g)+    return $ Parsers+      { parser         = parse (parseSections, pTop  g)+      , argsParser     = parse (parseSections, pArgs g)+      , operators      = everything+      , flattenedScope = flat+      }     where-        level :: NewNotation -> PrecedenceLevel+        level :: NewNotation -> FixityLevel         level = fixityLevel . notaFixity          nonfix, isinfix, isprefix, ispostfix :: NewNotation -> Bool@@ -408,57 +392,84 @@              &&           fixityAssoc (notaFixity (sectNotation s)) == ass -        mkP :: Either Integer Integer-               -- ^ Memoisation key.+        mkP :: PrecedenceKey  -- Memoisation key.             -> ParseSections             -> Parser e e             -> [NotationSection]-            -> Parser e e-               -- ^ A parser for an expression of higher precedence.-            -> Bool-               -- ^ Include the \"expression of higher precedence\"-               -- parser as one of the choices?+            -> Parser e e  -- A parser for an expression of higher precedence.+            -> Bool  -- Include the \"expression of higher precedence\"+                     -- parser as one of the choices?             -> 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@@ -468,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)@@ -483,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) @@ -497,46 +508,44 @@                   flip ($) <$> (noPlaceholder <$> (postLefts <|> higher))                            <*> postLeft ------------------------------------------------------------------------------- * Helpers for pattern and lhs parsing---------------------------------------------------------------------------- --- | View a pattern @p@ as a list @p0 .. pn@ where @p0@ is the identifier---   (in most cases a constructor).------  Pattern needs to be parsed already (operators resolved).-patternAppView :: Pattern -> [NamedArg Pattern]-patternAppView p = case p of-    AppP p arg      -> patternAppView p ++ [arg]-    OpAppP _ x _ ps -> defaultNamedArg (IdentP x) : ps-    ParenP _ p      -> patternAppView p-    RawAppP _ _     -> __IMPOSSIBLE__-    _               -> [ defaultNamedArg p ]-- --------------------------------------------------------------------------- -- * Parse functions --------------------------------------------------------------------------- --- | Returns the list of possible parses.-parsePat ::-  (ParseSections, Parser Pattern Pattern) -> Pattern -> [Pattern]-parsePat prs p = case p of+-- | 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 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 =<< parse prs 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-    DotP r o e       -> return $ DotP r o e-    ParenP r p       -> fullParen' <$> parsePat prs p-    WildP _          -> return p-    AbsurdP _        -> return p-    LitP _           -> return p-    QuoteP _         -> return p-    IdentP _         -> return p-    RecP r fs        -> RecP r <$> mapM (traverse (parsePat prs)) fs+    AsP r x p        -> AsP r x <$> loop p+    p@DotP{}         -> return 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 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 <$> loop p+    WithP r p        -> WithP r <$> loop p   {- Implement parsing of copattern left hand sides, e.g.@@ -575,101 +584,166 @@    - the applied patterns -} -type ParseLHS = Either Pattern (QName, LHSCore)+-- | The result of 'parseLHS'.+data ParseLHS+  = ParsePattern Pattern    -- ^ We parsed a pattern.+  | ParseLHS QName LHSCore  -- ^ We parsed a lhs. --- | The returned list contains all operators/notations/sections that--- were used to generate the grammar.+instance Pretty ParseLHS where+  pretty = \case+    ParsePattern p  -> pretty p+    ParseLHS _f lhs -> pretty lhs +-- | Parses a left-hand side, workhorse for 'parseLHS'.+-- parseLHS' ::-  LHSOrPatSyn -> Maybe QName -> Pattern ->-  ScopeM (ParseLHS, [NotationSection])-parseLHS' IsLHS (Just qn) (RawAppP _ [WildP{}]) =-    return (Right (qn, LHSHead qn []), [])-parseLHS' lhsOrPatSyn top p = do-    let names = patternQNames p-        ms    = qualifierModules names-    flat <- flattenScope ms <$> getScope-    (parseSections, ops, parsers) <--      buildParsers (getRange p) flat IsPattern names-    let patP = (parseSections, pTop parsers)-    let cons = getNames [ConName, PatternSynName] flat-    let flds = getNames [FldName] flat-    case [ res | let result = parsePat patP p-               , p' <- foldr seq () result `seq` result-               , res <- validPattern (PatternCheckConfig top cons flds) p' ] of-        [(p,lhs)] -> do reportSDoc "scope.operators" 50 $ return $-                          text "Parsed lhs:" <+> pretty lhs-                        return (lhs, ops)-        []        -> typeError $ OperatorChangeMessage-                               $ OperatorInformation ops-                               $ NoParseForLHS lhsOrPatSyn p-        rs        -> typeError $ OperatorChangeMessage-                               $ OperatorInformation ops-                               $ AmbiguousParseForLHS lhsOrPatSyn p $-                       map (fullParen . fst) rs+     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+       -- ^ Name of the function/patSyn definition if we parse a lhs.+       --   'Nothing' if we parse a pattern.+  -> Pattern+       -- ^ Thing to parse.+  -> ScopeM (ParseLHS, [NotationSection])+       -- ^ The returned list contains all operators\/notations\/sections that+       --   were used to generate the grammar.++parseLHS' NoDisplayLHS IsLHS (Just qn) WildP{} =+    return (ParseLHS qn $ LHSHead qn [], [])++parseLHS' displayLhs lhsOrPatSyn top p = do++    -- Build parser.+    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 $ applyWhen displayLhs (defNameKinds ++) conLikeNameKinds)+                        (flattenedScope patP)+    let flds = getNames (someKindsOfNames [FldName])+                        (flattenedScope patP)+    let conf = PatternCheckConfig top (hasElem cons) (hasElem flds)++    let (errs, results) = partitionEithers $ map (validPattern conf) ps+    reportS "scope.operators" 60 $ vcat $+      [ "Possible parses for lhs:" ] ++ map (nest 2 . pretty . snd) results+    case results of+        -- Unique result.+        [(_,lhs)] -> (lhs, operators patP) <$ do+                       reportS "scope.operators" 50 $ "Parsed lhs:" <+> pretty lhs+        -- No result.+        []        -> typeError $ OperatorInformation (operators patP) $+                       NoParseForLHS lhsOrPatSyn (catMaybes errs) p+        -- Ambiguous result.+        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 -        -- validPattern returns an empty or singleton list (morally a Maybe)-        validPattern :: PatternCheckConfig -> Pattern -> [(Pattern, ParseLHS)]-        validPattern conf p = case (classifyPattern conf p, top) of-            (Just r@(Left _), Nothing) -> [(p, r)] -- expect pattern-            (Just r@(Right _), Just{}) -> [(p, r)] -- expect lhs-            _ -> []+        -- The pattern is retained for error reporting in case of ambiguous parses.+        validPattern :: PatternCheckConfig -> Pattern -> PM (Pattern, ParseLHS)+        validPattern conf p = do+          res <- classifyPattern conf p+          case (res, top) of+            (ParsePattern{}, Nothing) -> return (p, res)  -- expect pattern+            (ParseLHS{}    , Just{} ) -> return (p, res)  -- expect lhs+            _ -> throwError Nothing  -- | Name sets for classifying a pattern. data PatternCheckConfig = PatternCheckConfig-  { topName  :: Maybe QName -- ^ name of defined symbol-  , conNames :: [QName]     -- ^ valid constructor names-  , fldNames :: [QName]     -- ^ valid field names+  { topName :: Maybe QName    -- ^ Name of defined symbol.+  , conName :: QName -> Bool  -- ^ Valid constructor name?+  , fldName :: QName -> Bool  -- ^ Valid field name?   } +-- | The monad for pattern checking and classification.+--+--   The error message is either empty or a subpattern that was found to be invalid.+type PM = Either (Maybe Pattern)+ -- | Returns zero or one classified patterns.-classifyPattern :: PatternCheckConfig -> Pattern -> Maybe ParseLHS+--   In case of zero, return the offending subpattern.+classifyPattern :: PatternCheckConfig -> Pattern -> PM ParseLHS classifyPattern conf p =   case patternAppView p of      -- case @f ps@-    Arg _ (Named _ (IdentP x)) : ps | Just x == topName conf -> do-      guard $ all validPat ps-      return $ Right (x, LHSHead x ps)+    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 | x `elem` fldNames conf -> do-      -- ps0 :: [NamedArg ParseLHS]-      ps0 <- mapM classPat ps-      let (ps1, rest) = span (isLeft . namedArg) ps0-      (p2, ps3) <- uncons rest -- when (null rest): no field pattern or def pattern found-      guard $ all (isLeft . namedArg) ps3-      let (f, lhs)      = fromR p2+    Arg _ (Named _ (IdentP _ x)) :| ps | fldName conf x -> do++      -- Step 1: check for valid copattern lhs.+      ps0 :: [NamedArg ParseLHS] <- mapM classPat ps+      let (ps1, rest) = span (isParsePattern . namedArg) ps0+      (p2, ps3) <- maybeToEither Nothing $ uncons rest+          -- when (null rest): no field pattern or def pattern found++      -- Ensure that the @ps3@ are patterns rather than lhss.+      mapM_ (guardWithError Nothing . isParsePattern . namedArg) ps3++      -- Step 2: construct the lhs.+      let (f, lhs0)     = fromParseLHS $ namedArg p2+          lhs           = setNamedArg p2 lhs0           (ps', _:ps'') = splitAt (length ps1) ps-      return $ Right (f, LHSProj x ps' lhs ps'')+      return $ ParseLHS f $ lhsCoreAddSpine (LHSProj x ps' lhs []) ps'' +    -- case @...@+    Arg _ (Named _ (EllipsisP r (Just p))) :| ps -> do+      classifyPattern conf p >>= \case  -- TODO: avoid re-parsing+        ParsePattern{}    -> throwError Nothing+        (ParseLHS f core) -> do+          mapM_ (valid . namedArg) ps+          let ellcore = LHSEllipsis r core+          return $ ParseLHS f $ lhsCoreAddSpine ellcore ps+     -- case: ordinary pattern-    _ -> do-      guard $ validConPattern (conNames conf) p-      return $ Left p+    _ -> ParsePattern p <$ valid p -  where -- allNames = conNames conf ++ fldNames conf-        validPat = validConPattern (conNames conf) . namedArg-        classPat :: NamedArg Pattern -> Maybe (NamedArg ParseLHS)-        classPat = Trav.mapM (Trav.mapM (classifyPattern conf))-        fromR :: NamedArg (Either a (b, c)) -> (b, NamedArg c)-        fromR (Arg info (Named n (Right (b, c)))) = (b, Arg info (Named n c))-        fromR (Arg info (Named n (Left  a     ))) = __IMPOSSIBLE__+  where+  valid = validConPattern $ conName conf +  classPat :: NamedArg Pattern -> PM (NamedArg ParseLHS)+  classPat = Trav.mapM (Trav.mapM (classifyPattern conf)) +  isParsePattern = \case+    ParsePattern{} -> True+    ParseLHS{}     -> False +  fromParseLHS :: ParseLHS -> (QName, LHSCore)+  fromParseLHS = \case+    ParseLHS f lhs -> (f, lhs)+    ParsePattern{} -> __IMPOSSIBLE__++ -- | Parses a left-hand side, and makes sure that it defined the expected name.-parseLHS :: QName -> Pattern -> ScopeM LHSCore-parseLHS top p = billToParser $ 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-    Right (f, lhs) -> return lhs-    _ -> typeError $ OperatorChangeMessage-                   $ OperatorInformation ops-                   $ NoParseForLHS IsLHS p+    ParseLHS f lhs -> return lhs+    _ -> typeError $ OperatorInformation ops+                   $ NoParseForLHS IsLHS [] p  -- | Parses a pattern. parsePattern :: Pattern -> ScopeM Pattern@@ -679,109 +753,138 @@ parsePatternSyn = parsePatternOrSyn IsPatSyn  parsePatternOrSyn :: LHSOrPatSyn -> Pattern -> ScopeM Pattern-parsePatternOrSyn lhsOrPatSyn p = billToParser $ do-  (res, ops) <- parseLHS' lhsOrPatSyn Nothing p+parsePatternOrSyn lhsOrPatSyn p = billToParser IsPattern $ do+  (res, ops) <- parseLHS' NoDisplayLHS lhsOrPatSyn Nothing p   case res of-    Left p -> return p-    _      -> typeError $ OperatorChangeMessage-                        $ OperatorInformation ops-                        $ NoParseForLHS lhsOrPatSyn p+    ParsePattern p -> return p+    _ -> typeError $ OperatorInformation ops+                   $ NoParseForLHS lhsOrPatSyn [] p  -- | Helper function for 'parseLHS' and 'parsePattern'.-validConPattern :: [QName] -> Pattern -> Bool-validConPattern cons p = case appView p of-    [_]           -> True-    IdentP x : ps -> elem x cons && all (validConPattern cons) ps-    [QuoteP _, _] -> True-    _             -> False--- Andreas, 2012-06-04: I do not know why the following line was--- the catch-all case.  It seems that the new catch-all works also--- and is more logical.---    ps            -> all (validConPattern cons) ps+--+--   Returns a subpattern that is not a valid constructor pattern+--   or nothing if the whole pattern is a valid constructor pattern.+validConPattern+  :: (QName -> Bool)     -- ^ Test for constructor name.+  -> Pattern             -- ^ Supposedly a constructor pattern.+  -> PM ()   -- ^ Offending subpattern or nothing.+validConPattern cons = loop+  where+  loop p = case appView p of +      -- 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++ -- | Helper function for 'parseLHS' and 'parsePattern'.-appView :: Pattern -> [Pattern]-appView p = case p of-    AppP p a         -> appView p ++ [namedArg a]-    OpAppP _ op _ ps -> IdentP op : map namedArg ps-    ParenP _ p       -> appView p+appView :: Pattern -> List1 Pattern+appView = loop []+  where+  loop acc = \case+    AppP p a         -> loop (namedArg a : acc) p+    OpAppP _ op _ ps -> (IdentP True op <| fmap namedArg ps)+                          `List1.appendList`+                        reverse acc+    ParenP _ p       -> loop acc p     RawAppP _ _      -> __IMPOSSIBLE__     HiddenP _ _      -> __IMPOSSIBLE__     InstanceP _ _    -> __IMPOSSIBLE__-    _                -> [p]+    p@IdentP{}       -> ret p+    p@WildP{}        -> ret p+    p@AsP{}          -> ret p+    p@AbsurdP{}      -> ret p+    p@LitP{}         -> ret p+    p@QuoteP{}       -> ret p+    p@DotP{}         -> ret p+    p@RecP{}         -> ret p+    p@EqualP{}       -> ret p+    p@EllipsisP{}    -> ret p+    p@WithP{}        -> ret p+   where+   ret p = p :| reverse acc  -- | Return all qualifiers occuring in a list of 'QName's. --   Each qualifier is returned as a list of names, e.g. --   for @Data.Nat._+_@ we return the list @[Data,Nat]@. qualifierModules :: [QName] -> [[Name]] qualifierModules qs =-  nub $ filter (not . null) $ map (init . qnameParts) qs+  nubOn id $ filter (not . null) $ map (List1.init . qnameParts) qs --- | Parse a list of expressions into an application.-parseApplication :: [Expr] -> ScopeM Expr-parseApplication [e] = return e-parseApplication es  = billToParser $ do+-- | Parse a list of expressions (typically from a 'RawApp') into an application.+parseApplication :: List2 Expr -> ScopeM Expr+parseApplication es  = billToParser IsExpr $ do+    let es0 = List2.toList es     -- Build the parser-    let names = [ q | Ident q <- es ]-        ms    = qualifierModules names-    flat <- flattenScope ms <$> getScope-    (parseSections, ops, p) <- buildParsers (getRange es) flat IsExpr names+    p <- buildParsers IsExpr Nothing [ q | Ident q <- es0 ]      -- Parse-    let result = parse (parseSections, pTop p) es+    let result = parser p es0     case foldr seq () result `seq` result of-        [e] -> do+      [e]   -> do           reportSDoc "scope.operators" 50 $ return $-            text "Parsed an operator application:" <+> pretty e+            "Parsed an operator application:" <+> pretty e           return e-        []  -> typeError $ OperatorChangeMessage-                         $ OperatorInformation ops+      []    -> typeError $ OperatorInformation (operators p)                          $ NoParseForApplication es-        es' -> typeError $ OperatorChangeMessage-                         $ OperatorInformation ops+      e:es' -> typeError $ OperatorInformation (operators p)                          $ AmbiguousParseForApplication es-                         $ map fullParen 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 :: [Expr] -> ScopeM (QName, [NamedArg Expr])-parseRawModuleApplication es = billToParser $ do-    let e : es_args = es-    m <- parseModuleIdentifier e+    -- Form the raw application for error reporting+    let es2 = List2 hd e1 rest      -- Build the arguments parser-    let names = [ q | Ident q <- es_args ]-        ms    = qualifierModules names-    flat <- flattenScope ms <$> getScope-    (parseSections, ops, p) <--      buildParsers (getRange es_args) flat IsExpr names+    p <- buildParsers IsExpr Nothing [ q | Ident q <- es ]      -- Parse     -- TODO: not sure about forcing-    case {-force $-} parse (parseSections, pArgs p) es_args of-        [as] -> return (m, as)-        []   -> typeError $ OperatorChangeMessage-                          $ OperatorInformation ops-                          $ NoParseForApplication es-        ass -> do-          let f = fullParen . foldl (App noRange) (Ident m)-          typeError $ OperatorChangeMessage-                    $ OperatorInformation ops-                    $ AmbiguousParseForApplication es-                    $ map f 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, [])+    case {-force $-} argsParser p es of+        [as] -> return as+        []   -> typeError $ OperatorInformation (operators p)+                          $ NoParseForApplication es2+        as : ass -> do+          let f = fullParen . foldl (App noRange) hd+          typeError $ OperatorInformation (operators p)+                    $ AmbiguousParseForApplication es2+                    $ fmap f (as :| ass)  --------------------------------------------------------------------------- -- * Inserting parenthesis@@ -803,10 +906,10 @@     AppV e1 (Arg info e2) -> par $ unExprView $ AppV (fullParen' e1) (Arg info e2')         where             e2' = case argInfoHiding info of-                Hidden    -> e2-                Instance  -> e2-                NotHidden -> fullParen' <$> e2-    OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (map . fmap . fmap . fmap . fmap) fullParen' es+                Hidden     -> e2+                Instance{} -> e2+                NotHidden  -> fullParen' <$> e2+    OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (fmap . fmap . fmap . fmap . fmap) fullParen' es     LamV bs e -> par $ unExprView $ LamV bs (fullParen e)     where         par = unExprView . ParenV
src/full/Agda/Syntax/Concrete/Operators/Parser.hs view
@@ -1,37 +1,40 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}+{-# OPTIONS_GHC -Wunused-imports #-} +{-# LANGUAGE DataKinds    #-}+ module Agda.Syntax.Concrete.Operators.Parser where -import Control.Applicative+import Control.Applicative ( Alternative((<|>), many) )+import Control.Monad ((<=<))  import Data.Either-import Data.Hashable+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 Text.PrettyPrint.HughesPJ hiding (empty)- import Agda.Syntax.Position import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common-import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse) import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P -#include "undefined.h"+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  placeholder :: PositionInName -> Parser e (MaybePlaceholder e) placeholder p =-  annotate (const $ text ("_" ++ show p)) $-  sat $ \t ->-  case t of+  doc (text ("_" ++ show p)) $+  sat $ \case     Placeholder p' | p' == p -> True     _                        -> False @@ -43,41 +46,35 @@   where   p' = noPlaceholder <$> p -notPlaceholder :: Parser e e-notPlaceholder = do-  tok <- token-  case tok of-    Placeholder _     -> empty-    NoPlaceholder _ e -> return e--sat' :: (e -> Bool) -> Parser e e-sat' p = do-  tok <- notPlaceholder-  if p tok then return tok else empty+satNoPlaceholder :: (e -> Maybe a) -> Parser e a+satNoPlaceholder p = sat' $ \case+    NoPlaceholder _ e -> p e+    Placeholder _     -> Nothing  data ExprView e     = LocalV QName     | WildV e     | OtherV e     | AppV e (NamedArg e)-    | OpAppV QName (Set A.Name) [NamedArg (MaybePlaceholder (OpApp 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)     | InstanceArgV (Named_ e)-    | LamV [LamBinding] e+    | LamV (List1 LamBinding) e     | ParenV e --    deriving (Show)  class HasRange e => IsExpr e where-    exprView   :: e -> ExprView e-    unExprView :: ExprView e -> e+  exprView    :: e -> ExprView e+  unExprView  :: ExprView e -> e+  patternView :: e -> Maybe Pattern  instance IsExpr e => HasRange (ExprView e) where   getRange = getRange . unExprView  instance IsExpr Expr where-    exprView e = case e of+    exprView = \case         Ident x         -> LocalV x         App _ e1 e2     -> AppV e1 e2         OpApp r d ns es -> OpAppV d ns es@@ -85,9 +82,9 @@         InstanceArg _ e -> InstanceArgV e         Paren _ e       -> ParenV e         Lam _ bs    e   -> LamV bs e-        Underscore{}    -> WildV e-        _               -> OtherV e-    unExprView e = case e of+        e@Underscore{}  -> WildV e+        e               -> OtherV e+    unExprView = \case         LocalV x       -> Ident x         AppV e1 e2     -> App (fuseRange e1 e2) e1 e2         OpAppV d ns es -> OpApp (fuseRange d es) d ns es@@ -98,23 +95,25 @@         WildV e        -> e         OtherV e       -> e +    patternView = isPattern+ instance IsExpr Pattern where-    exprView e = case e of-        IdentP x         -> LocalV x+    exprView = \case+        IdentP True x    -> LocalV x+        IdentP False _   -> __IMPOSSIBLE__         AppP e1 e2       -> AppV e1 e2-        OpAppP r d ns es -> OpAppV d ns ((map . fmap . fmap)-                                           (noPlaceholder . Ordinary) es)+        OpAppP r d ns es -> OpAppV d ns $ (fmap . fmap . fmap) (noPlaceholder . Ordinary) es         HiddenP _ e      -> HiddenArgV e         InstanceP _ e    -> InstanceArgV e         ParenP _ e       -> ParenV e-        WildP{}          -> WildV e-        _                -> OtherV e-    unExprView e = case e of-        LocalV x       -> IdentP x+        e@WildP{}        -> WildV e+        e                -> OtherV e+    unExprView = \case+        LocalV x       -> IdentP True x         AppV e1 e2     -> AppP e1 e2-        OpAppV d ns es -> let ess :: [NamedArg Pattern]-                              ess = (map . fmap . fmap)-                                      (\x -> case x of+        OpAppV d ns es -> let ess :: List1 (NamedArg Pattern)+                              ess = (fmap . fmap . fmap)+                                      (\case                                           Placeholder{}     -> __IMPOSSIBLE__                                           NoPlaceholder _ x -> fromOrdinary __IMPOSSIBLE__ x)                                       es@@ -126,6 +125,8 @@         WildV e        -> e         OtherV e       -> e +    patternView = pure+ -- | Should sections be parsed? data ParseSections = ParseSections | DoNotParseSections   deriving (Eq, Show)@@ -137,18 +138,18 @@  parse :: IsExpr e => (ParseSections, Parser e a) -> [e] -> [a] parse (DoNotParseSections, p) es = P.parse p (map noPlaceholder es)-parse (ParseSections,      p) es = P.parse p (concat $ map splitExpr es)+parse (ParseSections,      p) es = P.parse p (List1.concat $ map splitExpr es)   where-  splitExpr :: IsExpr e => e -> [MaybePlaceholder e]+  splitExpr :: IsExpr e => e -> List1 (MaybePlaceholder e)   splitExpr e = case exprView e of     LocalV n -> splitName n     _        -> noSplit     where-    noSplit = [noPlaceholder e]+    noSplit = singleton $ noPlaceholder e -    splitName n = case last ns of-      Name r ps@(_ : _ : _) -> splitParts r (init ns) Beginning ps-      _                     -> noSplit+    splitName n = case List1.last ns of+      Name r nis ps@(_ :| _ : _) -> splitParts r nis (List1.init ns) Beginning ps+      _                          -> noSplit       where       ns = qnameParts n @@ -159,16 +160,15 @@       -- Note also that the module qualifier, if any, is only applied       -- to the first name part. -      splitParts _ _ _ []          = __IMPOSSIBLE__-      splitParts _ _ _ (Hole : []) = [Placeholder End]-      splitParts r m _ (Id s : []) = [part r m End s]-      splitParts r m w (Hole : ps) = Placeholder w : splitParts r m  Middle ps-      splitParts r m w (Id s : ps) = part r m w s  : splitParts r [] Middle ps+      splitParts _ _   _ _ (Hole :| [])     = singleton $ Placeholder End+      splitParts r nis m _ (Id s :| [])     = singleton $ part r nis m End s+      splitParts r nis m w (Hole :| p : ps) = Placeholder w    <| splitParts r nis m  Middle (p :| ps)+      splitParts r nis m w (Id s :| p : ps) = part r nis m w s <| splitParts r nis [] Middle (p :| ps) -      part r m w s =+      part r nis m w s =         NoPlaceholder (Strict.Just w)                       (unExprView $ LocalV $-                         foldr Qual (QName (Name r [Id s])) m)+                         foldr Qual (QName $ Name r nis $ singleton $ Id s) m)  --------------------------------------------------------------------------- -- * Parser combinators@@ -179,16 +179,14 @@  -- | Parse a specific identifier as a NamePart partP :: IsExpr e => [Name] -> RawName -> Parser e Range-partP ms s = annotate (const $ text (show str)) $ do-    tok <- notPlaceholder-    case isLocal tok of-      Just p  -> return p-      Nothing -> empty-    where-        str = show (foldr Qual (QName (Name noRange [Id s])) ms)-        isLocal e = case exprView e of-            LocalV y | str == show y -> Just (getRange y)-            _                        -> Nothing+partP ms s =+  doc (text (show str)) $+  satNoPlaceholder isLocal+  where+  str = prettyShow $ foldr Qual (QName $ simpleName s) ms+  isLocal e = case exprView e of+      LocalV y | str == prettyShow y -> Just $ getRange y+      _ -> Nothing  -- | Parses a split-up, unqualified name consisting of at least two -- name parts.@@ -198,46 +196,35 @@ -- first name part that is not an underscore.  atLeastTwoParts :: IsExpr e => Parser e Name-atLeastTwoParts = do-  (r, ps) <- parts Beginning-  case r of-    Nothing -> __IMPOSSIBLE__-    Just r  -> return (Name r ps)+atLeastTwoParts =+  (\p1 ps p2 ->+      let all = p1 :| ps ++ [p2] in+      case List1.mapMaybe fst all of+        (r,nis) : _ -> Name r nis (fmap snd all)+        []          -> __IMPOSSIBLE__)+  <$> part Beginning+  <*> many (part Middle)+  <*> part End   where-  parts pos = do-    tok          <- token-    (pos', r, p) <- case tok of-      Placeholder pos'                   -> return (pos', Nothing, Hole)-      NoPlaceholder (Strict.Just pos') e -> case exprView e of-        LocalV (QName (Name r [Id s])) -> return (pos', Just r, Id s)-        _                              -> empty-      _ -> empty-    if pos == Middle && pos' == End then-      return (r, [p])-     else if pos' == pos then do-      (r', ps) <- parts Middle-      return (maybe r' Just r, p : ps)-     else-      empty+  part pos = sat' $ \case+    Placeholder pos'                   | pos == pos' -> Just ( Nothing+                                                             , Hole+                                                             )+    NoPlaceholder (Strict.Just pos') e | pos == pos' ->+      case exprView e of+        LocalV (QName (Name r nis (Id s :| []))) -> Just (Just (r, nis), Id s)+        _ -> Nothing+    _ -> Nothing --- | Either a wildcard (@_@), or an unqualified name (possibly--- containing multiple name parts).+-- | Parses a potentially pattern-matching binder -wildOrUnqualifiedName :: IsExpr e => Parser e (Maybe Name)-wildOrUnqualifiedName =-  (Nothing <$ partP [] "_")-    <|>-  (do e <- notPlaceholder-      case exprView e of-        LocalV (QName n) -> return (Just n)-        WildV _          -> return Nothing-        _                -> empty)-    <|>-  Just <$> atLeastTwoParts+patternBinder :: IsExpr e => Parser e Binder+patternBinder = inOnePart <|> mkBinder_ <$> atLeastTwoParts+  where inOnePart = satNoPlaceholder $ isBinderP <=< patternView  -- | Used to define the return type of 'opP'. -type family OperatorType (k :: NotationKind) (e :: *) :: *+type family OperatorType (k :: NotationKind) (e :: Type) :: Type type instance OperatorType 'InfixNotation   e = MaybePlaceholder e -> MaybePlaceholder e -> e type instance OperatorType 'PrefixNotation  e = MaybePlaceholder e -> e type instance OperatorType 'PostfixNotation e = MaybePlaceholder e -> e@@ -246,7 +233,7 @@ -- | A singleton type for 'NotationKind' (except for the constructor -- 'NoNotation'). -data NK (k :: NotationKind) :: * where+data NK (k :: NotationKind) :: Type where   In   :: NK 'InfixNotation   Pre  :: NK 'PrefixNotation   Post :: NK 'PostfixNotation@@ -263,14 +250,14 @@     => ParseSections     -> Parser e e -> NewNotation -> NK k -> Parser e (OperatorType k e) opP parseSections p (NewNotation q names _ syn isOp) kind =-  flip fmap (worker (init $ qnameParts q)+  flip fmap (worker (List1.init $ qnameParts q)                     withoutExternalHoles) $ \(range, hs) ->    let (normal, binders) = partitionEithers hs-      lastHole          = maximum $ mapMaybe holeTarget syn+      lastHole          = maximum $ (-1) : mapMaybe holeTarget syn -      app :: ([(MaybePlaceholder e, NamedArg Int)] ->-              [(MaybePlaceholder e, NamedArg Int)]) -> e+      app :: ([(MaybePlaceholder e, NamedArg (Ranged Int))] ->+              [(MaybePlaceholder e, NamedArg (Ranged Int))]) -> e       app f =         -- If we have an operator and there is exactly one         -- placeholder for every hole, then we only return@@ -280,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 @@ -294,95 +283,81 @@    where -  (leadingHoles,  syn1) = span isNormalHole syn-  (trailingHoles, syn2) = span isNormalHole (reverse syn1)-  withoutExternalHoles  = reverse syn2+  (leadingHoles, syn1)                  = span    isAHole syn+  (withoutExternalHoles, trailingHoles) = spanEnd isAHole syn1    leadingHole = case leadingHoles of-    [NormalHole h] -> h+    [HolePart _ h] -> h     _              -> __IMPOSSIBLE__    trailingHole = case trailingHoles of-    [NormalHole h] -> h+    [HolePart _ h] -> h     _              -> __IMPOSSIBLE__    worker ::     [Name] -> Notation ->-    Parser e (Range, [Either (MaybePlaceholder e, NamedArg Int)-                             (LamBinding, Int)])-  worker ms []              = return (noRange, [])+    Parser e (Range, [Either (MaybePlaceholder e, NamedArg (Ranged Int))+                             (LamBinding, Ranged BoundVariablePosition)])+  worker ms []              = pure (noRange, [])   worker ms (IdPart x : xs) =     (\r1 (r2, es) -> (fuseRanges r1 r2, es))-      <$> partP ms x+      <$> 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) =-    (\(r, es) -> (r, Right (mkBinding h $ Name noRange [Hole]) : es))+  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-    (\e (r, es) ->-        let x = case e of-                  Just name -> name-                  Nothing   -> Name noRange [Hole]-        in (r, Right (mkBinding h x) : es))+  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?-      <$> wildOrUnqualifiedName+      <$> patternBinder       <*> worker ms xs -  mkBinding h x = (DomainFree defaultArgInfo $ mkBoundName_ x, h)+  mkBinding h b = (DomainFree $ defaultNamedArg b, h)    set x arg = fmap (fmap (const x)) arg    findExprFor ::-    [(MaybePlaceholder e, NamedArg Int)] ->-    [(LamBinding, Int)] -> Int ->+    [(MaybePlaceholder e, NamedArg (Ranged Int))] ->+    [(LamBinding, Ranged BoundVariablePosition)] -> Int ->     NamedArg (MaybePlaceholder (OpApp e))   findExprFor normalHoles binders n =-    case [ h | h@(_, m) <- normalHoles, namedArg m == n ] of+    case [ h | h@(_, m) <- normalHoles, rangedThing (namedArg m) == n ] of       [(Placeholder p,     arg)] -> set (Placeholder p) arg-      [(NoPlaceholder _ e, arg)] -> case [b | (b, m) <- binders, m == n] of-        [] -> set (noPlaceholder (Ordinary e)) arg -- no variable to bind-        bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg+      [(NoPlaceholder _ e, arg)] ->+        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 :: [NamedArg (MaybePlaceholder (OpApp e))] -> Int-  noPlaceholders = sum . map (isPlaceholder . namedArg)+  noPlaceholders :: OpAppArgs0 e -> Int+  noPlaceholders = sum . fmap (isPlaceholder . namedArg)     where     isPlaceholder NoPlaceholder{} = 0     isPlaceholder Placeholder{}   = 1  argsP :: IsExpr e => Parser e e -> Parser e [NamedArg e]-argsP p = many (annotate (const $ text "<argument>") $-                  nothidden <|> hidden <|> instanceH)-    where-        isHidden (HiddenArgV _) = True-        isHidden _              = False--        isInstance (InstanceArgV _) = True-        isInstance _                = False--        nothidden = defaultArg . unnamed <$> do-            e <- p-            case exprView e of-                HiddenArgV   _ -> empty-                InstanceArgV _ -> empty-                _              -> return e--        instanceH = do-            InstanceArgV e <- exprView <$> sat' (isInstance . exprView)-            return $ makeInstance $ defaultArg e--        hidden = do-            HiddenArgV e <- exprView <$> sat' (isHidden . exprView)-            return $ hide $ defaultArg e+argsP p = many (mkArg <$> p)+  where+  mkArg e = case exprView e of+    HiddenArgV   e -> hide (defaultArg e)+    InstanceArgV e -> makeInstance (defaultArg e)+    _              -> defaultArg (unnamed e)  appP :: IsExpr e => Parser e e -> Parser e [NamedArg e] -> Parser e e appP p pa = foldl app <$> p <*> pa@@ -390,8 +365,9 @@         app e = unExprView . AppV e  atomP :: IsExpr e => (QName -> Bool) -> Parser e e-atomP p = annotate (const $ text "<atom>") $ do-    e <- notPlaceholder-    case exprView e of-        LocalV x | not (p x) -> empty-        _                    -> return e+atomP p =+  doc "<atom>" $+  satNoPlaceholder $ \e ->+  case exprView e of+    LocalV x | not (p x) -> Nothing+    _                    -> Just e
src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs view
@@ -1,20 +1,18 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- | The parser monad used by the operator parser ------------------------------------------------------------------------ -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}  module Agda.Syntax.Concrete.Operators.Parser.Monad-  ( MemoKey(..)+  ( MemoKey(..), PrecedenceKey   , Parser   , parse-  , token+  , sat'   , sat-  , tok-  , annotate+  , doc   , memoise   , memoiseIfPrinting   , grammar@@ -22,27 +20,30 @@  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. -data MemoKey = NodeK      (Either Integer Integer)-             | PostLeftsK (Either Integer Integer)-             | PreRightsK (Either Integer Integer)+data MemoKey = NodeK      PrecedenceKey+             | PostLeftsK PrecedenceKey+             | PreRightsK PrecedenceKey              | TopK              | AppK              | NonfixK   deriving (Eq, Show, Generic) +type PrecedenceKey = Either PrecedenceLevel PrecedenceLevel+ instance Hashable MemoKey  -- | The parser monad.  type Parser tok a =-#ifdef DEBUG+#ifdef DEBUG_PARSING   Parser.ParserWithGrammar #else   Parser.Parser@@ -54,10 +55,11 @@ parse :: forall tok a. Parser tok a -> [MaybePlaceholder tok] -> [a] parse = Parser.parse --- | Parses a single token.+-- | Parses a token satisfying the given predicate. The computed value+-- is returned. -token :: Parser tok (MaybePlaceholder tok)-token = Parser.token+sat' :: (MaybePlaceholder tok -> Maybe a) -> Parser tok a+sat' = Parser.sat'  -- | Parses a token satisfying the given predicate. @@ -65,17 +67,11 @@        Parser tok (MaybePlaceholder tok) sat = Parser.sat --- | Parses a given token.--tok :: (Eq tok, Show tok) =>-       MaybePlaceholder tok -> Parser tok (MaybePlaceholder tok)-tok = Parser.tok---- | Uses the given function to modify the printed representation (if--- any) of the given parser.+-- | Uses the given document as the printed representation of the+-- given parser. The document's precedence is taken to be 'atomP'. -annotate :: (Doc -> Doc) -> Parser tok a -> Parser tok a-annotate = Parser.annotate+doc :: Doc -> Parser tok a -> Parser tok a+doc = Parser.doc  -- | Memoises the given parser. --
+ src/full/Agda/Syntax/Concrete/Pattern.hs view
@@ -0,0 +1,387 @@++-- | Tools for patterns in concrete syntax.++module Agda.Syntax.Concrete.Pattern where++import Control.Applicative ( liftA2 )+import Control.Arrow ( first )+import Control.Monad ( (>=>) )+import Control.Monad.Identity++import Data.Monoid ( Any(..), Endo(..), Sum(..) )++import Agda.Syntax.Common+import Agda.Syntax.Concrete++import Agda.Utils.AffineHole+import Agda.Utils.Functor+import Agda.Utils.Impossible+import Agda.Utils.List+import Agda.Utils.List1  ( List1, pattern (:|), (<|) )+import Agda.Utils.List2  ( List2 )+import Agda.Utils.Maybe+import Agda.Utils.Singleton+import qualified Agda.Utils.List1 as List1+++-- | Check for ellipsis @...@.++class IsEllipsis a where+  isEllipsis :: a -> Bool++-- | Is the pattern just @...@?+instance IsEllipsis Pattern where+  isEllipsis = \case+    EllipsisP{}         -> True+    ParenP _ p          -> isEllipsis p+    _ -> False++-- | Has the lhs an occurrence of the ellipsis @...@?++class HasEllipsis a where+  hasEllipsis :: a -> Bool++instance HasEllipsis Pattern where+  hasEllipsis p =+    case hasEllipsis' p of+      ZeroHoles _ -> False+      OneHole _ _ -> True+      ManyHoles   -> True++-- | Does the lhs contain an ellipsis?+instance HasEllipsis LHS where+  hasEllipsis (LHS p _ _) = hasEllipsis p+  -- clauses that are already expanded don't have an ellipsis++-- | Check for with-pattern @| p@.++class IsWithP p where+  isWithP :: p -> Maybe p++  default isWithP :: (IsWithP q, Decoration f, f q ~ p) => p -> Maybe p+  isWithP = traverseF isWithP++instance IsWithP Pattern where+  isWithP = \case+    WithP _ p           -> Just p+    ParenP _ p          -> isWithP p+    _ -> Nothing++instance IsWithP p => IsWithP (Arg p) where+instance IsWithP p => IsWithP (Named n p) where+++-- * LHS manipulation (see also ''Agda.Syntax.Abstract.Pattern'')++-- | The next patterns are ...+--+-- (This view discards 'PatInfo'.)+data LHSPatternView+  = LHSAppP  (List1 (NamedArg Pattern))+      -- ^ Application patterns (non-empty list).+  | LHSWithP (List1 Pattern)+      -- ^ With patterns (non-empty list).+      --   These patterns are not prefixed with 'WithP'.++-- | Construct the 'LHSPatternView' of the given list (if not empty).+--+-- Return the view and the remaining patterns.++lhsPatternView :: [NamedArg Pattern] -> Maybe (LHSPatternView, [NamedArg Pattern])+lhsPatternView [] = Nothing+lhsPatternView (p0 : ps) =+  case namedArg p0 of+    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)+      where+      (ps1, ps2) = span (isNothing . isWithP) ps++-- | Add applicative patterns (non-projection / non-with patterns) to the right.+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 -> 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.+lhsCoreAddSpine :: LHSCore -> [NamedArg Pattern] -> LHSCore+lhsCoreAddSpine core ps0 =+  -- Recurse on lhsPatternView until no patterns left.+  case lhsPatternView ps0 of+    Nothing       -> core+    Just (LHSAppP  ps , ps') -> lhsCoreApp  core ps  `lhsCoreAddSpine` ps'+    Just (LHSWithP wps, ps') -> lhsCoreWith core wps `lhsCoreAddSpine` ps'+++-- | Modify the 'Pattern' component in 'LHS'.+mapLhsOriginalPattern :: (Pattern -> Pattern) -> LHS -> LHS+mapLhsOriginalPattern f lhs@LHS{ lhsOriginalPattern = p } =+  lhs { lhsOriginalPattern = f p }++-- | Effectfully modify the 'Pattern' component in 'LHS'.+mapLhsOriginalPatternM :: (Functor m, Applicative m) => (Pattern -> m Pattern) -> LHS -> m LHS+mapLhsOriginalPatternM f lhs@LHS{ lhsOriginalPattern = p } = f p <&> \ p' ->+  lhs { lhsOriginalPattern = p' }++-- | Does the LHS contain projection patterns?+hasCopatterns :: LHSCore -> Bool+hasCopatterns = \case+  LHSHead{}     -> False+  LHSProj{}     -> True+  LHSWith h _ _ -> hasCopatterns h+  LHSEllipsis{} -> False++-- * Generic fold++-- | Generic pattern traversal.+--+-- See 'Agda.Syntax.Abstract.Pattern.APatternLike'.++class CPatternLike p where++  -- | Fold pattern.+  foldrCPattern+    :: Monoid m+    => (Pattern -> m -> m)+         -- ^ Combine a pattern and the value computed from its subpatterns.+    -> p -> m++  default foldrCPattern+    :: (Monoid m, Foldable f, CPatternLike q, f q ~ p)+    => (Pattern -> m -> m) -> p -> m+  foldrCPattern = foldMap . foldrCPattern++  -- | Traverse pattern with option of post-traversal modification.+  traverseCPatternA :: (Applicative m, Functor m)+      => (Pattern -> m Pattern -> m Pattern)+         -- ^ Combine a pattern and the its recursively computed version.+      -> p -> m p++  default traverseCPatternA :: (Traversable f, CPatternLike q, f q ~ p, Applicative m, Functor m)+      => (Pattern -> m Pattern -> m Pattern)+      -> p -> m p+  traverseCPatternA = traverse . traverseCPatternA++  -- | Traverse pattern.+  traverseCPatternM :: Monad m+    => (Pattern -> m Pattern)  -- ^ @pre@: Modification before recursion.+    -> (Pattern -> m Pattern)  -- ^ @post@: Modification after recursion.+    -> p -> m p++  default traverseCPatternM+    :: (Traversable f, CPatternLike q, f q ~ p, Monad m)+    => (Pattern -> m Pattern)+    -> (Pattern -> m Pattern)+    -> p -> m p+  traverseCPatternM pre post = traverse $ traverseCPatternM pre post++instance CPatternLike Pattern where+  foldrCPattern f p0 = f p0 $+    case p0 of+      -- Recursive cases:+      AppP p ps       -> foldrCPattern f (p, ps)+      RawAppP _ ps    -> foldrCPattern f ps+      OpAppP _ _ _ ps -> foldrCPattern f ps+      HiddenP _ ps    -> foldrCPattern f ps+      InstanceP _ ps  -> foldrCPattern f ps+      ParenP _ p      -> foldrCPattern f p+      AsP _ _ p       -> foldrCPattern f p+      WithP _ p       -> foldrCPattern f p+      RecP _ _ ps     -> foldrCPattern f ps+      EllipsisP _ mp  -> foldrCPattern f mp+      -- Nonrecursive cases:+      IdentP _ _      -> mempty+      WildP _         -> mempty+      DotP _ _ _      -> mempty+      AbsurdP _       -> mempty+      LitP _ _        -> mempty+      QuoteP _        -> mempty+      EqualP _ _      -> mempty++  traverseCPatternA f p0 = f p0 $ case p0 of+      -- Recursive cases:+      AppP        p ps    -> liftA2 AppP (traverseCPatternA f p) (traverseCPatternA f ps)+      RawAppP   r ps      -> RawAppP r     <$> traverseCPatternA f ps+      OpAppP    r x xs ps -> OpAppP r x xs <$> traverseCPatternA f ps+      HiddenP   r p       -> HiddenP r     <$> traverseCPatternA f p+      InstanceP r p       -> InstanceP r   <$> traverseCPatternA f p+      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  kwr r ps      -> RecP kwr r    <$> traverseCPatternA f ps+      EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternA f mp+      -- Nonrecursive cases:+      IdentP _ _      -> pure p0+      WildP _         -> pure p0+      DotP _ _ _      -> pure p0+      AbsurdP _       -> pure p0+      LitP _ _        -> pure p0+      QuoteP _        -> pure p0+      EqualP _ _      -> pure p0++  traverseCPatternM pre post = pre >=> recurse >=> post+    where+    recurse p0 = case p0 of+      -- Recursive cases:+      AppP        p ps    -> uncurry AppP  <$> traverseCPatternM pre post (p, ps)+      RawAppP   r ps      -> RawAppP r     <$> traverseCPatternM pre post ps+      OpAppP    r x xs ps -> OpAppP r x xs <$> traverseCPatternM pre post ps+      HiddenP   r p       -> HiddenP r     <$> traverseCPatternM pre post p+      InstanceP r p       -> InstanceP r   <$> traverseCPatternM pre post p+      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  kwr r ps      -> RecP kwr r    <$> traverseCPatternM pre post ps+      EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternM pre post mp+      -- Nonrecursive cases:+      IdentP _ _      -> return p0+      WildP _         -> return p0+      DotP _ _ _      -> return p0+      AbsurdP _       -> return p0+      LitP _ _        -> return p0+      QuoteP _        -> return p0+      EqualP _ _      -> return p0++instance (CPatternLike a, CPatternLike b) => CPatternLike (a,b) where+  foldrCPattern f (p, p') =+    foldrCPattern f p `mappend` foldrCPattern f p'++  traverseCPatternA f (p, p') =+    liftA2 (,)+      (traverseCPatternA f p)+      (traverseCPatternA f p')++  traverseCPatternM pre post (p, p') =+    liftA2 (,)+      (traverseCPatternM pre post p)+      (traverseCPatternM pre post p')++instance CPatternLike p => CPatternLike (Arg p)+instance CPatternLike p => CPatternLike (Named n p)+instance CPatternLike p => CPatternLike [p]+instance CPatternLike p => CPatternLike (List1 p)+instance CPatternLike p => CPatternLike (List2 p)+instance CPatternLike p => CPatternLike (Maybe p)+instance CPatternLike p => CPatternLike (FieldAssignment' p)++-- | Compute a value from each subpattern and collect all values in a monoid.++foldCPattern :: (CPatternLike p, Monoid m) => (Pattern -> m) -> p -> m+foldCPattern f = foldrCPattern $ \ p m -> f p `mappend` m++-- | Traverse pattern(s) with a modification before the recursive descent.++preTraverseCPatternM+  :: (CPatternLike p, Monad m)+  => (Pattern -> m Pattern)  -- ^ @pre@: Modification before recursion.+  -> p -> m p+preTraverseCPatternM pre p = traverseCPatternM pre return p++-- | Traverse pattern(s) with a modification after the recursive descent.++postTraverseCPatternM+  :: (CPatternLike p, Monad m)+  => (Pattern -> m Pattern)  -- ^ @post@: Modification after recursion.+  -> p -> m p+postTraverseCPatternM post p = traverseCPatternM return post p++-- | Map pattern(s) with a modification after the recursive descent.++mapCPattern :: CPatternLike p => (Pattern -> Pattern) -> p -> p+mapCPattern f = runIdentity . postTraverseCPatternM (Identity . f)+++-- * Specific folds.++-- | Get all the identifiers in a pattern in left-to-right order.+--+-- Implemented using difference lists.+patternQNames :: CPatternLike p => p -> [QName]+patternQNames p = foldCPattern f p `appEndo` []+  where+  f :: Pattern -> Endo [QName]+  f = \case+    IdentP _ x     -> Endo (x :)+    OpAppP _ x _ _ -> Endo (x :)+    AsP _ x _      -> mempty  -- x must be a bound name, can't be a constructor!+    AppP _ _       -> mempty+    WithP _ _      -> mempty+    RawAppP _ _    -> mempty+    HiddenP _ _    -> mempty+    ParenP _ _     -> mempty+    WildP _        -> mempty+    AbsurdP _      -> mempty+    DotP _ _ _     -> mempty+    LitP _ _       -> mempty+    QuoteP _       -> mempty+    InstanceP _ _  -> mempty+    RecP _ _ _     -> mempty+    EqualP _ _     -> mempty+    EllipsisP _ _  -> mempty++-- | Get all the identifiers in a pattern in left-to-right order.+patternNames :: Pattern -> [Name]+patternNames = map unqualify . patternQNames++-- | Does the pattern contain a with-pattern?+-- (Shortcutting.)+hasWithPatterns :: CPatternLike p => p -> Bool+hasWithPatterns = getAny . foldCPattern (Any . isWithPattern)++-- | Is 'WithP'?+isWithPattern :: Pattern -> Bool+isWithPattern = \case+  WithP{} -> True+  _ -> False++-- | Count the number of with-subpatterns in a pattern?+numberOfWithPatterns :: CPatternLike p => p -> Int+numberOfWithPatterns = getSum . foldCPattern (Sum . f)+  where f p = if isWithPattern p then 1 else 0++-- | Compute the context in which the ellipsis occurs, if at all.+--   If there are several occurrences, this is an error.+--   This only counts ellipsis that haven't already been expanded.+hasEllipsis' :: CPatternLike p => p -> AffineHole Pattern p+hasEllipsis' = traverseCPatternA $ \ p mp ->+  case p of+    EllipsisP _ Nothing -> OneHole id p+    _                   -> mp++reintroduceEllipsis :: ExpandedEllipsis -> Pattern -> Pattern+reintroduceEllipsis (ExpandedEllipsis r k) p | hasWithPatterns p =+  let (args, wargs) = splitEllipsis k $ List1.toList $ patternAppView p+      (hd,args') = fromMaybe __IMPOSSIBLE__ $ uncons args+      core = foldl AppP (namedArg hd) args+  in foldl AppP (EllipsisP r $ Just $ core) wargs+reintroduceEllipsis _ p = p++splitEllipsis :: (IsWithP p) => Int -> [p] -> ([p],[p])+splitEllipsis k [] = ([] , [])+splitEllipsis k (p:ps)+  | isJust (isWithP p) = if+      | k == 0    -> ([] , p:ps)+      | otherwise -> first (p:) $ splitEllipsis (k-1) ps+  | otherwise = first (p:) $ splitEllipsis k ps++---------------------------------------------------------------------------+-- * Helpers for pattern and lhs parsing+---------------------------------------------------------------------------++-- | View a pattern @p@ as a list @p0 .. pn@ where @p0@ is the identifier+--   (in most cases a constructor).+--+--  Pattern needs to be parsed already (operators resolved).+patternAppView :: Pattern -> List1 (NamedArg Pattern)+patternAppView = \case+    AppP p arg      -> patternAppView p `List1.appendList` [arg]+    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,54 +1,56 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-}- {-| Pretty printer for the concrete syntax. -}-module Agda.Syntax.Concrete.Pretty where+module Agda.Syntax.Concrete.Pretty+  ( module Agda.Syntax.Concrete.Pretty+  , module Agda.Syntax.Concrete.Glyph+  ) where -import Prelude hiding (null)+import Prelude hiding ( null ) -import Data.Functor import Data.Maybe+import qualified Data.Foldable  as Fold+import qualified Data.Semigroup as Semigroup import qualified Data.Strict.Maybe as Strict+import qualified Data.Text as T  import Agda.Syntax.Common import Agda.Syntax.Concrete-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Position--import Agda.TypeChecking.Positivity.Occurrence+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 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 Agda.Utils.String+import qualified Agda.Syntax.Common.Aspect as Asp+import Agda.Syntax.Common.Pretty+import Agda.Interaction.Options ( HasOptions(pragmaOptions), optPolarity ) -#include "undefined.h" import Agda.Utils.Impossible -instance Show Expr            where show = show . pretty-instance Show Declaration     where show = show . pretty-instance Show Pattern         where show = show . pretty-instance Show TypedBinding    where show = show . pretty-instance Show TypedBindings   where show = show . pretty-instance Show LamBinding      where show = show . pretty-instance (Pretty a, Pretty b) => Show (ImportDirective' a b)-                              where show = show . pretty-instance Show Pragma          where show = show . pretty-instance Show RHS             where show = show . pretty--braces' :: Doc -> Doc-braces' d = case render d of-  -- Add space to avoid starting a comment-  '-':_ -> braces (text " " <> d)-  _     -> braces d---- double braces...-dbraces :: Doc -> Doc-dbraces = braces . braces'+deriving instance Show Expr+deriving instance (Show a) => Show (OpApp a)+deriving instance Show Declaration+deriving instance Show Pattern+deriving instance Show a => Show (Binder' a)+deriving instance Show TypedBinding+deriving instance Show LamBinding+deriving instance Show BoundName+deriving instance Show ModuleAssignment+deriving instance Show Pragma+deriving instance Show RHS+deriving instance Show LHS+deriving instance Show LHSCore+deriving instance Show LamClause+deriving instance Show WhereClause+deriving instance Show ModuleApplication+deriving instance Show DoStmt+deriving instance Show Module  -- Lays out a list of documents [d₁, d₂, …] in the following way: -- @@@ -59,508 +61,595 @@ -- @ -- If the list is empty, then the notation @{}@ is used. -bracesAndSemicolons :: [Doc] -> Doc-bracesAndSemicolons []       = text "{}"-bracesAndSemicolons (d : ds) =-  sep ([text "{" <+> d] ++ map (text ";" <+>) ds ++ [text "}"])+bracesAndSemicolons :: Foldable t => t Doc -> Doc+bracesAndSemicolons ts = case Fold.toList ts of+  []       -> "{}"+  (d : ds) -> sep (["{" <+> d] ++ map (";" <+>) ds ++ ["}"]) -arrow, lambda :: Doc-arrow  = text "\x2192"-lambda = text "\x03bb"+prettyTactic :: BoundName -> Doc -> Doc+prettyTactic = prettyTactic' . bnameTactic --- | @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+prettyFiniteness :: BoundName -> Doc -> Doc+prettyFiniteness name+  | bnameIsFinite name = ("@finite" <+>)+  | otherwise = id -prettyRelevance :: LensRelevance a => a -> Doc -> Doc-prettyRelevance a d =-  if render d == "_" then d else pretty (getRelevance a) <> d+prettyTactic' :: TacticAttribute -> Doc -> Doc+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 Forced{}   = empty-  pretty UnusedArg  = empty-  pretty Relevant   = empty-  pretty Irrelevant = text "."-  pretty NonStrict  = text ".."--instance Pretty Induction where-  pretty Inductive = text "data"-  pretty CoInductive = text "codata"+-- | 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   pretty (SyntaxBindingLambda r bs e) = pretty (Lam r bs e)  instance Pretty a => Pretty (MaybePlaceholder a) where-  pretty Placeholder{}       = text "_"+  pretty Placeholder{}       = "_"   pretty (NoPlaceholder _ e) = pretty e  instance Pretty Expr where-    pretty e =-        case e of+    pretty = \case             Ident x          -> pretty x-            Lit l            -> pretty l-            QuestionMark _ n -> text "?" <> maybe empty (text . show) n+            KnownIdent nk x  -> annotateAspect (Asp.Name (Just nk) False) (pretty x)+            Lit _ l          -> pretty l+            QuestionMark _ n -> hlSymbol "?" <> maybe empty (text . show) n             Underscore _ n   -> maybe underscore text n---          Underscore _ n   -> underscore <> maybe empty (text . show) n-            App _ _ _        ->+            e@(App _ _ _)    ->                 case appView e of                     AppView e1 args     ->                         fsep $ pretty e1 : map pretty args --                      sep [ pretty e1 --                          , nest 2 $ fsep $ map pretty args --                          ]-            RawApp _ es    -> fsep $ map pretty es-            OpApp _ q _ es -> fsep $ prettyOpApp q es+            RawApp _ es    -> fsep $ map pretty $ List2.toList 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 ((text "|" <+>) . pretty) es+              pretty e <| fmap ((hlSymbol "|" <+>) . pretty) es              HiddenArg _ e -> braces' $ pretty e             InstanceArg _ e -> dbraces $ pretty e+            Lam _ bs (AbsurdLam _ h) -> lambda <+> fsep (fmap pretty bs) <+> absurd h             Lam _ bs e ->-                sep [ lambda <+> fsep (map pretty bs) <+> arrow+                sep [ lambda <+> fsep (fmap pretty bs) <+> arrow                     , nest 2 $ pretty e                     ]-            AbsurdLam _ NotHidden -> lambda <+> text "()"-            AbsurdLam _ Instance -> lambda <+> text "{{}}"-            AbsurdLam _ Hidden -> lambda <+> text "{}"-            ExtendedLam _ pes ->-              lambda <+> bracesAndSemicolons (map (\(x,y,z,_) -> prettyClause x y z) pes)-                   where prettyClause lhs rhs wh = sep [ pretty lhs-                                                       , nest 2 $ pretty' rhs-                                                       ] $$ nest 2 (pretty wh)-                         pretty' (RHS e)   = arrow <+> pretty e-                         pretty' AbsurdRHS = empty+            AbsurdLam _ h -> lambda <+> absurd h+            ExtendedLam _ e pes ->+              lambda <+>+              prettyErased e (bracesAndSemicolons (fmap pretty pes))             Fun _ e1 e2 ->-                sep [ pretty e1 <+> arrow+                sep [ pretty (getModality e1) <+> pretty e1 <+> arrow                     , pretty e2                     ]             Pi tel e ->-                sep [ pretty (Tel $ smashTel tel) <+> arrow+                sep [ pretty (Tel $ smashTel $ List1.toList tel) <+> arrow                     , pretty e                     ]-            Set _   -> text "Set"-            Prop _  -> text "Prop"-            SetN _ n    -> text "Set" <> text (showIndex n)-            Let _ ds e  ->-                sep [ text "let" <+> vcat (map pretty ds)-                    , text "in" <+> pretty e+            Let _ ds me  ->+                sep [ hlKeyword "let" <+> vcat (fmap pretty ds)+                    , maybe empty (\ e -> hlKeyword "in" <+> pretty e) me                     ]             Paren _ e -> parens $ pretty e-            IdiomBrackets _ e -> text "(|" <+> pretty e <+> text "|)"-            As _ x e  -> pretty x <> text "@" <> pretty e-            Dot _ e   -> text "." <> pretty e-            Absurd _  -> text "()"-            Rec _ xs  -> sep [text "record", bracesAndSemicolons (map pretty xs)]-            RecUpdate _ e xs ->-              sep [text "record" <+> pretty e, bracesAndSemicolons (map pretty xs)]-            ETel []  -> text "()"-            ETel tel -> fsep $ map pretty tel-            QuoteGoal _ x e -> sep [text "quoteGoal" <+> pretty x <+> text "in",-                                    nest 2 $ pretty e]-            QuoteContext _ -> text "quoteContext"-            Quote _ -> text "quote"-            QuoteTerm _ -> text "quoteTerm"-            Unquote _ -> text "unquote"-            Tactic _ t es ->-              sep [ text "tactic" <+> pretty t-                  , fsep [ text "|" <+> pretty e | e <- es ]-                  ]+            IdiomBrackets _ es ->+              case es of+                []   -> emptyIdiomBrkt+                [e]  -> leftIdiomBrkt <+> pretty e <+> rightIdiomBrkt+                e:es -> leftIdiomBrkt <+> pretty e <+> fsep (map (("|" <+>) . pretty) es) <+> rightIdiomBrkt+            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 -> text "." <> parens (pretty e)-            Equal _ a b -> pretty a <+> text "=" <+> pretty b+            DontCare e -> hlSymbol "." <> parens (pretty e)+            Equal _ a b -> pretty a <+> equals <+> pretty b+            Ellipsis _  -> hlSymbol "..."+            Generalized e -> pretty e+        where+          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  instance Pretty a => Pretty (FieldAssignment' a) where-  pretty (FieldAssignment x e) = sep [ pretty x <+> text "=" , nest 2 $ pretty e ]+  pretty (FieldAssignment x e) = sep [ pretty x <+> "=" , nest 2 $ pretty e ]  instance Pretty ModuleAssignment where-  pretty (ModuleAssignment m es i) = (fsep $ pretty m : map pretty es) <+> pretty i+  pretty (ModuleAssignment m es i) = fsep (pretty m : map pretty es) <+> pretty i +instance Pretty LamClause where+  pretty (LamClause ps rhs _) =+    sep [ fsep (map pretty ps)+        , nest 2 $ pretty' rhs+        ]+    where+      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, boundLabel = l }-    | x == l    = pretty x-    | otherwise = pretty l <+> text "=" <+> pretty x+  pretty (BName x _fix _tac _fin) = pretty x +data NamedBinding = NamedBinding+  { withHiding   :: Bool+  , namedBinding :: NamedArg Binder+  }++isLabeled :: NamedArg Binder -> Maybe ArgName+isLabeled x+  | visible x              = Nothing  -- Ignore labels on visible arguments+  | Just l <- bareNameOf x = boolToMaybe (l /= nameToRawName (boundName $ binderName $ namedArg x)) l+  | otherwise              = Nothing++instance Pretty a => Pretty (Binder' a) where+  pretty (Binder mpat UserBinderName n) =+    applyWhenJust mpat (\ pat -> (<+> ("@" <+> parens (pretty pat)))) $ pretty n++  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+    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-    -- TODO guilhem: colors are unused (colored syntax disallowed)-    pretty (DomainFree i x) = prettyRelevance i $ prettyHiding i id $ pretty x-    pretty (DomainFull b)   = pretty b+    pretty (DomainFree x) = pretty (NamedBinding True x)+    pretty (DomainFull b) = pretty b -instance Pretty TypedBindings where-  pretty (TypedBindings _ a) = prettyRelevance a $ prettyHiding a p $-    pretty $ unArg a+instance Pretty TypedBinding where+    pretty (TLet _ ds) = parens $ "let" <+> vcat (fmap pretty ds)+    pretty (TBind _ xs (Underscore _ Nothing)) =+      fsep (fmap (pretty . NamedBinding True) xs)+    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 ]+      | ys@(y : _) <- groupBinds $ List1.toList xs ]       where-        p | isUnderscore (unArg a) = id-          | otherwise        = parens--        isUnderscore (TBind _ _ (Underscore _ Nothing)) = True-        isUnderscore _ = False+        groupBinds [] = []+        groupBinds (x : xs)+          | Just{} <- isLabeled x = [x] : groupBinds xs+          | otherwise   = (x : ys) : groupBinds zs+          where (ys, zs) = span (same x) xs+                same x y = getArgInfo x == getArgInfo y && isNothing (isLabeled y)  newtype Tel = Tel Telescope  instance Pretty Tel where     pretty (Tel tel)-      | any isMeta tel = text "∀" <+> fsep (map pretty tel)+      | any isMeta tel = forallQ <+> fsep (map pretty tel)       | otherwise      = fsep (map pretty tel)       where-        isMeta (TypedBindings _ (Arg _ (TBind _ _ (Underscore _ Nothing)))) = True+        isMeta (TBind _ _ (Underscore _ Nothing)) = True         isMeta _ = False --instance Pretty TypedBinding where-    pretty (TBind _ xs (Underscore _ Nothing)) =-      fsep (map pretty xs)-    pretty (TBind _ xs e) =-        sep [ fsep (map pretty xs)-            , text ":" <+> pretty e-            ]-    pretty (TLet _ ds) =-        text "let" <+> vcat (map pretty ds)- smashTel :: Telescope -> Telescope-smashTel (TypedBindings r (Arg i  (TBind r' xs e)) :-          TypedBindings _ (Arg i' (TBind _  ys e')) : tel)-  | show i == show i' && show e == show e' && all (isUnnamed . dget) (xs ++ ys) =-    smashTel (TypedBindings r (Arg i (TBind r' (xs ++ ys) e)) : tel)-  where-    isUnnamed x = boundLabel x == boundName x+smashTel (TBind r xs e  :+          TBind _ ys e' : tel)+  | prettyShow e == prettyShow e' = smashTel (TBind r (xs Semigroup.<> ys) e : tel) smashTel (b : tel) = b : smashTel tel smashTel [] = []   instance Pretty RHS where-    pretty (RHS e)   = text "=" <+> pretty e+    pretty (RHS e)   = "=" <+> pretty e     pretty AbsurdRHS = empty -instance Show WhereClause where show = show . pretty instance Pretty WhereClause where   pretty  NoWhere = empty-  pretty (AnyWhere [Module _ x [] ds]) | isNoName (unqualify x)-                       = vcat [ text "where", nest 2 (vcat $ map pretty ds) ]-  pretty (AnyWhere ds) = vcat [ text "where", nest 2 (vcat $ map pretty ds) ]-  pretty (SomeWhere m a ds) =-    vcat [ hsep $ applyWhen (a == PrivateAccess UserWritten) (text "private" :)-             [ text "module", pretty m, text "where" ]+  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 _ 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 Show LHS where show = show . pretty instance Pretty LHS where-  pretty lhs = case lhs of-    LHS p ps eqs es  -> pr (pretty p) ps eqs es-    Ellipsis _ ps eqs es -> pr (text "...") ps eqs es-    where-      pr d ps eqs es =-        sep [ d-            , nest 2 $ fsep $ map ((text "|" <+>) . pretty) ps-            , nest 2 $ pThing "rewrite" eqs-            , nest 2 $ pThing "with" es-            ]-      pThing thing []       = empty-      pThing thing (e : es) = fsep $ (text thing <+> pretty e)-                                   : map ((text "|" <+>) . pretty) es+  pretty (LHS p eqs es) = sep+    [ pretty p+    , nest 2 $ if null eqs then empty else fsep $ map pretty eqs+    , nest 2 $ prefixedThings "with" (map prettyWithd es)+    ] where -instance Show LHSCore where show = show . pretty+    prettyWithd :: WithExpr -> Doc+    prettyWithd (Named nm wh) =+      let e = pretty wh in+      case nm of+        Nothing -> e+        Just n  -> pretty n <+> ":" <+> e+ instance Pretty LHSCore where   pretty (LHSHead f ps) = sep $ pretty f : map (parens . pretty) ps   pretty (LHSProj d ps lhscore ps') = sep $     pretty d : map (parens . pretty) ps ++     parens (pretty lhscore) : map (parens . pretty) ps'--instance Pretty [Declaration] where-  pretty = vcat . map pretty+  pretty (LHSWith h wps ps) = if null ps then doc else+      sep $ parens doc : map (parens . pretty) ps+    where+    doc = sep $ pretty h <$ fmap (("|" <+>) . pretty) wps+  pretty (LHSEllipsis r p) = "..." -instance Show ModuleApplication where show = show . pretty instance Pretty ModuleApplication where-  pretty (SectionApp _ bs e) = fsep (map pretty bs) <+> text "=" <+> pretty e-  pretty (RecordModuleIFS _ rec) = text "=" <+> pretty rec <+> text "{{...}}"+  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) =+    ((pretty p <+> "←") <?> pretty e) <?> prCs cs+    where+      prCs [] = empty+      prCs cs = "where" <?> vcat (map pretty cs)+  pretty (DoThen e) = pretty e+  pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds)+ instance Pretty Declaration where-    pretty d =-        case d of-            TypeSig i x e ->-                sep [ prettyRelevance i $ pretty x <+> text ":"-                    , nest 2 $ pretty e-                    ]-            Field inst x (Arg i e) ->-                sep [ text "field"-                    , nest 2 $ mkInst inst $ mkOverlap i $-                      prettyRelevance i $ prettyHiding i id $-                        pretty $ TypeSig (i {argInfoRelevance = Relevant}) x e-                    ]-                where-                  mkInst InstanceDef    d = sep [ text "instance", nest 2 d ]-                  mkInst NotInstanceDef d = 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 -                  mkOverlap i d | argInfoOverlappable i = text "overlap" <+> d-                                | otherwise             = d-            FunClause lhs rhs wh _ ->-                sep [ pretty lhs-                    , nest 2 $ pretty rhs-                    ] $$ nest 2 (pretty wh)-            DataSig _ ind x tel e ->-                sep [ hsep  [ pretty ind-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ text ":"-                            , pretty e-                            ]-                    ]-            Data _ ind x tel (Just e) cs ->-                sep [ hsep  [ pretty ind-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ text ":"-                            , pretty e-                            , text "where"-                            ]-                    ] $$ nest 2 (vcat $ map pretty cs)-            Data _ ind x tel Nothing cs ->-                sep [ hsep  [ pretty ind-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ text "where"-                    ] $$ nest 2 (vcat $ map pretty cs)-            RecordSig _ x tel e ->-                sep [ hsep  [ text "record"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ text ":"-                            , pretty e-                            ]-                    ]-            Record _ x ind eta con tel me cs ->-                sep [ hsep  [ text "record"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ pType me-                    ] $$ nest 2 (vcat $ pInd ++-                                        pEta ++-                                        pCon ++-                                        map pretty cs)-              where pType (Just e) = hsep-                            [ text ":"-                            , pretty e-                            , text "where"-                            ]-                    pType Nothing  =-                              text "where"-                    pInd = maybeToList $ text . show . rangedThing <$> ind-                    pEta = maybeToList $ (\x -> if x then text "eta-equality" else text "no-eta-equality") <$> eta-                    pCon = maybeToList $ (text "constructor" <+>) . pretty <$> fst <$> con-            Infix f xs  ->-                pretty f <+> (fsep $ punctuate comma $ map pretty xs)-            Syntax n xs -> text "syntax" <+> pretty n <+> text "..."-            PatternSyn _ n as p -> text "pattern" <+> pretty n <+> fsep (map pretty as)-                                     <+> text "=" <+> pretty p-            Mutual _ ds     -> namedBlock "mutual" 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-            Module _ x tel ds ->-                hsep [ text "module"-                     , pretty x-                     , fcat (map pretty tel)-                     , text "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 <+> text "module" <+> pretty x <+> fcat (map pretty tel)-                    , nest 2 $ text "=" <+> pretty e <+> pretty i-                    ]-            ModuleMacro _ x (RecordModuleIFS _ rec) open i ->-                sep [ pretty open <+> text "module" <+> pretty x-                    , nest 2 $ text "=" <+> pretty rec <+> text "{{...}}"-                    ]-            Open _ x i  -> hsep [ text "open", pretty x, pretty i ]-            Import _ x rn open i   ->-                hsep [ pretty open, text "import", pretty x, as rn, pretty i ]-                where-                    as Nothing  = empty-                    as (Just x) = text "as" <+> pretty (asName x)-            UnquoteDecl _ xs t ->-              sep [ text "unquoteDecl" <+> fsep (map pretty xs) <+> text "=", nest 2 $ pretty t ]-            UnquoteDef _ xs t ->-              sep [ text "unquoteDef" <+> fsep (map pretty xs) <+> text "=", nest 2 $ pretty t ]-            Pragma pr   -> sep [ text "{-#" <+> pretty pr, text "#-}" ]-        where-            namedBlock s ds =-                sep [ text s-                    , nest 2 $ vcat $ map pretty ds-                    ]+        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)+                  ]+          , 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)+  Constructor n inst -> hsep [ pInst, "constructor", pretty n ] where+    pInst = case inst of+      InstanceDef{} -> "instance"+      NotInstanceDef{} -> empty+  Eta eta -> pHasEta0 (rangedThing eta)+  PatternOrCopattern{} -> "pattern"++pRecord+  :: Erased+  -> Name+  -> [RecordDirective]+  -> [LamBinding]+  -> Maybe Expr+  -> [Declaration]+  -> Doc+pRecord erased x directives tel me ds = vcat+    [ sep+      [ hsep  [ "record"+              , prettyErased erased (pretty x)+              , fsep (map pretty tel)+              ]+      , nest 2 $ pType me+      ]+    , nest 2 $ vcat $ concat+      [ map pretty directives+      , map pretty ds+      ]+    ]+  where pType (Just e) = hsep+                [ ":"+                , pretty e+                , "where"+                ]+        pType Nothing  =+                  "where"+ instance Pretty OpenShortHand where-    pretty DoOpen = text "open"+    pretty DoOpen = "open"     pretty DontOpen = empty  instance Pretty Pragma where-    pretty (OptionsPragma _ opts) = fsep $ map text $ "OPTIONS" : opts-    pretty (BuiltinPragma _ b x)  = hsep [ text "BUILTIN", text b, pretty x ]-    pretty (RewritePragma _ xs)    =-      hsep [ text "REWRITE", hsep $ map pretty xs ]-    pretty (CompiledPragma _ x hs) =-      hsep [ text "COMPILED", pretty x, text hs ]-    pretty (CompiledExportPragma _ x hs) =-      hsep [ text "COMPILED_EXPORT", pretty x, text hs ]-    pretty (CompiledTypePragma _ x hs) =-      hsep [ text "COMPILED_TYPE", pretty x, text hs ]-    pretty (CompiledDeclareDataPragma _ x hs) =-      hsep [ text "COMPILED_DECLARE_DATA", pretty x, text hs ]-    pretty (CompiledDataPragma _ x hs hcs) =-      hsep $ [text "COMPILED_DATA", pretty x] ++ map text (hs : hcs)-    pretty (CompiledEpicPragma _ x e) =-      hsep [ text "COMPILED_EPIC", pretty x, text e ]-    pretty (CompiledJSPragma _ x e) =-      hsep [ text "COMPILED_JS", pretty x, text e ]-    pretty (CompiledUHCPragma _ x e) =-      hsep [ text "COMPILED_UHC", pretty x, text e ]-    pretty (CompiledDataUHCPragma _ x crd crcs) =-      hsep $ [ text "COMPILED_DATA_UHC", pretty x] ++ map text (crd : crcs)-    pretty (HaskellCodePragma _ s) =-      vcat (text "HASKELL" : map text (lines s))+    pretty (OptionsPragma _ opts)  = fsep $ map text $ "OPTIONS" : opts+    pretty (BuiltinPragma _ b x)   = hsep [ "BUILTIN", text (rangedThing b), pretty x ]+    pretty (RewritePragma _ _ xs)    =+      hsep [ "REWRITE", hsep $ map pretty xs ]+    pretty (CompilePragma _ b x e) =+      hsep [ "COMPILE", pretty (rangedThing b), pretty x, textNonEmpty e ]+    pretty (ForeignPragma _ b s) =+      vcat $ hsep [ "FOREIGN", pretty (rangedThing b) ] : map text (lines s)     pretty (StaticPragma _ i) =-      hsep $ [text "STATIC", pretty i]-    pretty (InlinePragma _ i) =-      hsep $ [text "INLINE", pretty i]-    pretty (ImportPragma _ i) =-      hsep $ [text "IMPORT", text i]-    pretty (ImportUHCPragma _ i) =-      hsep $ [text "IMPORT_UHC", text i]-    pretty (ImpossiblePragma _) =-      hsep $ [text "IMPOSSIBLE"]+      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) =+      hsep $ ["IMPOSSIBLE"] ++ map text strs+    pretty (EtaPragma _ x) =+      hsep $ ["ETA", pretty x]     pretty (TerminationCheckPragma _ tc) =       case tc of         TerminationCheck       -> __IMPOSSIBLE__-        NoTerminationCheck     -> text "NO_TERMINATION_CHECK"-        NonTerminating         -> text "NON_TERMINATING"-        Terminating            -> text "TERMINATING"-        TerminationMeasure _ x -> hsep $ [text "MEASURE", pretty x]-    pretty (CatchallPragma _) = text "CATCHALL"-    pretty (DisplayPragma _ lhs rhs) = text "DISPLAY" <+> sep [ pretty lhs <+> text "=", nest 2 $ pretty rhs ]-    pretty (NoPositivityCheckPragma _) = text "NO_POSITIVITY_CHECK"+        NoTerminationCheck     -> "NO_TERMINATION_CHECK"+        NonTerminating         -> "NON_TERMINATING"+        Terminating            -> "TERMINATING"+        TerminationMeasure _ x -> hsep $ ["MEASURE", pretty x]+    pretty (NoCoverageCheckPragma _) = "NON_COVERING"+    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 (text "NO_POSITIVITY_CHECK" : pretty q : map pretty occs)--instance Pretty Fixity where-    pretty (Fixity _ Unrelated   _)   = __IMPOSSIBLE__-    pretty (Fixity _ (Related n) ass) = text s <+> text (show n)-      where-      s = case ass of-            LeftAssoc  -> "infixl"-            RightAssoc -> "infixr"-            NonAssoc   -> "infix"--instance Pretty Occurrence where-  pretty Unused    = text "_"-  pretty Mixed     = text "*"-  pretty JustNeg   = text "-"-  pretty JustPos   = text "+"-  pretty StrictPos = text "++"--  -- No syntax has been assigned to GuardPos.--  pretty GuardPos  = __IMPOSSIBLE__+      hsep ("POLARITY" : pretty q : map pretty occs)+    pretty (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK"+    pretty (OverlapPragma _ x m) = hsep [pretty m, pretty x] -instance Pretty GenPart where-    pretty (IdPart x)   = text 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 -instance Pretty Notation where-    pretty = hcat . map pretty+    prettyList = hcat . map pretty  instance Pretty Fixity' where-    pretty (Fixity' fix nota _)-      | nota == noNotation = pretty fix-      | otherwise          = text "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 id $ prettyPrec p' e-      where p' | getHiding ai == NotHidden = p-               | otherwise                 = 0--instance Pretty e => Pretty (Named_ e) where-    prettyPrec p (Named Nothing e) = prettyPrec p e-    prettyPrec p (Named (Just s) e) = mparens (p > 0) $ sep [ text (rawNameToString $ rangedThing s) <+> text "=", pretty e ]--instance Pretty [Pattern] where-    pretty = fsep . map pretty+    pretty (Fixity' fix nota _range)+      | null nota = pretty fix+      | otherwise = "syntax" <+> pretty nota  instance Pretty Pattern where-    pretty p =-        case p of-            IdentP x        -> pretty x+    prettyList = fsep . map pretty+    pretty = \case+            IdentP _ x      -> pretty x             AppP p1 p2      -> sep [ pretty p1, nest 2 $ pretty p2 ]-            RawAppP _ ps    -> fsep $ map pretty ps-            OpAppP _ q _ ps -> fsep $ prettyOpApp q (fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps)+            RawAppP _ ps    -> fsep $ map pretty $ List2.toList 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 <> text "@" <> pretty p-            DotP _ _ p      -> text "." <> pretty p-            AbsurdP _       -> text "()"-            LitP l          -> pretty l-            QuoteP _        -> text "quote"-            RecP _ fs       -> sep [ text "record", bracesAndSemicolons (map pretty fs) ]+            AsP _ x p       -> pretty x <> "@" <> pretty p+            DotP _ _ p      -> "." <> pretty p+            AbsurdP _       -> "()"+            LitP _ l        -> pretty l+            QuoteP _        -> "quote"+            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 ::-  Pretty a => QName -> [NamedArg (MaybePlaceholder a)] -> [Doc]-prettyOpApp q es = merge [] $ prOp ms xs es+prettyOpApp :: forall a .+  Pretty a => Asp.Aspect -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc]+prettyOpApp asp q es = merge [] $ prOp ms xs $ List1.toList es   where-    ms = init (qnameParts q)+    -- ms: the module part of the name.+    ms = List1.init (qnameParts q)+    -- xs: the concrete name (alternation of @Id@ and @Hole@)     xs = case unqualify q of-           Name _ xs -> xs-           NoName{}  -> __IMPOSSIBLE__+           Name _ _ xs    -> List1.toList xs+           NoName{}       -> __IMPOSSIBLE__ -    prOp ms (Hole : xs) (e : es) = (pretty e, case namedArg e of-                                                Placeholder p -> Just p-                                                _             -> Nothing) :-                                   prOp ms xs es+    prOp :: [Name] -> [NamePart] -> [NamedArg (MaybePlaceholder a)] -> [(Doc, Maybe PositionInName)]+    prOp ms (Hole : xs) (e : es) =+      case namedArg e of+        Placeholder p   -> (qual ms $ pretty e, Just p) : prOp [] xs es+        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       = ( pretty (foldr Qual (QName (Name noRange $ [Id x])) ms)+    prOp ms (Id x : xs) es       = ( qual ms $ annotateAspect asp $ pretty $ simpleName x                                    , Nothing                                    ) : prOp [] xs es-    prOp _  []       []          = []+      -- Qualify the name part with the module.+      -- We then clear @ms@ such that the following name parts will not be qualified.+     prOp _  []       es          = map (\e -> (pretty e, Nothing)) es +    qual ms doc = hcat $ punctuate "." $ map pretty ms ++ [doc]+     -- Section underscores should be printed without surrounding     -- whitespace. This function takes care of that.     merge :: [Doc] -> [(Doc, Maybe PositionInName)] -> [Doc]@@ -581,33 +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 True  = text "public"-            public False = empty--            prettyHiding [] = empty-            prettyHiding xs = text "hiding" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)--            rename [] = empty-            rename xs = hsep [ text "renaming"-                             , parens $ fsep $ punctuate (text ";") $ map pr xs-                             ]--            pr r = hsep [ pretty (renFrom r), text "to", pretty (renTo r) ]--instance (Pretty a, Pretty b) => Pretty (Using' a b) where-    pretty UseEverything = empty-    pretty (Using xs)    =-        text "using" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)--instance (Pretty a, Pretty b) => Pretty (ImportedName' a b) where-    pretty (ImportedName x)     = pretty x-    pretty (ImportedModule x)   = text "module" <+> pretty x
+ src/full/Agda/Syntax/DoNotation.hs view
@@ -0,0 +1,151 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-|+    Desugaring for do-notation. Uses whatever `_>>=_` and `_>>_` happen to be+    in scope.++    Example:++    ```+      foo = do+        x ← m₁+        m₂+        just y ← m₃+          where nothing → m₄+        let z = t+        m₅+    ```+    desugars to+    ```+      foo =+        m₁ >>= λ x →+        m₂ >>+        m₃ >>= λ where+          just y → let z = t in m₅+          nothing → m₄+    ```+ -}+module Agda.Syntax.DoNotation (desugarDoNotation) where++import Prelude hiding (null)++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Concrete++import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Monad+import Agda.TypeChecking.Monad++import Agda.Utils.List1  ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Syntax.Common.Pretty ( prettyShow )++import Agda.Utils.Null+import Agda.Utils.Singleton++import Agda.Utils.Impossible++desugarDoNotation :: Range -> List1 DoStmt -> ScopeM Expr+desugarDoNotation r ss = do+  let qBind = QName $ simpleBinaryOperator ">>="+      qThen = QName $ simpleBinaryOperator ">>"+      isBind DoBind{} = True+      isBind _        = False+      isThen DoThen{} = True+      isThen _        = False+  -- Only check the operation we actually need. One could imagine to fall back+  -- on _>>=_ if _>>_ is not in scope, but if we are desugaring to _>>_ at all+  -- I think we should throw an error rather than silently switching to _>>=_.+  -- / Ulf+  mapM_ ensureInScope $ [qBind | any isBind ss] +++                        [qThen | any isThen $ List1.init ss] -- ignore the last 'DoThen'+  desugarDo qBind qThen ss++desugarDo :: QName -> QName -> List1 DoStmt -> ScopeM Expr+desugarDo qBind qThen = \case++  -- The last statement must be a DoThen.+  DoThen e        :| [] -> return e++  -- Or an absurd bind.+  DoBind r p e [] :| [] | Just (r', NotHidden) <- isAbsurdP p ->+    return $ appOp (setRange r qBind) e $ AbsurdLam r' NotHidden++  -- Otherwise, sorry.+  _ :| [] -> failure++  -- `DoThen` and `DoLet` are easy.+  DoThen e   :| ss -> appOp qThen e   <$> desugarDo0 ss+  DoLet r ds :| ss -> Let r ds . Just <$> desugarDo0 ss++  -- `DoBind` requires more work since we want to generate plain lambdas when possible.+  DoBind r p e [] :| ss | Just x <- singleName p -> do+    -- In this case we have a single name in the bind pattern and no where clauses.+    -- It could still be a pattern bind though (for instance, `refl ← pure eq`), so+    -- to figure out which one to use we look up the name in the scope; if it's a+    -- constructor or pattern synonym we desugar to a pattern lambda.+    res <- resolveName (QName x)+    let isMatch = case res of+          ConstructorName{}   -> True+          PatternSynResName{} -> True+          _                   -> False+    rest <- desugarDo0 ss+    if isMatch then return $ matchingBind qBind r p e rest []+               else return $ nonMatchingBind qBind r x e rest++  -- If there are @where@ clauses we have to desugar to a pattern lambda.+  DoBind r p e cs :| ss -> do+    rest <- desugarDo0 ss+    return $ matchingBind qBind r p e rest cs++  where+  desugarDo0 :: [DoStmt] -> ScopeM Expr+  desugarDo0 ss = List1.ifNull ss failure $ desugarDo qBind qThen++  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+  _ -> Nothing++matchingBind :: QName -> Range -> Pattern -> Expr -> Expr -> [LamClause] -> Expr+matchingBind qBind r p e body cs =+  appOp (setRange r qBind) e             -- Set the range of the lambda to that of the+    $ ExtendedLam (getRange cs)          -- where-clauses to make highlighting of overlapping+        defaultErased                    -- patterns not highlight the rest of the do-block.+    $ fmap addParens (mainClause :| cs)+  where+    mainClause = LamClause { lamLHS      = [p]+                           , lamRHS      = RHS body+                           , lamCatchall = empty }++    -- Add parens to left-hand sides.+    addParens c = c { lamLHS = addP (lamLHS c) }+      where+      addP []           = __IMPOSSIBLE__+      addP pps@(p : ps) = [ParenP (getRange pps) $ rawAppP $ p :| ps ]++nonMatchingBind :: QName -> Range -> Name -> Expr -> Expr -> Expr+nonMatchingBind qBind r x e body =+    appOp (setRange r qBind) e $ Lam (getRange (x, body)) (singleton bx) body+  where bx = DomainFree $ defaultNamedArg $ mkBinder_ x++appOp :: QName -> Expr -> Expr -> Expr+appOp q e1 e2 = app (Ident q) [par e1, par e2]+  where+    par e = Paren (getRange e) e  -- Add parens to get the right precedence context (#3152)+    app e es = foldl (\ e1 e2 -> App (getRange (e1, e2)) e1 (defaultNamedArg e2)) e es++ensureInScope :: QName -> ScopeM ()+ensureInScope q = do+  r <- resolveName q+  case r of+    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,360 +1,154 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wunused-imports #-}  {-| Definitions for fixity, precedence levels, and declared syntax. -} module Agda.Syntax.Fixity where -import Prelude hiding (concatMap)- import Control.DeepSeq -import Data.Foldable-import Data.Function-import qualified Data.List as List-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Traversable-import Data.Typeable (Typeable)+import GHC.Generics (Generic)  import Agda.Syntax.Position import Agda.Syntax.Common-import qualified Agda.Syntax.Abstract.Name as A-import Agda.Syntax.Concrete.Name-import Agda.Syntax.Notation -import Agda.Utils.Lens-import Agda.Utils.List+import Agda.Syntax.Common.Pretty -#include "undefined.h" import Agda.Utils.Impossible --- * 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 (Typeable, Show)--instance Eq Fixity' where-  Fixity' f n _ == Fixity' f' n' _ = f == f' && n == n'+-- The Fixity data type is now defined in Agda.Syntax.Common.+-- Andreas, 2019-08-16, issue #1346  -- | Decorating something with @Fixity'@. data ThingWithFixity x = ThingWithFixity x Fixity'-  deriving (Functor, Foldable, Traversable, Typeable, Show)---- | All the notation information related to a name.-data NewNotation = NewNotation-  { notaName  :: QName-  , notaNames :: Set A.Name-    -- ^ The names the syntax and/or fixity belong to.-    ---    -- Invariant: The set is non-empty. Every name in the list matches-    -- 'notaName'.-  , notaFixity :: Fixity-    -- ^ Associativity and precedence (fixity) of the names.-  , notation :: Notation-    -- ^ Syntax associated with the names.-  , notaIsOperator :: Bool-    -- ^ True if the notation comes from an operator (rather than a-    -- syntax declaration).-  } deriving (Typeable, Show)---- | If an operator has no specific notation, then it is computed from--- its name.-namesToNotation :: QName -> A.Name -> NewNotation-namesToNotation q n = NewNotation-  { notaName       = q-  , notaNames      = Set.singleton n-  , notaFixity     = f-  , notation       = if null syn then syntaxOf (unqualify q) else syn-  , notaIsOperator = null syn-  }-  where Fixity' f syn _ = A.nameFixity n---- | Replace 'noFixity' by 'defaultFixity'.-useDefaultFixity :: NewNotation -> NewNotation-useDefaultFixity n-  | notaFixity n == noFixity = n { notaFixity = defaultFixity }-  | otherwise                = n---- | Return the 'IdPart's of a notation, the first part qualified,---   the other parts unqualified.---   This allows for qualified use of operators, e.g.,---   @M.for x ∈ xs return e@, or @x ℕ.+ y@.-notationNames :: NewNotation -> [QName]-notationNames (NewNotation q _ _ parts _) =-  zipWith ($) (reQualify : repeat QName) [Name noRange [Id x] | IdPart x <- parts ]-  where-    -- The qualification of @q@.-    modules     = init (qnameParts q)-    -- Putting the qualification onto @x@.-    reQualify x = List.foldr Qual (QName x) modules---- | Create a 'Notation' (without binders) from a concrete 'Name'.---   Does the obvious thing:---   'Hole's become 'NormalHole's, 'Id's become 'IdParts'.---   If 'Name' has no 'Hole's, it returns 'noNotation'.-syntaxOf :: Name -> Notation-syntaxOf (NoName _ _) = noNotation-syntaxOf (Name _ [_]) = noNotation-syntaxOf (Name _ xs)  = mkSyn 0 xs-  where-    -- Turn a concrete name into a Notation,-    -- numbering the holes from left to right.-    -- Result will have no 'BindingHole's.-    mkSyn :: Int -> [NamePart] -> Notation-    mkSyn n []          = []-    mkSyn n (Hole : xs) = NormalHole (defaultNamedArg n) : mkSyn (1 + n) xs-    mkSyn n (Id x : xs) = IdPart x : mkSyn n xs--noFixity' :: Fixity'-noFixity' = Fixity' noFixity noNotation noRange---- | Merges 'NewNotation's that have the same precedence level and--- notation, with two exceptions:------ * Operators and notations coming from syntax declarations are kept---   separate.------ * If /all/ instances of a given 'NewNotation' have the same---   precedence level or are \"unrelated\", then they are merged. They---   get the given precedence level, if any, and otherwise they become---   unrelated (but related to each other).------ If 'NewNotation's that are merged have distinct associativities,--- then they get 'NonAssoc' as their associativity.------ Precondition: No 'A.Name' may occur in more than one list element.--- 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-                 ))-  where-  groupIfLevelsMatch :: [NewNotation] -> [[NewNotation]]-  groupIfLevelsMatch []         = __IMPOSSIBLE__-  groupIfLevelsMatch ns@(n : _) =-    if allEqual (map fixityLevel related)-    then [sameAssoc (sameLevel ns)]-    else map (: []) ns-    where-    -- Fixities of operators whose precedence level is not Unrelated.-    related = mapMaybe (\f -> case fixityLevel f of-                                Unrelated  -> Nothing-                                Related {} -> Just f)-                       (map notaFixity ns)--    -- Precondition: All related operators have the same precedence-    -- level.-    ---    -- Gives all unrelated operators the same level.-    sameLevel = map (set (_notaFixity . _fixityLevel) level)-      where-      level = case related of-        f : _ -> fixityLevel f-        []    -> Unrelated--    -- 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)-      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 }---- * Sections---- | Sections, as well as non-sectioned operators.--data NotationSection = NotationSection-  { sectNotation  :: NewNotation-  , sectKind      :: NotationKind-    -- ^ For non-sectioned operators this should match the notation's-    -- 'notationKind'.-  , sectLevel     :: Maybe PrecedenceLevel-    -- ^ Effective precedence level. 'Nothing' for closed notations.-  , sectIsSection :: Bool-    -- ^ 'False' for non-sectioned operators.-  }-  deriving Show---- | Converts a notation to a (non-)section.--noSection :: NewNotation -> NotationSection-noSection n = NotationSection-  { sectNotation  = n-  , sectKind      = notationKind (notation n)-  , sectLevel     = Just (fixityLevel (notaFixity n))-  , sectIsSection = False-  }+  deriving (Functor, Foldable, Traversable, Show) --- * Fixity+instance LensFixity' (ThingWithFixity a) where+  lensFixity' f (ThingWithFixity a fix') = ThingWithFixity a <$> f fix' --- | Precedence levels for operators.+instance LensFixity (ThingWithFixity a) where+  lensFixity = lensFixity' . lensFixity -data PrecedenceLevel-  = Unrelated-    -- ^ No fixity declared.-  | Related !Integer-    -- ^ Fixity level declared as the @Integer@.-  deriving (Eq, Ord, Show, Typeable)+-- | Do we prefer parens around arguments like @λ x → x@ or not?+--   See 'lamBrackets'.+data ParenPreference = PreferParen | PreferParenless+  deriving (Eq, Ord, Show, Generic) --- | Associativity.+instance NFData ParenPreference -data Associativity = NonAssoc | LeftAssoc | RightAssoc-   deriving (Eq, Ord, Show, Typeable)+preferParen :: ParenPreference -> Bool+preferParen p = PreferParen == p --- | Fixity of operators.+preferParenless :: ParenPreference -> Bool+preferParenless p = PreferParenless == p -data Fixity = Fixity-  { fixityRange :: Range-    -- ^ Range of the whole fixity declaration.-  , fixityLevel :: !PrecedenceLevel-  , fixityAssoc :: !Associativity-  }-  deriving (Typeable, Show)+-- * Precendence -instance Eq Fixity where-  f1 == f2 = compare f1 f2 == EQ+-- | Precedence is associated with a context.+data Precedence = TopCtx | FunctionSpaceDomainCtx+                | LeftOperandCtx Fixity | RightOperandCtx Fixity ParenPreference+                | FunctionCtx | ArgumentCtx ParenPreference | InsideOperandCtx+                | WithFunCtx | WithArgCtx | DotPatternCtx+    deriving (Show, Eq, Generic) -instance Ord Fixity where-  compare = compare `on` (\f -> (fixityLevel f, fixityAssoc f))+instance NFData Precedence --- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty+instance Pretty Precedence where+  pretty = text . show -noFixity :: Fixity-noFixity = Fixity noRange Unrelated NonAssoc+-- | When printing we keep track of a stack of precedences in order to be able+--   to decide whether it's safe to leave out parens around lambdas. An empty+--   stack is equivalent to `TopCtx`. Invariant: `notElem TopCtx`.+type PrecedenceStack = [Precedence] -defaultFixity :: Fixity-defaultFixity = Fixity noRange (Related 20) NonAssoc+pushPrecedence :: Precedence -> PrecedenceStack -> PrecedenceStack+pushPrecedence TopCtx _  = []+pushPrecedence p      ps = p : ps --- * Precendence+headPrecedence :: PrecedenceStack -> Precedence+headPrecedence []      = TopCtx+headPrecedence (p : _) = p --- | Precedence is associated with a context.-data Precedence = TopCtx | FunctionSpaceDomainCtx-                | LeftOperandCtx Fixity | RightOperandCtx Fixity-                | FunctionCtx | ArgumentCtx | InsideOperandCtx-                | WithFunCtx | WithArgCtx | DotPatternCtx-    deriving (Show, Typeable, Eq)+-- | Argument context preferring parens.+argumentCtx_ :: Precedence+argumentCtx_ = ArgumentCtx PreferParen --- | The precedence corresponding to a possibly hidden argument.-hiddenArgumentCtx :: Hiding -> Precedence-hiddenArgumentCtx NotHidden = ArgumentCtx-hiddenArgumentCtx Hidden    = TopCtx-hiddenArgumentCtx Instance  = TopCtx+-- | Do we need to bracket an operator application of the given fixity+--   in a context with the given precedence.+opBrackets :: Fixity -> PrecedenceStack -> Bool+opBrackets = opBrackets' False  -- | Do we need to bracket an operator application of the given fixity --   in a context with the given precedence.-opBrackets :: Fixity -> Precedence -> Bool-opBrackets                   (Fixity _ (Related n1) LeftAssoc)-           (LeftOperandCtx   (Fixity _ (Related n2) LeftAssoc))  | n1 >= n2 = False-opBrackets                   (Fixity _ (Related n1) RightAssoc)-           (RightOperandCtx  (Fixity _ (Related n2) RightAssoc)) | n1 >= n2 = False-opBrackets f1-           (LeftOperandCtx  f2) | Related f1 <- fixityLevel f1-                                , Related f2 <- fixityLevel f2-                                , f1 > f2 = False-opBrackets f1-           (RightOperandCtx f2) | Related f1 <- fixityLevel f1-                                , Related f2 <- fixityLevel f2-                                , f1 > f2 = False-opBrackets _ TopCtx = False-opBrackets _ FunctionSpaceDomainCtx = False-opBrackets _ InsideOperandCtx       = False-opBrackets _ WithArgCtx             = False-opBrackets _ WithFunCtx             = False-opBrackets _ _                      = True+opBrackets' :: Bool ->   -- Is the last argument a parenless lambda?+               Fixity -> PrecedenceStack -> Bool+opBrackets' isLam f ps = brack f (headPrecedence ps)+  where+    false = isLam && lamBrackets ps -- require more parens for `e >>= λ x → e₁` than `e >>= e₁`+    brack                        (Fixity _ (Related n1) LeftAssoc)+               (LeftOperandCtx   (Fixity _ (Related n2) LeftAssoc))  | n1 >= n2 = false+    brack                        (Fixity _ (Related n1) RightAssoc)+               (RightOperandCtx  (Fixity _ (Related n2) RightAssoc) _) | n1 >= n2 = false+    brack f1   (LeftOperandCtx  f2) | Related f1 <- fixityLevel f1+                                    , Related f2 <- fixityLevel f2+                                    , f1 > f2 = false+    brack f1   (RightOperandCtx f2 _) | Related f1 <- fixityLevel f1+                                    , Related f2 <- fixityLevel f2+                                    , f1 > f2 = false+    brack _ TopCtx                 = false+    brack _ FunctionSpaceDomainCtx = false+    brack _ InsideOperandCtx       = false+    brack _ WithArgCtx             = false+    brack _ WithFunCtx             = false+    brack _ _                      = True  -- | Does a lambda-like thing (lambda, let or pi) need brackets in the -- given context? A peculiar thing with lambdas is that they don't--- need brackets in certain right operand contexts. However, we insert--- brackets anyway, for the following reasons:------ * Clarity.------ * Sometimes brackets are needed. Example: @m₁ >>= (λ x → x) >>= m₂@---   (here @_>>=_@ is left associative).-lamBrackets :: Precedence -> Bool-lamBrackets TopCtx = False-lamBrackets _      = True+-- need brackets in certain right operand contexts. To decide we need to look+-- at the stack of precedences and not just the current precedence.+-- Example: @m₁ >>= (λ x → x) >>= m₂@ (for @_>>=_@ left associative).+lamBrackets :: PrecedenceStack -> Bool+lamBrackets []       = False+lamBrackets (p : ps) = case p of+  TopCtx                 -> __IMPOSSIBLE__+  ArgumentCtx pref       -> preferParen pref || lamBrackets ps+  RightOperandCtx _ pref -> preferParen pref || lamBrackets ps+  FunctionSpaceDomainCtx -> True+  LeftOperandCtx{}       -> True+  FunctionCtx            -> True+  InsideOperandCtx       -> True+  WithFunCtx             -> True+  WithArgCtx             -> True+  DotPatternCtx          -> True  -- | Does a function application need brackets?-appBrackets :: Precedence -> Bool-appBrackets ArgumentCtx   = True-appBrackets DotPatternCtx = True-appBrackets _             = False+appBrackets :: PrecedenceStack -> Bool+appBrackets = appBrackets' False +-- | Does a function application need brackets?+appBrackets' :: Bool ->   -- Is the argument of the application a parenless lambda?+                PrecedenceStack -> Bool+appBrackets' isLam ps = brack (headPrecedence ps)+  where+    brack ArgumentCtx{} = True+    brack DotPatternCtx = True+    brack _             = isLam && lamBrackets ps -- allow e + e₁ λ x → e₂+ -- | Does a with application need brackets?-withAppBrackets :: Precedence -> Bool-withAppBrackets TopCtx                 = False-withAppBrackets FunctionSpaceDomainCtx = False-withAppBrackets WithFunCtx             = False-withAppBrackets _                      = True+withAppBrackets :: PrecedenceStack -> Bool+withAppBrackets = brack . headPrecedence+  where+    brack TopCtx                 = False+    brack FunctionSpaceDomainCtx = False+    brack WithFunCtx             = False+    brack _                      = True  -- | Does a function space need brackets?-piBrackets :: Precedence -> Bool-piBrackets TopCtx   = False-piBrackets _        = True--roundFixBrackets :: Precedence -> Bool-roundFixBrackets DotPatternCtx = True-roundFixBrackets _ = False--instance HasRange Fixity where-  getRange = fixityRange--instance KillRange Fixity where-  killRange f = f { fixityRange = noRange }+piBrackets :: PrecedenceStack -> Bool+piBrackets [] = False+piBrackets _  = True -instance KillRange Fixity' where-  killRange (Fixity' f n r) = killRange3 Fixity' f n r+roundFixBrackets :: PrecedenceStack -> Bool+roundFixBrackets ps = DotPatternCtx == headPrecedence ps  instance KillRange x => KillRange (ThingWithFixity x) where   killRange (ThingWithFixity c f) = ThingWithFixity (killRange c) f---- * Some lenses--_notaFixity :: Lens' Fixity NewNotation-_notaFixity f r = f (notaFixity r) <&> \x -> r { notaFixity = x }--_fixityAssoc :: Lens' Associativity Fixity-_fixityAssoc f r = f (fixityAssoc r) <&> \x -> r { fixityAssoc = x }--_fixityLevel :: Lens' PrecedenceLevel Fixity-_fixityLevel f r = f (fixityLevel r) <&> \x -> r { fixityLevel = x }----------------------------------------------------------------------------- * Printing----------------------------------------------------------------------------- deriving instance Show Fixity'----------------------------------------------------------------------------- * NFData instances---------------------------------------------------------------------------instance NFData Fixity' where-  rnf (Fixity' _ a _) = rnf a---- | Ranges are not forced.--instance NFData Fixity where-  rnf (Fixity _ _ _) = ()
− src/full/Agda/Syntax/Fixity.hs-boot 
@@ -1,13 +0,0 @@-module Agda.Syntax.Fixity where--import Control.DeepSeq (NFData)--import Agda.Syntax.Position ( KillRange )--data Fixity'--instance KillRange Fixity'-instance NFData Fixity'-instance Show Fixity'--noFixity' :: Fixity'
src/full/Agda/Syntax/IdiomBrackets.hs view
@@ -1,48 +1,69 @@-module Agda.Syntax.IdiomBrackets (parseIdiomBrackets) where+module Agda.Syntax.IdiomBrackets (parseIdiomBracketsSeq) where -import Control.Applicative import Control.Monad  import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Concrete import Agda.Syntax.Concrete.Operators+import Agda.Syntax.Concrete.Pretty ( leftIdiomBrkt, rightIdiomBrkt ) +import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad +import Agda.Utils.List1  ( List1, pattern (:|), (<|) )+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Singleton++parseIdiomBracketsSeq :: Range -> [Expr] -> ScopeM Expr+parseIdiomBracketsSeq r es = do+  let qEmpty = QName $ simpleName "empty"+      qPlus  = QName $ simpleBinaryOperator "<|>"+      ePlus a b = App r (App r (Ident qPlus) (defaultNamedArg a)) (defaultNamedArg b)+  case es of+    []       -> ensureInScope qEmpty >> return (Ident qEmpty)+    [e]      -> parseIdiomBrackets r e+    es@(_:_) -> do+      ensureInScope qPlus+      es' <- mapM (parseIdiomBrackets r) es+      return $ foldr1 ePlus es'+ parseIdiomBrackets :: Range -> Expr -> ScopeM Expr parseIdiomBrackets r e = do-  let qPure = QName $ Name noRange [Id "pure"]-      qAp   = QName $ Name noRange [Hole, Id "<*>", Hole]-      ePure = App r (Ident qPure) . defaultNamedArg+  let qPure = QName $ simpleName "pure"+      qAp   = QName $ simpleBinaryOperator "<*>"+      ePure   = App r (Ident qPure) . defaultNamedArg       eAp a b = App r (App r (Ident qAp) (defaultNamedArg a)) (defaultNamedArg b)   mapM_ ensureInScope [qPure, qAp]   case e of     RawApp _ es -> do-      e : es <- appViewM =<< parseApplication es+      e :| es <- appViewM =<< parseApplication es       return $ foldl eAp (ePure e) es     _ -> return $ ePure e -appViewM :: Expr -> ScopeM [Expr]-appViewM e =-  case e of-    App{}           -> let AppView e' es = appView e in (e' :) <$> mapM onlyVisible es-    OpApp _ op _ es -> (Ident op :) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es-    _               -> return [e]+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+    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"+      | defaultNamedArg () == fmap (() <$) a = return $ namedArg a+      | 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 $ show q ++ " needs to be in scope to use idiom brackets (| ... |)"+    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
@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-}  {-| An info object contains additional information about a piece of abstract     syntax that isn't part of the actual syntax. For instance, it might contain@@ -12,50 +9,87 @@  import Prelude hiding (null) -import Data.Typeable (Typeable)+import Control.DeepSeq +import Data.Semigroup (Semigroup)++import GHC.Generics (Generic)+ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Common 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.Function+import Agda.Utils.Functor import Agda.Utils.Null  {--------------------------------------------------------------------------     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 (Typeable, Show, Eq)+  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 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 (Typeable, Show, Eq, Null)+  deriving (Show, Eq, Null, NFData)  exprNoRange :: ExprInfo exprNoRange = ExprRange noRange@@ -67,6 +101,41 @@   killRange (ExprRange r) = exprNoRange  {--------------------------------------------------------------------------+    Application information+ --------------------------------------------------------------------------}++-- | Information about application+data AppInfo = AppInfo+  { appRange  :: Range+  , appOrigin :: Origin+  , appParens :: ParenPreference -- ^ Do we prefer a lambda argument with or without parens?+  }+  deriving (Show, Eq, Ord, Generic)++-- | Default is system inserted and prefer parens.+defaultAppInfo :: Range -> AppInfo+defaultAppInfo r = AppInfo{ appRange = r, appOrigin = Inserted, appParens = PreferParen }++-- | `AppInfo` with no range information.+defaultAppInfo_ :: AppInfo+defaultAppInfo_ = defaultAppInfo noRange++instance Null AppInfo where+  empty = defaultAppInfo_++instance HasRange AppInfo where+  getRange = appRange++instance KillRange AppInfo where+  killRange (AppInfo r o p) = AppInfo (killRange r) o p++instance LensOrigin AppInfo where+  getOrigin = appOrigin+  mapOrigin f i = i { appOrigin = f (appOrigin i) }++instance NFData AppInfo++{--------------------------------------------------------------------------     Module information  --------------------------------------------------------------------------} @@ -81,9 +150,7 @@   , minfoDirective :: Maybe ImportDirective     -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'.   }-  deriving (Typeable, Eq)--deriving instance (Show OpenShortHand, Show ImportDirective) => Show ModuleInfo+  deriving (Eq, Show, Generic)  instance HasRange ModuleInfo where   getRange = minfoRange@@ -94,12 +161,14 @@ instance KillRange ModuleInfo where   killRange m = m { minfoRange = noRange } +instance NFData ModuleInfo+ --------------------------------------------------------------------------- -- Let info ---------------------------------------------------------------------------  newtype LetInfo = LetRange Range-  deriving (Typeable, Show, Eq, Null)+  deriving (Show, Eq, Null, NFData)  instance HasRange LetInfo where   getRange (LetRange r)   = r@@ -111,32 +180,49 @@     Definition information (declarations that actually define something)  --------------------------------------------------------------------------} -data DefInfo = DefInfo+data DefInfo' t = DefInfo   { defFixity   :: Fixity'   , defAccess   :: Access   , defAbstract :: IsAbstract+  , defOpaque   :: IsOpaque   , defInstance :: IsInstance   , defMacro    :: IsMacro   , defInfo     :: DeclInfo+  , defTactic   :: TacticAttribute' t   }-  deriving (Typeable, Show, Eq)+  deriving (Show, Eq, Generic) -mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo-mkDefInfo x f a ab r = DefInfo f a ab NotInstanceDef NotMacroDef (DeclInfo x r)+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-mkDefInfoInstance x f a ab i m r = DefInfo f a ab i m (DeclInfo x r)+mkDefInfoInstance :: Name -> Fixity' -> Access -> IsAbstract -> IsInstance -> IsMacro -> Range -> DefInfo' t+mkDefInfoInstance x f a ab i m r = DefInfo f a ab TransparentDef i m (DeclInfo x r) empty -instance HasRange DefInfo where+instance HasRange (DefInfo' t) where   getRange = getRange . defInfo -instance SetRange DefInfo where+instance SetRange (DefInfo' t) where   setRange r i = i { defInfo = setRange r (defInfo i) } -instance KillRange DefInfo where-  killRange i = i { defInfo = killRange $ defInfo i }+instance KillRange t => KillRange (DefInfo' t) where+  killRange i = i { defInfo   = killRange $ defInfo i,+                    defTactic = killRange $ defTactic i } +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)+ {--------------------------------------------------------------------------     General declaration information  --------------------------------------------------------------------------}@@ -145,7 +231,7 @@   { declName  :: Name   , declRange :: Range   }-  deriving (Typeable, Show, Eq)+  deriving (Show, Eq, Generic)  instance HasRange DeclInfo where   getRange = declRange@@ -156,20 +242,23 @@ instance KillRange DeclInfo where   killRange i = i { declRange = noRange } +instance NFData DeclInfo+ {--------------------------------------------------------------------------     Mutual block information  --------------------------------------------------------------------------}  data MutualInfo = MutualInfo-  { mutualTermCheck       :: TerminationCheck Name-  , mutualPositivityCheck :: PositivityCheck-  , mutualRange           :: Range+  { mutualTerminationCheck :: TerminationCheck Name+  , mutualCoverageCheck    :: CoverageCheck+  , mutualPositivityCheck  :: PositivityCheck+  , mutualRange            :: Range   }-  deriving (Typeable, Show, Eq)+  deriving (Show, Eq, Generic)  -- | Default value for 'MutualInfo'. instance Null MutualInfo where-  empty = MutualInfo TerminationCheck True noRange+  empty = MutualInfo TerminationCheck YesCoverageCheck YesPositivityCheck noRange  instance HasRange MutualInfo where   getRange = mutualRange@@ -177,19 +266,29 @@ instance KillRange MutualInfo where   killRange i = i { mutualRange = noRange } +instance NFData MutualInfo+ {--------------------------------------------------------------------------     Left hand side information  --------------------------------------------------------------------------} -newtype LHSInfo = LHSRange Range-  deriving (Typeable, Show, Eq, Null)+data LHSInfo = LHSInfo+  { lhsRange    :: Range+  , lhsEllipsis :: ExpandedEllipsis+  } deriving (Show, Eq, Generic)  instance HasRange LHSInfo where-  getRange (LHSRange r) = r+  getRange (LHSInfo r _) = r  instance KillRange LHSInfo where-  killRange (LHSRange r) = LHSRange noRange+  killRange (LHSInfo r ell) = LHSInfo noRange ell +instance Null LHSInfo where+  null i = null (lhsRange i) && null (lhsEllipsis i)+  empty  = LHSInfo empty empty++instance NFData LHSInfo+ {--------------------------------------------------------------------------     Pattern information  --------------------------------------------------------------------------}@@ -197,7 +296,8 @@ -- | For a general pattern we remember the source code position. newtype PatInfo   = PatRange Range-  deriving (Typeable, Eq, Null, Show, HasRange, KillRange)+  deriving (Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,+            KillRange, NFData)  -- | Empty range for patterns. patNoRange :: PatInfo@@ -205,21 +305,29 @@  -- | Constructor pattern info. data ConPatInfo = ConPatInfo-  { patOrigin   :: ConOrigin+  { conPatOrigin   :: ConOrigin     -- ^ Does this pattern come form the eta-expansion of an implicit pattern?     ---  Or from a user written constructor or record pattern?-  , patInfo     :: PatInfo+  , conPatInfo     :: PatInfo+  , conPatLazy     :: ConPatLazy   }-  deriving (Typeable, Eq)--instance Show ConPatInfo where-  show (ConPatInfo po i) = applyWhen (po == ConOSystem) ("implicit " ++) $ show i+  deriving (Eq, Show, Generic)  instance HasRange ConPatInfo where-  getRange = getRange . patInfo+  getRange = getRange . conPatInfo  instance KillRange ConPatInfo where-  killRange (ConPatInfo b i) = ConPatInfo b $ killRange i+  killRange (ConPatInfo b i l) = ConPatInfo b (killRange i) l  instance SetRange ConPatInfo where-  setRange r (ConPatInfo b i) = ConPatInfo b $ PatRange r+  setRange r (ConPatInfo b i l) = ConPatInfo b (PatRange r) l++instance NFData ConPatInfo++-- | Has the constructor pattern a dotted (forced) constructor?+data ConPatLazy+  = ConPatLazy   -- ^ Dotted constructor.+  | ConPatEager  -- ^ Ordinary constructor.+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance NFData ConPatLazy
src/full/Agda/Syntax/Internal.hs view
@@ -1,1300 +1,1530 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell            #-}-#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif--module Agda.Syntax.Internal-    ( module Agda.Syntax.Internal-    , module Agda.Syntax.Abstract.Name-    , module Agda.Utils.Pointer-    , MetaId(..)-    ) where--import Prelude hiding (foldr, mapM, null)--import Control.Applicative hiding (empty)-import Control.Monad.Identity hiding (mapM)-import Control.DeepSeq--import Data.Foldable ( Foldable, foldMap )-import Data.Function-import qualified Data.List as List-import Data.Maybe-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Sum(..))---- base-4.7 defines the Num instance for Sum-#if !(MIN_VERSION_base(4,7,0))-import Data.Orphans             ()-#endif--import Data.Traversable-import Data.Typeable (Typeable)--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.Utils.Empty---- See Issue 1593.-#if !MIN_VERSION_transformers(0,4,1)-import Agda.Utils.Except ( Error(noMsg) )-#endif--import Agda.Utils.Functor-import Agda.Utils.Geniplate-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pointer-import Agda.Utils.Size-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Pretty hiding ((<>))-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible---- | Type of argument lists.----type Args       = [Arg Term]-type NamedArgs  = [NamedArg Term]---- | 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.-data ConHead = ConHead-  { conName      :: QName     -- ^ The name of the constructor.-  , conInductive :: Induction -- ^ Record constructors can be coinductive.-  , conFields    :: [QName]   -- ^ The name of the record fields.-                              --   Empty list for data constructors.-                              --   'Arg' is not needed here since it-                              --   is stored in the constructor args.-  } deriving (Typeable)--instance Eq ConHead where-  (==) = (==) `on` conName--instance Ord ConHead where-  (<=) = (<=) `on` conName--instance Show ConHead where-  show (ConHead c i fs) = show c ++ "(" ++ show i ++ ")" ++ show fs--instance HasRange ConHead where-  getRange = getRange . conName--instance SetRange ConHead where-  setRange r = mapConName (setRange r)--class LensConName a where-  getConName :: a -> QName-  setConName :: QName -> a -> a-  setConName = mapConName . const-  mapConName :: (QName -> QName) -> a -> a-  mapConName f a = setConName (f (getConName a)) a--instance LensConName ConHead where-  getConName = conName-  setConName c con = con { conName = c }----- | Raw values.------   @Def@ is used for both defined and undefined constants.---   Assume there is a type declaration and a definition for---     every constant, even if the definition is an empty---     list of clauses.----data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral-          | Lam ArgInfo (Abs Term)        -- ^ Terms are beta normal. Relevance is ignored-          | Lit Literal-          | Def QName Elims               -- ^ @f es@, possibly a delta/iota-redex-          | Con ConHead ConInfo Args      -- ^ @c vs@ or @record { fs = vs }@-          | Pi (Dom Type) (Abs Type)      -- ^ dependent or non-dependent function space-          | Sort Sort-          | Level Level-          | MetaV {-# UNPACK #-} !MetaId Elims-          | DontCare Term-            -- ^ Irrelevant stuff in relevant position, but created-            --   in an irrelevant context.  Basically, an internal-            --   version of the irrelevance axiom @.irrAx : .A -> A@.-          | Shared !(Ptr Term)-            -- ^ Explicit sharing-  deriving (Typeable, Show)--type ConInfo = ConOrigin---- | Eliminations, subsuming applications and projections.----data Elim' a-  = Apply (Arg a)         -- ^ Application.-  | Proj ProjOrigin QName -- ^ Projection.  'QName' is name of a record projection.-  deriving (Typeable, Show, Functor, Foldable, Traversable)--type Elim = Elim' Term-type Elims = [Elim]  -- ^ eliminations ordered left-to-right.---- | Names in binders and arguments.-type ArgName = String--argNameToString :: ArgName -> String-argNameToString = id--stringToArgName :: String -> ArgName-stringToArgName = id--appendArgNames :: ArgName -> ArgName -> ArgName-appendArgNames = (++)--nameToArgName :: Name -> ArgName-nameToArgName = stringToArgName . prettyShow---- | Binder.---   'Abs': The bound variable might appear in the body.---   'NoAbs' is pseudo-binder, it does not introduce a fresh variable,---      similar to the @const@ of Haskell.-data Abs a = Abs   { absName :: ArgName, unAbs :: a }-               -- ^ The body has (at least) one free variable.-               --   Danger: 'unAbs' doesn't shift variables properly-           | NoAbs { absName :: ArgName, unAbs :: a }-  deriving (Typeable, Functor, Foldable, Traversable)--instance Decoration Abs where-  traverseF f (Abs   x a) = Abs   x <$> f a-  traverseF f (NoAbs x a) = NoAbs x <$> f a---- | Types are terms with a sort annotation.----data Type' a = El { _getSort :: Sort, unEl :: a }-  deriving (Typeable, Show, Functor, Foldable, Traversable)--type Type = Type' Term--instance Decoration Type' where-  traverseF f (El s a) = El s <$> f a--class LensSort a where-  lensSort ::  Lens' Sort a-  getSort  :: a -> Sort-  getSort a = a ^. lensSort--instance LensSort (Type' a) where-  lensSort f (El s a) = f s <&> \ s' -> El s' a---- General instance leads to overlapping instances.--- instance (Decoration f, LensSort a) => LensSort (f a) where-instance LensSort a => LensSort (Dom a) where-  lensSort = traverseF . lensSort--instance LensSort a => LensSort (Abs a) where-  lensSort = traverseF . lensSort---- | Sequence of types. An argument of the first type is bound in later types---   and so on.-data Tele a = EmptyTel-            | ExtendTel a (Abs (Tele a))  -- ^ 'Abs' is never 'NoAbs'.-  deriving (Typeable, Show, Functor, Foldable, Traversable)--type Telescope = Tele (Dom Type)---- | A traversal for the names in a telescope.-mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a)-mapAbsNamesM f EmptyTel                  = pure EmptyTel-mapAbsNamesM f (ExtendTel a (  Abs x b)) = ExtendTel a <$> (  Abs <$> f x <*> mapAbsNamesM f b)-mapAbsNamesM f (ExtendTel a (NoAbs x b)) = ExtendTel a <$> (NoAbs <$> f x <*> mapAbsNamesM f b)-  -- Ulf, 2013-11-06: Last case is really impossible but I'd rather find out we-  --                  violated that invariant somewhere other than here.--mapAbsNames :: (ArgName -> ArgName) -> Tele a -> Tele a-mapAbsNames f = runIdentity . mapAbsNamesM (Identity . f)---- Ulf, 2013-11-06--- The record parameter is named "" inside the record module so we can avoid--- printing it (issue 208), but we don't want that to show up in the type of--- the functions in the module (issue 892). This function is used on the record--- module telescope before adding it to a type in--- TypeChecking.Monad.Signature.addConstant (to handle functions defined in--- record modules) and TypeChecking.Rules.Record.checkProjection (to handle--- record projections).-replaceEmptyName :: ArgName -> Tele a -> Tele a-replaceEmptyName x = mapAbsNames $ \ y -> if null y then x else y---- | Sorts.----data Sort-  = Type Level  -- ^ @Set ℓ@.-  | Prop        -- ^ Dummy sort.-  | Inf         -- ^ @Setω@.-  | SizeUniv    -- ^ @SizeUniv@, a sort inhabited by type @Size@.-  | DLub Sort (Abs Sort)-    -- ^ Dependent least upper bound.-    --   If the free variable occurs in the second sort,-    --   the whole thing should reduce to Inf,-    --   otherwise it's the normal lub.-  deriving (Typeable, Show)---- | A level is a maximum expression of 0..n 'PlusLevel' expressions---   each of which is a number or an atom plus a number.------   The empty maximum is the canonical representation for level 0.-newtype Level = Max [PlusLevel]-  deriving (Show, Typeable)--data PlusLevel-  = ClosedLevel Integer     -- ^ @n@, to represent @Setₙ@.-  | Plus Integer LevelAtom  -- ^ @n + ℓ@.-  deriving (Show, Typeable)---- | An atomic term of type @Level@.-data LevelAtom-  = MetaLevel MetaId Elims-    -- ^ A meta variable targeting @Level@ under some eliminations.-  | BlockedLevel MetaId Term-    -- ^ A term of type @Level@ whose reduction is blocked by a meta.-  | NeutralLevel NotBlocked Term-    -- ^ A neutral term of type @Level@.-  | UnreducedLevel Term-    -- ^ Introduced by 'instantiate', removed by 'reduce'.-  deriving (Show, Typeable)-------------------------------------------------------------------------------- * Blocked Terms-------------------------------------------------------------------------------- | Even if we are not stuck on a meta during reduction---   we can fail to reduce a definition by pattern matching---   for another reason.-data NotBlocked-  = StuckOn Elim-    -- ^ The 'Elim' is neutral and blocks a pattern match.-  | Underapplied-    -- ^ 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-    --   produced an actual mismatch.-    --   This can happen when try to reduce a function application-    --   but we are still missing some function clauses.-    --   See "Agda.TypeChecking.Patterns.Match".-  | ReallyNotBlocked-    -- ^ Reduction was not blocked, we reached a whnf-    --   which can be anything but a stuck @'Def'@.-  deriving (Show, Typeable)---- | 'ReallyNotBlocked' is the unit.---   'MissingClauses' is dominant.---   @'StuckOn'{}@ should be propagated, if tied, we take the left.-instance Semigroup NotBlocked where-  ReallyNotBlocked <> b = b-  -- MissingClauses is dominant (absorptive)-  b@MissingClauses <> _ = b-  _ <> b@MissingClauses = b-  -- StuckOn is second strongest-  b@StuckOn{}      <> _ = b-  _ <> b@StuckOn{}      = b-  b <> _                = b--instance Monoid NotBlocked where-  -- ReallyNotBlocked is neutral-  mempty = ReallyNotBlocked-  mappend = (<>)---- | Something where a meta variable may block reduction.-data Blocked t-  = Blocked    { theBlockingMeta :: MetaId    , ignoreBlocking :: t }-  | NotBlocked { blockingStatus  :: NotBlocked, ignoreBlocking :: t }-  deriving (Typeable, Show, Functor, Foldable, Traversable)-  -- deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)---- | Blocking by a meta is dominant.-instance Applicative Blocked where-  pure = notBlocked-  f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)---- -- | Blocking by a meta is dominant.--- instance Applicative Blocked where---   pure = notBlocked---   Blocked x f     <*> e                = Blocked x $ f (ignoreBlocking e)---   NotBlocked nb f <*> Blocked    x   e = Blocked x $ f e---   NotBlocked nb f <*> NotBlocked nb' e = NotBlocked (nb `mappend` nb') $ f e---- | @'Blocked' t@ without the @t@.-type Blocked_ = Blocked ()--instance Semigroup Blocked_ where-  b@Blocked{}    <> _              = b-  _              <> b@Blocked{}    = b-  NotBlocked x _ <> NotBlocked y _ = NotBlocked (x <> y) ()--instance Monoid Blocked_ where-  mempty = notBlocked ()-  mappend = (<>)---- See issues 1573 and 1674.-#if !MIN_VERSION_transformers(0,4,1)-instance Error Blocked_ where-  noMsg = mempty-#endif---- | When trying to reduce @f es@, on match failed on one---   elimination @e ∈ es@ that came with info @r :: NotBlocked@.---   @stuckOn e r@ produces the new @NotBlocked@ info.------   'MissingClauses' must be propagated, as this is blockage---   that can be lifted in the future (as more clauses are added).------   @'StuckOn' e0@ is also propagated, since it provides more---   precise information as @StuckOn e@ (as @e0@ is the original---   reason why reduction got stuck and usually a subterm of @e@).---   An information like @StuckOn (Apply (Arg info (Var i [])))@---   (stuck on a variable) could be used by the lhs/coverage checker---   to trigger a split on that (pattern) variable.------   In the remaining cases for @r@, we are terminally stuck---   due to @StuckOn e@.  Propagating @'AbsurdMatch'@ does not---   seem useful.------   'Underapplied' must not be propagated, as this would mean---   that @f es@ is underapplied, which is not the case (it is stuck).---   Note that 'Underapplied' can only arise when projection patterns were---   missing to complete the original match (in @e@).---   (Missing ordinary pattern would mean the @e@ is of function type,---   but we cannot match against something of function type.)-stuckOn :: Elim -> NotBlocked -> NotBlocked-stuckOn e r =-  case r of-    MissingClauses   -> r-    StuckOn{}        -> r-    Underapplied     -> r'-    AbsurdMatch      -> r'-    ReallyNotBlocked -> r'-  where r' = StuckOn e-------------------------------------------------------------------------------- * Definitions-------------------------------------------------------------------------------- | A clause is a list of patterns and the clause body.------  The telescope contains the types of the pattern variables and the---  de Bruijn indices say how to get from the order the variables occur in---  the patterns to the order they occur in the telescope. The body---  binds the variables in the order they appear in the telescope.------  @clauseTel ~ permute clausePerm (patternVars namedClausePats)@------  Terms in dot patterns are valid in the clause telescope.------  For the purpose of the permutation and the body dot patterns count---  as variables. TODO: Change this!-data Clause = Clause-    { clauseRange     :: Range-    , clauseTel       :: Telescope-      -- ^ @Δ@: The types of the pattern variables in dependency order.-    , namedClausePats :: [NamedArg DeBruijnPattern]-      -- ^ @Δ ⊢ ps@.  The de Bruijn indices refer to @Δ@.-    , clauseBody      :: Maybe Term-      -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an-      --   absurd one.-    , 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-      -- ^ Clause has been labelled as CATCHALL.-    }-  deriving (Typeable, Show)--clausePats :: Clause -> [Arg DeBruijnPattern]-clausePats = map (fmap namedThing) . namedClausePats--instance HasRange Clause where-  getRange = clauseRange---- | Pattern variables.-type PatVarName = ArgName--patVarNameToString :: PatVarName -> String-patVarNameToString = argNameToString--nameToPatVarName :: Name -> PatVarName-nameToPatVarName = nameToArgName---- | Patterns are variables, constructors, or wildcards.---   @QName@ is used in @ConP@ rather than @Name@ since---     a constructor might come from a particular namespace.---     This also meshes well with the fact that values (i.e.---     the arguments we are matching with) use @QName@.----data Pattern' x-  = VarP x-    -- ^ @x@-  | DotP Term-    -- ^ @.t@-  | ConP ConHead ConPatternInfo [NamedArg (Pattern' x)]-    -- ^ @c ps@-    --   The subpatterns do not contain any projection copatterns.-  | LitP Literal-    -- ^ E.g. @5@, @"hello"@.-  | ProjP ProjOrigin QName-    -- ^ Projection copattern.  Can only appear by itself.-  deriving (Typeable, Show, Functor, Foldable, Traversable)--type Pattern = Pattern' PatVarName-    -- ^ The @PatVarName@ is a name suggestion.--varP :: ArgName -> Pattern-varP = VarP---- | Type used when numbering pattern variables.-data DBPatVar = DBPatVar-  { dbPatVarName  :: PatVarName-  , dbPatVarIndex :: Int-  } deriving (Typeable, Show)--type DeBruijnPattern = Pattern' DBPatVar--namedVarP :: PatVarName -> Named_ Pattern-namedVarP x = Named named $ varP x-  where named = if isUnderscore x then Nothing else Just $ unranged x--namedDBVarP :: Int -> PatVarName -> Named_ DeBruijnPattern-namedDBVarP m = (fmap . fmap) (\x -> DBPatVar x m) . namedVarP---- | The @ConPatternInfo@ states whether the constructor belongs to---   a record type (@Just@) or data type (@Nothing@).---   In the former case, the @Bool@ says whether the record pattern---   orginates from the expansion of an implicit pattern.---   The @Type@ is the type of the whole record pattern.---   The scope used for the type is given by any outer scope---   plus the clause's telescope ('clauseTel').-data ConPatternInfo = ConPatternInfo-  { conPRecord :: Maybe ConOrigin-    -- ^ @Nothing@ if data constructor.-    --   @Just@ if record constructor.-  , conPType   :: Maybe (Arg Type)-    -- ^ The type of the whole constructor pattern.-    --   Should be present (@Just@) if constructor pattern is-    --   is generated ordinarily by type-checking.-    --   Could be absent (@Nothing@) if pattern comes from some-    --   plugin (like Agsy).-    --   Needed e.g. for with-clause stripping.-  }-  deriving (Typeable, Show)--noConPatternInfo :: ConPatternInfo-noConPatternInfo = ConPatternInfo Nothing Nothing---- | Build partial 'ConPatternInfo' from 'ConInfo'-toConPatternInfo :: ConInfo -> ConPatternInfo-toConPatternInfo ConORec = ConPatternInfo (Just ConORec) Nothing-toConPatternInfo _ = noConPatternInfo---- | Build 'ConInfo' from 'ConPatternInfo'.-fromConPatternInfo :: ConPatternInfo -> ConInfo-fromConPatternInfo = fromMaybe ConOSystem . conPRecord---- | Extract pattern variables in left-to-right order.---   A 'DotP' is also treated as variable (see docu for 'Clause').-patternVars :: Arg (Pattern' a) -> [Arg (Either a Term)]-patternVars (Arg i (VarP x)     ) = [Arg i $ Left x]-patternVars (Arg i (DotP t)     ) = [Arg i $ Right t]-patternVars (Arg i (ConP _ _ ps)) = List.concat $ map (patternVars . fmap namedThing) ps-patternVars (Arg i (LitP l)     ) = []-patternVars (Arg i ProjP{}      ) = []---- | Does the pattern perform a match that could fail?-properlyMatching :: DeBruijnPattern -> Bool-properlyMatching (VarP x) = isAbsurdPatternName $ dbPatVarName x-properlyMatching DotP{} = False-properlyMatching LitP{} = True-properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record cons-  List.any (properlyMatching . namedArg) ps  -- or one of subpatterns is a proper m-properlyMatching ProjP{} = True--instance IsProjP (Pattern' a) where-  isProjP (ProjP o d) = Just (o, AmbQ [d])-  isProjP _ = Nothing---------------------------------------------------------------------------------- * Explicit substitutions---------------------------------------------------------------------------------- | Substitutions.--data Substitution' a--  = IdS-    -- ^ Identity substitution.-    --   @Γ ⊢ IdS : Γ@--  | EmptyS-    -- ^ Empty substitution, lifts from the empty context.-    --   Apply this to closed terms you want to use in a non-empty context.-    --   @Γ ⊢ EmptyS : ()@--  | a :# Substitution' a-    -- ^ Substitution extension, ``cons''.-    --   @-    --     Γ ⊢ u : Aρ   Γ ⊢ ρ : Δ-    --     -----------------------    --     Γ ⊢ u :# ρ : Δ, A-    --   @--  | Strengthen Empty (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.-    --   @-    --             Γ ⊢ ρ : Δ-    --     ----------------------------    --     Γ ⊢ Strengthen ρ : Δ, A-    --   @--  | Wk !Int (Substitution' a)-    -- ^ Weakning substitution, lifts to an extended context.-    --   @-    --         Γ ⊢ ρ : Δ-    --     --------------------    --     Γ, Ψ ⊢ Wk |Ψ| ρ : Δ-    --   @---  | Lift !Int (Substitution' a)-    -- ^ Lifting substitution.  Use this to go under a binder.-    --   @Lift 1 ρ == var 0 :# Wk 1 ρ@.-    --   @-    --            Γ ⊢ ρ : Δ-    --     --------------------------    --     Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ-    --   @--  deriving (Show, Functor, Foldable, Traversable)--type Substitution = Substitution' Term-type PatternSubstitution = Substitution' DeBruijnPattern--infixr 4 :#--instance Null (Substitution' a) where-  empty = IdS-  null IdS = True-  null _   = False--------------------------------------------------------------------------------- * Views-------------------------------------------------------------------------------- | View type as equality type.--data EqualityView-  = EqualityType-    { eqtSort  :: Sort     -- ^ Sort of this type.-    , eqtName  :: QName    -- ^ Builtin EQUALITY.-    , eqtLevel :: Arg Term -- ^ Hidden-    , eqtType  :: Arg Term -- ^ Hidden-    , eqtLhs   :: Arg Term -- ^ NotHidden-    , eqtRhs   :: Arg Term -- ^ NotHidden-    }-  | OtherType Type -- ^ reduced--isEqualityType :: EqualityView -> Bool-isEqualityType EqualityType{} = True-isEqualityType OtherType{}    = False-------------------------------------------------------------------------------- * Absurd Lambda-------------------------------------------------------------------------------- | Absurd lambdas are internally represented as identity---   with variable name "()".-absurdBody :: Abs Term-absurdBody = Abs absurdPatternName $ Var 0 []--isAbsurdBody :: Abs Term -> Bool-isAbsurdBody (Abs x (Var 0 [])) = isAbsurdPatternName x-isAbsurdBody _                  = False--absurdPatternName :: PatVarName-absurdPatternName = "()"--isAbsurdPatternName :: PatVarName -> Bool-isAbsurdPatternName x = x == absurdPatternName-------------------------------------------------------------------------------- * Pointers and Sharing-------------------------------------------------------------------------------- | Remove top-level @Shared@ data constructors.-ignoreSharing :: Term -> Term-ignoreSharing (Shared p) = ignoreSharing $ derefPtr p-ignoreSharing v          = v--ignoreSharingType :: Type -> Type-ignoreSharingType (El s v) = El s (ignoreSharing v)--- ignoreSharingType v = v---- | Introduce sharing.-shared_ :: Term -> Term-shared_ v@Shared{}   = v-shared_ v@(Var _ []) = v-shared_ v@(Con _ _ []) = v -- Issue 1691: sharing (zero : Nat) destroys constructorForm-shared_ v            = Shared (newPtr v)---- | Typically m would be TCM and f would be Blocked.-updateSharedFM-#if __GLASGOW_HASKELL__ <= 708-  :: (Applicative m, Monad m, Traversable f)-#else-  :: (Monad m, Traversable f)-#endif-  => (Term -> m (f Term)) -> Term -> m (f Term)-updateSharedFM f v0@(Shared p) = do-  fv <- f (derefPtr p)-  flip traverse fv $ \v ->-    case derefPtr (setPtr v p) of-      Var _ [] -> return v-      _        -> return $! compressPointerChain v0-updateSharedFM f v = f v--updateSharedM :: Monad m => (Term -> m Term) -> Term -> m Term-updateSharedM f v0@(Shared p) = do-  v <- f (derefPtr p)-  case derefPtr (setPtr v p) of-    Var _ [] -> return v-    _        -> return $! compressPointerChain v0-updateSharedM f v = f v--updateShared :: (Term -> Term) -> Term -> Term-updateShared f v0@(Shared p) =-  case derefPtr (setPtr (f $ derefPtr p) p) of-    v@(Var _ []) -> v-    _            -> compressPointerChain v0-updateShared f v = f v--pointerChain :: Term -> [Ptr Term]-pointerChain (Shared p) = p : pointerChain (derefPtr p)-pointerChain _          = []---- Redirect all top-level pointers to point to the last pointer. So, after--- compression there are at most two top-level indirections. Then return the--- inner-most pointer so we have only one pointer for the result.-compressPointerChain :: Term -> Term-compressPointerChain v =-  case reverse $ pointerChain v of-    p:_:ps@(_:_) -> setPointers (Shared p) ps-    p:_:_        -> (Shared p)-    _            -> v-  where-    setPointers u [] = u-    setPointers u (p : ps) =-      setPtr u p `seq` setPointers u ps-------------------------------------------------------------------------------- * Smart constructors-------------------------------------------------------------------------------- | An unapplied variable.-var :: Nat -> Term-var i | i >= 0    = Var i []-      | otherwise = __IMPOSSIBLE__---- | Add 'DontCare' is it is not already a @DontCare@.-dontCare :: Term -> Term-dontCare v =-  case ignoreSharing v of-    DontCare{} -> v-    _          -> DontCare v---- | A dummy type.-typeDontCare :: Type-typeDontCare = El Prop (Sort Prop)---- | Top sort (Set\omega).-topSort :: Type-topSort = El Inf (Sort Inf)--sort :: Sort -> Type-sort s = El (sSuc s) $ Sort s--varSort :: Int -> Sort-varSort n = Type $ Max [Plus 0 $ NeutralLevel mempty $ var n]---- | Get the next higher sort.-sSuc :: Sort -> Sort-sSuc Prop            = mkType 1-sSuc Inf             = Inf-sSuc SizeUniv        = SizeUniv-sSuc (DLub a b)      = DLub (sSuc a) (fmap sSuc b)-sSuc (Type l)        = Type $ levelSuc l--levelSuc :: Level -> Level-levelSuc (Max []) = Max [ClosedLevel 1]-levelSuc (Max as) = Max $ map inc as-  where inc (ClosedLevel n) = ClosedLevel (n + 1)-        inc (Plus n l)      = Plus (n + 1) l--mkType :: Integer -> Sort-mkType n = Type $ Max [ClosedLevel n | n > 0]--impossibleTerm :: String -> Int -> Term-impossibleTerm file line = Lit $ LitString noRange $ unlines-  [ "An internal error has occurred. Please report this as a bug."-  , "Location of the error: " ++ file ++ ":" ++ show line-  ]---- | Constructing a singleton telescope.-class SgTel a where-  sgTel :: a -> Telescope--instance SgTel (ArgName, Dom Type) where-  sgTel (x, dom) = ExtendTel dom $ Abs x EmptyTel--instance SgTel (Dom (ArgName, Type)) where-  sgTel (Dom ai (x, t)) = ExtendTel (Dom ai t) $ Abs x EmptyTel--instance SgTel (Dom Type) where-  sgTel dom = sgTel (stringToArgName "_", dom)--hackReifyToMeta :: Term-hackReifyToMeta = DontCare $ Lit $ LitNat noRange (-42)--isHackReifyToMeta :: Term -> Bool-isHackReifyToMeta (DontCare (Lit (LitNat r (-42)))) = r == noRange-isHackReifyToMeta _ = False-------------------------------------------------------------------------------- * Handling blocked terms.------------------------------------------------------------------------------blockingMeta :: Blocked t -> Maybe MetaId-blockingMeta (Blocked m _) = Just m-blockingMeta NotBlocked{}  = Nothing--blocked :: MetaId -> a -> Blocked a-blocked x = Blocked x--notBlocked :: a -> Blocked a-notBlocked = NotBlocked ReallyNotBlocked-------------------------------------------------------------------------------- * Simple operations on terms and types.-------------------------------------------------------------------------------- | Removing a topmost 'DontCare' constructor.-stripDontCare :: Term -> Term-stripDontCare v = case ignoreSharing v of-  DontCare v -> v-  _          -> v---- | Doesn't do any reduction.-arity :: Type -> Nat-arity t = case ignoreSharing $ unEl t of-  Pi  _ b -> 1 + arity (unAbs b)-  _       -> 0---- | Make a name that is not in scope.-notInScopeName :: ArgName -> ArgName-notInScopeName = stringToArgName . ("." ++) . argNameToString---- | Pick the better name suggestion, i.e., the one that is not just underscore.-class Suggest a b where-  suggest :: a -> b -> String--instance Suggest String String where-  suggest "_" y = y-  suggest  x  _ = x--instance Suggest (Abs a) (Abs b) where-  suggest b1 b2 = suggest (absName b1) (absName b2)--instance Suggest String (Abs b) where-  suggest x b = suggest x (absName b)--instance Suggest Name (Abs b) where-  suggest n b = suggest (nameToArgName n) (absName b)-------------------------------------------------------------------------------- * Eliminations.-------------------------------------------------------------------------------- | Convert top-level postfix projections into prefix projections.-unSpine :: Term -> Term-unSpine = unSpine' $ const True---- | Convert 'Proj' projection eliminations---   according to their 'ProjOrigin' into---   'Def' projection applications.-unSpine' :: (ProjOrigin -> Bool) -> Term -> Term-unSpine' p v =-  case hasElims v of-    Just (h, es) -> loop h [] es-    Nothing      -> v-  where-    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'-      where v = h $ reverse res---- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which---   can be projected.-hasElims :: Term -> Maybe (Elims -> Term, Elims)-hasElims v =-  case ignoreSharing v of-    Var   i es -> Just (Var   i, es)-    Def   f es -> Just (Def   f, es)-    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 _ (Abs _ v)  -> case ignoreSharing v of-      Var 0 [Proj _o f] -> Just (Def f, [])-      _ -> Nothing-    Lam{}      -> Nothing-    Pi{}       -> Nothing-    Sort{}     -> Nothing-    Level{}    -> Nothing-    DontCare{} -> Nothing-    Shared{}   -> __IMPOSSIBLE__--{- PROBABLY USELESS-getElims :: Term -> (Elims -> Term, Elims)-getElims v = maybe default id $ hasElims v-  where-    default = (\ [] -> v, [])--}---- | Drop 'Apply' constructor. (Unsafe!)-argFromElim :: Elim' a -> Arg a-argFromElim (Apply u) = u-argFromElim Proj{}    = __IMPOSSIBLE__---- | Drop 'Apply' constructor. (Safe)-isApplyElim :: Elim' a -> Maybe (Arg a)-isApplyElim (Apply u) = Just u-isApplyElim Proj{}    = Nothing---- | Drop 'Apply' constructors. (Safe)-allApplyElims :: [Elim' a] -> Maybe [Arg a]-allApplyElims = mapM isApplyElim---- | Split at first non-'Apply'-splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])-splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es-splitApplyElims es             = ([], es)--class IsProjElim e where-  isProjElim  :: e -> Maybe (ProjOrigin, QName)--instance IsProjElim Elim where-  isProjElim (Proj o d) = Just (o, d)-  isProjElim Apply{}    = Nothing---- | Discard @Proj f@ entries.-dropProjElims :: IsProjElim e => [e] -> [e]-dropProjElims = filter (isNothing . isProjElim)---- | Discards @Proj f@ entries.-argsFromElims :: Elims -> Args-argsFromElims = map argFromElim . dropProjElims---- | Drop 'Proj' constructors. (Safe)-allProjElims :: Elims -> Maybe [(ProjOrigin, QName)]-allProjElims = mapM isProjElim-------------------------------------------------------------------------------- * Null instances.------------------------------------------------------------------------------instance Null (Tele a) where-  empty = EmptyTel-  null EmptyTel    = True-  null ExtendTel{} = False---- | 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 False-  null (Clause r tel pats body t catchall)-    =  null tel-    && null pats-    && null body--------------------------------------------------------------------------------- * Show instances.------------------------------------------------------------------------------instance Show a => Show (Abs a) where-  showsPrec p (Abs x a) = showParen (p > 0) $-    showString "Abs " . shows x . showString " " . showsPrec 10 a-  showsPrec p (NoAbs x a) = showParen (p > 0) $-    showString "NoAbs " . shows x . showString " " . showsPrec 10 a---- instance Show t => Show (Blocked t) where---   showsPrec p (Blocked m x) = showParen (p > 0) $---     showString "Blocked " . shows m . showString " " . showsPrec 10 x---   showsPrec p (NotBlocked x) = showsPrec p x-------------------------------------------------------------------------------- * Sized instances and TermSize.-------------------------------------------------------------------------------- | The size of a telescope is its length (as a list).-instance Sized (Tele a) where-  size  EmptyTel         = 0-  size (ExtendTel _ tel) = 1 + size tel--instance Sized a => Sized (Abs a) where-  size = size . unAbs---- | The size of a term is roughly the number of nodes in its---   syntax tree.  This number need not be precise for logical---   correctness of Agda, it is only used for reporting---   (and maybe decisions regarding performance).------   Not counting towards the term size are:------     * sort and color annotations,---     * projections.----class TermSize a where-  termSize :: a -> Int-  termSize = getSum . tsize--  tsize :: a -> Sum Int--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} (Foldable t, TermSize a) => TermSize (t a) where-#else-instance (Foldable t, TermSize a) => TermSize (t a) where-#endif-  tsize = foldMap tsize--instance TermSize Term where-  tsize v = case v of-    Var _ vs    -> 1 + tsize vs-    Def _ vs    -> 1 + tsize vs-    Con _ _ vs    -> 1 + tsize vs-    MetaV _ vs  -> 1 + tsize vs-    Level l     -> tsize l-    Lam _ f     -> 1 + tsize f-    Lit _       -> 1-    Pi a b      -> 1 + tsize a + tsize b-    Sort s      -> tsize s-    DontCare mv -> tsize mv-    Shared p    -> tsize (derefPtr p)--instance TermSize Sort where-  tsize s = case s of-    Type l    -> 1 + tsize l-    Prop      -> 1-    Inf       -> 1-    SizeUniv  -> 1-    DLub s s' -> 1 + tsize s + tsize s'--instance TermSize Level where-  tsize (Max as) = 1 + tsize as--instance TermSize PlusLevel where-  tsize (ClosedLevel _) = 1-  tsize (Plus _ a)      = tsize a--instance TermSize LevelAtom where-  tsize (MetaLevel _   vs) = 1 + tsize vs-  tsize (BlockedLevel _ v) = tsize v-  tsize (NeutralLevel _ v) = tsize v-  tsize (UnreducedLevel v) = tsize v--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-------------------------------------------------------------------------------- * KillRange instances.------------------------------------------------------------------------------instance KillRange ConHead where-  killRange (ConHead c i fs) = killRange3 ConHead c i fs--instance KillRange Term where-  killRange v = case v of-    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-    Shared p    -> Shared $ updatePtr killRange p--instance KillRange Level where-  killRange (Max as) = killRange1 Max as--instance KillRange PlusLevel where-  killRange l@ClosedLevel{} = l-  killRange (Plus n l) = killRange1 (Plus n) l--instance KillRange LevelAtom where-  killRange (MetaLevel n as)   = killRange1 (MetaLevel n) as-  killRange (BlockedLevel m v) = killRange1 (BlockedLevel m) v-  killRange (NeutralLevel r v) = killRange1 (NeutralLevel r) v-  killRange (UnreducedLevel v) = killRange1 UnreducedLevel v--instance (KillRange a) => KillRange (Type' a) where-  killRange (El s v) = killRange2 El s v--instance KillRange Sort where-  killRange s = case s of-    Prop       -> Prop-    Inf        -> Inf-    SizeUniv   -> SizeUniv-    Type a     -> killRange1 Type a-    DLub s1 s2 -> killRange2 DLub s1 s2--instance KillRange Substitution where-  killRange IdS                  = IdS-  killRange EmptyS               = EmptyS-  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--instance KillRange ConPatternInfo where-  killRange (ConPatternInfo mr mt) = killRange1 (ConPatternInfo mr) mt--instance KillRange DBPatVar where-  killRange (DBPatVar x i) = killRange2 DBPatVar x i--instance KillRange a => KillRange (Pattern' a) where-  killRange p =-    case p of-      VarP x           -> killRange1 VarP x-      DotP v           -> killRange1 DotP v-      ConP con info ps -> killRange3 ConP con info ps-      LitP l           -> killRange1 LitP l-      ProjP o q        -> killRange1 (ProjP o) q--instance KillRange Clause where-  killRange (Clause r tel ps body t catchall) = killRange6 Clause r tel ps body t catchall--instance KillRange a => KillRange (Tele a) where-  killRange = fmap killRange--instance KillRange a => KillRange (Blocked a) where-  killRange = fmap killRange--instance KillRange a => KillRange (Abs a) where-  killRange = fmap killRange--instance KillRange a => KillRange (Elim' a) where-  killRange = fmap killRange-------------------------------------------------------------------------------- * UniverseBi instances.------------------------------------------------------------------------------instanceUniverseBiT' [] [t| (([Type], [Clause]), Pattern) |]-instanceUniverseBiT' [] [t| (Args, Pattern)               |]-instanceUniverseBiT' [] [t| (Elims, Pattern)              |] -- ?-instanceUniverseBiT' [] [t| (([Type], [Clause]), Term)    |]-instanceUniverseBiT' [] [t| (Args, Term)                  |]-instanceUniverseBiT' [] [t| (Elims, Term)                 |] -- ?-instanceUniverseBiT' [] [t| ([Term], Term)                |]---------------------------------------------------------------------------------- * Simple pretty printing--------------------------------------------------------------------------------instance Pretty a => Pretty (Substitution' a) where-  prettyPrec p rho = pr p rho-    where-    pr p rho = case rho of-      IdS              -> text "idS"-      EmptyS           -> text "emptyS"-      t :# rho         -> mparens (p > 2) $ sep [ pr 2 rho P.<> text ",", prettyPrec 3 t ]-      Strengthen _ rho -> mparens (p > 9) $ text "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--instance Pretty Term where-  prettyPrec p v =-    case ignoreSharing v of-      Var x els -> text ("@" ++ show x) `pApp` els-      Lam ai b   ->-        mparens (p > 0) $-        sep [ text "λ" <+> prettyHiding ai id (text . show . absName $ b) <+> text "->"-            , nest 2 $ pretty (unAbs b) ]-      Lit l                -> pretty l-      Def q els            -> text (show q) `pApp` els-      Con c ci vs          -> text (show $ conName c) `pApp` map Apply vs-      Pi a (NoAbs _ b)     -> mparens (p > 0) $-        sep [ prettyPrec 1 (unDom a) <+> text "->"-            , nest 2 $ pretty b ]-      Pi a b               -> mparens (p > 0) $-        sep [ pDom (domInfo a) (text (absName b) <+> text ":" <+> pretty (unDom a)) <+> text "->"-            , nest 2 $ pretty (unAbs b) ]-      Sort s      -> prettyPrec p s-      Level l     -> prettyPrec p l-      MetaV x els -> pretty x `pApp` els-      DontCare v  -> prettyPrec p v-      Shared{}    -> __IMPOSSIBLE__-    where-      pApp d els = mparens (not (null els) && p > 9) $-                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]--pDom :: LensHiding a => a -> Doc -> Doc-pDom i =-  case getHiding i of-    NotHidden -> parens-    Hidden    -> braces-    Instance  -> braces . braces--instance Pretty Clause where-  pretty Clause{clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t} =-    sep [ pretty tel <+> text "|-"-        , nest 2 $ sep [ fsep (map (prettyPrec 10) ps) <+> text "="-                       , nest 2 $ pBody b t ] ]-    where-      pBody Nothing _ = text "(absurd)"-      pBody (Just b) Nothing  = pretty b-      pBody (Just b) (Just t) = sep [ pretty b <+> text ":", nest 2 $ pretty t ]--instance Pretty a => Pretty (Tele (Dom a)) where-  pretty tel = fsep [ pDom a (text x <+> text ":" <+> pretty (unDom a)) | (x, a) <- telToList tel ]-    where-      telToList EmptyTel = []-      telToList (ExtendTel a tel) = (absName tel, a) : telToList (unAbs tel)--instance Pretty Level where-  prettyPrec p (Max as) =-    case as of-      []  -> prettyPrec p (ClosedLevel 0)-      [a] -> prettyPrec p a-      _   -> mparens (p > 9) $ List.foldr1 (\a b -> text "lub" <+> a <+> b) $ map (prettyPrec 10) as--instance Pretty PlusLevel where-  prettyPrec p l =-    case l of-      ClosedLevel n -> sucs p n $ \_ -> text "lzero"-      Plus n a      -> sucs p n $ \p -> prettyPrec p a-    where-      sucs p 0 d = d p-      sucs p n d = mparens (p > 9) $ text "lsuc" <+> sucs 10 (n - 1) d--instance Pretty LevelAtom where-  prettyPrec p a =-    case a of-      MetaLevel x els  -> prettyPrec p (MetaV x els)-      BlockedLevel _ v -> prettyPrec p v-      NeutralLevel _ v -> prettyPrec p v-      UnreducedLevel v -> prettyPrec p v--instance Pretty Sort where-  prettyPrec p s =-    case s of-      Type (Max []) -> text "Set"-      Type (Max [ClosedLevel n]) -> text $ "Set" ++ show n-      Type l -> mparens (p > 9) $ text "Set" <+> prettyPrec 10 l-      Prop -> text "Prop"-      Inf -> text "Setω"-      SizeUniv -> text "SizeUniv"-      DLub s b -> mparens (p > 9) $-        text "dlub" <+> prettyPrec 10 s-                    <+> parens (sep [ text ("λ " ++ show (absName b) ++ " ->")-                                    , nest 2 $ pretty (unAbs b) ])--instance Pretty Type where-  prettyPrec p (El _ a) = prettyPrec p a--instance Pretty Elim where-  prettyPrec p (Apply v)    = prettyPrec p v-  prettyPrec _ (Proj _o x)  = text ("." ++ show x)--instance Pretty DBPatVar where-  prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x)--instance Pretty a => Pretty (Pattern' a) where-  prettyPrec n (VarP x)      = prettyPrec n x-  prettyPrec _ (DotP t)      = text "." P.<> prettyPrec 10 t-  prettyPrec n (ConP c i nps)= mparens (n > 0) $-    text (show $ conName c) <+> fsep (map pretty ps)-    where ps = map (fmap namedThing) nps-  -- -- Version with printing record type:-  -- prettyPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $-  --   text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)-  --   where-  --     b = maybe False (== ConOSystem) $ conPRecord i-  --     prTy d = caseMaybe (conPType i) d $ \ t -> d  <+> text ":" <+> pretty t-  prettyPrec _ (LitP l)      = text (show l)-  prettyPrec _ (ProjP _o q)  = text ("." ++ show q)---------------------------------------------------------------------------------- * NFData instances---------------------------------------------------------------------------------- Note: only strict in the shape of the terms.--instance NFData Term where-  rnf v = case v of-    Var _ es   -> rnf es-    Lam _ b    -> rnf (unAbs b)-    Lit l      -> rnf l-    Def _ es   -> rnf es-    Con _ _ vs -> rnf vs-    Pi a b     -> rnf (unDom a, unAbs b)-    Sort s     -> rnf s-    Level l    -> rnf l-    MetaV _ es -> rnf es-    DontCare v -> rnf v-    Shared{}   -> ()--instance NFData Type where-  rnf (El s v) = rnf (s, v)--instance NFData Sort where-  rnf s = case s of-    Type l   -> rnf l-    Prop     -> ()-    Inf      -> ()-    SizeUniv -> ()-    DLub a b -> rnf (a, unAbs b)--instance NFData Level where-  rnf (Max as) = rnf as--instance NFData PlusLevel where-  rnf (ClosedLevel n) = rnf n-  rnf (Plus n l) = rnf (n, l)--instance NFData LevelAtom where-  rnf (MetaLevel _ es)   = rnf es-  rnf (BlockedLevel _ v) = rnf v-  rnf (NeutralLevel _ v) = rnf v-  rnf (UnreducedLevel v) = rnf v--instance NFData a => NFData (Elim' a) where-  rnf (Apply x) = rnf x-  rnf Proj{}    = ()++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++import Prelude hiding (null)++import Control.Monad.Identity+import Control.DeepSeq++import Data.Function (on)+import qualified Data.List as List+import Data.Maybe+import Data.Semigroup ( Semigroup, (<>), Sum(..) )++import GHC.Generics (Generic)++import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Literal+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+    , HasCallStack+    , prettyCallSite+    , headCallSite+    , withCallerCallStack+    )++import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.Null+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Function type domain+---------------------------------------------------------------------------++-- | Similar to 'Arg', but we need to distinguish+--   an irrelevance annotation in a function domain+--   (the domain itself is not irrelevant!)+--   from an irrelevant argument.+--+--   @Dom@ is used in 'Pi' of internal syntax, in 'Context' and 'Telescope'.+--   'Arg' is used for actual arguments ('Var', 'Con', 'Def' etc.)+--   and in 'Abstract' syntax and other situations.+--+--   [ 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+  , 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 (Show, Functor, Foldable, Traversable)++type Dom = Dom' Term++instance Decoration (Dom' t) where+  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 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) 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+  lensNamed f dom = f (domName dom) <&> \ nm -> dom { domName = nm }++instance LensArgInfo (Dom' t e) where+  getArgInfo        = domInfo+  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+instance LensModality      (Dom' t e) where+instance LensOrigin        (Dom' t e) where+instance LensFreeVariables (Dom' t e) where+instance LensAnnotation    (Dom' t e) where++-- Since we have LensModality, we get relevance and quantity by default++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++namedArgFromDom :: Dom' t a -> NamedArg a+namedArgFromDom Dom{domInfo = i, domName = s, unDom = a} = Arg i $ Named s a++-- The following functions are less general than they could be:+-- @Dom@ could be replaced by @Dom' t@.+-- However, this causes problems with instance resolution in several places.+-- often for class AddContext.++domFromArg :: Arg a -> Dom a+domFromArg (Arg i a) = Dom i Nothing False Nothing a++domFromNamedArg :: NamedArg a -> Dom a+domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing (namedThing a)++defaultDom :: a -> Dom a+defaultDom = defaultArgDom defaultArgInfo++defaultArgDom :: ArgInfo -> a -> Dom a+defaultArgDom info x = domFromArg (Arg info x)++defaultNamedArgDom :: ArgInfo -> String -> a -> Dom a+defaultNamedArgDom info s x = (defaultArgDom info x) { domName = Just $ WithOrigin Inserted $ unranged s }++-- | Type of argument lists.+--+type Args       = [Arg Term]+type NamedArgs  = [NamedArg Term]++data DataOrRecord' p+  = IsData+  | 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.+data ConHead = ConHead+  { conName       :: QName         -- ^ The name of the constructor.+  , conDataRecord :: DataOrRecord  -- ^ Data or record constructor?+  , conInductive  :: Induction     -- ^ Record constructors can be coinductive.+  , 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 (Show, Generic)++instance Eq ConHead where+  (==) = (==) `on` conName++instance Ord ConHead where+  (<=) = (<=) `on` conName++instance Pretty ConHead where+  pretty = pretty . conName++instance HasRange ConHead where+  getRange = getRange . conName++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+  setConName = mapConName . const+  mapConName :: (QName -> QName) -> a -> a+  mapConName f a = setConName (f (getConName a)) a++instance LensConName ConHead where+  getConName = conName+  setConName c con = con { conName = c }+++-- | Raw values.+--+--   @Def@ is used for both defined and undefined constants.+--   Assume there is a type declaration and a definition for+--     every constant, even if the definition is an empty+--     list of clauses.+--+data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral+          | Lam ArgInfo (Abs Term)        -- ^ Terms are beta normal. Relevance is ignored+          | Lit Literal+          | Def QName Elims               -- ^ @f es@, possibly a delta/iota-redex+          | Con ConHead ConInfo Elims+          -- ^ @c es@ or @record { fs = es }@+          --   @es@ allows only Apply and IApply eliminations,+          --   and IApply only for data constructors.+          | Pi (Dom Type) (Abs Type)      -- ^ dependent or non-dependent function space+          | Sort Sort+          | Level Level+          | MetaV {-# UNPACK #-} !MetaId Elims+          | DontCare Term+            -- ^ Irrelevant stuff in relevant position, but created+            --   in an irrelevant context.  Basically, an internal+            --   version of the irrelevance axiom @.irrAx : .A -> A@.+          | Dummy String Elims+            -- ^ A (part of a) term or type which is only used for internal purposes.+            --   Replaces the @Sort Prop@ hack.+            --   The @String@ typically describes the location where we create this dummy,+            --   but can contain other information as well.+            --   The second field accumulates eliminations in case we+            --   apply a dummy term to more of them. Dummy terms should never be used in places+            --   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 Show++type ConInfo = ConOrigin++type Elim = Elim' Term+type Elims = [Elim]  -- ^ eliminations ordered left-to-right.++-- | Binder.+--+--   'Abs': The bound variable might appear in the body.+--   'NoAbs' is pseudo-binder, it does not introduce a fresh variable,+--      similar to the @const@ of Haskell.+--+data Abs a = Abs   { absName :: ArgName, unAbs :: a }+               -- ^ The body has (at least) one free variable.+               --   Danger: 'unAbs' doesn't shift variables properly+           | NoAbs { absName :: ArgName, unAbs :: a }+  deriving (Functor, Foldable, Traversable, Generic)++instance Decoration Abs where+  traverseF f (Abs   x a) = Abs   x <$> f a+  traverseF f (NoAbs x a) = NoAbs x <$> f a++-- | Types are terms with a sort annotation.+--+data Type'' t a = El { _getSort :: Sort' t, unEl :: a }+  deriving (Show, Functor, Foldable, Traversable)++type Type' a = Type'' Term a++type Type = Type' Term++instance Decoration (Type'' t) where+  traverseF f (El s a) = El s <$> f a++class LensSort a where+  lensSort ::  Lens' a Sort+  getSort  :: a -> Sort+  getSort a = a ^. lensSort++instance LensSort Sort where+  lensSort f s = f s <&> \ s' -> s'++instance LensSort (Type' a) where+  lensSort f (El s a) = f s <&> \ s' -> El s' a++-- General instance leads to overlapping instances.+-- instance (Decoration f, LensSort a) => LensSort (f a) where+instance LensSort a => LensSort (Dom a) where+  lensSort = traverseF . lensSort++instance LensSort a => LensSort (Arg a) where+  lensSort = traverseF . lensSort+++-- | Sequence of types. An argument of the first type is bound in later types+--   and so on.+data Tele a = EmptyTel+            | ExtendTel a (Abs (Tele a))  -- ^ 'Abs' is never 'NoAbs'.+  deriving (Show, Functor, Foldable, Traversable, Generic)++type Telescope = Tele (Dom Type)++data UnivSize+  = USmall  -- ^ @Prop/Set/SSet ℓ@.+  | ULarge  -- ^ @(Prop/Set/SSet)ωᵢ@.+  deriving stock (Eq, Show)++-- | Sorts.+--+data Sort' t+  = 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.+  | MetaS {-# UNPACK #-} !MetaId [Elim' t]+  | DefS QName [Elim' t] -- ^ A postulated sort.+  | DummyS String+    -- ^ A (part of a) term or type which is only used for internal purposes.+    --   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 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, Functor, Foldable, Traversable)++type Level = Level' Term++data PlusLevel' t = Plus !Integer t+  deriving (Show, Functor, Foldable, Traversable)++type PlusLevel = PlusLevel' Term+type LevelAtom = Term++---------------------------------------------------------------------------+-- * Brave Terms+---------------------------------------------------------------------------++-- | Newtypes for terms that produce a dummy, rather than crash, when+--   applied to incompatible eliminations.+newtype BraveTerm = BraveTerm { unBrave :: Term } deriving Show++---------------------------------------------------------------------------+-- * Blocked Terms+---------------------------------------------------------------------------++type Blocked    = Blocked' Term+type NotBlocked = NotBlocked' Term+--+-- | @'Blocked a@ without the @a@.+type Blocked_ = Blocked ()++---------------------------------------------------------------------------+-- * Definitions+---------------------------------------------------------------------------++-- | Named pattern arguments.+type NAPs = [NamedArg DeBruijnPattern]++-- | A clause is a list of patterns and the clause body.+--+--  The telescope contains the types of the pattern variables and the+--  de Bruijn indices say how to get from the order the variables occur in+--  the patterns to the order they occur in the telescope. The body+--  binds the variables in the order they appear in the telescope.+--+--  @clauseTel ~ permute clausePerm (patternVars namedClausePats)@+--+--  Terms in dot patterns are valid in the clause telescope.+--+--  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+      -- ^ @Δ@: The types of the pattern variables in dependency order.+    , namedClausePats   :: NAPs+      -- ^ @Δ ⊢ ps@.  The de Bruijn indices refer to @Δ@.+    , clauseBody        :: Maybe Term+      -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an+      --   absurd one.+    , 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    :: Catchall+      -- ^ Clause has been labelled as CATCHALL.+    , clauseRecursive   :: Maybe Bool+      -- ^ @clauseBody@ contains recursive calls; computed by termination checker.+      --   @Nothing@ means that termination checker has not run yet,+      --   or that @clauseBody@ contains meta-variables;+      --   these could be filled with recursive calls later!+      --   @Just False@ means definitely no recursive call.+      --   @Just True@ means definitely a recursive call.+    , clauseUnreachable :: Maybe Bool+      -- ^ Clause has been labelled as unreachable by the coverage checker.+      --   @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+      -- ^ 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 (Show, Generic)++clausePats :: Clause -> [Arg DeBruijnPattern]+clausePats = map (fmap namedThing) . namedClausePats++instance HasRange Clause where+  getRange = clauseLHSRange++-- | Pattern variables.+type PatVarName = ArgName++patVarNameToString :: PatVarName -> String+patVarNameToString = argNameToString++nameToPatVarName :: Name -> PatVarName+nameToPatVarName = nameToArgName++data PatternInfo = PatternInfo+  { patOrigin :: PatOrigin+  , patAsNames :: [Name]+  } deriving (Show, Eq, Generic)++defaultPatternInfo :: PatternInfo+defaultPatternInfo = PatternInfo PatOSystem []++-- | Origin of the pattern: what did the user write in this position?+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+  | PatOCon            -- ^ User wrote a constructor pattern+  | PatORec            -- ^ User wrote a record pattern+  | PatOLit            -- ^ User wrote a literal pattern+  | PatOAbsurd         -- ^ User wrote an absurd pattern+  deriving (Show, Eq, Generic)++-- | Patterns are variables, constructors, or wildcards.+--   @QName@ is used in @ConP@ rather than @Name@ since+--     a constructor might come from a particular namespace.+--     This also meshes well with the fact that values (i.e.+--     the arguments we are matching with) use @QName@.+--+data Pattern' x+  = VarP PatternInfo x+    -- ^ @x@+  | DotP PatternInfo Term+    -- ^ @.t@+  | ConP ConHead ConPatternInfo [NamedArg (Pattern' x)]+    -- ^ @c ps@+    --   The subpatterns do not contain any projection copatterns.+  | LitP PatternInfo Literal+    -- ^ E.g. @5@, @"hello"@.+  | ProjP ProjOrigin QName+    -- ^ Projection copattern.  Can only appear by itself.+  | IApplyP PatternInfo Term Term x+    -- ^ 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 (Show, Functor, Foldable, Traversable, Generic)++type Pattern = Pattern' PatVarName+    -- ^ The @PatVarName@ is a name suggestion.++varP :: a -> Pattern' a+varP = VarP defaultPatternInfo++dotP :: Term -> Pattern' a+dotP = DotP defaultPatternInfo++litP :: Literal -> Pattern' a+litP = LitP defaultPatternInfo++-- | Type used when numbering pattern variables.+data DBPatVar = DBPatVar+  { dbPatVarName  :: PatVarName+  , dbPatVarIndex :: !Int+  } deriving (Show, Eq, Generic)++type DeBruijnPattern = Pattern' DBPatVar++namedVarP :: PatVarName -> Named_ Pattern+namedVarP x = Named named $ varP x+  where named = if isUnderscore x then Nothing else Just $ WithOrigin Inserted $ unranged x++namedDBVarP :: Int -> PatVarName -> Named_ DeBruijnPattern+namedDBVarP m = (fmap . fmap) (\x -> DBPatVar x m) . namedVarP++-- | Make an absurd pattern with the given de Bruijn index.+absurdP :: Int -> DeBruijnPattern+absurdP = VarP (PatternInfo PatOAbsurd []) . DBPatVar absurdPatternName++-- | The @ConPatternInfo@ states whether the constructor belongs to+--   a record type (@True@) or data type (@False@).+--   In the former case, the @PatOrigin@ of the @conPInfo@ says+--   whether the record pattern orginates from the expansion of an+--   implicit pattern.+--   The @Type@ is the type of the whole record pattern.+--   The scope used for the type is given by any outer scope+--   plus the clause's telescope ('clauseTel').+data ConPatternInfo = ConPatternInfo+  { conPInfo   :: PatternInfo+    -- ^ Information on the origin of the pattern.+  , conPRecord :: Bool+    -- ^ @False@ if data constructor.+    --   @True@ if record constructor.+  , conPFallThrough :: Bool+    -- ^ Should the match block on non-canonical terms or can it+    --   proceed to the catch-all clause?+  , conPType   :: Maybe (Arg Type)+    -- ^ The type of the whole constructor pattern.+    --   Should be present (@Just@) if constructor pattern is+    --   is generated ordinarily by type-checking.+    --   Could be absent (@Nothing@) if pattern comes from some+    --   plugin (like Agsy).+    --   Needed e.g. for with-clause stripping.+  , conPLazy :: Bool+    -- ^ Lazy patterns are generated by the forcing translation in the unifier+    --   ('Agda.TypeChecking.Rules.LHS.Unify.unifyStep') and are dropped by+    --   the clause compiler (TODO: not yet)+    --   ('Agda.TypeChecking.CompiledClause.Compile.compileClauses') when the+    --   variables they bind are unused. The GHC backend compiles lazy matches+    --   to lazy patterns in Haskell (TODO: not yet).+  }+  deriving (Show, Generic)++noConPatternInfo :: ConPatternInfo+noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False++-- | Build partial 'ConPatternInfo' from 'ConInfo'+toConPatternInfo :: ConInfo -> ConPatternInfo+toConPatternInfo ConORec = noConPatternInfo{ conPInfo = PatternInfo PatORec [] , conPRecord = True }+toConPatternInfo _ = noConPatternInfo++-- | Build 'ConInfo' from 'ConPatternInfo'.+fromConPatternInfo :: ConPatternInfo -> ConInfo+fromConPatternInfo i = patToConO $ patOrigin $ conPInfo i+  where+    patToConO :: PatOrigin -> ConOrigin+    patToConO = \case+      PatOSystem -> ConOSystem+      PatOSplit  -> ConOSplit+      PatOSplitArg{} -> ConOSystem+      PatOVar{}  -> ConOSystem+      PatODot    -> ConOSystem+      PatOWild   -> ConOSystem+      PatOCon    -> ConOCon+      PatORec    -> ConORec+      PatOLit    -> ConOCon+      PatOAbsurd -> ConOSystem++-- | Extract pattern variables in left-to-right order.+--   A 'DotP' is also treated as variable (see docu for 'Clause').+class PatternVars a where+  type PatternVarOut a+  patternVars :: a -> [Arg (Either (PatternVarOut a) Term)]++instance PatternVars (Arg (Pattern' a)) where+  type PatternVarOut (Arg (Pattern' a)) = a++  -- patternVars :: Arg (Pattern' a) -> [Arg (Either a Term)]+  patternVars (Arg i (VarP _ x)   ) = [Arg i $ Left x]+  patternVars (Arg i (DotP _ t)   ) = [Arg i $ Right t]+  patternVars (Arg _ (ConP _ _ ps)) = patternVars ps+  patternVars (Arg _ (DefP _ _ ps)) = patternVars ps+  patternVars (Arg _ (LitP _ _)   ) = []+  patternVars (Arg _ ProjP{}      ) = []+  patternVars (Arg i (IApplyP _ _ _ x)) = [Arg i $ Left x]+++instance PatternVars (NamedArg (Pattern' a)) where+  type PatternVarOut (NamedArg (Pattern' a)) = a++  patternVars = patternVars . fmap namedThing++instance PatternVars a => PatternVars [a] where+  type PatternVarOut [a] = PatternVarOut a++  patternVars = concatMap patternVars++-- | Retrieve the PatternInfo from a pattern+patternInfo :: Pattern' x -> Maybe PatternInfo+patternInfo (VarP i _)        = Just i+patternInfo (DotP i _)        = Just i+patternInfo (LitP i _)        = Just i+patternInfo (ConP _ ci _)     = Just $ conPInfo ci+patternInfo ProjP{}           = Nothing+patternInfo (IApplyP i _ _ _) = Just i+patternInfo (DefP i _ _)      = Just i++-- | Retrieve the origin of a pattern+patternOrigin :: Pattern' x -> Maybe PatOrigin+patternOrigin = fmap patOrigin . patternInfo++instance IsProjP (Pattern' a) where+  isProjP = \case+    ProjP o d -> Just (o, unambiguous d)+    _ -> Nothing++-----------------------------------------------------------------------------+-- * Explicit substitutions+-----------------------------------------------------------------------------++-- | Substitutions.++data Substitution' a++  = IdS+    -- ^ Identity substitution.+    --   @Γ ⊢ IdS : Γ@++  | EmptyS Impossible+    -- ^ Empty substitution, lifts from the empty context. First argument is @__IMPOSSIBLE__@.+    --   Apply this to closed terms you want to use in a non-empty context.+    --   @Γ ⊢ EmptyS : ()@++  | a :# Substitution' a+    -- ^ Substitution extension, ``cons''.+    --   @+    --     Γ ⊢ u : Aρ   Γ ⊢ ρ : Δ+    --     ----------------------+    --     Γ ⊢ u :# ρ : Δ, A+    --   @++  | Strengthen Impossible !Int (Substitution' a)+    -- ^ Strengthening substitution.  First argument is @__IMPOSSIBLE__@.+    --   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 n ρ : Δ, Θ+    --   @++  | Wk !Int (Substitution' a)+    -- ^ Weakening substitution, lifts to an extended context.+    --   @+    --         Γ ⊢ ρ : Δ+    --     -------------------+    --     Γ, Ψ ⊢ Wk |Ψ| ρ : Δ+    --   @+++  | Lift !Int (Substitution' a)+    -- ^ Lifting substitution.  Use this to go under a binder.+    --   @Lift 1 ρ == var 0 :# Wk 1 ρ@.+    --   @+    --            Γ ⊢ ρ : Δ+    --     -------------------------+    --     Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ+    --   @++  deriving ( Show+           , Functor+           , Foldable+           , Traversable+           , Generic+           )++type Substitution = Substitution' Term+type PatternSubstitution = Substitution' DeBruijnPattern++infixr 4 :#++instance Null (Substitution' a) where+  empty = IdS+  null IdS = True+  null _   = False+++---------------------------------------------------------------------------+-- * Views+---------------------------------------------------------------------------++-- | View type as equality type.++data EqualityView+  = 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.+    }++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+isEqualityType IdiomType{}    = False++-- | View type as path type.++data PathView+  = PathType+    { pathSort  :: Sort     -- ^ Sort of this type.+    , pathName  :: QName    -- ^ Builtin PATH.+    , pathLevel :: Arg Term -- ^ Hidden+    , pathType  :: Arg Term -- ^ Hidden+    , pathLhs   :: Arg Term -- ^ NotHidden+    , pathRhs   :: Arg Term -- ^ NotHidden+    }+  | OType Type -- ^ reduced++isPathType :: PathView -> Bool+isPathType PathType{} = True+isPathType OType{}    = False++data IntervalView+      = IZero+      | IOne+      | IMin (Arg Term) (Arg Term)+      | IMax (Arg Term) (Arg Term)+      | INeg (Arg Term)+      | OTerm Term+      deriving Show++isIOne :: IntervalView -> Bool+isIOne IOne = True+isIOne _ = False++---------------------------------------------------------------------------+-- * Absurd Lambda+---------------------------------------------------------------------------++-- | Absurd lambdas are internally represented as identity+--   with variable name "()".+absurdBody :: Abs Term+absurdBody = Abs absurdPatternName $ Var 0 []++isAbsurdBody :: Abs Term -> Bool+isAbsurdBody (Abs x (Var 0 [])) = isAbsurdPatternName x+isAbsurdBody _                  = False++absurdPatternName :: PatVarName+absurdPatternName = "()"++isAbsurdPatternName :: PatVarName -> Bool+isAbsurdPatternName x = x == absurdPatternName++---------------------------------------------------------------------------+-- * Smart constructors+---------------------------------------------------------------------------++-- | An unapplied variable.+var :: Nat -> Term+var i | i >= 0    = Var i []+      | otherwise = __IMPOSSIBLE__++-- | Add 'DontCare' is it is not already a @DontCare@.+dontCare :: Term -> Term+dontCare v =+  case v of+    DontCare{} -> v+    _          -> DontCare v++type DummyTermKind = String++-- | Construct a string representing the call-site that created the dummy thing.+dummyLocName :: CallStack -> String+dummyLocName cs = maybe __IMPOSSIBLE__ prettyCallSite (headCallSite cs)++-- | Aux: A dummy term to constitute a dummy term/level/sort/type.+dummyTermWith :: DummyTermKind -> CallStack -> Term+dummyTermWith kind cs = flip Dummy [] $ concat [kind, ": ", dummyLocName cs]++__DUMMY_TERM_WITH__ :: HasCallStack => DummyTermKind -> Term+__DUMMY_TERM_WITH__ = withCallerCallStack . dummyTermWith++-- | A dummy term created at location.+--   Note: use macro __DUMMY_TERM__ !+dummyTerm :: CallStack -> Term+dummyTerm = dummyTermWith "dummyTerm"++__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++-- | A dummy sort created at location.+--   Note: use macro __DUMMY_SORT__ !+dummySort :: CallStack -> Sort+dummySort = DummyS . dummyLocName++__DUMMY_SORT__ :: HasCallStack => Sort+__DUMMY_SORT__ = withCallerCallStack dummySort++-- | A dummy type created at location.+--   Note: use macro __DUMMY_TYPE__ !+dummyType :: CallStack -> Type+dummyType cs = El (dummySort cs) $ dummyTermWith "dummyType" cs++__DUMMY_TYPE__ :: HasCallStack => Type+__DUMMY_TYPE__ = withCallerCallStack dummyType++-- | Context entries without a type have this dummy type.+--   Note: use macro __DUMMY_DOM__ !+dummyDom :: CallStack -> Dom Type+dummyDom = defaultDom . dummyType++__DUMMY_DOM__ :: HasCallStack => Dom Type+__DUMMY_DOM__ = withCallerCallStack dummyDom++-- | Constant level @n@+pattern ClosedLevel :: Integer -> Level+pattern ClosedLevel n = Max n []++atomicLevel :: t -> Level' t+atomicLevel a = Max 0 [ Plus 0 a ]++varSort :: Int -> Sort+varSort n = Type $ atomicLevel $ var n++tmSort :: Term -> Sort+tmSort t = Type $ atomicLevel t++tmSSort :: Term -> Sort+tmSSort t = SSet $ atomicLevel t++-- | Given a constant @m@ and level @l@, compute @m + l@+levelPlus :: Integer -> Level -> Level+levelPlus m (Max n as) = Max (m + n) $ map pplus as+  where pplus (Plus n l) = Plus (m + n) l++levelSuc :: Level -> Level+levelSuc = levelPlus 1++mkType :: Integer -> Sort+mkType n = Type $ ClosedLevel n++mkProp :: Integer -> Sort+mkProp n = Prop $ ClosedLevel n++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++-- | 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.+---------------------------------------------------------------------------++-- | A traversal for the names in a telescope.+mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a)+mapAbsNamesM f EmptyTel                  = pure EmptyTel+mapAbsNamesM f (ExtendTel a (  Abs x b)) = ExtendTel a <$> (  Abs <$> f x <*> mapAbsNamesM f b)+mapAbsNamesM f (ExtendTel a (NoAbs x b)) = ExtendTel a <$> (NoAbs <$> f x <*> mapAbsNamesM f b)+  -- Ulf, 2013-11-06: Last case is really impossible but I'd rather find out we+  --                  violated that invariant somewhere other than here.++mapAbsNames :: (ArgName -> ArgName) -> Tele a -> Tele a+mapAbsNames f = runIdentity . mapAbsNamesM (Identity . f)++-- Ulf, 2013-11-06+-- The record parameter is named "" inside the record module so we can avoid+-- printing it (issue 208), but we don't want that to show up in the type of+-- the functions in the module (issue 892). This function is used on the record+-- module telescope before adding it to a type in+-- TypeChecking.Monad.Signature.addConstant (to handle functions defined in+-- record modules) and TypeChecking.Rules.Record.checkProjection (to handle+-- record projections).+replaceEmptyName :: ArgName -> Tele a -> Tele a+replaceEmptyName x = mapAbsNames $ \ y -> if null y then x else y++-- | Telescope as list.+type ListTel' a = [Dom (a, Type)]+type ListTel = ListTel' ArgName++telFromList' :: (a -> ArgName) -> ListTel' a -> Telescope+telFromList' f = List.foldr extTel EmptyTel+  where+    extTel dom@Dom{unDom = (x, a)} = ExtendTel (dom{unDom = a}) . Abs (f x)++-- | Convert a list telescope to a telescope.+telFromList :: ListTel -> Telescope+telFromList = telFromList' id++-- | Convert a telescope to its list form.+telToList :: Tele (Dom t) -> [Dom (ArgName,t)]+telToList EmptyTel                    = []+telToList (ExtendTel arg (Abs x tel)) = fmap (x,) arg : telToList tel+telToList (ExtendTel _    NoAbs{}   ) = __IMPOSSIBLE__++-- | Lens to edit a 'Telescope' as a list.+listTel :: Lens' Telescope ListTel+listTel f = fmap telFromList . f . telToList++-- | Drop the types from a telescope.+class TelToArgs a where+  telToArgs :: a -> [Arg ArgName]++instance TelToArgs ListTel where+  telToArgs = map $ \ dom -> Arg (domInfo dom) (fst $ unDom dom)++instance TelToArgs Telescope where+  telToArgs = telToArgs . telToList++-- | Constructing a singleton telescope.+class SgTel a where+  sgTel :: a -> Telescope++instance SgTel (ArgName, Dom Type) where+  sgTel (x, !dom) = ExtendTel dom $ Abs x EmptyTel++instance SgTel (Dom (ArgName, Type)) where+  sgTel dom = ExtendTel (snd <$> dom) $ Abs (fst $ unDom dom) EmptyTel++instance SgTel (Dom Type) where+  sgTel dom = sgTel (stringToArgName "_", dom)++---------------------------------------------------------------------------+-- * Simple operations on terms and types.+---------------------------------------------------------------------------++-- | Removing a topmost 'DontCare' constructor.+stripDontCare :: Term -> Term+stripDontCare = \case+  DontCare v -> v+  v          -> v++-- | Doesn't do any reduction.+arity :: Type -> Nat+arity t = case unEl t of+  Pi  _ b -> 1 + arity (unAbs b)+  _       -> 0++-- | Suggest a name if available (i.e. name is not "_")+class Suggest a where+  suggestName :: a -> Maybe String++instance Suggest String where+  suggestName "_" = Nothing+  suggestName  x  = Just x++instance Suggest (Abs b) where+  suggestName = suggestName . absName++instance Suggest Name where+  suggestName = suggestName . nameToArgName++instance Suggest Term where+  suggestName (Lam _ v) = suggestName v+  suggestName _         = Nothing++-- Wrapping @forall a. (Suggest a) => a@ into a datatype because+-- GHC doesn't support impredicative polymorphism+data Suggestion = forall a. Suggest a => Suggestion a++suggests :: [Suggestion] -> String+suggests []     = "x"+suggests (Suggestion x : xs) = fromMaybe (suggests xs) $ suggestName x++---------------------------------------------------------------------------+-- * Eliminations.+---------------------------------------------------------------------------++-- | Convert top-level postfix projections into prefix projections.+unSpine :: Term -> Term+unSpine = unSpine' $ \_ _ -> True++-- | Convert 'Proj' projection eliminations+--   according to their 'ProjOrigin' into+--   'Def' projection applications.+unSpine' :: (ProjOrigin -> QName -> Bool) -> Term -> Term+unSpine' p v =+  case hasElims v of+    Just (h, es) -> loop h [] es+    Nothing      -> v+  where+    loop :: (Elims -> Term) -> Elims -> Elims -> Term+    loop h res es =+      case es of+        []                     -> 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+--   can be projected.+hasElims :: Term -> Maybe (Elims -> Term, Elims)+hasElims v =+  case v of+    Var   i es -> Just (Var   i, es)+    Def   f es -> Just (Def   f, es)+    MetaV x es -> Just (MetaV x, es)+    Con{}      -> Nothing+    Lit{}      -> Nothing+    Lam{}      -> Nothing+    Pi{}       -> Nothing+    Sort{}     -> Nothing+    Level{}    -> Nothing+    DontCare{} -> Nothing+    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.+---------------------------------------------------------------------------++instance Null (Tele a) where+  empty = EmptyTel+  null EmptyTel    = True+  null ExtendTel{} = False++-- | 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 empty empty empty empty empty+  null (Clause _ _ tel pats body _ _ _ _ _ wm)+    =  null tel+    && null pats+    && null body+    && null wm+++---------------------------------------------------------------------------+-- * Show instances.+---------------------------------------------------------------------------++instance Show a => Show (Abs a) where+  showsPrec p (Abs x a) = showParen (p > 0) $+    showString "Abs " . shows x . showString " " . showsPrec 10 a+  showsPrec p (NoAbs x a) = showParen (p > 0) $+    showString "NoAbs " . shows x . showString " " . showsPrec 10 a++-- instance Show t => Show (Blocked t) where+--   showsPrec p (Blocked m x) = showParen (p > 0) $+--     showString "Blocked " . shows m . showString " " . showsPrec 10 x+--   showsPrec p (NotBlocked x) = showsPrec p x++---------------------------------------------------------------------------+-- * Sized instances and TermSize.+---------------------------------------------------------------------------++-- | The size of a telescope is its length (as a list).+instance Sized (Tele a) where+  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+  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+--   correctness of Agda, it is only used for reporting+--   (and maybe decisions regarding performance).+--+--   Not counting towards the term size are:+--+--     * sort and color annotations,+--     * projections.+--+class TermSize a where+  termSize :: a -> Int+  termSize = getSum . tsize++  tsize :: a -> Sum Int++instance {-# OVERLAPPABLE #-} (Foldable t, TermSize a) => TermSize (t a) where+  tsize = foldMap tsize++instance TermSize Term where+  tsize = \case+    Var _ vs    -> 1 + tsize vs+    Def _ vs    -> 1 + tsize vs+    Con _ _ vs    -> 1 + tsize vs+    MetaV _ vs  -> 1 + tsize vs+    Level l     -> tsize l+    Lam _ f     -> 1 + tsize f+    Lit _       -> 1+    Pi a b      -> 1 + tsize a + tsize b+    Sort s      -> tsize s+    DontCare mv -> tsize mv+    Dummy{}     -> 1++instance TermSize Sort where+  tsize = \case+    Univ _ l  -> 1 + tsize l+    Inf _ _   -> 1+    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+    MetaS _ es -> 1 + tsize es+    DefS _ es  -> 1 + tsize es+    DummyS{}   -> 1++instance TermSize Level where+  tsize (Max _ as) = 1 + tsize as++instance TermSize PlusLevel where+  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++---------------------------------------------------------------------------+-- * KillRange instances.+---------------------------------------------------------------------------++instance KillRange DataOrRecord where+  killRange = id++instance KillRange ConHead where+  killRange (ConHead c d i fs) = killRangeN ConHead c d i fs++instance KillRange Term where+  killRange = \case+    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) = killRangeN (Max n) as++instance KillRange PlusLevel where+  killRange (Plus n l) = killRangeN (Plus n) l++instance (KillRange a) => KillRange (Type' a) where+  killRange (El s v) = killRangeN El s v++instance KillRange Sort where+  killRange = \case+    Inf u n    -> Inf u n+    SizeUniv   -> SizeUniv+    LockUniv   -> LockUniv+    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)             = 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) = killRangeN PatternInfo o xs++instance KillRange ConPatternInfo where+  killRange (ConPatternInfo i mr b mt lz) = killRangeN (ConPatternInfo i mr b) mt lz++instance KillRange DBPatVar where+  killRange (DBPatVar x i) = killRangeN DBPatVar x i++instance KillRange a => KillRange (Pattern' a) where+  killRange p =+    case p of+      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 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++instance KillRange a => KillRange (Blocked a) where+  killRange = fmap killRange++instance KillRange a => KillRange (Abs a) where+  killRange = fmap killRange++-----------------------------------------------------------------------------+-- * Simple pretty printing+-----------------------------------------------------------------------------++instance Pretty a => Pretty (Substitution' a) where+  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 _ 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 =+    case v of+      Var x els -> text ("@" ++ show x) `pApp` els+      Lam ai b   ->+        mparens (p > 0) $+        sep [ "λ" <+> prettyHiding ai id (text . absName $ b) <+> "->"+            , nest 2 $ pretty (unAbs b) ]+      Lit l                -> pretty l+      Def q els            -> pretty q `pApp` els+      Con c ci vs          -> pretty (conName c) `pApp` vs+      Pi a (NoAbs _ b)     -> mparens (p > 0) $+        sep [ pretty (getModality a) <+> prettyPrec 1 (unDom a) <+> "->"+            , nest 2 $ pretty b ]+      Pi a b               -> mparens (p > 0) $+        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+      MetaV x els -> pretty x `pApp` els+      DontCare v  -> prettyPrec p v+      Dummy s es  -> parens (text s) `pApp` es+    where+      pApp d els = mparens (not (null els) && p > 9) $+                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]++instance Pretty t => Pretty (Abs t) where+  pretty (Abs   x t) = "Abs"   <+> (text x <> ".") <+> pretty t+  pretty (NoAbs x t) = "NoAbs" <+> (text x <> ".") <+> pretty t++instance (Pretty t, Pretty e) => Pretty (Dom' t e) where+  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 =+  case getHiding i of+    NotHidden  -> parens+    Hidden     -> braces+    Instance{} -> braces . braces++instance Pretty Clause where+  pretty Clause{clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t} =+    sep [ pretty tel <+> "|-"+        , nest 2 $ sep [ fsep (map (prettyPrec 10) ps) <+> "="+                       , nest 2 $ pBody b t ] ]+    where+      pBody Nothing _ = "(absurd)"+      pBody (Just b) Nothing  = pretty b+      pBody (Just b) (Just t) = sep [ pretty b <+> ":", nest 2 $ pretty t ]++instance Pretty a => Pretty (Tele (Dom a)) where+  pretty tel = fsep [ pDom a (text x <+> ":" <+> pretty (unDom a)) | (x, a) <- telToList tel ]+    where+      telToList EmptyTel = []+      telToList (ExtendTel a tel) = (absName tel, a) : telToList (unAbs tel)++prettyPrecLevelSucs :: Int -> Integer -> (Int -> Doc) -> Doc+prettyPrecLevelSucs p 0 d = d p+prettyPrecLevelSucs p n d = mparens (p > 9) $ "lsuc" <+> prettyPrecLevelSucs 10 (n - 1) d++instance Pretty Level where+  prettyPrec p (Max n as) =+    case as of+      []  -> prettyN+      [a] | n == 0 -> prettyPrec p a+      _   -> mparens (p > 9) $ List.foldr1 (\a b -> "lub" <+> a <+> b) $+        [ prettyN | n > 0 ] ++ map (prettyPrec 10) as+    where+      prettyN = prettyPrecLevelSucs p n (const "lzero")++instance Pretty PlusLevel where+  prettyPrec p (Plus n a) = prettyPrecLevelSucs p n $ \p -> prettyPrec p a++instance Pretty Sort where+  prettyPrec p s =+    case s of+      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) <+> ":" <+> 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+      MetaS x es -> prettyPrec p $ MetaV x es+      DefS d es  -> prettyPrec p $ Def d es+      DummyS s   -> parens $ text s+   where+     suffix n = applyWhen (n /= 0) (++ show n)++instance Pretty Type where+  prettyPrec p (El _ a) = prettyPrec p a++instance Pretty DBPatVar where+  prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x)++instance Pretty a => Pretty (Pattern' a) where+  prettyPrec n (VarP _o x)   = prettyPrec n x+  prettyPrec _ (DotP _o t)   = "." <> prettyPrec 10 t+  prettyPrec n (ConP c i nps)= mparens (n > 0 && not (null nps)) $+    (lazy <> pretty (conName c)) <+> fsep (map (prettyPrec 10) ps)+    where ps = map (fmap namedThing) nps+          lazy | conPLazy i = "~"+               | otherwise  = empty+  prettyPrec n (DefP o q nps)= mparens (n > 0 && not (null nps)) $+    pretty q <+> fsep (map (prettyPrec 10) ps)+    where ps = map (fmap namedThing) nps+  -- -- Version with printing record type:+  -- prettyPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $+  --   text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)+  --   where+  --     b = maybe False (== ConOSystem) $ conPRecord i+  --     prTy d = caseMaybe (conPType i) d $ \ t -> d  <+> ":" <+> pretty t+  prettyPrec _ (LitP _ l)    = pretty l+  prettyPrec _ (ProjP _o q)  = text ("." ++ prettyShow q)+  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+-----------------------------------------------------------------------------++-- Note: only strict in the shape of the terms.++instance NFData Term where+  rnf = \case+    Var _ es   -> rnf es+    Lam _ b    -> rnf (unAbs b)+    Lit l      -> rnf l+    Def _ es   -> rnf es+    Con _ _ vs -> rnf vs+    Pi a b     -> rnf (unDom a, unAbs b)+    Sort s     -> rnf s+    Level l    -> rnf l+    MetaV _ es -> rnf es+    DontCare v -> rnf v+    Dummy _ es -> rnf es++instance NFData Type where+  rnf (El s v) = rnf (s, v)++instance NFData Sort where+  rnf = \case+    Univ _ l   -> rnf l+    Inf _ _  -> ()+    SizeUniv -> ()+    LockUniv -> ()+    LevelUniv -> ()+    IntervalUniv -> ()+    PiSort a b c -> rnf (a, b, unAbs c)+    FunSort a b -> rnf (a, b)+    UnivSort a -> rnf a+    MetaS _ es -> rnf es+    DefS _ es  -> rnf es+    DummyS _   -> ()++instance NFData Level where+  rnf (Max n as) = rnf (n, as)++instance NFData PlusLevel where+  rnf (Plus n l) = rnf (n, l)++instance NFData e => NFData (Dom e) where+  rnf (Dom a c d e f) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f++instance NFData a => NFData (DataOrRecord' a)+instance NFData ConHead+instance NFData a => NFData (Abs a)+instance NFData a => NFData (Tele a)+instance NFData IsFibrant+instance NFData Clause+instance NFData PatternInfo+instance NFData PatOrigin+instance NFData x => NFData (Pattern' x)+instance NFData DBPatVar+instance NFData ConPatternInfo+instance NFData a => NFData (Substitution' a)
+ src/full/Agda/Syntax/Internal/Blockers.hs view
@@ -0,0 +1,319 @@++module Agda.Syntax.Internal.Blockers where++import Control.DeepSeq++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Semigroup++import GHC.Generics (Generic)++import Agda.Syntax.Common+import Agda.Syntax.Abstract.Name (QName)+import Agda.Syntax.Internal.Elim++import Agda.Syntax.Common.Pretty hiding ((<>))+import Agda.Utils.Functor++---------------------------------------------------------------------------+-- * Blocked Terms+---------------------------------------------------------------------------++-- | Even if we are not stuck on a meta during reduction+--   we can fail to reduce a definition by pattern matching+--   for another reason.+data NotBlocked' t+  = StuckOn (Elim' t)+    -- ^ The 'Elim' is neutral and blocks a pattern match.+  | Underapplied+    -- ^ Not enough arguments were supplied to complete the matching.+  | AbsurdMatch+    -- ^ We matched an absurd clause, results in a neutral 'Def'.+  | 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.+    --   See "Agda.TypeChecking.Patterns.Match".+  | ReallyNotBlocked+    -- ^ Reduction was not blocked, we reached a whnf+    --   which can be anything but a stuck @'Def'@.+  deriving (Show, Generic)++-- | 'ReallyNotBlocked' is the unit.+--   'MissingClauses' is dominant.+--   @'StuckOn'{}@ should be propagated, if tied, we take the left.+instance Semigroup (NotBlocked' t) where+  ReallyNotBlocked <> b = b+  -- MissingClauses is dominant (absorptive)+  b@MissingClauses{} <> _ = b+  _ <> b@MissingClauses{} = b+  -- StuckOn is second strongest+  b@StuckOn{}      <> _ = b+  _ <> b@StuckOn{}      = b+  b <> _                = b++instance Monoid (NotBlocked' t) where+  -- ReallyNotBlocked is neutral+  mempty  = ReallyNotBlocked+  mappend = (<>)++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+             | UnblockOnDef QName       -- ^ Unblock when function is defined+  deriving (Show, Eq, Ord, Generic)++instance NFData Blocker++alwaysUnblock :: Blocker+alwaysUnblock = UnblockOnAll Set.empty++neverUnblock :: Blocker+neverUnblock = UnblockOnAny Set.empty++unblockOnAll :: Set Blocker -> Blocker+unblockOnAll us =+  case allViewS us of+    us | [u] <- Set.toList us -> u+    us                        -> UnblockOnAll us+  where+    allViewS = Set.unions . map allView . Set.toList+    allView (UnblockOnAll us) = allViewS us+    allView u                 = Set.singleton u++unblockOnAny :: Set Blocker -> Blocker+unblockOnAny us =+  case anyViewS us of+    us | [u] <- Set.toList us        -> u+    us | Set.member alwaysUnblock us -> alwaysUnblock+       | otherwise                   -> UnblockOnAny us+  where+    anyViewS = Set.unions . map anyView . Set.toList+    anyView (UnblockOnAny us) = anyViewS us+    anyView u                 = Set.singleton u++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++unblockOnAnyMeta :: Set MetaId -> Blocker+unblockOnAnyMeta = unblockOnAny . Set.mapMonotonic unblockOnMeta++onBlockingMetasM :: Monad m => (MetaId -> m Blocker) -> Blocker -> m Blocker+onBlockingMetasM f (UnblockOnAll bs)    = unblockOnAll . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs)+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++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 (Show, Functor, Foldable, Traversable, Generic)++instance Decoration (Blocked' t) where+  traverseF f (Blocked b x)     = Blocked b <$> f x+  traverseF f (NotBlocked nb x) = NotBlocked nb <$> f x++-- | Blocking on _all_ blockers.+instance Applicative (Blocked' t) where+  pure = notBlocked+  f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)++instance Semigroup a => Semigroup (Blocked' t a) where+  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)++instance (Semigroup a, Monoid a) => Monoid (Blocked' t a) where+  mempty = notBlocked mempty+  mappend = (<>)++instance (NFData t, NFData a) => NFData (Blocked' t a)++-- | When trying to reduce @f es@, on match failed on one+--   elimination @e ∈ es@ that came with info @r :: NotBlocked@.+--   @stuckOn e r@ produces the new @NotBlocked@ info.+--+--   'MissingClauses' must be propagated, as this is blockage+--   that can be lifted in the future (as more clauses are added).+--+--   @'StuckOn' e0@ is also propagated, since it provides more+--   precise information as @StuckOn e@ (as @e0@ is the original+--   reason why reduction got stuck and usually a subterm of @e@).+--   An information like @StuckOn (Apply (Arg info (Var i [])))@+--   (stuck on a variable) could be used by the lhs/coverage checker+--   to trigger a split on that (pattern) variable.+--+--   In the remaining cases for @r@, we are terminally stuck+--   due to @StuckOn e@.  Propagating @'AbsurdMatch'@ does not+--   seem useful.+--+--   'Underapplied' must not be propagated, as this would mean+--   that @f es@ is underapplied, which is not the case (it is stuck).+--   Note that 'Underapplied' can only arise when projection patterns were+--   missing to complete the original match (in @e@).+--   (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 = \case+    r@MissingClauses{} -> r+    r@StuckOn{}        -> r+    Underapplied     -> r'+    AbsurdMatch      -> r'+    ReallyNotBlocked -> r'+  where r' = StuckOn e++---------------------------------------------------------------------------+-- * Handling blocked terms.+---------------------------------------------------------------------------++blockedOn :: Blocker -> a -> Blocked' t a+blockedOn b | alwaysUnblock == b = notBlocked+            | otherwise          = Blocked b++blocked :: MetaId -> a -> Blocked' t a+blocked = Blocked . unblockOnMeta++notBlocked :: a -> Blocked' t a+notBlocked = NotBlocked ReallyNotBlocked++blocked_ :: MetaId -> Blocked' t ()+blocked_ x = blocked x ()++notBlocked_ :: Blocked' t ()+notBlocked_ = notBlocked ()++getBlocker :: Blocked' t a -> Blocker+getBlocker (Blocked b _) = b+getBlocker NotBlocked{}  = neverUnblock++-----------------------------------------------------------------------------+-- * Waking up logic+-----------------------------------------------------------------------------++-- | Should a constraint wake up or not? If not, we might refine the unblocker.+data WakeUp = WakeUp | DontWakeUp (Maybe Blocker)+  deriving (Show, Eq)++wakeUpWhen :: (constr -> Bool) -> (constr -> WakeUp) -> constr -> WakeUp+wakeUpWhen guard wake c | guard c   = wake c+                        | otherwise = DontWakeUp Nothing++wakeUpWhen_ :: (constr -> Bool) -> constr -> WakeUp+wakeUpWhen_ p = wakeUpWhen p (const WakeUp)++wakeIfBlockedOnProblem :: ProblemId -> Blocker -> WakeUp+wakeIfBlockedOnProblem pid u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  where+    u' = unblockProblem pid u++wakeIfBlockedOnMeta :: MetaId -> Blocker -> WakeUp+wakeIfBlockedOnMeta x u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  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++unblockProblem :: ProblemId -> Blocker -> Blocker+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,5 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Extract used definitions from terms.+ module Agda.Syntax.Internal.Defs where  import Control.Monad.Reader@@ -38,14 +40,22 @@   doMeta x = getDefs . ($ x) =<< asks lookupMeta  -- | Getting the used definitions.+--+-- Note: in contrast to 'Agda.Syntax.Internal.Generic.foldTerm'+-- @getDefs@ also collects from sorts in terms.+-- Thus, this is not an instance of @foldTerm@.+ class GetDefs a where   getDefs :: MonadGetDefs m => a -> m () +  default getDefs :: (MonadGetDefs m, Foldable f, GetDefs b, f b ~ a) => a -> m ()+  getDefs = Fold.mapM_ getDefs+ instance GetDefs Clause where   getDefs = getDefs . clauseBody  instance GetDefs Term where-  getDefs v = case v of+  getDefs = \case     Def d vs   -> doDef d >> getDefs vs     Con _ _ vs -> getDefs vs     Lit l      -> return ()@@ -56,7 +66,7 @@     Level l    -> getDefs l     MetaV x vs -> getDefs x >> getDefs vs     DontCare v -> getDefs v-    Shared p   -> getDefs $ derefPtr p  -- TODO: exploit sharing!+    Dummy{}    -> return ()  instance GetDefs MetaId where   getDefs x = doMeta x@@ -65,46 +75,42 @@   getDefs (El s t) = getDefs s >> getDefs t  instance GetDefs Sort where-  getDefs s = case s of-    Type l    -> getDefs l-    Prop      -> return ()-    Inf       -> return ()+  getDefs = \case+    Univ _ l  -> getDefs l+    Inf _ _   -> return ()     SizeUniv  -> return ()-    DLub s s' -> getDefs s >> getDefs s'+    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+    MetaS x es  -> getDefs x >> getDefs es+    DefS d es   -> doDef d >> getDefs es+    DummyS{}    -> return ()  instance GetDefs Level where-  getDefs (Max ls) = getDefs ls+  getDefs (Max _ ls) = getDefs ls  instance GetDefs PlusLevel where-  getDefs ClosedLevel{} = return ()   getDefs (Plus _ l)    = getDefs l -instance GetDefs LevelAtom where-  getDefs a = case a of-    MetaLevel x vs   -> getDefs x >> getDefs vs-    BlockedLevel _ v -> getDefs v-    NeutralLevel _ v -> getDefs v-    UnreducedLevel v -> getDefs v- -- collection instances  instance GetDefs a => GetDefs (Maybe a) where-  getDefs = Fold.mapM_ getDefs--instance GetDefs a => GetDefs [a] where-  getDefs = Fold.mapM_ getDefs-+instance GetDefs a => GetDefs [a]       where instance GetDefs a => GetDefs (Elim' a) where-  getDefs = Fold.mapM_ getDefs+instance GetDefs a => GetDefs (Arg a)   where+instance GetDefs a => GetDefs (Dom a)   where+instance GetDefs a => GetDefs (Abs a)   where -instance GetDefs a => GetDefs (Arg a) where-  getDefs = getDefs . unArg+instance (GetDefs a, GetDefs b) => GetDefs (a,b) where+  getDefs (a,b) = getDefs a >> getDefs b -instance GetDefs a => GetDefs (Dom a) where-  getDefs = getDefs . unDom+instance GetDefs Telescope where+  getDefs = getDefs . telToList -instance GetDefs a => GetDefs (Abs a) where-  getDefs = getDefs . unAbs+-- no defs here -instance (GetDefs a, GetDefs b) => GetDefs (a,b) where-  getDefs (a,b) = getDefs a >> getDefs b+instance {-# OVERLAPPING #-} GetDefs String where+  getDefs _ = return ()
+ src/full/Agda/Syntax/Internal/Elim.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Syntax.Internal.Elim where++import Control.DeepSeq++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Abstract.Name++import Agda.Syntax.Common.Pretty+import Agda.Utils.Empty+import Agda.Utils.Maybe+import Agda.Utils.Tuple++-- | Eliminations, subsuming applications and projections.+--+data Elim' a+  = 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 (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'.+--   Same for IApply+instance LensOrigin (Elim' a) where+  getOrigin (Apply a)   = getOrigin a+  getOrigin Proj{}      = UserWritten+  getOrigin IApply{}    = UserWritten+  mapOrigin f (Apply a) = Apply $ mapOrigin f a+  mapOrigin f e@Proj{}  = e+  mapOrigin f e@IApply{} = e++-- | Drop 'Apply' constructor. (Safe)+isApplyElim :: Elim' a -> Maybe (Arg a)+isApplyElim (Apply u) = Just u+isApplyElim Proj{}    = Nothing+isApplyElim (IApply _ _ r) = Just (defaultArg r)++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++-- | Split at first non-'Apply'+splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])+splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es+splitApplyElims es             = ([], es)++class IsProjElim e where+  isProjElim  :: e -> Maybe (ProjOrigin, QName)++instance IsProjElim (Elim' a) where+  isProjElim (Proj o d) = Just (o, d)+  isProjElim Apply{}    = Nothing+  isProjElim IApply{} = Nothing++-- | Discards @Proj f@ entries.+argsFromElims :: [Elim' t] -> [Arg t]+argsFromElims = mapMaybe isApplyElim++-- | Drop 'Proj' constructors. (Safe)+allProjElims :: [Elim' t] -> Maybe [(ProjOrigin, QName)]+allProjElims = mapM isProjElim++instance KillRange a => KillRange (Elim' a) where+  killRange = fmap killRange++instance Pretty tm => Pretty (Elim' tm) where+  prettyPrec p (Apply v)    = prettyPrec p v+  prettyPrec _ (Proj _o x)  = text ("." ++ prettyShow x)+  prettyPrec p (IApply x y r) = prettyPrec p r+--  prettyPrec p (IApply x y r) = text "@[" <> prettyPrec 0 x <> text ", " <> prettyPrec 0 y <> text "]" <> prettyPrec p r++instance NFData a => NFData (Elim' a) where+  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,126 +1,89 @@-{-# LANGUAGE CPP               #-} +-- | Tree traversal for internal syntax.+ module Agda.Syntax.Internal.Generic where -import Control.Applicative-import Data.Traversable-import Data.Monoid-import Data.Foldable import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Utils.Functor+import Agda.Utils.List1 (List1) +-- | Generic term traversal.+--+--   Note: ignores sorts in terms!+--   (Does not traverse into or collect from them.)+ class TermLike a where-  traverseTerm :: (Term -> Term) -> a -> a-  traverseTermM-#if __GLASGOW_HASKELL__ <= 708-    :: (Applicative m, Monad m)-#else-    :: Monad m-#endif-    => (Term -> m Term) -> a -> m a++  -- | Generic traversal with post-traversal action.+  --   Ignores sorts.+  traverseTermM :: Monad m => (Term -> m Term) -> a -> m a++  default traverseTermM :: (Monad m, Traversable f, TermLike b, f b ~ a)+                        => (Term -> m Term) -> a -> m a+  traverseTermM = traverse . traverseTermM++  -- | Generic fold, ignoring sorts.   foldTerm :: Monoid m => (Term -> m) -> a -> m --- * Constants+  default foldTerm+    :: (Monoid m, Foldable f, TermLike b, f b ~ a) => (Term -> m) -> a -> m+  foldTerm = foldMap . foldTerm +-- Constants+ instance TermLike Bool where-  traverseTerm  _ = id   traverseTermM _ = pure   foldTerm _      = mempty  instance TermLike Int where-  traverseTerm  _ = id   traverseTermM _ = pure   foldTerm _      = mempty  instance TermLike Integer where-  traverseTerm  _ = id   traverseTermM _ = pure   foldTerm _      = mempty  instance TermLike Char where-  traverseTerm  _ = id   traverseTermM _ = pure   foldTerm _      = mempty  instance TermLike QName where-  traverseTerm  _ = id   traverseTermM _ = pure   foldTerm _      = mempty --- * Functors--instance TermLike a => TermLike (Elim' a) where-  traverseTerm  f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)--instance TermLike a => TermLike (Arg a) where-  traverseTerm  f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)--instance TermLike a => TermLike (Dom a) where-  traverseTerm  f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)+-- Functors -instance TermLike a => TermLike [a] where-  traverseTerm f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)+instance TermLike a => TermLike (Elim' a)      where+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+instance TermLike a => TermLike (Tele a)       where+instance TermLike a => TermLike (WithHiding a) where -instance TermLike a => TermLike (Maybe a) where-  traverseTerm f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)+-- Tuples  instance (TermLike a, TermLike b) => TermLike (a, b) where-  traverseTerm f (x, y) = (traverseTerm f x, traverseTerm f y)   traverseTermM f (x, y) = (,) <$> traverseTermM f x <*> traverseTermM f y   foldTerm f (x, y) = foldTerm f x `mappend` foldTerm f y  instance (TermLike a, TermLike b, TermLike c) => TermLike (a, b, c) where-  traverseTerm f (x, y, z) = (traverseTerm f x, traverseTerm f y, traverseTerm f z)   traverseTermM f (x, y, z) = (,,) <$> traverseTermM f x <*> traverseTermM f y <*> traverseTermM f z   foldTerm f (x, y, z) = mconcat [foldTerm f x, foldTerm f y, foldTerm f z]  instance (TermLike a, TermLike b, TermLike c, TermLike d) => TermLike (a, b, c, d) where-  traverseTerm f (x, y, z, u) = (traverseTerm f x, traverseTerm f y, traverseTerm f z, traverseTerm f u)   traverseTermM f (x, y, z, u) = (,,,) <$> traverseTermM f x <*> traverseTermM f y <*> traverseTermM f z <*> traverseTermM f u   foldTerm f (x, y, z, u) = mconcat [foldTerm f x, foldTerm f y, foldTerm f z, foldTerm f u] -instance TermLike a => TermLike (Abs a) where-  traverseTerm f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)--instance TermLike a => TermLike (Ptr a) where-  traverseTerm f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)--instance TermLike a => TermLike (Blocked a) where-  traverseTerm f = fmap (traverseTerm f)-  traverseTermM f = traverse (traverseTermM f)-  foldTerm f = foldMap (foldTerm f)---- * Real terms+-- Real terms  instance TermLike Term where-  traverseTerm f t = case t of-    Var i xs    -> f $ Var i $ traverseTerm f xs-    Def c xs    -> f $ Def c $ traverseTerm f xs-    Con c ci xs -> f $ Con c ci $ traverseTerm f xs-    Lam h b     -> f $ Lam h $ traverseTerm f b-    Pi a b      -> f $ uncurry Pi $ traverseTerm f (a, b)-    MetaV m xs  -> f $ MetaV m $ traverseTerm f xs-    Level l     -> f $ Level $ traverseTerm f l-    Lit _       -> f t-    Sort _      -> f t-    DontCare mv -> f $ DontCare $ traverseTerm f mv-    Shared p    -> f $ Shared $ traverseTerm f p -  traverseTermM f t = case t of+  traverseTermM f = \case     Var i xs    -> f =<< Var i <$> traverseTermM f xs     Def c xs    -> f =<< Def c <$> traverseTermM f xs     Con c ci xs -> f =<< Con c ci <$> traverseTermM f xs@@ -128,10 +91,10 @@     Pi a b      -> f =<< uncurry Pi <$> traverseTermM f (a, b)     MetaV m xs  -> f =<< MetaV m <$> traverseTermM f xs     Level l     -> f =<< Level <$> traverseTermM f l-    Lit _       -> f t-    Sort _      -> f t+    t@Lit{}     -> f t+    Sort s      -> f =<< Sort <$> traverseTermM f s     DontCare mv -> f =<< DontCare <$> traverseTermM f mv-    Shared p    -> f =<< Shared <$> traverseTermM f p+    Dummy s xs  -> f =<< Dummy s <$> traverseTermM f xs    foldTerm f t = f t `mappend` case t of     Var i xs    -> foldTerm f xs@@ -142,77 +105,69 @@     MetaV m xs  -> foldTerm f xs     Level l     -> foldTerm f l     Lit _       -> mempty-    Sort _      -> mempty+    Sort s      -> foldTerm f s     DontCare mv -> foldTerm f mv-    Shared p    -> foldTerm f p+    Dummy _ xs  -> foldTerm f xs  instance TermLike Level where-  traverseTerm f  (Max as) = Max $ traverseTerm f as-  traverseTermM f (Max as) = Max <$> traverseTermM f as-  foldTerm f      (Max as) = foldTerm f as+  traverseTermM f (Max n as) = Max n <$> traverseTermM f as+  foldTerm f      (Max n as) = foldTerm f as  instance TermLike PlusLevel where-  traverseTerm f l = case l of-    ClosedLevel{} -> l-    Plus n l      -> Plus n $ traverseTerm f l-  traverseTermM f l = case l of-    ClosedLevel{} -> return l-    Plus n l      -> Plus n <$> traverseTermM f l-  foldTerm f ClosedLevel{} = mempty-  foldTerm f (Plus _ l)    = foldTerm f l--instance TermLike LevelAtom where-  traverseTerm f l = case l of-    MetaLevel m vs   -> MetaLevel m $ traverseTerm f vs-    NeutralLevel r v -> NeutralLevel r $ traverseTerm f v-    BlockedLevel m v -> BlockedLevel m $ traverseTerm f v-    UnreducedLevel v -> UnreducedLevel $ traverseTerm f v-  traverseTermM f l = case l of-    MetaLevel m vs   -> MetaLevel m <$> traverseTermM f vs-    NeutralLevel r v -> NeutralLevel r <$> traverseTermM f v-    BlockedLevel m v -> BlockedLevel m <$> traverseTermM f v-    UnreducedLevel v -> UnreducedLevel <$> traverseTermM f v-  foldTerm f l = case l of-    MetaLevel m vs   -> foldTerm f vs-    NeutralLevel _ v -> foldTerm f v-    BlockedLevel _ v -> foldTerm f v-    UnreducedLevel v -> foldTerm f v+  traverseTermM f (Plus n l) = Plus n <$> traverseTermM f l+  foldTerm f (Plus _ l)      = foldTerm f l  instance TermLike Type where-  traverseTerm f (El s t) = El s $ traverseTerm f t   traverseTermM f (El s t) = El s <$> traverseTermM f t   foldTerm f (El s t) = foldTerm f t -instance TermLike EqualityView where+instance TermLike Sort where+  traverseTermM f = \case+    Univ u l   -> Univ u <$> traverseTermM f l+    s@(Inf _ _)-> pure s+    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 -  traverseTerm f v = case v of-    OtherType t -> OtherType-      (traverseTerm f t)-    EqualityType s eq l t a b -> EqualityType s eq-      (traverseTerm f l)-      (traverseTerm f t)-      (traverseTerm f a)-      (traverseTerm f b)+  foldTerm f = \case+    Univ _ l   -> foldTerm f l+    Inf _ _    -> mempty+    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 -  traverseTermM f v = case v of+instance TermLike EqualityView where++  traverseTermM f = \case     OtherType t -> OtherType       <$> traverseTermM f t-    EqualityType s eq l t a b -> EqualityType s eq-      <$> traverseTermM f l+    IdiomType t -> IdiomType+      <$> traverseTermM f t+    EqualityType r s eq l t a b -> EqualityType r s eq+      <$> traverse (traverseTermM f) l       <*> traverseTermM f t       <*> traverseTermM f a       <*> traverseTermM f b -  foldTerm f v = case v of+  foldTerm f = \case     OtherType t -> foldTerm f t-    EqualityType s eq l t a b -> foldTerm f [l, t, a, b]+    IdiomType t -> foldTerm f t+    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-#if __GLASGOW_HASKELL__ <= 708-  :: (TermLike a, Applicative m, Monad m)-#else-  :: (TermLike a, Monad m)-#endif-  => a -> m a+copyTerm :: (TermLike a, Monad m) => a -> m a copyTerm = traverseTermM return
+ src/full/Agda/Syntax/Internal/MetaVars.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Syntax.Internal.MetaVars where++import Data.Monoid+import qualified Data.Set as Set++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Generic++import Agda.Utils.Singleton++-- | Returns every meta-variable occurrence in the given type, except+-- for those in sort annotations on types.+class AllMetas t where+  allMetas :: Monoid m => (MetaId -> m) -> t -> m++  default allMetas :: (TermLike t, Monoid m) => (MetaId -> m) -> t -> m+  allMetas = allMetas'++-- Default instances+instance AllMetas Term+instance AllMetas Type+instance TermLike a => AllMetas (Elim' a)+instance TermLike a => AllMetas (Tele 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++instance (AllMetas a, AllMetas b, AllMetas c) => AllMetas (a, b, c) where+  allMetas f (x, y, z) = allMetas f (x, (y, z))++instance (AllMetas a, AllMetas b, AllMetas c, AllMetas d) => AllMetas (a, b, c, d) where+  allMetas f (x, y, z, w) = allMetas f (x, (y, (z, w)))++instance AllMetas a => AllMetas [a]       where allMetas f xs = foldMap (allMetas f) xs+instance AllMetas a => AllMetas (Maybe a) where allMetas f xs = foldMap (allMetas f) xs+instance AllMetas a => AllMetas (Arg a)   where allMetas f xs = foldMap (allMetas f) xs++allMetas' :: (TermLike a, Monoid m) => (MetaId -> m) -> a -> m+allMetas' singl = foldTerm metas+  where+  metas (MetaV m _) = singl m+  metas (Sort s)    = sortMetas s+  metas _           = 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+  sortMetas (MetaS x _)   = singl x+  sortMetas DefS{}        = mempty+  sortMetas DummyS{}      = mempty++-- | Returns 'allMetas' in a list.+--   @allMetasList = allMetas (:[])@.+--+--   Note: this resulting list is computed via difference lists.+--   Thus, use this function if you actually need the whole list of metas.+--   Otherwise, use 'allMetas' with a suitable monoid.+allMetasList :: AllMetas a => a -> [MetaId]+allMetasList t = allMetas singleton t `appEndo` []++-- | 'True' if thing contains no metas.+--   @noMetas = null . allMetasList@.+noMetas :: AllMetas a => a -> Bool+noMetas = getAll . allMetas (\ _m -> All False)++-- | Returns the first meta it find in the thing, if any.+--   @firstMeta == listToMaybe . allMetasList@.+firstMeta :: AllMetas a => a -> Maybe MetaId+firstMeta = getFirst . allMetas (First . Just)++-- | A blocker that unblocks if any of the metas in a term are solved.+unblockOnAnyMetaIn :: AllMetas t => t -> Blocker+unblockOnAnyMetaIn t = unblockOnAnyMeta $ allMetas Set.singleton t++-- | A blocker that unblocks if any of the metas in a term are solved.+unblockOnAllMetasIn :: AllMetas t => t -> Blocker+unblockOnAllMetasIn t = unblockOnAllMetas $ allMetas Set.singleton t
src/full/Agda/Syntax/Internal/Names.hs view
@@ -1,177 +1,396 @@-{-# LANGUAGE CPP #-}+{-# 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.Foldable+import Data.HashMap.Strict (HashMap) import Data.Map (Map)-import qualified Data.Map as Map import Data.Set (Set)-import qualified Data.Set as Set -import Control.Applicative- import Agda.Syntax.Common import Agda.Syntax.Literal 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.Functor+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Singleton import Agda.Utils.Impossible-#include "undefined.h" +-- | 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 :: a -> Set QName+  -- | 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 -namesInFoldable :: (Foldable f, NamesIn a) => f a -> Set QName-namesInFoldable x = Set.unions $ foldMap ((:[]) . namesIn) x+  default namesAndMetasIn' ::+    (Monoid m, Foldable f, NamesIn b, f b ~ a) =>+    (Either QName MetaId -> m) -> a -> m+  namesAndMetasIn' = foldMap . namesAndMetasIn' -instance NamesIn a => NamesIn (Maybe a)       where namesIn = namesInFoldable-instance NamesIn a => NamesIn [a]             where namesIn = namesInFoldable-instance NamesIn a => NamesIn (Arg a)         where namesIn = namesInFoldable-instance NamesIn a => NamesIn (Dom a)         where namesIn = namesInFoldable-instance NamesIn a => NamesIn (Named n a)     where namesIn = namesInFoldable-instance NamesIn a => NamesIn (Abs a)         where namesIn = namesInFoldable-instance NamesIn a => NamesIn (WithArity a)   where namesIn = namesInFoldable-instance NamesIn a => NamesIn (Tele a)        where namesIn = namesInFoldable+-- Generic collections+instance NamesIn a => NamesIn (Maybe a)+instance NamesIn a => NamesIn (Strict.Maybe a)+instance NamesIn a => NamesIn [a]+instance NamesIn a => NamesIn (List1 a)+instance NamesIn a => NamesIn (Set a)+instance NamesIn a => NamesIn (Map k a) -instance NamesIn a => NamesIn (C.FieldAssignment' a) where namesIn = namesInFoldable+-- Decorations+instance NamesIn a => NamesIn (Arg 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 (x, y) = Set.union (namesIn x) (namesIn 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 (x, y, z) = namesIn (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+  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+  namesAndMetasIn' sg (CompKit a b) = namesAndMetasIn' sg (a,b)++-- Base cases++instance NamesIn QName where+  namesAndMetasIn' sg x = sg (Left x)  -- interesting case!++instance NamesIn MetaId where+  namesAndMetasIn' sg x = sg (Right x)++instance NamesIn ConHead where+  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.+ instance NamesIn Definition where-  namesIn def = namesIn (defType def, theDef def)+  namesAndMetasIn' sg+    (Defn _ _ t _ _ _ disp _ _ _ _ _ _ _ _ _ _ def) =+    namesAndMetasIn' sg (t, def, disp)  instance NamesIn Defn where-  namesIn def = case def of-    Axiom -> Set.empty-    Function    { funClauses = cl, funCompiled = cc }              -> namesIn (cl, cc)-    Datatype    { dataClause = cl, dataCons = cs, dataSort = s }   -> namesIn (cl, cs, s)-    Record      { recClause = cl, recConHead = c, recFields = fs } -> namesIn (cl, c, fs)-      -- Don't need recTel since those will be reachable from the constructor-    Constructor { conSrcCon = c, conData = d }                     -> namesIn (c, d)-    Primitive   { primClauses = cl, primCompiled = cc }            -> namesIn (cl, cc)-    AbstractDefn -> __IMPOSSIBLE__+  namesAndMetasIn' sg = \case+    Axiom _            -> 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 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 Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =-    namesIn ((tel, ps, b), t)+  namesAndMetasIn' sg (Clause _ _ tel ps b t _ _ _ _ _) =+    namesAndMetasIn' sg (tel, ps, b, t)  instance NamesIn CompiledClauses where-  namesIn (Case _ c) = namesIn c-  namesIn (Done _ v) = namesIn v-  namesIn Fail       = Set.empty+  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 Branches{ conBranches = bs, catchAllBranch = c } =-    namesIn (Map.toList bs, c)+  namesAndMetasIn' sg (Branches _ bs _ _ c _ _) =+    namesAndMetasIn' sg (bs, c)  instance NamesIn (Pattern' a) where-  namesIn p = case p of-    VarP{}        -> Set.empty-    LitP l        -> namesIn l-    DotP v        -> namesIn v-    ConP c _ args -> namesIn (c, args)-    ProjP _ f     -> namesIn f+  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 (El s t) = namesIn (s, t)+  namesAndMetasIn' sg (El s t) = namesAndMetasIn' sg (s, t)  instance NamesIn Sort where-  namesIn s = case s of-    Type l   -> namesIn l-    Prop     -> Set.empty-    Inf      -> Set.empty-    SizeUniv -> Set.empty-    DLub a b -> namesIn (a, b)+  namesAndMetasIn' sg = \case+    Univ _ l    -> namesAndMetasIn' sg l+    Inf _ _     -> mempty+    SizeUniv    -> mempty+    LockUniv    -> 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 v = case ignoreSharing v of-    Var _ args   -> namesIn args-    Lam _ b      -> namesIn b-    Lit l        -> namesIn l-    Def f args   -> namesIn (f, args)-    Con c _ args -> namesIn (c, args)-    Pi a b       -> namesIn (a, b)-    Sort s       -> namesIn s-    Level l      -> namesIn l-    MetaV _ args -> namesIn args-    DontCare v   -> namesIn v-    Shared{}     -> __IMPOSSIBLE__+  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 (Max ls) = namesIn ls+  namesAndMetasIn' sg (Max _ ls) = namesAndMetasIn' sg ls  instance NamesIn PlusLevel where-  namesIn ClosedLevel{} = Set.empty-  namesIn (Plus _ l)    = namesIn l--instance NamesIn LevelAtom where-  namesIn l = case l of-    MetaLevel _ args -> namesIn args-    BlockedLevel _ v -> namesIn v-    NeutralLevel _ v -> namesIn v-    UnreducedLevel v -> namesIn v+  namesAndMetasIn' sg (Plus _ l) = namesAndMetasIn' sg l --- For QName literals!+-- For QName and Meta literals! instance NamesIn Literal where-  namesIn l = case l of-    LitNat{}      -> Set.empty-    LitString{}   -> Set.empty-    LitChar{}     -> Set.empty-    LitFloat{}    -> Set.empty-    LitQName _  x -> namesIn x-    LitMeta{}     -> Set.empty+  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 (Apply arg) = namesIn arg-  namesIn (Proj _ f)  = namesIn f--instance NamesIn QName   where namesIn x = Set.singleton x-instance NamesIn ConHead where namesIn h = namesIn (conName h)--instance NamesIn a => NamesIn (Open a) where-  namesIn = namesIn . openThing+  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 (Local a) where namesIn = namesIn . dget+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 (Display _ ps v) = namesIn (ps, v)+  namesAndMetasIn' sg (Display _ ps v) = namesAndMetasIn' sg (ps, v)  instance NamesIn DisplayTerm where-  namesIn v = case v of-    DWithApp v us es -> namesIn (v, us, es)-    DCon c _ vs      -> namesIn (c, vs)-    DDef f es        -> namesIn (f, es)-    DDot v           -> namesIn v-    DTerm v          -> namesIn 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 (PSyn (_args, p)) = namesIn 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 p = case p of-    A.VarP{}               -> Set.empty-    A.ConP _ c args        -> namesIn (c, args)-    A.ProjP _ _ d          -> namesIn d-    A.DefP _ f args        -> namesIn (f, args)-    A.WildP{}              -> Set.empty-    A.AsP _ _ p            -> namesIn p-    A.AbsurdP{}            -> Set.empty-    A.LitP l               -> namesIn l-    A.PatternSynP _ c args -> namesIn (c, args)-    A.RecP _ fs            -> namesIn 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            -> namesAndMetasIn' sg p  instance NamesIn AmbiguousQName where-  namesIn (AmbQ cs) = namesIn cs+  namesAndMetasIn' sg (AmbQ cs) = namesAndMetasIn' sg cs
src/full/Agda/Syntax/Internal/Pattern.hs view
@@ -1,32 +1,22 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE UndecidableInstances   #-}  -- because of func. deps.--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Internal.Pattern where -import Control.Applicative-import Control.Monad.State+import Control.Arrow       ( second )+import Control.Monad       ( (>=>), forM )+import Control.Monad.State ( MonadState(..), State, evalState )  import Data.Maybe-import Data.List-import Data.Traversable (traverse)+import Data.Monoid+import qualified Data.List as List  import Agda.Syntax.Common-import Agda.Syntax.Abstract (IsProjP(..)) import Agda.Syntax.Internal-import qualified Agda.Syntax.Internal as I -import Agda.Utils.Empty-import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Permutation import Agda.Utils.Size (size)-import Agda.Utils.Tuple -#include "undefined.h" import Agda.Utils.Impossible  -- * Tools for clauses@@ -49,11 +39,7 @@  -- | Get the number of initial 'Apply' patterns. -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPABLE #-} IsProjP p => FunArity [p] where-#else-instance IsProjP p => FunArity [p] where-#endif   funArity = length . takeWhile (isNothing . isProjP)  -- | Get the number of initial 'Apply' patterns in a clause.@@ -61,11 +47,7 @@   funArity = funArity . namedClausePats  -- | Get the number of common initial 'Apply' patterns in a list of clauses.-#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} FunArity [Clause] where-#else-instance FunArity [Clause] where-#endif   funArity []  = 0   funArity cls = minimum $ map funArity cls @@ -73,34 +55,50 @@  -- | Label the pattern variables from left to right --   using one label for each variable pattern and one for each dot pattern.-class LabelPatVars a b i | b -> i where-  labelPatVars :: a -> State [i] b+class LabelPatVars a b where+  type PatVarLabel b+  labelPatVars :: a -> State [PatVarLabel b] b   unlabelPatVars :: b -> a   -- ^ Intended, but unpractical due to the absence of type-level lambda, is:   --   @labelPatVars :: f (Pattern' x) -> State [i] (f (Pattern' (i,x)))@ -instance LabelPatVars a b i => LabelPatVars (Arg a) (Arg b) i where+  default labelPatVars+    :: (Traversable f+      , LabelPatVars a' b'+      , PatVarLabel b ~  PatVarLabel b'+      , f a' ~ a, f b' ~ b)+    => a -> State [PatVarLabel b] b   labelPatVars = traverse labelPatVars-  unlabelPatVars = fmap unlabelPatVars -instance LabelPatVars a b i => LabelPatVars (Named x a) (Named x b) i where-  labelPatVars = traverse labelPatVars+  default unlabelPatVars+    :: (Traversable f, LabelPatVars a' b', f a' ~ a, f b' ~ b)+    => b -> a   unlabelPatVars = fmap unlabelPatVars -instance LabelPatVars a b i => LabelPatVars [a] [b] i where-  labelPatVars = traverse labelPatVars-  unlabelPatVars = fmap unlabelPatVars+instance LabelPatVars a b => LabelPatVars (Arg a) (Arg b) where+  type PatVarLabel (Arg b) = PatVarLabel b -instance LabelPatVars Pattern DeBruijnPattern Int where-  labelPatVars p =-    case p of-      VarP x       -> do i <- next-                         return $ VarP (DBPatVar x i)-      DotP t       -> DotP t <$ next-      ConP c mt ps -> ConP c mt <$> labelPatVars ps-      LitP l       -> return $ LitP l-      ProjP o q    -> return $ ProjP o q-    where next = do (x:xs) <- get; put xs; return x+instance LabelPatVars a b => LabelPatVars (Named x a) (Named x b) where+  type PatVarLabel (Named x b) = PatVarLabel b++instance LabelPatVars a b => LabelPatVars [a] [b] where+  type PatVarLabel [b] = PatVarLabel b++instance LabelPatVars Pattern DeBruijnPattern where+  type PatVarLabel DeBruijnPattern = Int++  labelPatVars = \case+    VarP o x        -> VarP o . DBPatVar x <$> next+    DotP o t        -> DotP o t <$ next+    ConP c mt ps    -> ConP c mt <$> labelPatVars ps+    DefP o q  ps    -> DefP o q <$> labelPatVars ps+    LitP  o l       -> return $ LitP o l+    ProjP o q       -> return $ ProjP o q+    IApplyP o u t x -> IApplyP o u t . DBPatVar x <$> next+   where+    next = caseListM get __IMPOSSIBLE__ $ \x xs -> do+      put xs+      return x   unlabelPatVars = fmap dbPatVarName  -- | Augment pattern variables with their de Bruijn index.@@ -119,11 +117,11 @@ --    dBpats    = 3 .(suc 2) (cons 2 1 0 ) --  @ ---numberPatVars :: LabelPatVars a b Int => Int -> Permutation -> a -> b+numberPatVars :: (LabelPatVars a b, PatVarLabel b ~ Int) => Int -> Permutation -> a -> b numberPatVars err perm ps = evalState (labelPatVars ps) $   permPicks $ flipP $ invertP err perm -unnumberPatVars :: LabelPatVars a b i => b -> a+unnumberPatVars :: LabelPatVars a b => b -> a unnumberPatVars = unlabelPatVars  dbPatPerm :: [NamedArg DeBruijnPattern] -> Maybe Permutation@@ -142,15 +140,16 @@   where     ixs   = concatMap (getIndices . namedThing . unArg) ps     n     = size $ catMaybes ixs-    picks = forM (downFrom n) $ \ i -> findIndex (Just i ==) ixs+    picks = forM (downFrom n) $ \ i -> List.elemIndex (Just i) ixs      getIndices :: DeBruijnPattern -> [Maybe Int]-    getIndices (VarP x)      = [Just $ dbPatVarIndex x]+    getIndices (VarP _ x)    = [Just $ dbPatVarIndex x]     getIndices (ConP c _ ps) = concatMap (getIndices . namedThing . unArg) ps-    getIndices (DotP _)      = [Nothing | countDots]-    getIndices (LitP _)      = []+    getIndices (DefP _ _ ps) = concatMap (getIndices . namedThing . unArg) ps+    getIndices (DotP _ _)    = [Nothing | countDots]+    getIndices (LitP _ _)    = []     getIndices ProjP{}       = []-+    getIndices (IApplyP _ _ _ x) = [Just $ dbPatVarIndex x]  -- | Computes the permutation from the clause telescope --   to the pattern variables.@@ -164,13 +163,16 @@ --   Projection patterns are turned into projection eliminations, --   other patterns into apply elimination. patternToElim :: Arg DeBruijnPattern -> Elim-patternToElim (Arg ai (VarP x)) = Apply $ Arg ai $ var $ dbPatVarIndex x+patternToElim (Arg ai (VarP o x)) = Apply $ Arg ai $ var $ dbPatVarIndex x patternToElim (Arg ai (ConP c cpi ps)) = Apply $ Arg ai $ Con c ci $-      map (argFromElim . patternToElim . fmap namedThing) ps+      map (patternToElim . fmap namedThing) ps   where ci = fromConPatternInfo cpi-patternToElim (Arg ai (DotP t)     ) = Apply $ Arg ai t-patternToElim (Arg ai (LitP l)     ) = Apply $ Arg ai $ Lit l+patternToElim (Arg ai (DefP o q ps)) = Apply $ Arg ai $ Def q $+      map (patternToElim . fmap namedThing) ps+patternToElim (Arg ai (DotP o t)   ) = Apply $ Arg ai t+patternToElim (Arg ai (LitP o l)    ) = Apply $ Arg ai $ Lit l patternToElim (Arg ai (ProjP o dest)) = Proj o dest+patternToElim (Arg ai (IApplyP o t u x)) = IApply t u $ var $ dbPatVarIndex x  patternsToElims :: [NamedArg DeBruijnPattern] -> [Elim] patternsToElims ps = map build ps@@ -182,18 +184,182 @@ patternToTerm p = case patternToElim (defaultArg p) of   Apply x -> unArg x   Proj{}  -> __IMPOSSIBLE__+  IApply _ _ x -> x -class MapNamedArg f where-  mapNamedArg :: (NamedArg a -> NamedArg b) -> NamedArg (f a) -> NamedArg (f b) -instance MapNamedArg Pattern' where-  mapNamedArg f np =+class MapNamedArgPattern a p where+  mapNamedArgPattern :: (NamedArg (Pattern' a) -> NamedArg (Pattern' a)) -> p -> p++  default mapNamedArgPattern+    :: (Functor f, MapNamedArgPattern a p', p ~ f p')+    => (NamedArg (Pattern' a) -> NamedArg (Pattern' a)) -> p -> p+  mapNamedArgPattern = fmap . mapNamedArgPattern++-- | Modify the content of @VarP@, and the closest surrounding @NamedArg@.+--+--   Note: the @mapNamedArg@ for @Pattern'@ is not expressible simply+--   by @fmap@ or @traverse@ etc., since @ConP@ has @NamedArg@ subpatterns,+--   which are taken into account by @mapNamedArg@.++instance MapNamedArgPattern a (NamedArg (Pattern' a)) where+  mapNamedArgPattern f np =     case namedArg np of-      VarP  x     -> map2 VarP $ f $ map2 (const x) np-      DotP  t     -> map2 (const $ DotP t) np  -- just Haskell type conversion-      LitP  l     -> map2 (const $ LitP l) np  -- ditto-      ProjP o q   -> map2 (const $ ProjP o q) np -- ditto-      ConP c i ps -> map2 (const $ ConP c i $ map (mapNamedArg f) ps) np+      VarP o x    -> f np+      DotP  o t   -> f np+      LitP o l    -> f np+      ProjP o q   -> f np+      ConP c i ps -> f $ setNamedArg np $ ConP c i $ mapNamedArgPattern f ps+      DefP o q ps -> f $ setNamedArg np $ DefP o q $ mapNamedArgPattern f ps+      IApplyP o u t x -> f np++instance MapNamedArgPattern a p => MapNamedArgPattern a [p] where+++-- | Generic pattern traversal.+--+--   Pre-applies a pattern modification, recurses, and post-applies another one.++class PatternLike a b where++  -- | Fold pattern.+  foldrPattern+    :: Monoid m+    => (Pattern' a -> m -> m)+         -- ^ Combine a pattern and the value computed from its subpatterns.+    -> b -> m++  default foldrPattern+    :: (Monoid m, Foldable f, PatternLike a p, f p ~ b)+    => (Pattern' a -> m -> m) -> b -> m+  foldrPattern = foldMap . foldrPattern++  -- | Traverse pattern.+  traversePatternM+    :: Monad m+    => (Pattern' a -> m (Pattern' a))  -- ^ @pre@: Modification before recursion.+    -> (Pattern' a -> m (Pattern' a))  -- ^ @post@: Modification after recursion.+    -> b -> m b++  default traversePatternM+    :: (Traversable f, PatternLike a p, f p ~ b, Monad m)+    => (Pattern' a -> m (Pattern' a))+    -> (Pattern' a -> m (Pattern' a))+    -> b -> m b++  traversePatternM pre post = traverse $ traversePatternM pre post++-- | Compute from each subpattern a value and collect them all in a monoid.++foldPattern :: (PatternLike a b, Monoid m) => (Pattern' a -> m) -> b -> m+foldPattern f = foldrPattern $ \ p m -> f p `mappend` m++-- | Traverse pattern(s) with a modification before the recursive descent.++preTraversePatternM+  :: (PatternLike a b, Monad m)+  => (Pattern' a -> m (Pattern' a))  -- ^ @pre@: Modification before recursion.+  -> b -> m b+preTraversePatternM pre = traversePatternM pre return++-- | Traverse pattern(s) with a modification after the recursive descent.++postTraversePatternM :: (PatternLike a b, Monad m)+                     => (Pattern' a -> m (Pattern' a))  -- ^ @post@: Modification after recursion.+                     -> b -> m b+postTraversePatternM = traversePatternM return++-- This is where the action is:++instance PatternLike a (Pattern' a) where++  foldrPattern f p = f p $ case p of+    ConP _ _ ps -> foldrPattern f ps+    DefP _ _ ps -> foldrPattern f ps+    VarP _ _    -> mempty+    LitP _ _    -> mempty+    DotP _ _    -> mempty+    ProjP _ _   -> mempty+    IApplyP{}   -> mempty++  traversePatternM pre post = pre >=> recurse >=> post     where-    map2 :: (a -> b) -> NamedArg a -> NamedArg b-    map2 = fmap . fmap+    recurse p = case p of+      ConP c ci ps -> ConP c ci <$> traversePatternM pre post ps+      DefP o q ps  -> DefP o q <$> traversePatternM pre post ps+      VarP  _ _    -> return p+      LitP  _ _    -> return p+      DotP  _ _    -> return p+      ProjP _ _    -> return p+      IApplyP{}    -> return p++-- Boilerplate instances:++instance PatternLike a b => PatternLike a [b]         where+instance PatternLike a b => PatternLike a (Arg b)     where+instance PatternLike a b => PatternLike a (Named x b) where++-- Counting pattern variables ---------------------------------------------++class CountPatternVars a where+  countPatternVars :: a -> Int++  default countPatternVars :: (Foldable f, CountPatternVars b, f b ~ a) =>+                              a -> Int+  countPatternVars = getSum . foldMap (Sum . countPatternVars)++instance CountPatternVars a => CountPatternVars [a] where+instance CountPatternVars a => CountPatternVars (Arg a) where+instance CountPatternVars a => CountPatternVars (Named x a) where++instance CountPatternVars (Pattern' x) where+  countPatternVars p =+    case p of+      VarP{}      -> 1+      ConP _ _ ps -> countPatternVars ps+      DotP{}      -> 1   -- dot patterns are treated as variables in the clauses+      _           -> 0++-- Computing modalities of pattern variables ------------------------------++class PatternVarModalities p where+  type PatVar p+  -- | Get the list of pattern variables annotated with modalities.+  patternVarModalities :: p -> [(PatVar p, Modality)]++instance PatternVarModalities a => PatternVarModalities [a] where+  type PatVar [a] = PatVar a+  patternVarModalities = foldMap patternVarModalities++instance PatternVarModalities a => PatternVarModalities (Named s a) where+  type PatVar (Named s a) = PatVar a+  patternVarModalities = foldMap patternVarModalities++instance PatternVarModalities a => PatternVarModalities (Arg a) where+  type PatVar (Arg a) = PatVar a+  patternVarModalities arg = map (second (composeModality m)) (patternVarModalities $ unArg arg)+    where m = getModality arg++-- UNUSED:+-- instance PatternVarModalities a x => PatternVarModalities (Elim' a) x where+--   patternVarModalities (Apply x) = patternVarModalities x -- Note: x :: Arg a+--   patternVarModalities (IApply x y p) = patternVarModalities [x, y, p]+--   patternVarModalities Proj{}    = []++instance PatternVarModalities (Pattern' x) where+  type PatVar (Pattern' x) = x+  patternVarModalities p =+    case p of+      VarP _ x    -> [(x, defaultModality)]+      ConP _ _ ps -> patternVarModalities ps+      DefP _ _ ps -> patternVarModalities ps+      DotP{}      -> []+      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,31 +1,29 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Sanity checking for internal syntax. Mostly checking variable scoping. module Agda.Syntax.Internal.SanityCheck where  import Control.Monad import qualified Data.IntSet as Set -import Text.PrettyPrint (empty)- import Agda.Syntax.Internal import Agda.TypeChecking.Free import Agda.TypeChecking.Monad-import Agda.TypeChecking.Substitute -import Agda.Utils.Pretty+import Agda.Utils.List ( dropEnd, initWithDefault )+import Agda.Syntax.Common.Pretty import Agda.Utils.Size import Agda.Utils.Impossible -#include "undefined.h" -sanityCheckVars :: (Pretty a, FreeVS a) => Telescope -> a -> TCM ()+sanityCheckVars :: (Pretty a, Free a) => Telescope -> a -> TCM () sanityCheckVars tel v =   case filter bad (Set.toList $ allFreeVars v) of     [] -> return ()     xs -> do-      reportSDoc "impossible" 1 . return $-        sep [ hang (text "Sanity check failed for") 2-                   (hang (pretty tel <+> text "|-") 2 (pretty v))+      alwaysReportSDoc "impossible" 1 . return $+        sep [ hang "Sanity check failed for" 2+                   (hang (pretty tel <+> "|-") 2 (pretty v))             , text $ "out of scope: " ++ show xs ]       __IMPOSSIBLE__   where@@ -33,40 +31,49 @@     bad x = x < 0 || x >= n  -- | Check that @Γ ⊢ ρ : Δ@.-sanityCheckSubst :: (Pretty a, FreeVS a) => Telescope -> Substitution' a -> Telescope -> TCM ()+sanityCheckSubst :: (Pretty a, Free a) => Telescope -> Substitution' a -> Telescope -> TCM () sanityCheckSubst gamma rho delta = go gamma rho delta   where     go gamma rho delta =       case rho of-        IdS      -> unless (size gamma == size delta) $ err $ text "idS:" <+> hang (pretty gamma <+> text "/=") 2 (pretty delta)-        EmptyS   -> unless (size delta == 0) $ err $ text "emptyS:" <+> pretty delta <+> text "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 $ text "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 $ text "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 $ text "wkS:" <+> sep [ text "|" <> pretty gamma <> text "|"-                                                               , 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 $ text "liftS: source" <+> sep [ text "|" <> pretty gamma <> text "|"-                                                                        , text $ "< " ++ show n ]-          unless (size delta >= n) $ err $ text "liftS: target" <+> sep [ text "|" <> pretty delta <> text "|"-                                                                        , 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 . init . telToList-    dropLastN n = telFromList . reverse . drop n . reverse . telToList+    dropLast = telFromList . initWithDefault __IMPOSSIBLE__ . telToList+    dropLastN n = telFromList . dropEnd n . telToList      err reason = do-      reportSDoc "impossible" 1 . return $-        sep [ hang (text "Sanity check failed for") 2 $-              hang (pretty gamma <+> text "|-") 2 $-              hang (pretty rho <+> text ":") 2 $+      alwaysReportSDoc "impossible" 1 . return $+        sep [ hang "Sanity check failed for" 2 $+              hang (pretty gamma <+> "|-") 2 $+              hang (pretty rho <+> ":") 2 $                     pretty delta             , reason ]       __IMPOSSIBLE__-
+ 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
@@ -1,50 +1,45 @@-{-# LANGUAGE DeriveDataTypeable #-}  module Agda.Syntax.Literal where  import Control.DeepSeq import Data.Char-import Data.Typeable (Typeable)+import Data.Word -import Numeric.IEEE ( IEEE(identicalIEEE) )+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.Pretty-import Agda.Utils.FileName--data Literal = LitNat    Range !Integer-             | LitFloat  Range !Double-             | LitString Range String-             | LitChar   Range !Char-             | LitQName  Range QName-             | LitMeta   Range AbsolutePath MetaId-  deriving (Typeable)+import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')+import Agda.Syntax.Position (Range)+import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd )+import Agda.Syntax.Common.Pretty -instance Show Literal where-  showsPrec p l = showParen (p > 9) $ case l of-    LitNat _ n    -> sh "LitNat" n-    LitFloat _ x  -> sh "LitFloat" x-    LitString _ s -> sh "LitString" s-    LitChar _ c   -> sh "LitChar" c-    LitQName _ q  -> sh "LitQName" q-    LitMeta _ _ x -> sh "LitMeta" x-    where-      sh :: Show a => String -> a -> ShowS-      sh c x = showString (c ++ " ") . shows x+type RLiteral = Ranged Literal+data Literal+  = LitNat    !Integer+  | LitWord64 !Word64+  | LitFloat  !Double+  | LitString !Text+  | LitChar   !Char+  | LitQName  !QName+  | LitMeta   !(TopLevelModuleName' Range) !MetaId+  deriving Show  instance Pretty Literal where-    pretty (LitNat _ n)     = text $ show n-    pretty (LitFloat _ x)   = text $ show x-    pretty (LitString _ s)  = text $ showString' s ""-    pretty (LitChar _ c)    = text $ "'" ++ showChar' c "" ++ "'"-    pretty (LitQName _ x)   = text $ show x-    pretty (LitMeta _ _ x)  = pretty x+    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 -showString' :: String -> ShowS-showString' s =-    foldr (.) id $ [ showString "\"" ] ++ map showChar' s ++ [ showString "\"" ]+showText :: Text -> ShowS+showText s = showString "\""+           . T.foldr (\ c -> (showChar' c .)) id s+           . showString "\""  showChar' :: Char -> ShowS showChar' '"'   = showString "\\\""@@ -55,26 +50,30 @@         escapeMe c = not (isPrint c) || c == '\\'  instance Eq Literal where-  LitNat _ n    == LitNat _ m    = n == m+  LitNat n    == LitNat m    = n == m   -- ASR (2016-09-29). We use bitwise equality for comparing Double   -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove   -- a contradiction (see Issue #2169).-  LitFloat _ x  == LitFloat _ y  = identicalIEEE x y || (isNaN x && isNaN y)-  LitString _ s == LitString _ t = s == t-  LitChar _ c   == LitChar _ d   = c == d-  LitQName _ x  == LitQName _ y  = x == y-  LitMeta _ f x == LitMeta _ g y = (f, x) == (f, y)-  _             == _             = False+  LitWord64 n == LitWord64 m = n == m+  LitFloat x  == LitFloat y  = doubleDenotEq x y+  LitString s == LitString t = s == t+  LitChar c   == LitChar d   = c == d+  LitQName x  == LitQName y  = x == y+  LitMeta f x == LitMeta g y = (f, x) == (g, y)+  _           == _             = False  instance Ord Literal where-  LitNat _ n    `compare` LitNat _ m    = n `compare` m-  LitFloat _ x  `compare` LitFloat _ y  = compareFloat x y-  LitString _ s `compare` LitString _ t = s `compare` t-  LitChar _ c   `compare` LitChar _ d   = c `compare` d-  LitQName _ x  `compare` LitQName _ y  = x `compare` y-  LitMeta _ f x `compare` LitMeta _ g y = (f, x) `compare` (g, y)+  LitNat n    `compare` LitNat m    = n `compare` m+  LitWord64 n `compare` LitWord64 m = n `compare` m+  LitFloat x  `compare` LitFloat y  = doubleDenotOrd x y+  LitString s `compare` LitString t = s `compare` t+  LitChar c   `compare` LitChar d   = c `compare` d+  LitQName x  `compare` LitQName y  = x `compare` y+  LitMeta f x `compare` LitMeta g y = (f, x) `compare` (g, y)   compare LitNat{}    _ = LT   compare _ LitNat{}    = GT+  compare LitWord64{} _ = LT+  compare _ LitWord64{} = GT   compare LitFloat{}  _ = LT   compare _ LitFloat{}  = GT   compare LitString{} _ = LT@@ -86,53 +85,22 @@   -- compare LitMeta{} _   = LT   -- compare _ LitMeta{}   = GT --- NOTE: This is not the same ordering as primFloatNumericalEquality!--- This ordering must be a total order of all allowed float values,--- while primFloatNumericalEquality is only a preorder-compareFloat :: Double -> Double -> Ordering-compareFloat x y-  | identicalIEEE x y          = EQ-  | isNegInf x                 = LT-  | isNegInf y                 = GT-  | isNaN x && isNaN y         = EQ-  | isNaN x                    = LT-  | isNaN y                    = GT-  | isNegativeZero x && x == y = LT-  | isNegativeZero y && x == y = GT-  | otherwise                  = compare x y-  where-    isNegInf z = z < 0 && isInfinite z--instance HasRange Literal where-  getRange (LitNat    r _) = r-  getRange (LitFloat  r _) = r-  getRange (LitString r _) = r-  getRange (LitChar   r _) = r-  getRange (LitQName  r _) = r-  getRange (LitMeta r _ _) = r--instance SetRange Literal where-  setRange r (LitNat    _ x) = LitNat    r x-  setRange r (LitFloat  _ x) = LitFloat  r x-  setRange r (LitString _ x) = LitString r x-  setRange r (LitChar   _ x) = LitChar   r x-  setRange r (LitQName  _ x) = LitQName  r x-  setRange r (LitMeta _ f x) = LitMeta   r f x- instance KillRange Literal where-  killRange (LitNat    r x) = LitNat    (killRange r) x-  killRange (LitFloat  r x) = LitFloat  (killRange r) x-  killRange (LitString r x) = LitString (killRange r) x-  killRange (LitChar   r x) = LitChar   (killRange r) x-  killRange (LitQName  r x) = killRange2 LitQName r x-  killRange (LitMeta r f x) = LitMeta   (killRange r) f x+  killRange (LitNat    x) = LitNat    x+  killRange (LitWord64 x) = LitWord64 x+  killRange (LitFloat  x) = LitFloat  x+  killRange (LitString x) = LitString x+  killRange (LitChar   x) = LitChar   x+  killRange (LitQName  x) = killRangeN LitQName x+  killRange (LitMeta m x) = LitMeta (killRange m) x  -- | Ranges are not forced.  instance NFData Literal where-  rnf (LitNat _ _)    = ()-  rnf (LitFloat _ _)  = ()-  rnf (LitString _ a) = rnf a-  rnf (LitChar _ _)   = ()-  rnf (LitQName _ a)  = rnf a-  rnf (LitMeta _ _ x) = rnf x+  rnf (LitNat _     ) = ()+  rnf (LitWord64 _  ) = ()+  rnf (LitFloat _   ) = ()+  rnf (LitString _  ) = ()+  rnf (LitChar _    ) = ()+  rnf (LitQName a   ) = rnf a+  rnf (LitMeta m _  ) = rnf m
src/full/Agda/Syntax/Notation.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# 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.@@ -15,30 +13,42 @@  module Agda.Syntax.Notation where -import Control.Applicative+import Prelude hiding (null)+ import Control.DeepSeq import Control.Monad+import Control.Monad.Except -import Data.List-import Data.Maybe-import Data.Typeable (Typeable)+import qualified Data.List as List +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.Except ( MonadError(throwError) )+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.Singleton  import Agda.Utils.Impossible-#include "undefined.h" --- | 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 :: RawName-               , holeName      :: RawName }-    -- ^ @\ x -> y@; 1st argument is the bound name (unused for now).-  | ExprHole   { holeName      :: RawName }+  = LambdaHole { _bindHoleNames :: List1 RString+               , holeName       :: RString+               }+    -- ^ @λ x₁ … xₙ → y@: The first argument contains the bound names.+  | ExprHole   { holeName      :: RString }     -- ^ Simple named hole with hiding.  -- | Is the hole a binder?@@ -46,64 +56,30 @@ isLambdaHole (LambdaHole _ _) = True isLambdaHole _ = False --- | Notation as provided by the @syntax@ declaration.-type Notation = [GenPart]---- | Part of a Notation-data GenPart-  = BindHole !Int-    -- ^ Argument is the position of the hole (with binding) where the binding should occur.-  | NormalHole (NamedArg Int)-    -- ^ Argument is where the expression should go.-  | WildHole !Int-    -- ^ An underscore in binding position.-  | IdPart RawName-  deriving (Typeable, Show, Eq, Ord)--instance KillRange GenPart where-  killRange p = case p of-    IdPart x     -> IdPart x-    BindHole i   -> BindHole i-    WildHole i   -> WildHole i-    NormalHole x -> NormalHole $ killRange x--instance NFData GenPart where-  rnf (BindHole _)   = ()-  rnf (NormalHole a) = rnf a-  rnf (WildHole _)   = ()-  rnf (IdPart a)     = rnf a- -- | Get a flat list of identifier parts of a notation.-stringParts :: Notation -> [RawName]-stringParts gs = [ x | IdPart x <- gs ]+stringParts :: Notation -> [String]+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 n-holeTarget (WildHole   n) = Just n-holeTarget (NormalHole n) = Just $ namedArg n+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 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---- | 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. @@ -113,14 +89,14 @@   | PostfixNotation -- ^ Ex: @bla_blub_@.   | NonfixNotation  -- ^ Ex: @bla_blub@.   | NoNotation-   deriving (Eq, Show)+   deriving (Eq, Show, Generic)  -- | Classify a notation by presence of leading and/or trailing -- /normal/ holes. notationKind :: Notation -> NotationKind notationKind []  = NoNotation-notationKind syn =-  case (isNormalHole $ head syn, isNormalHole $ last syn) of+notationKind (h:syn) =+  case (isAHole h, isAHole $ last1 h syn) of     (True , True ) -> InfixNotation     (True , False) -> PostfixNotation     (False, True ) -> PrefixNotation@@ -128,74 +104,327 @@  -- | 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] -> [RawName] -> Either String Notation+mkNotation :: [NamedArg HoleName] -> [RString] -> Either String Notation mkNotation _ [] = throwError "empty notation is disallowed" mkNotation holes ids = do   unless uniqueHoleNames     $ throwError "syntax must use unique argument names"   let xs :: Notation = map mkPart ids-  unless (isAlternating xs)  $ throwError "syntax must alternate holes and non-holes"   unless (isExprLinear xs)   $ throwError "syntax must use holes exactly once"   unless (isLambdaLinear xs) $ throwError "syntax must use binding holes exactly once"-  return $ insertWildHoles xs+  unless (noAdjacentHoles xs)  $ throwError $ concat+     [ "syntax must not contain adjacent holes ("+     , prettyHoles+     , ")"+     ]+  -- 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 $ insertWildParts xs     where-      mkPart ident = fromMaybe (IdPart ident) $ lookup ident holeMap+      holeNames :: [RString]+      holeNames = map namedArg holes >>= \case+        LambdaHole _ y -> [y]+        ExprHole y     -> [y] +      prettyHoles :: String+      prettyHoles = List.unwords $ map (rawNameToString . rangedThing) holeNames++      mkPart ident = maybe (IdPart ident) (`withRangeOf` ident) $ lookup ident holeMap+       holeNumbers   = [0 .. length holes - 1]++      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 xs = foldr ins xs wilds+      insertWildParts :: [NotationPart] -> [NotationPart]+      insertWildParts xs = foldr ins xs wilds         where-          wilds = [ i | (_, WildHole i) <- holeMap ]-          ins w (NormalHole h : hs)-            | namedArg h == w = NormalHole 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 h : hs)-            | namedArg h == w = WildHole w : NormalHole 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.+      -- 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-        let normalHole = NormalHole $ fmap (i <$) h+        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)]-          LambdaHole "_" y -> [("_", WildHole i), (y, normalHole)]-          LambdaHole x y   -> [(x, BindHole i), (y, normalHole)]+          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, x /= "_" ]+      uniqueHoleNames = distinct [ x | (x, _) <- holeMap, rangedThing x /= "_" ] -      isExprLinear   xs = sort [ i | x <- xs, isNormalHole x, let Just i = holeTarget x ] == holeNumbers-      isLambdaLinear xs = sort [ x | BindHole x <- xs ] ==-                          [ i | (i, h) <- numberedHoles,-                                LambdaHole x _ <- [namedArg h], x /= "_" ]+      isExprLinear xs =+        List.sort [ i | x <- xs, isAHole x, let Just i = holeTarget x ]+          ==+        holeNumbers -      isAlternating :: [GenPart] -> Bool-      isAlternating []       = __IMPOSSIBLE__-      isAlternating [x]      = True-      isAlternating (x:y:xs) = isAHole x /= isAHole y && isAlternating (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 /= "_"+        ] -noNotation :: Notation-noNotation = []+      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+        _            -> False++-- | All the notation information related to a name.+data NewNotation = NewNotation+  { notaName  :: QName+  , notaNames :: Set1 A.Name+    -- ^ The names the syntax and/or fixity belong to.+    --+    -- Invariant: Every name in the list matches 'notaName'.+  , notaFixity :: Fixity+    -- ^ Associativity and precedence (fixity) of the names.+  , notation :: Notation+    -- ^ Syntax associated with the names.+  , notaIsOperator :: Bool+    -- ^ True if the notation comes from an operator (rather than a+    -- syntax declaration).+  } deriving (Show, Generic)++instance LensFixity NewNotation where+  lensFixity f nota = f (notaFixity nota) <&> \ fx -> nota { notaFixity = fx }++-- | If an operator has no specific notation, then it is computed from+-- its name.+namesToNotation :: QName -> A.Name -> NewNotation+namesToNotation q n = NewNotation+  { notaName       = q+  , notaNames      = singleton n+  , notaFixity     = f+  , notation       = if null syn then syntaxOf (unqualify q) else syn+  , notaIsOperator = null syn+  }+  where Fixity' f syn _ = A.nameFixity n++-- | Replace 'noFixity' by 'defaultFixity'.+useDefaultFixity :: NewNotation -> NewNotation+useDefaultFixity n+  | notaFixity n == noFixity = n { notaFixity = defaultFixity }+  | otherwise                = n++-- | Return the 'IdPart's of a notation, the first part qualified,+--   the other parts unqualified.+--   This allows for qualified use of operators, e.g.,+--   @M.for x ∈ xs return e@, or @x ℕ.+ y@.+notationNames :: NewNotation -> [QName]+notationNames (NewNotation q _ _ parts _) =+  zipWith ($) (reQualify : repeat QName) [simpleName $ rangedThing x | IdPart x <- parts ]+  where+    -- The qualification of @q@.+    modules     = List1.init (qnameParts q)+    -- Putting the qualification onto @x@.+    reQualify x = List.foldr Qual (QName x) modules++-- | Create a 'Notation' (without binders) from a concrete 'Name'.+--   Does the obvious thing:+--   'Hole's become 'HolePart's, 'Id's become 'IdParts'.+--   If 'Name' has no 'Hole's, it returns 'noNotation'.+syntaxOf :: Name -> Notation+syntaxOf y+  | isOperator y = mkSyn 0 $ List1.toList $ nameNameParts y+  | otherwise    = noNotation+  where+    -- Turn a concrete name into a Notation,+    -- numbering the holes from left to right.+    -- Result will have no 'BindingHole's.+    mkSyn :: Int -> [NamePart] -> Notation+    mkSyn n []          = []+    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+-- notation, with two exceptions:+--+-- * Operators and notations coming from syntax declarations are kept+--   separate.+--+-- * If /all/ instances of a given 'NewNotation' have the same+--   precedence level or are \"unrelated\", then they are merged. They+--   get the given precedence level, if any, and otherwise they become+--   unrelated (but related to each other).+--+-- If 'NewNotation's that are merged have distinct associativities,+-- then they get 'NonAssoc' as their associativity.+--+-- Precondition: No 'A.Name' may occur in more than one list element.+-- Every 'NewNotation' must have the same 'notaName'.+--+-- Postcondition: No 'A.Name' occurs in more than one list element.+mergeNotations :: List1 NewNotation -> List1 NewNotation+mergeNotations ns@(_ :| []) = ns+mergeNotations ns =+  fmap merge+  . List1.concatMap1 groupIfLevelsMatch+  . List1.groupOn1 (notation &&& notaIsOperator)+  $ ns+  where+  groupIfLevelsMatch :: List1 NewNotation -> List1 (List1 NewNotation)+  groupIfLevelsMatch ns =+    if allEqual (map fixityLevel related)+    then singleton $ sameAssoc $ sameLevel ns+    else fmap singleton ns+    where+    -- Fixities of operators whose precedence level is not Unrelated.+    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 = fmap (set (_notaFixity . _fixityLevel) level)+      where+      level = case related of+        f : _ -> fixityLevel f+        []    -> Unrelated++    -- 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 = fmap (set (_notaFixity . _fixityAssoc) assoc)+      where+      assoc = case related of+        f : _ | allEqual (map fixityAssoc related) -> fixityAssoc f+        _                                          -> NonAssoc++  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' NewNotation Fixity+_notaFixity f r = f (notaFixity r) <&> \x -> r { notaFixity = x }++-- * Sections++-- | Sections, as well as non-sectioned operators.++data NotationSection = NotationSection+  { sectNotation  :: NewNotation+  , sectKind      :: NotationKind+    -- ^ For non-sectioned operators this should match the notation's+    -- 'notationKind'.+  , sectLevel     :: Maybe FixityLevel+    -- ^ Effective precedence level. 'Nothing' for closed notations.+  , sectIsSection :: Bool+    -- ^ 'False' for non-sectioned operators.+  }+  deriving (Show, Generic)++-- | Converts a notation to a (non-)section.++noSection :: NewNotation -> NotationSection+noSection n = NotationSection+  { sectNotation  = n+  , sectKind      = notationKind (notation n)+  , sectLevel     = Just (fixityLevel (notaFixity n))+  , sectIsSection = False+  }+++-- * Pretty printing++instance Pretty NewNotation where+  pretty (NewNotation x _xs fx nota isOp) = hsepWith "=" px pn+    where+    px = fsep [ if isOp then empty else "syntax" , pretty fx , pretty x ]+    pn = if isOp then empty else pretty nota++instance Pretty NotationKind where pretty = pshow++instance Pretty NotationSection where+  pretty (NotationSection nota kind mlevel isSection)+    | isSection = fsep+        [ "section"+        , pretty kind+        , maybe empty pretty mlevel+        , pretty nota+        ]+    | otherwise = pretty nota++-- NFData instances++instance NFData NotationKind+instance NFData NewNotation+instance NFData NotationSection
src/full/Agda/Syntax/Parser.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Syntax.Parser     ( -- * Types@@ -8,13 +5,17 @@       -- * Parse functions     , Agda.Syntax.Parser.parse     , Agda.Syntax.Parser.parsePosString-    , parseFile'+    , parseFile       -- * Parsers     , moduleParser     , moduleNameParser+    , agdaFileExtensions     , exprParser     , exprWhereParser+    , holeContentParser     , tokensParser+      -- * Reading files.+    , readFilePM       -- * Parse errors     , ParseError(..)     , ParseWarning(..)@@ -22,15 +23,17 @@     , runPMIO     ) where -import Control.Arrow (second) import Control.Exception-import Control.Monad ((>=>), forM_)+import Control.Monad          ( forM_ )+import Control.Monad.Except import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer hiding ((<>))-import Data.List-import Data.Typeable ( Typeable )+import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Bifunctor+import qualified Data.List as List+import Data.Text.Lazy (Text)++import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Parser.Monad as M hiding (Parser, parseFlags) import qualified Agda.Syntax.Parser.Monad as M@@ -38,57 +41,60 @@ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Literate import Agda.Syntax.Concrete-import Agda.Syntax.Concrete.Definitions+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Parser.Tokens -import Agda.Utils.Except-  ( Error(strMsg)-  , ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  ) import Agda.Utils.FileName+import Agda.Utils.IO.UTF8 (readTextFile)+import Agda.Utils.Maybe   (forMaybe) import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Pretty +------------------------------------------------------------------------+-- Wrapping parse results +-- | A monad for handling parse errors and warnings. +newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }+  deriving ( Functor, Applicative, Monad, MonadIO+           , MonadError ParseError, MonadState [ParseWarning]+           ) -#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative ((<$>), Applicative)-#endif+-- | Run a 'PM' computation, returning a list of warnings in first-to-last order+--   and either a parse error or the parsed thing. -#include "undefined.h"-import Agda.Utils.Impossible+runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])+runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM ---------------------------------------------------------------------------- Wrapping parse results+-- | Add a 'ParseWarning'. -wrap :: ParseResult a -> PM a-wrap (ParseOk _ x)      = return x+warning :: ParseWarning -> PM ()+warning w = PM (modify (w:))++-- | Embed a 'ParseResult' as 'PM' computation.++wrap :: ParseResult a -> PM (a, Attributes) wrap (ParseFailed err)  = throwError err+wrap (ParseOk s x)      = do+  modify' (parseWarnings s ++)+  return (x, parseAttributes s) +wrapM :: IO (ParseResult a) -> PM (a, Attributes)+wrapM m = liftIO m >>= wrap++-- | Returns the contents of the given file.++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) -wrapM :: IO (ParseResult a) -> PM a-wrapM m = liftIO m >>= wrap---- | A monad for handling parse results-newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }-               deriving (Functor, Applicative, Monad,-                         MonadError ParseError, MonadIO)--warning :: ParseWarning -> PM ()-warning w = PM (modify (w:))--runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])-runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM- ------------------------------------------------------------------------ -- Parse functions @@ -100,64 +106,100 @@   , parseLiterate  :: LiterateParser a   } -type LiterateParser a = Parser a -> [Layer] -> PM a+type LiterateParser a =+  Parser a -> SrcFile -> [Layer] -> PM (a, Attributes) -parse :: Parser a -> String -> PM a-parse p = wrapM . return . M.parse (parseFlags p) [normal] (parser p)+-- | Initial state for lexing. -parseFile :: Parser a -> AbsolutePath -> PM a-parseFile p = wrapM . M.parseFile (parseFlags p) [layout, normal] (parser p)+normalLexState :: [LexState]+normalLexState = [normal] -parseString :: Parser a -> String -> PM a-parseString = parseStringFromFile Strict.Nothing+-- | Initial state for lexing with top-level layout. -parseStringFromFile :: SrcFile -> Parser a -> String -> PM a-parseStringFromFile src p = wrapM . return . M.parseFromSrc (parseFlags p) [layout, normal] (parser p) src+layoutLexState :: [LexState]+layoutLexState = [layout, normal] +-- | Parse without top-level layout.++parse :: Parser a -> String -> PM (a, Attributes)+parse p = wrapM . return . M.parse (parseFlags p) normalLexState (parser p)++-- | Parse with top-level layout.++parseFileFromString+  :: SrcFile   -- ^ Name of source file.+  -> Parser a  -- ^ Parser to use.+  -> String    -- ^ Contents of source file.+  -> 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 = parseStringFromFile (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 <- map Left <$> parseLiterateWithoutComments p layers-  let literate = Right <$> filter (not . isCode) layers-  let (terms, overlaps) = interleaveRanges code literate+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$ concat [ case m of-                       Left t -> [t]-                       Right (Layer Comment interval s) -> [TokTeX (interval, s)]-                       Right (Layer Markup _ _) -> []-                       Right (Layer Code _ _) -> []-                   | m <- terms ]+  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 -readFilePM :: AbsolutePath -> PM String-readFilePM path = wrapIOM (ReadFileError path) (readFile (filePath path)) -parseLiterateFile :: Processor -> Parser a -> AbsolutePath -> PM a-parseLiterateFile po p path = readFilePM path >>= parseLiterate p p . po (startPos (Just path))+parseLiterateFile+  :: Processor+  -> Parser a+  -> RangeFile+     -- ^ The file.+  -> String+     -- ^ The file contents. Note that the file is /not/ read from+     -- disk.+  -> PM (a, Attributes)+parseLiterateFile po p path = parseLiterate p p (pure path) . po (startPos' ()) -parsePosString :: Parser a -> Position -> String -> PM a-parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)+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'`-parseFileExts :: [String]-parseFileExts = ".agda":literateExts+-- | Extensions supported by `parseFile`. -parseFile' :: (Show a) => Parser a -> AbsolutePath -> PM a-parseFile' p file =-  if ".agda" `isSuffixOf` filePath file then-    Agda.Syntax.Parser.parseFile p file+agdaFileExtensions :: [String]+agdaFileExtensions = ".agda" : (fst <$> literateProcessors)++parseFile+  :: Show a+  => Parser a+  -> RangeFile+     -- ^ The file.+  -> String+     -- ^ The file contents. Note that the file is /not/ read from+     -- disk.+  -> PM ((a, Attributes), FileType)+parseFile p file input =+  if ".agda" `List.isSuffixOf` path then+    (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input   else     go literateProcessors   where-    go [] = throwError InvalidExtensionError {-                     errPath = file-                   , errValidExts = parseFileExts+    path = filePath (rangeFilePath file)++    go [] = throwError InvalidExtensionError+                   { errPath = file+                   , errValidExts = agdaFileExtensions                    }-    go ((ext, po):pos) | ext `isSuffixOf` filePath file = parseLiterateFile po p file-    go (_:pos) = go pos+    go ((ext, (po, ft)) : pos)+      | ext `List.isSuffixOf` path =+          (, ft) <$> parseLiterateFile po p file input+      | otherwise = go pos  ------------------------------------------------------------------------ -- Specific parsers@@ -165,43 +207,56 @@ -- | Parses a module.  moduleParser :: Parser Module-moduleParser = Parser { parser = P.moduleParser-                      , parseFlags = withoutComments-                      , parseLiterate = parseLiterateWithoutComments-                      }+moduleParser = Parser+  { parser        = P.moduleParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses a module name.  moduleNameParser :: Parser QName-moduleNameParser = Parser { parser = P.moduleNameParser-                          , parseFlags = withoutComments-                          , parseLiterate = parseLiterateWithoutComments-                          }+moduleNameParser = Parser+  { parser        = P.moduleNameParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses an expression.  exprParser :: Parser Expr-exprParser = Parser { parser = P.exprParser-                    , parseFlags = withoutComments-                    , parseLiterate = parseLiterateWithoutComments-                    }+exprParser = Parser+  { parser        = P.exprParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }  -- | Parses an expression followed by a where clause.  exprWhereParser :: Parser ExprWhere exprWhereParser = Parser-  { parser     = P.exprWhereParser-  , parseFlags = withoutComments+  { parser        = P.exprWhereParser+  , parseFlags    = withoutComments   , parseLiterate = parseLiterateWithoutComments   } +-- | Parses an expression or some other content of an interaction hole.++holeContentParser :: Parser HoleContent+holeContentParser = Parser+  { parser        = P.holeContentParser+  , parseFlags    = withoutComments+  , parseLiterate = parseLiterateWithoutComments+  }+ -- | Gives the parsed token stream (including comments).  tokensParser :: Parser [Token]-tokensParser = Parser { parser = P.tokensParser-                      , parseFlags = withComments-                      , parseLiterate = parseLiterateWithComments-                      }+tokensParser = Parser+  { parser        = P.tokensParser+  , parseFlags    = withComments+  , parseLiterate = parseLiterateWithComments+  }  -- | Keep comments in the token stream generated by the lexer. 
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. -}@@ -8,7 +10,7 @@     , alexInputPrevChar     , alexGetChar, alexGetByte       -- * Lex actions-    , LexAction, LexPredicate+    , LexAction(..), LexPredicate     , (.&&.), (.||.), not'     , PreviousInput, CurrentInput, TokenLength       -- * Monad operations@@ -17,13 +19,13 @@     where  import Control.Monad.State+import Data.Char import Data.Word  import Agda.Syntax.Position import Agda.Syntax.Parser.Monad  import Agda.Utils.Lens-import Agda.Utils.Monad import Agda.Utils.Tuple  -- | This is what the lexer manipulates.@@ -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@@ -43,9 +45,10 @@ alexInputPrevChar :: AlexInput -> Char alexInputPrevChar = lexPrevChar --- | Lex a character. No surprises.+-- | Returns the next character, and updates the 'AlexInput' value. ----- This function is used by Alex 2.+-- This function is not suitable for use by Alex 2, because it can+-- return non-ASCII characters. alexGetChar :: AlexInput -> Maybe (Char, AlexInput) alexGetChar     (AlexInput { lexInput = []              }) = Nothing alexGetChar inp@(AlexInput { lexInput = c:s, lexPos = p }) =@@ -57,21 +60,40 @@                  }          ) --- | A variant of 'alexGetChar'.+-- | Returns the next byte, and updates the 'AlexInput' value. ----- This function is used by Alex 3.+-- A trick is used to handle the fact that there are more than 256+-- Unicode code points. The function translates characters to bytes in+-- the following way:+--+-- * Whitespace characters other than \'\\t\' and \'\\n\' are+--   translated to \' \'.+-- * Non-ASCII alphabetical characters are translated to \'z\'.+-- * Other non-ASCII printable characters are translated to \'+\'.+-- * Everything else is translated to \'\\1\'.+--+-- Note that it is important that there are no keywords containing+-- \'z\', \'+\', \' \' or \'\\1\'.+--+-- This function is used by Alex (version 3).+ alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte ai =-  -- Note that we ensure that every character presented to Alex fits-  -- in seven bits.-  mapFst (fromIntegral . fromEnum) <$> alexGetChar ai+  mapFst (fromIntegral . fromEnum . toASCII) <$> alexGetChar ai+  where+  toASCII c+    | isSpace c && c /= '\t' && c /= '\n' = ' '+    | isAscii c                           = c+    | isPrint c                           = if isAlpha c then 'z'+                                                         else '+'+    | otherwise                           = '\1'  {--------------------------------------------------------------------------     Monad operations  --------------------------------------------------------------------------}  getLexInput :: Parser AlexInput-getLexInput = getInp <$> get+getLexInput = gets getInp     where         getInp s = AlexInput                     { lexSrcFile    = parseSrcFile s@@ -99,7 +121,23 @@  -- | In the lexer, regular expressions are associated with lex actions who's --   task it is to construct the tokens.-type LexAction r    = PreviousInput -> CurrentInput -> TokenLength -> Parser r+newtype LexAction r+  = LexAction { runLexAction :: PreviousInput -> CurrentInput -> TokenLength -> Parser r }+  deriving (Functor)++instance Applicative LexAction where+  pure r    = LexAction $ \ _ _ _ -> pure r+  mf <*> mr = LexAction $ \ a b c -> runLexAction mf a b c <*> runLexAction mr a b c++instance Monad LexAction where+  return = pure+  m >>= k  = LexAction $ \ a b c -> do+    r <- runLexAction m a b c+    runLexAction (k r) a b c++instance MonadState ParseState LexAction where+  get   = LexAction $ \ _ _ _ -> get+  put s = LexAction $ \ _ _ _ -> put s  -- | Sometimes regular expressions aren't enough. Alex provides a way to do --   arbitrary computations to see if the input matches. This is done with a
src/full/Agda/Syntax/Parser/Comments.hs view
@@ -1,4 +1,4 @@--- {-# LANGUAGE CPP #-}+{-# 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@@ -10,7 +10,7 @@ module Agda.Syntax.Parser.Comments     where -import Data.List+import qualified Data.List as List  import {-# SOURCE #-} Agda.Syntax.Parser.LexActions import Agda.Syntax.Parser.Monad@@ -19,8 +19,6 @@ import Agda.Syntax.Parser.LookAhead import Agda.Syntax.Position -import Agda.Utils.Monad- -- | Should comment tokens be output?  keepComments :: LexPredicate@@ -35,8 +33,10 @@ --   In the end the comment is discarded and 'lexToken' is called to lex a real --   token. nestedComment :: LexAction Token-nestedComment inp inp' _ =+nestedComment = LexAction $ \ inp inp' _ ->     do  setLexInput inp'+        let err :: forall a. String -> LookAhead a+            err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{-'"         runLookAhead err $ skipBlock "{-" "-}"         keep <- keepCommentsM         if keep then do@@ -45,25 +45,24 @@               i = posToInterval (lexSrcFile inp) p1 p2               s = case (p1, p2) of                     (Pn { posPos = p1 }, Pn { posPos = p2 }) ->-                      genericTake (p2 - p1) $ lexInput inp+                      List.genericTake (p2 - p1) $ lexInput inp           return $ TokComment (i, s)          else           lexToken-    where-        err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{-'" + -- | Lex a hole (@{! ... !}@). Holes can be nested. --   Returns @'TokSymbol' 'SymQuestionMark'@. hole :: LexAction Token-hole inp inp' _ =+hole = LexAction $ \ inp inp' _ ->     do  setLexInput inp'+        let err :: forall a. String -> LookAhead a+            err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{!'"         runLookAhead err $ skipBlock "{!" "!}"         p <- lexPos <$> getLexInput         return $           TokSymbol SymQuestionMark $           posToInterval (lexSrcFile inp) (lexPos inp) p-    where-        err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{!'"  -- | Skip a block of text enclosed by the given open and close strings. Assumes --   the first open string has been consumed. Open-close pairs may be nested.
+ 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,4 +1,4 @@--- {-# LANGUAGE CPP #-}+{-# 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@@ -7,26 +7,110 @@      > f x = x'     >   where-    >     x' = case x of { True -> False; False -> ...+    >     x' = do y <- foo x; bar ...      At the @...@ the layout context would be -    > [NoLayout, Layout 4, Layout 0]+    > [Layout 12, Layout 4, Layout 0] -    The closest layout block is the one containing the @case@ branches.  This-    block starts with an open brace (@\'{\'@) and so doesn't use layout.  The-    second closest block is the @where@ clause.  Here, there is no open brace-    so the block is started by the @x'@ token which has indentation 4. Finally-    there is a top-level layout block with indentation 0.+    The closest layout block is the one following @do@ which is+    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.++    In April 2021 we changed layout handling in the lexer to allow+    stacking of layout keywords on the same line, e.g.:++    > private module M where+    >    postulate A : Set+    >              private+    >                B : Set++    The layout columns in the layout context (stack of layout blocks) can+    have 'LayoutStatus' either 'Tentative' or 'Confirmed'. New layout+    columns following a layout keyword are tentative until we see a new+    line. E.g.++      - The first @private@ block (column 8) is 'Tentative' when we+        encounter the layout keyword @where@.++      - The @postulate@ block (column 12) is 'Tentative' until the newline+        after @A : Set@.++    In contrast,++      - The @module@ block (column 2) is 'Confirmed' from the beginning+        since the first token (@postulate@) after the layout keyword @where@+        is on a new line.++      - The second @private@ block (column 14) is also 'Confirmed' from the+        beginning (for the same reason).++    A new layout column has to be strictly above the last __confirmed__+    column only. E.g., when encountering @postulate@ at column 2 after+    @where@, the confirmed column is still 0, so this is a valid start of+    the block following @where@.++    The column 8 of the @private@ block never enters the 'Confirmed' status+    but remains 'Tentative'. Also, this block can never get more than the+    one declaration it has (@module...@), because when the @module@ block+    closes due to a column \< 2, it closes as well. One could say that+    tentative blocks buried under confirmed blocks are passive, the only+    wait for their closing.++    To implement the process of block confirmation (function+    'confirmLayout'), the lexer has to act on newline characters (except for+    those in a block comment).++      - In ordinary mode, when encountering a newline, we confirm the top+        unconfirmed blocks. Example: The newline after @A : Set@ confirms+        the column 12 after @postulate@. Function: 'confirmLayoutAtNewLine',+        state @bol@.++      - In the @layout@ state following a layout keyword, a newline does not+        confirm any block, but announces that the next block should be+        confirmed from the start. Function: 'confirmedLayoutComing'.++    In order to implement 'confirmedLayoutComing' we have a 'LayoutStatus'+    flag in the parse state (field 'stateLayStatus'). By default, for a new+    layout block, the status is 'Tentative' (unless we saw a newline).++    New layout blocks are created as follows. When a layout keyword is+    encountered, we enter lexer state 'layout' via function 'withLayout'.+    When we exit the 'layout' state via 'newLayoutBlock' with a token that+    marks the new layout column, we push a new 'LayoutBlock' onto the+    'LayoutContext' using the given column and the current 'parseLayStatus'+    which is then reset to 'Tentative'.++    The new block is actually only pushed if the column is above the last+    confirmed layout column ('confirmedLayoutColumn'). If this check fails,+    we instead enter the 'empty_layout' state. This state produces the+    closing brace and is immediately left for 'bol' (beginning of line).++    (Remark: In 'bol' we might confirm some tentative top blocks, but this+    is irrelevant, since they will be closed immediately, given that the+    current token is left of the confirmed column, and tentative columns+    above it must be to the right of this column.)++    The 'offsideRule' (state 'bol') is unchanged. It checks how the first+    token on a new line relates to the top layout column, be it tentative or+    confirmed. (Since we are on a new line, 'Tentative' can only happen when+    we popped some 'Confirmed' columns and continue popping the top+    'Tentative' columns here.) While the token is to the left of the layout+    column, we keep closing blocks.+ -} module Agda.Syntax.Parser.Layout-    ( openBrace, closeBrace-    , withLayout+    ( withLayout     , offsideRule-    , newLayoutContext+    , newLayoutBlock     , emptyLayout+    , confirmLayout     ) where +import Control.Monad        ( when )+import Control.Monad.State  ( gets, modify )+ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad@@ -34,34 +118,16 @@ import Agda.Syntax.Parser.LexActions import Agda.Syntax.Position ---- | Executed upon lexing an open brace (@\'{\'@). Enters the 'NoLayout'---   context.-openBrace :: LexAction Token-openBrace = token $ \_ ->-    do  pushContext NoLayout-        i <- getParseInterval-        return (TokSymbol SymOpenBrace i)---{-| Executed upon lexing a close brace (@\'}\'@). Exits the current layout-    context. This might look a bit funny--the lexer will happily use a close-    brace to close a context open by a virtual brace. This is not a problem-    since the parser will make sure the braces are appropriately matched.--}-closeBrace :: LexAction Token-closeBrace = token $ \_ ->-    do  popContext-        i <- getParseInterval-        return (TokSymbol SymCloseBrace i)+import Agda.Utils.Functor ((<&>)) +{-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol'),+    except when the last token was a layout keyword. -{-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol').     Checks the position of the token relative to the current layout context.     If the token is      - /to the left/ :-        Exit the current context and a return virtual close brace (stay in the+        Exit the current block and a return virtual close brace (stay in the         'Agda.Syntax.Parser.Lexer.bol' state).      - /same column/ :@@ -71,50 +137,44 @@     - /to the right/ :         Exit the 'Agda.Syntax.Parser.Lexer.bol' state and continue lexing. -    If the current block doesn't use layout (i.e. it was started by-    'openBrace') all positions are considered to be /to the right/. -} offsideRule :: LexAction Token-offsideRule inp _ _ =-    do  offs <- getOffside p-        case offs of-            LT  -> do   popContext-                        return (TokSymbol SymCloseVirtualBrace i)-            EQ  -> do   popLexState-                        return (TokSymbol SymVirtualSemi i)-            GT  -> do   popLexState-                        lexToken-    where-        p = lexPos inp+offsideRule = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+    getOffside p >>= \case+        LT  -> do   popBlock+                    return (TokSymbol SymCloseVirtualBrace i)+        EQ  -> do   popLexState+                    return (TokSymbol SymVirtualSemi i)+        GT  -> do   popLexState+                    lexToken   {-| This action is only executed from the 'Agda.Syntax.Parser.Lexer.empty_layout'     state. It will exit this state, enter the 'Agda.Syntax.Parser.Lexer.bol' state,     and return a virtual close brace (closing the empty layout block started-    by 'newLayoutContext').+    by 'newLayoutBlock'). -} emptyLayout :: LexAction Token-emptyLayout inp _ _ =-    do  popLexState-        pushLexState bol-        return (TokSymbol SymCloseVirtualBrace i)-    where-        p = lexPos inp+emptyLayout = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+    popLexState+    pushLexState bol+    return (TokSymbol SymCloseVirtualBrace i)  -{-| Start a new layout context. This is one of two ways to get out of the-    'Agda.Syntax.Parser.Lexer.layout' state (the other is 'openBrace'). There are+{-| Start a new layout block. This is how to get out of the+    'Agda.Syntax.Parser.Lexer.layout' state. There are     two possibilities: -    - The current token is to the right of the current layout context (or we're-      in a no layout context).+    - The current token is to the right of the confirmed layout column. -    - The current token is to the left of or in the same column as the current-      context.+    - The current token is to the left of or in the same column as the confirmed+      layout column. -    In the first case everything is fine and we enter a new layout context at+    In the first case everything is fine and we enter a new layout block at     the column of the current token. In the second case we have an empty layout     block so we enter the 'Agda.Syntax.Parser.Lexer.empty_layout' state. In both     cases we return a virtual open brace without consuming any input.@@ -125,27 +185,71 @@     then enter a state in which the only thing you can do is generate the     second one. -}-newLayoutContext :: LexAction Token-newLayoutContext inp _ _ =-    do  let offset = posCol p-        ctx <- topContext-        case ctx of-            Layout prevOffs | prevOffs >= offset ->-                do  pushLexState empty_layout-                    return (TokSymbol SymOpenVirtualBrace i)-            _ ->-                do  pushContext (Layout offset)-                    return (TokSymbol SymOpenVirtualBrace i)-    where-        p = lexPos inp+newLayoutBlock :: LexAction Token+newLayoutBlock = LexAction $ \ inp _ _ -> do+    let p = lexPos inp         i = posToInterval (lexSrcFile inp) p p+        offset = posCol p+    status   <- popPendingLayout+    kw       <- gets parseLayKw+    prevOffs <- confirmedLayoutColumn <$> getContext+    if prevOffs >= offset+        then pushLexState empty_layout+        else do+            when (status == Confirmed) $+              modifyContext $ confirmTentativeBlocks $ Just offset+            pushBlock $ Layout kw status offset+    return $ TokSymbol SymOpenVirtualBrace i+  where +    -- Get and reset the status of the coming layout block.+    popPendingLayout :: Parser LayoutStatus+    popPendingLayout = do+        status <- gets parseLayStatus+        resetLayoutStatus+        return status +    -- The confirmed layout column, or 0 if there is none.+    confirmedLayoutColumn :: LayoutContext -> Column+    confirmedLayoutColumn = \case+       Layout _ Confirmed c : _   -> c+       Layout _ Tentative _ : cxt -> confirmedLayoutColumn cxt+       [] -> 0 -- should only happen when looking at the first token (top-level layout)+ -- | Compute the relative position of a location to the --   current layout context. getOffside :: Position' a -> Parser Ordering getOffside loc =-    do  ctx <- topContext-        return $ case ctx of-            Layout n    -> compare (posCol loc) n-            _           -> GT+    getContext <&> \case+        Layout _ _ n : _ -> compare (posCol loc) n+        _                -> GT++-- | At a new line, we confirm either existing tentative layout+--   columns, or, if the last token was a layout keyword, the expected+--   new layout column.+confirmLayout :: Parser ()+confirmLayout = getLexState >>= \ case+  s : _ | s == layout -> confirmedLayoutComing+  _                   -> confirmLayoutAtNewLine+  where++  -- Mark the pending layout block as 'Confirmed'.+  confirmedLayoutComing :: Parser ()+  confirmedLayoutComing = modify $ \ s -> s { parseLayStatus = Confirmed }++  -- Encountering a newline outside of a 'layout' state we confirm top+  -- tentative layout columns.+  confirmLayoutAtNewLine :: Parser ()+  confirmLayoutAtNewLine = modifyContext $ confirmTentativeBlocks Nothing++-- | Confirm all top 'Tentative' layout columns.+-- If a column is given, only those below the given column.+--+-- The code ensures that the newly created 'Definitive' columns+-- are strictly decreasing.+--+confirmTentativeBlocks :: Maybe Column -> LayoutContext -> LayoutContext+confirmTentativeBlocks mcol = \case+    Layout kw Tentative col : cxt | maybe True (col <) mcol+            -> Layout kw Confirmed col : confirmTentativeBlocks (Just col) cxt+    cxt  -> cxt
src/full/Agda/Syntax/Parser/Layout.hs-boot view
@@ -1,8 +1,15 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Parser.Layout where -import Agda.Syntax.Parser.Alex-import Agda.Syntax.Parser.Tokens+import Agda.Syntax.Parser.Alex   (LexAction)+import Agda.Syntax.Parser.Monad  (Parser)+import Agda.Syntax.Parser.Tokens (Token)  offsideRule      :: LexAction Token-newLayoutContext :: LexAction Token+newLayoutBlock   :: LexAction Token emptyLayout      :: LexAction Token++confirmLayout    :: Parser ()+-- confirmLayoutAtNewLine :: Parser ()+-- confirmedLayoutComing  :: Parser ()
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@@ -9,17 +12,26 @@     , token     , withInterval, withInterval', withInterval_     , withLayout-    , begin, end, endWith+    , andThen, skip+    , begin, end, beginWith, endWith     , begin_, end_     , lexError       -- ** Specialized actions-    , keyword, symbol, identifier, literal+    , keyword, symbol, identifier, literal, literal', integer       -- * Lex predicates     , followedBy, eof, inState     ) where +import Control.Monad.State (modify)++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) import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad@@ -27,24 +39,35 @@ import Agda.Syntax.Position import Agda.Syntax.Literal -import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.Tuple+import Agda.Utils.List1 (String1, toList)+import qualified Agda.Utils.List1 as List1 +import Agda.Utils.Impossible+ {--------------------------------------------------------------------------     Scan functions  --------------------------------------------------------------------------}  -- | Called at the end of a file. Returns 'TokEOF'. returnEOF :: AlexInput -> Parser Token-returnEOF inp =-    do  setLastPos $ lexPos inp-        setPrevToken "<EOF>"-        return TokEOF+returnEOF AlexInput{ lexSrcFile, lexPos } = do+  -- Andreas, 2018-12-30, issue #3480+  -- The following setLastPos leads to parse error reporting+  -- far away from the interesting position, in particular+  -- if there is a long comment before the EOF.+  -- (Such a long comment is frequent in interactive programming, as+  -- commenting out until the end of the file is a common habit.)+  -- -- setLastPos lexPos+  -- Without it, we get much more useful error locations.+  setPrevToken "<EOF>"+  return $ TokEOF $ posToInterval lexSrcFile lexPos lexPos  -- | Set the current input and lex a new token (calls 'lexToken'). skipTo :: AlexInput -> Parser Token-skipTo inp = setLexInput inp >> lexToken+skipTo inp = do+  setLexInput inp+  lexToken  {-| Scan the input to find the next token. Calls 'Agda.Syntax.Parser.Lexer.alexScanUser'. This is the main lexing function@@ -54,18 +77,27 @@ lexToken :: Parser Token lexToken =     do  inp <- getLexInput-        lss@(ls:_) <- getLexState+        lss <- getLexState         flags <- getParseFlags-        case alexScanUser (lss, flags) (foolAlex inp) ls of+        case alexScanUser (lss, flags) inp (headWithDefault __IMPOSSIBLE__ lss) of             AlexEOF                     -> returnEOF inp-            AlexSkip inp' len           -> skipTo (newInput inp inp' len)-            AlexToken inp' len action   -> fmap postToken $ action inp (newInput inp inp' len) len-            AlexError i                 -> parseError $ "Lexical error" ++-              (case lexInput i of-                 '\t' : _ -> " (you may want to replace tabs with spaces)"-                 _        -> "") ++-              ":"+            AlexSkip inp' len           -> skipTo inp'+            AlexToken inp' len action   -> postToken <$> runLexAction action inp inp' len+            AlexError i                 -> parseError $ concat+              [ "Lexical error"+              , case listToMaybe $ lexInput i of+                  Just '\t'                -> " (you may want to replace tabs with spaces)"+                  Just c | not (isPrint c) -> " (unprintable character)"+                  _ -> ""+              , ":"+              ] +isSub :: Char -> Bool+isSub c = '\x2080' <= c && c <= '\x2089'++readSubscript :: [Char] -> Integer+readSubscript = read . map (\c -> toEnum (fromEnum c - 0x2080 + fromEnum '0'))+ postToken :: Token -> Token postToken (TokId (r, "\x03bb")) = TokSymbol SymLambda r postToken (TokId (r, "\x2026")) = TokSymbol SymEllipsis r@@ -74,56 +106,22 @@ postToken (TokId (r, "\x2984")) = TokSymbol SymDoubleCloseBrace r postToken (TokId (r, "\x2987")) = TokSymbol SymOpenIdiomBracket r postToken (TokId (r, "\x2988")) = TokSymbol SymCloseIdiomBracket r+postToken (TokId (r, "\x2987\x2988")) = TokSymbol SymEmptyIdiomBracket r postToken (TokId (r, "\x2200")) = TokKeyword KwForall r-postToken (TokId (r, s))-  | set == "Set" && all isSub n = TokSetN (r, readSubscript n)-  where-    (set, n)      = splitAt 3 s-    isSub c       = c `elem` ['\x2080'..'\x2089']-    readSubscript = read . map (\c -> toEnum (fromEnum c - 0x2080 + fromEnum '0')) postToken t = t --- | Use the input string from the previous input (with the appropriate---   number of characters dropped) instead of the fake input string that---   was given to Alex (with unicode characters removed).-newInput :: PreviousInput -> CurrentInput -> TokenLength -> CurrentInput-newInput inp inp' len =-    case drop (len - 1) (lexInput inp) of-        c:s'    -> inp' { lexInput    = s'-                        , lexPrevChar = c-                        }-        []      -> inp' { lexInput = [] }   -- we do get empty tokens moving between states---- | Alex 2 can't handle unicode characters. To solve this we---   translate all Unicode (non-ASCII) identifiers to @z@, all Unicode---   operator characters to @+@, and all whitespace characters (except---   for @\t@ and @\n@) to ' '.---   Further, non-printable Unicode characters are translated to an---   arbitrary, harmless ASCII non-printable character, @'\1'@.------   It is important that there aren't any keywords containing @z@, @+@ or @ @.--foolAlex :: AlexInput -> AlexInput-foolAlex = over lensLexInput $ map $ \ c ->-  case c of-    _ | isSpace c && not (c `elem` "\t\n") -> ' '-    _ | isAscii c                          -> c-    _ | isPrint c                          -> if isAlpha c then 'z' else '+'-    _ | otherwise                          -> '\1'- {--------------------------------------------------------------------------     Lex actions  --------------------------------------------------------------------------}  -- | The most general way of parsing a token. token :: (String -> Parser tok) -> LexAction tok-token action inp inp' len =+token action = LexAction $ \ inp inp' len ->     do  setLexInput inp'+        let t = take len $ lexInput inp         setPrevToken t         setLastPos $ lexPos inp         action t-    where-        t = take len $ lexInput inp  -- | Parse a token from an 'Interval' and the lexed string. withInterval :: ((Interval, String) -> tok) -> LexAction tok@@ -133,7 +131,7 @@  -- | Like 'withInterval', but applies a function to the string. withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok-withInterval' f t = withInterval (t . (id -*- f))+withInterval' f t = withInterval (t . second f)  -- | Return a token without looking at the lexed string. withInterval_ :: (Interval -> r) -> LexAction r@@ -142,76 +140,133 @@  -- | Executed for layout keywords. Enters the 'Agda.Syntax.Parser.Lexer.layout' --   state and performs the given action.-withLayout :: LexAction r -> LexAction r-withLayout a i1 i2 n =-    do  pushLexState layout-        a i1 i2 n+withLayout :: Keyword -> LexAction r -> LexAction r+withLayout kw a = pushLexState layout `andThen` setLayoutKw `andThen` a+  where+  setLayoutKw = modify $ \ st -> st { parseLayKw = kw } +infixr 1 `andThen` +-- | Prepend some parser manipulation to an action.+andThen :: Parser () -> LexAction r -> LexAction r+andThen cmd a = LexAction $ \ inp inp' n -> do+  cmd+  runLexAction a inp inp' n++-- | Visit the current lexeme again.+revisit :: LexAction Token+revisit = LexAction $ \ _ _ _ -> lexToken++-- | Throw away the current lexeme.+skip :: LexAction Token+skip = LexAction $ \ _ inp' _ -> skipTo inp'+ -- | Enter a new state without consuming any input. begin :: LexState -> LexAction Token-begin code _ _ _ =-    do  pushLexState code-        lexToken+begin code = beginWith code revisit +-- | Exit the current state without consuming any input.+end :: LexAction Token+end = endWith revisit  -- | Enter a new state throwing away the current lexeme. begin_ :: LexState -> LexAction Token-begin_ code _ inp' _ =-    do  pushLexState code-        skipTo inp'-+begin_ code = beginWith code skip  -- | Exit the current state throwing away the current lexeme. end_ :: LexAction Token-end_ _ inp' _ =-    do  popLexState-        skipTo inp'+end_ = endWith skip +-- | Enter a new state and perform the given action.+beginWith :: LexState -> LexAction a -> LexAction a+beginWith code a = pushLexState code `andThen` a  -- | Exit the current state and perform the given action. endWith :: LexAction a -> LexAction a-endWith a inp inp' n =-    do  popLexState-        a inp inp' n+endWith a = popLexState `andThen` a  --- | Exit the current state without consuming any input-end :: LexAction Token-end _ _ _ =-    do  popLexState-        lexToken- -- | Parse a 'Keyword' token, triggers layout for 'layoutKeywords'. keyword :: Keyword -> LexAction Token-keyword k = layout $ withInterval_ (TokKeyword k)+keyword k =+    case k of++        -- Unconditional layout keyword.+        _ | k `elem` layoutKeywords ->+            withLayout k cont++        -- Andreas, 2021-05-06, issue #5356:+        -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.+        -- -- @constructor@ is not a layout keyword in @record ... where@ blocks,+        -- -- only in @interleaved mutual@ blocks.+        -- KwConstructor -> do+        --     cxt <- getContext+        --     if inMutualAndNotInWhereBlock cxt+        --       then withLayout k cont+        --       else cont++        _ -> cont     where-        layout | elem k layoutKeywords  = withLayout-               | otherwise              = id+    cont = withInterval_ (TokKeyword k) +    -- Andreas, 2021-05-06, issue #5356:+    -- @constructor@ is not a layout keyword after all, replaced by @data _ where@.+    -- -- Most recent block decides ...+    -- inMutualAndNotInWhereBlock = \case+    --   Layout KwMutual _ _ : _ -> True+    --   Layout KwWhere  _ _ : _ -> False+    --   _ : bs                  -> inMutualAndNotInWhereBlock bs+    --   []                      -> True  -- For better errors on stray @constructor@ decls. + -- | Parse a 'Symbol' token. symbol :: Symbol -> LexAction Token symbol s = withInterval_ (TokSymbol s)  +-- | Parse a number.++number :: String -> Integer+number str = case str of+    '0' : 'x' : num -> parseNumber 16 num+    '0' : 'b' : num -> parseNumber 2  num+    num             -> parseNumber 10 num+    where+        parseNumber :: Integer -> String -> Integer+        parseNumber radix = foldl' (addDigit radix) 0++        -- We rely on Agda.Syntax.Parser.Lexer to enforce that the digits are+        -- in the correct range (so e.g. the digit 'E' cannot appear in a+        -- binary number).+        addDigit :: Integer -> Integer -> Char -> Integer+        addDigit radix n '_' = n+        addDigit radix n c   = n * radix + fromIntegral (digitToInt c)++integer :: String -> Integer+integer = \case+  '-' : str -> - (number str)+  str       -> number str+ -- | Parse a literal.-literal :: Read a => (Range -> a -> Literal) -> LexAction Token-literal lit =-  withInterval' read (TokLiteral . uncurry lit . mapFst getRange)+literal' :: (String -> a) -> (a -> Literal) -> LexAction Token+literal' read lit = withInterval' read $ \ (r, a) ->+  TokLiteral $ Ranged (getRange r) $ lit a +literal :: Read a => (a -> Literal) -> LexAction Token+literal = literal' read+ -- | 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@@ -219,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@@ -12,17 +14,23 @@  withInterval  :: ((Interval, String) -> tok) -> LexAction tok withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok-withLayout :: LexAction r -> LexAction r+withLayout :: Keyword -> LexAction r -> LexAction r -begin   :: LexState -> LexAction Token-endWith :: LexAction a -> LexAction a-begin_  :: LexState -> LexAction Token-end_    :: LexAction Token+andThen   :: Parser () -> LexAction r -> LexAction r+skip      :: LexAction Token +begin     :: LexState -> LexAction Token+beginWith :: LexState -> LexAction a -> LexAction a+endWith   :: LexAction a -> LexAction a+begin_    :: LexState -> LexAction Token+end_      :: LexAction Token+ keyword    :: Keyword -> LexAction Token symbol     :: Symbol -> LexAction Token identifier :: LexAction Token-literal    :: Read a => (Range -> a -> Literal) -> LexAction Token+literal    :: Read a => (a -> Literal) -> LexAction Token+literal'   :: (String -> a) -> (a -> Literal) -> LexAction Token+integer    :: String -> Integer  followedBy    :: Char -> LexPredicate eof           :: LexPredicate
src/full/Agda/Syntax/Parser/Lexer.x view
@@ -1,11 +1,15 @@ {+#if  __GLASGOW_HASKELL__ > 800+{-# OPTIONS_GHC -Wno-error=deprecated-flags   #-}+{-# OPTIONS_GHC -Wno-error=missing-signatures #-}+{-# OPTIONS_GHC -Wno-error=tabs               #-}+{-# OPTIONS_GHC -Wno-error=unused-imports     #-}+#endif {-# OPTIONS_GHC -fno-warn-deprecated-flags   #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-tabs               #-} {-# OPTIONS_GHC -fno-warn-unused-imports     #-} -{-# LANGUAGE BangPatterns #-}- {-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an     adaptation of GHC's lexer. The main lexing function 'lexer' is called by     the "Agda.Syntax.Parser.Parser" to get the next token from the input.@@ -20,8 +24,6 @@     , AlexReturn(..), alexScanUser     ) where --- -- import Data.List- import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Comments #ifndef __HADDOCK__@@ -35,25 +37,28 @@  } --- Unicode is not handled by the following regular expressions.--- Instead, unicode characters are translated to 7-bit ASCII--- by Agda.Syntax.Parser.LexActions.foolAlex in a preprocessing pass.+-- Note that the regular expressions should not use non-ASCII+-- characters, see Agda.Syntax.Parser.Alex.alexGetByte.  $digit       = 0-9 $hexdigit    = [ $digit a-f A-F ]+$binarydigit = 0-1 $alpha       = [ A-Z a-z _ ] $op          = [ \- \! \# \$ \% \& \* \+ \/ \< \= \> \^ \| \~ \? \` \[ \] \, \: ] $idstart     = [ $digit $alpha $op ] $idchar      = [ $idstart ' \\ ] $nonalpha    = $idchar # $alpha-$nonalphanum = $nonalpha # $digit $white_notab = $white # \t $white_nonl  = $white_notab # \n -@number      = $digit+ | "0x" $hexdigit+-@integer     = [\-]? @number-@exponent    = [eE] [\-\+]? @number-@float       = @integer \. @number @exponent? | @number @exponent+@prettynumber = $digit+ ([_] $digit+)*+              | "0x" $hexdigit+ ([_] $hexdigit+)*+              | "0b" $binarydigit+ ([_] $binarydigit+)*+@integer      = [\-]? @prettynumber+@decimal      = $digit++@exponent     = [eE] [\-\+]? @decimal+@float        = [\-]? @decimal \. @decimal @exponent?+              | [\-]? @decimal @exponent  -- A name can't start with \x (to allow \x -> x). -- Bug in alex: [ _ op ]+ doesn't seem to work!@@ -69,40 +74,44 @@ <0,code,bol_,layout_,empty_layout_,imp_dir_>     $white_nonl+    ; -<pragma_> $white_notab ;+<pragma_,fpragma_> $white_notab ;  -- Pragmas-<0,code>    "{-#"                      { begin pragma }-<pragma_>   "{-#"                      { symbol SymOpenPragma }-<pragma_>   "#-}"                      { endWith $ symbol SymClosePragma }+<0,code,pragma_>   "{-#"               { beginWith pragma  $ symbol SymOpenPragma }+<fpragma_>         "{-#"               { beginWith fpragma $ symbol SymOpenPragma }+<pragma_,fpragma_> "#-}"               { endWith $ symbol SymClosePragma } <pragma_>   "BUILTIN"                  { keyword KwBUILTIN } <pragma_>   "CATCHALL"                 { keyword KwCATCHALL }-<pragma_>   "COMPILED"                 { keyword KwCOMPILED }-<pragma_>   "COMPILED_DATA"            { keyword KwCOMPILED_DATA }-<pragma_>   "COMPILED_DATA_UHC"        { keyword KwCOMPILED_DATA_UHC }-<pragma_>   "COMPILED_DECLARE_DATA"    { keyword KwCOMPILED_DECLARE_DATA }-<pragma_>   "COMPILED_EPIC"            { keyword KwCOMPILED_EPIC }-<pragma_>   "COMPILED_EXPORT"          { keyword KwCOMPILED_EXPORT }-<pragma_>   "COMPILED_JS"              { keyword KwCOMPILED_JS }-<pragma_>   "COMPILED_TYPE"            { keyword KwCOMPILED_TYPE }-<pragma_>   "COMPILED_UHC"             { keyword KwCOMPILED_UHC }-<pragma_>   "HASKELL"                  { keyword KwHASKELL }+<pragma_>   "COMPILE"                  { endWith $ beginWith fpragma $ keyword KwCOMPILE }+<pragma_>   "FOREIGN"                  { endWith $ beginWith fpragma $ keyword KwFOREIGN } <pragma_>   "DISPLAY"                  { keyword KwDISPLAY }-<pragma_>   "IMPORT"                   { keyword KwIMPORT }-<pragma_>   "IMPORT_UHC"               { keyword KwIMPORT_UHC }+<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 } <pragma_>   "NO_TERMINATION_CHECK"     { keyword KwNO_TERMINATION_CHECK }+<pragma_>   "NO_UNIVERSE_CHECK"        { keyword KwNO_UNIVERSE_CHECK }+<pragma_>   "NON_COVERING"             { keyword KwNON_COVERING } <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 }-<pragma_>   . # [ $white ] +           { withInterval $ TokString }+<pragma_>   "WARNING_ON_USAGE"         { keyword KwWARNING_ON_USAGE }+<pragma_>   "WARNING_ON_IMPORT"        { keyword KwWARNING_ON_IMPORT }+<pragma_>   . # [ $white \" ] +        { withInterval $ TokString } -- we recognise string literals in pragmas+<fpragma_>  . # [ $white ] +           { withInterval $ TokString }  -- Comments     -- We need to rule out pragmas here. Usually longest match would take@@ -115,75 +124,80 @@  -- Dashes followed by a name symbol should be parsed as a name. <0,code,bol_,layout_,empty_layout_,imp_dir_>-   "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }-             { withInterval TokComment }+    "--" .* / { keepComments .&&. (followedBy '\n' .||. eof) }+              { confirmLayout `andThen` withInterval TokComment } <0,code,bol_,layout_,empty_layout_,imp_dir_>-  "--" .* / { followedBy '\n' .||. eof } ;+    "--" .* / { followedBy '\n' .||. eof }+              { confirmLayout `andThen` skip } +-- Note: we need to confirm tentative layout columns whenever we meet+-- a newline character ('\n').+-- The exception is the newline after a layout keyword.+ -- We need to check the offside rule for the first token on each line.  We -- should not check the offside rule for the end of file token or an -- '\end{code}'-<0,code,imp_dir_> \n    { begin bol_ }+<0,code,imp_dir_> \n    { begin bol_ }  -- Note that @begin@ revisits '\n' in the new state! <bol_>     {-        \n                  ;+        \n                      { confirmLayout `andThen` skip } --      ^ \\ "end{code}"    { end }         () / { not' eof }       { offsideRule }     } --- After a layout keyword there is either an open brace (no layout) or the+-- After a layout keyword the -- indentation of the first token decides the column of the layout block. <layout_>-    {   \n      ;---      \{      { endWith openBrace }-        ()      { endWith newLayoutContext }+    {   \n      { confirmLayout `andThen` skip}+        ()      { endWith newLayoutBlock }     }  -- The only rule for the empty_layout state. Generates a close brace. <empty_layout_> ()              { emptyLayout }  -- Keywords-<0,code> let            { keyword KwLet }-<0,code> in             { keyword KwIn }-<0,code> where          { keyword KwWhere }-<0,code> field          { keyword KwField }-<0,code> with           { keyword KwWith }-<0,code> rewrite        { keyword KwRewrite }-<0,code> postulate      { keyword KwPostulate }-<0,code> primitive      { keyword KwPrimitive }-<0,code> open           { keyword KwOpen }-<0,code> import         { keyword KwImport }-<0,code> module         { keyword KwModule }-<0,code> data           { keyword KwData }-<0,code> codata         { keyword KwCoData }-<0,code> record         { keyword KwRecord }-<0,code> constructor    { keyword KwConstructor }-<0,code> inductive      { keyword KwInductive }-<0,code> coinductive    { keyword KwCoInductive }+<0,code> abstract          { keyword KwAbstract }+<0,code> codata            { keyword KwCoData }+<0,code> coinductive       { keyword KwCoInductive }+<0,code> constructor       { keyword KwConstructor }+<0,code> data              { keyword KwData }+<0,code> do                { keyword KwDo } <0,code> "eta-equality"    { keyword KwEta }+<0,code> field             { keyword KwField }+<0,code> forall            { keyword KwForall }+<0,code> import            { keyword KwImport }+<0,code> in                { keyword KwIn }+<0,code> inductive         { keyword KwInductive }+<0,code> infix             { keyword KwInfix }+<0,code> infixl            { keyword KwInfixL }+<0,code> infixr            { keyword KwInfixR }+<0,code> instance          { keyword KwInstance }+<0,code> interleaved       { keyword KwInterleaved }+<0,code> let               { keyword KwLet }+<0,code> macro             { keyword KwMacro }+<0,code> module            { keyword KwModule }+<0,code> mutual            { keyword KwMutual } <0,code> "no-eta-equality" { keyword KwNoEta }-<0,code> infix          { keyword KwInfix }-<0,code> infixl         { keyword KwInfixL }-<0,code> infixr         { keyword KwInfixR }-<0,code> mutual         { keyword KwMutual }-<0,code> abstract       { keyword KwAbstract }-<0,code> private        { keyword KwPrivate }-<0,code> instance       { keyword KwInstance }-<0,code> overlap        { keyword KwOverlap }-<0,code> macro          { keyword KwMacro }-<0,code> Set            { keyword KwSet }-<0,code> forall         { keyword KwForall }-<0,code> Set @number    { withInterval' (read . drop 3) TokSetN }-<0,code> quoteGoal      { keyword KwQuoteGoal }-<0,code> quoteContext   { keyword KwQuoteContext }-<0,code> quote          { keyword KwQuote }-<0,code> quoteTerm      { keyword KwQuoteTerm }-<0,code> unquote        { keyword KwUnquote }-<0,code> unquoteDecl    { keyword KwUnquoteDecl }-<0,code> unquoteDef     { keyword KwUnquoteDef  }-<0,code> tactic         { keyword KwTactic }-<0,code> syntax         { keyword KwSyntax }-<0,code> pattern        { keyword KwPatternSyn }+<0,code> open              { keyword KwOpen }+<0,code> overlap           { keyword KwOverlap }+<0,code> pattern           { keyword KwPatternSyn }+<0,code> postulate         { keyword KwPostulate }+<0,code> primitive         { keyword KwPrimitive }+<0,code> private           { keyword KwPrivate }+<0,code> quote             { keyword KwQuote }+<0,code> quoteTerm         { keyword KwQuoteTerm }+<0,code> record            { keyword KwRecord }+<0,code> rewrite           { keyword KwRewrite }+<0,code> syntax            { keyword KwSyntax }+<0,code> tactic            { keyword KwTactic }+<0,code> unquote           { keyword KwUnquote }+<0,code> unquoteDecl       { keyword KwUnquoteDecl }+<0,code> unquoteDef        { keyword KwUnquoteDef  }+<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@@ -209,12 +223,16 @@ <0,code> "|"            { symbol SymBar } <0,code> "(|" /[$white] { symbol SymOpenIdiomBracket } <0,code> "|)"           { symbol SymCloseIdiomBracket }+<0,code> "(|)"          { symbol SymEmptyIdiomBracket } <0,code> "("            { symbol SymOpenParen } <0,code> ")"            { symbol SymCloseParen } <0,code> "->"           { symbol SymArrow } <0,code> "\"            { symbol SymLambda } -- " <0,code> "@"            { symbol SymAs }-<0,code> "{{" /[^!]             { symbol SymDoubleOpenBrace }+<0,code> "{{" /[^[!\-]] { symbol SymDoubleOpenBrace }+-- Andreas, 2019-08-08, issue #3962, don't lex '{{' if followed by '-'+-- since this will be confused with '{-' (start of comment) by Emacs.+ -- We don't lex '}}' into a SymDoubleCloseBrace. Instead, we lex it as -- two SymCloseBrace's. When the parser is looking for a double -- closing brace, it will also accept two SymCloseBrace's, after@@ -222,13 +240,14 @@ -- This trick allows us to keep "record { a = record {}}" working -- properly. -- <0,code> "}}"                { symbol SymDoubleCloseBrace }+ <0,code> "{"            { symbol SymOpenBrace }     -- you can't use braces for layout <0,code> "}"            { symbol SymCloseBrace }  -- Literals <0,code> \'             { litChar }-<0,code> \"             { litString }-<0,code> @integer       { literal LitNat }+<0,code,pragma_> \"     { litString }+<0,code> @integer       { literal' integer LitNat } <0,code> @float         { literal LitFloat }  -- Identifiers@@ -247,10 +266,7 @@   {-| The layout state. Entered when we see a layout keyword ('withLayout') and-    exited either when seeing an open brace ('openBrace') or at the next token-    ('newLayoutContext').--    Update: we don't use braces for layout anymore.+    exited at the next token ('newLayoutBlock'). -} layout :: LexState layout = layout_@@ -261,7 +277,12 @@ pragma :: LexState pragma = pragma_ -{-| We enter this state from 'newLayoutContext' when the token following a+-- | The state inside a FOREIGN pragma. This needs to be different so that we don't+--   lex further strings as pragma keywords.+fpragma :: LexState+fpragma = fpragma_++{-| We enter this state from 'newLayoutBlock' when the token following a     layout keyword is to the left of (or at the same column as) the current     layout context. Example: @@ -272,7 +293,7 @@     same indentation as the @data@ definition. What we have to do is insert an     empty layout block @{}@ after the @where@. The only thing that can happen     in this state is that 'emptyLayout' is executed, generating the closing-    brace. The open brace is generated when entering by 'newLayoutContext'.+    brace. The open brace is generated when entering by 'newLayoutBlock'. -} empty_layout :: LexState empty_layout = empty_layout_
src/full/Agda/Syntax/Parser/Literate.hs view
@@ -1,219 +1,338 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}--- | Preprocessors for literate code formats-module Agda.Syntax.Parser.Literate (-  literateProcessors,-  literateExts,-  literateExtsShortList,-  literateSrcFile,-  literateTeX,-  literateRsT,-  illiterate,-  isCode,-  Processor,-  Layer(..),-  LayerType(..)+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Preprocessors for literate code formats.++module Agda.Syntax.Parser.Literate+  ( literateProcessors+  , literateExtsShortList+  , literateTeX+  , literateRsT+  , literateMd+  , literateOrg+  , illiterate+  , atomizeLayers+  , Processor+  , Layers+  , Layer(..)+  , LayerRole(..)+  , isCode+  , isCodeLayer   )   where -import Prelude hiding (getLine)-import Data.Char (isSpace, isControl)+import Control.Monad ((<=<))+import Data.Char (isSpace) import Data.List (isPrefixOf)-import Agda.Syntax.Position import Text.Regex.TDFA+  ( Regex, getAllTextSubmatches, match, matchM+  , makeRegexOpts, blankCompOpt, blankExecOpt, newSyntax, caseSensitive+  ) -#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative ((<$>),(<*>))-#endif+import Agda.Syntax.Common+import Agda.Syntax.Position -#include "undefined.h"+import Agda.Utils.List+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Singleton+ import Agda.Utils.Impossible -data LayerType = Markup | Comment | Code-                deriving (Show, Eq)+-- | Role of a character in the file. -data Layer = Layer {-  layerType    :: LayerType- ,interval     :: Interval- ,layerContent :: String-} deriving (Show)+data LayerRole = Markup | Comment | Code+  deriving (Show, Eq) -instance HasRange Layer where-  getRange = getRange . interval+-- | A sequence of characters in a file playing the same role. +data Layer = Layer+  { layerRole    :: LayerRole+  , interval     :: IntervalWithoutFile+  , layerContent :: String+  } deriving Show++-- | A list of contiguous layers.++type Layers = [Layer]++instance HasRangeWithoutFile Layer where+  getRangeWithoutFile = getRangeWithoutFile . interval+ -- | Annotates a tokenized string with position information.-mkLayers :: Position -> [(LayerType, String)] -> [Layer]-mkLayers pos [] = emptyLiterate pos-mkLayers pos ((_,""):xs) = mkLayers pos xs-mkLayers pos ((ty,s):xs) = let next = movePosByString pos s in-                           (Layer ty (Interval pos next) s):(mkLayers next xs) --- | Checks if a layer corresponds to Agda code-isCode :: Layer -> Bool-isCode Layer{layerType=Code}    = True-isCode Layer{layerType=Markup } = False-isCode Layer{layerType=Comment} = False+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+  where+  next = movePosByString pos s +unMkLayers :: Layers -> [(LayerRole, String)]+unMkLayers = map ((,) <$> layerRole <*> layerContent)++atomizeLayers :: Layers -> [(LayerRole, Char)]+atomizeLayers = (fmap <$> ((,) . fst) <*> snd) <=< unMkLayers+ -- | Type of a literate preprocessor: --   Invariants: -- --   > 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.+-- | List of valid extensions for literate Agda files, and their+--   corresponding preprocessors. -----   If you add new extensions, remember to update test/Utils.hs so that test---   cases ending in the new extensions are found.-literateProcessors :: [(String, Processor)]-literateProcessors = map ((,) <$> (".lagda" ++) . fst <*> snd)-                 [(""    , literateTeX)-                 ,(".rst", literateRsT)-                 ,(".tex", literateTeX)-                 ]+--   If you add new extensions, remember to update test/Utils.hs so+--   that test cases ending in the new extensions are found. +literateProcessors :: [(String, (Processor, FileType))]+literateProcessors =+  ((,) <$> (".lagda" ++) . fst <*> snd) <$>+    [ (""    , (literateTeX, TexFileType))+    , (".rst", (literateRsT, RstFileType))+    , (".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.++isCode :: LayerRole -> Bool+isCode Code    = True+isCode Markup  = False+isCode Comment = False++-- | Returns @True@ if the layer contains Agda code.++isCodeLayer :: Layer -> Bool+isCodeLayer = isCode . layerRole+ -- | Blanks the non-code parts of a given file, preserving positions of --   characters corresponding to code. This way, there is a direct --   correspondence between source positions and positions in the --   processed result.+ illiterate :: [Layer] -> String-illiterate xs = concat [-  (if isCode m then id else bleach) layerContent-  | m@Layer{layerContent} <- xs]+illiterate xs = concat+  [ (if isCode layerRole then id else bleach) layerContent+  | Layer{layerRole, layerContent} <- xs+  ]  -- | Replaces non-space characters in a string with spaces.+ bleach :: String -> String-bleach s = map go s-  where-    go c | isSpace c = c-    go _             = ' '+bleach = map $ \ c -> if isSpace c && c /= '\t' then c else ' '  -- | Check if a character is a blank character.-isBlank :: Char -> Bool-isBlank = (&&) <$> isSpace <*> not . (== '\n') --- | Possible extensions for a literate Agda file-literateExts :: [String]-literateExts = map fst literateProcessors+isBlank :: Char -> Bool+isBlank = (&&) <$> isSpace <*> (/= '\n') --- | Short list of extensions for literate Agda files+-- | Short list of extensions for literate Agda files. --   For display purposes.-literateExtsShortList :: [String]-literateExtsShortList = [".lagda"] --- | break a list just *after* an element satisfying the predicate is found------   >>> break1 even [1,3,5,2,4,7,8]---   ([1,3,5,2],[4,7,8])----break1 :: (a -> Bool) -> [a] -> ([a],[a])-break1 _ []           =  ([], [])-break1 p (x:xs) | p x = (x:[],xs)-break1 p (x:xs)       = let (ys,zs) = break1 p xs in (x:ys,zs)+literateExtsShortList :: List1 String+literateExtsShortList = singleton ".lagda"  -- | Returns a tuple consisting of the first line of the input, and the rest --   of the input.-getLine :: String -> (String, String)-getLine = break1 (== '\n') --- | Canonical decomposition of an empty literate file-emptyLiterate :: Position -> [Layer]-emptyLiterate pos = [Layer (Markup) (Interval pos pos) ""]+caseLine :: a -> (String -> String -> a) -> String -> a+caseLine a k = \case+  []   -> a+  x:xs -> k (List1.toList line) rest+    where+    (line, rest) = breakAfter1 (== '\n') x xs +-- | Canonical decomposition of an empty literate file.++emptyLiterate :: PositionWithoutFile -> [Layer]+emptyLiterate pos = [Layer Markup (Interval () pos pos) ""]+ -- | Create a regular expression that: --   - Must match the whole string --   - Works across line boundaries+ rex :: String -> Regex-rex s = makeRegexOpts blankCompOpt{newSyntax = True} blankExecOpt$ "\\`" ++ s ++ "\\'"+rex s =+  makeRegexOpts blankCompOpt{newSyntax = True} blankExecOpt $+    "\\`" ++ s ++ "\\'" --- | Preprocessor for literate TeX-literateTeX :: Position -> String -> [Layer]-literateTeX pos s = mkLayers pos$ tex s+-- | Preprocessor for literate TeX.++literateTeX :: Processor+literateTeX pos s = mkLayers pos (tex s)   where-  tex :: String -> [(LayerType, String)]-  tex [] = []-  tex s  = let (line, rest) = getLine s in+  tex :: String -> [(LayerRole, String)]+  tex = caseLine [] $ \ line rest ->     case r_begin `matchM` line of-      Just (getAllTextSubmatches -> [_, pre, markup]) ->-        (Comment, pre):(Markup, markup):code rest-      Just _                 -> __IMPOSSIBLE__-      Nothing                -> (Comment, line):tex rest--  r_begin = rex "(.*)([[:space:]]*\\\\begin\\{code\\}[[:space:]]*)"+      Just (getAllTextSubmatches -> [_, pre, _, markup, whitespace]) ->+        (Comment, pre) : (Markup, markup) :+        (Code, whitespace) : code rest+      Just _  -> __IMPOSSIBLE__+      Nothing -> (Comment, line) : tex rest +  r_begin = rex "(([^\\%]|\\\\.)*)(\\\\begin\\{code\\}[^\n]*)(\n)?" -  code :: String -> [(LayerType, String)]-  code [] = []-  code s = let (line, rest) = getLine s in+  code :: String -> [(LayerRole, String)]+  code = caseLine [] $ \ line rest ->     case r_end `matchM` line of-      Just (getAllTextSubmatches -> [_, markup, post]) ->-        (Markup, markup):(Comment, post):tex rest-      Just _ -> __IMPOSSIBLE__-      Nothing             -> (Code, line):code rest+      Just (getAllTextSubmatches -> [_, code, markup, post]) ->+        (Code, code) : (Markup, markup) : (Comment, post) : tex rest+      Just _  -> __IMPOSSIBLE__+      Nothing -> (Code, line) : code rest -  r_end   = rex "([[:space:]]*\\\\end\\{code\\}[[:space:]]*)(.*)"+  r_end = rex "([[:blank:]]*)(\\\\end\\{code\\})(.*)" +-- | Preprocessor for Markdown. --- | Preprocessor for reStructuredText-literateRsT :: Position -> String -> [Layer]-literateRsT pos s = mkLayers pos$ rst s+literateMd :: Processor+literateMd pos s = mkLayers pos $ md s   where-  rst :: String -> [(LayerType, String)]-  rst [] = []-  rst s  = maybe_code s+  md :: String -> [(LayerRole, String)]+  md = caseLine [] $ \ line rest ->+    case md_begin `matchM` line of+      Just (getAllTextSubmatches -> [_, pre, markup, _]) ->+        (Comment, pre) : (Markup, markup) : code rest+      Just _  -> __IMPOSSIBLE__+      Nothing ->+        (Comment, line) :+        if md_begin_other `match` line+        then code_other rest+        else md rest -  maybe_code s =+  md_begin       = rex "(.*)([[:space:]]*```(agda)?[[:space:]]*)"+  md_begin_other = rex "[[:space:]]*```[a-zA-Z0-9-]*[[:space:]]*"++  code :: String -> [(LayerRole, String)]+  code = caseLine [] $ \ line rest ->+    case md_end `matchM` line of+      Just (getAllTextSubmatches -> [_, markup]) ->+        (Markup, markup) : md rest+      Just _  -> __IMPOSSIBLE__+      Nothing -> (Code, line) : code rest++  -- A non-Agda code block.+  code_other :: String -> [(LayerRole, String)]+  code_other = caseLine [] $ \ line rest ->+    (Comment, line) :+    if md_end `match` line+    then md rest+    else code_other rest++  md_end = rex "([[:space:]]*```[[:space:]]*)"++-- | Preprocessor for reStructuredText.++literateRsT :: Processor+literateRsT pos s = mkLayers pos $ rst s+  where+  rst :: String -> [(LayerRole, String)]+  rst = caseLine [] maybe_code++  maybe_code line rest =     if r_comment `match` line then       not_code     else case r_code `match` line of-      []      -> not_code+      []                         -> not_code       [[_, before, "::", after]] ->         -- Code starts-          if null before || isBlank (last before) then-             (Markup,  line):code rest-          else-             (Comment, before ++ ":"):(Markup, ':':after):code rest-+        if maybe True isBlank $ lastMaybe before then+          (Markup, line) : code rest+        else+          (Comment, before ++ ":") : (Markup, ":" ++ after) : code rest       _ -> __IMPOSSIBLE__     where-      (line, rest) = getLine s-      not_code = (Comment, line):rst rest-+    not_code     = (Comment, line) : rst rest -  -- | Finds the next indented block in the input-  code :: String -> [(LayerType, String)]-  code [] = []-  code s = let (line, rest) = getLine s in+  -- Finds the next indented block in the input.+  code :: String -> [(LayerRole, String)]+  code = caseLine [] $ \ line rest ->     if all isSpace line then-      (Markup, line):(code rest)+      (Markup, line) : code rest     else-      let (xs,ys) = span isBlank line in-      case xs of-        [] -> maybe_code s-        _  -> (Code, line):-              (indented xs rest)+      let xs = takeWhile isBlank line in+      if null xs+      then maybe_code line rest+      else (Code, line) : indented xs rest -  -- | Process an indented block-  indented :: String -> String -> [(LayerType, String)]-  indented _   [] = []-  indented ind s  = let (line, rest) = getLine s in-      if all isSpace line then-        (Code, line):(indented ind rest)-      else if ind `isPrefixOf` line then-        (Code, line):(indented ind rest)-      else-        maybe_code s+  -- Process an indented block.+  indented :: String -> String -> [(LayerRole, String)]+  indented ind = caseLine [] $ \ line rest ->+    if all isSpace line || (ind `isPrefixOf` line)+          then (Code, line) : indented ind rest+          else maybe_code line rest -  -- | Beginning of a code block+  -- Beginning of a code block.   r_code = rex "(.*)(::)([[:space:]]*)" -  -- | Beginning of a comment block+  -- Beginning of a comment block.   r_comment = rex "[[:space:]]*\\.\\.([[:space:]].*)?"++-- | Preprocessor for Org mode documents.++literateOrg :: Processor+literateOrg pos s = mkLayers pos $ org s+  where+  org :: String -> [(LayerRole, String)]+  org = caseLine [] $ \ line rest ->+    if org_begin `match` line then+      (Markup, line) : code rest+    else+      (Comment, line) : org rest++  -- Valid: #+begin_src agda2 :tangle yes+  -- Valid: #+begin_src agda2+  -- Invalid: #+begin_src adga2-foo+  org_begin = rex' "\\`(.*)([[:space:]]*\\#\\+begin_src agda2[[:space:]]+)"++  code :: String -> [(LayerRole, String)]+  code = caseLine [] $ \ line rest ->+    if org_end `match` line then+      (Markup, line) : org rest+    else+      (Code, line) : code rest++  org_end = rex' "\\`([[:space:]]*\\#\\+end_src[[:space:]]*)(.*)"++  -- Explicit type annotation required to disambiguate source.+  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
@@ -1,6 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-| When lexing by hands (for instance string literals) we need to do some+{-| When lexing by hand (for instance string literals) we need to do some     looking ahead. The 'LookAhead' monad keeps track of the position we are     currently looking at, and provides facilities to synchronise the look-ahead     position with the actual position of the 'Parser' monad (see 'sync' and@@ -11,6 +10,7 @@       LookAhead     , runLookAhead       -- * Operations+    , lookAheadError     , getInput, setInput, liftP     , nextChar, eatNextChar     , sync, rollback@@ -18,13 +18,15 @@     )     where -import Control.Applicative import Control.Monad.Reader import Control.Monad.State  import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad +import Agda.Utils.Null (ifNull)+import Agda.Utils.Maybe (fromMaybeM)+ {--------------------------------------------------------------------------     The look-ahead monad  --------------------------------------------------------------------------}@@ -33,24 +35,19 @@     'AlexInput', wrapped around the 'Parser' monad. -} newtype LookAhead a =-    LookAhead { unLookAhead :: ReaderT ErrorFunction+    LookAhead { _unLookAhead :: ReaderT ErrorFunction                                        (StateT AlexInput Parser) a               }-    deriving (Functor, Applicative)+    deriving (Functor, Applicative, Monad)  newtype ErrorFunction =     ErrorFun { throwError :: forall a. String -> LookAhead a } -{---------------------------------------------------------------------------    Monad instances- --------------------------------------------------------------------------}--instance Monad LookAhead where-    return  = pure-    m >>= k = LookAhead $ unLookAhead m >>= unLookAhead . k-    fail s  =-        do  err <- LookAhead ask-            throwError err s+-- | Throw an error message according to the supplied method.+lookAheadError :: String -> LookAhead a+-- ASR (2021-02-07). The eta-expansion @\e -> throwError e@ is+-- required GHC >= 9.0.1 ((see Issue #4955).+lookAheadError s = ($ s) =<< do LookAhead $ asks (\e -> throwError e)  {--------------------------------------------------------------------------     Operations@@ -73,13 +70,17 @@  -- | Look at the next character. Fails if there are no more characters. nextChar :: LookAhead Char-nextChar =+nextChar = fromMaybeM (lookAheadError "unexpected end of file") nextCharMaybe++-- | Look at the next character. Return 'Nothing' if there are no more characters.+nextCharMaybe :: LookAhead (Maybe Char)+nextCharMaybe =     do  inp <- getInput         case alexGetChar inp of-            Nothing         -> fail "unexpected end of file"+            Nothing         -> return Nothing             Just (c,inp')   ->                 do  setInput inp'-                    return c+                    return $ Just c   -- | Consume all the characters up to the current look-ahead position.@@ -119,17 +120,42 @@     the input is not advanced. -} match' :: Char -> [(String, LookAhead a)] -> LookAhead a -> LookAhead a-match' c xs def =-    do  inp <- getInput-        match'' inp xs c-    where-        match'' inp bs c =-            case bs' of-                []          -> setInput inp >> def-                [("",p)]    -> p-                _           -> match'' inp bs' =<< nextChar-            where-                bs' = [ (s, p) | (c':s, p) <- bs, c == c' ]+match' c xs def = do++  -- Set the error continuation to the default @def@, but make sure we reset+  -- the input to where we started speculative matching.+  inp <- getInput+  let fallback = setInput inp >> def++  -- Find the longest match from the table.+  match'' fallback xs c++  where+  match'' fallback bs c =++    -- Match the first character, dropping entries that do not match.+    ifNull [ (s, p) | (c':s, p) <- bs, c == c' ]++      -- If no alternatives are left, fall back to the failure continuation.+      {-then-} fallback++      -- Otherwise:+      {-else-} $ \ bs' -> do++        -- If we have a successful match, store it in the failure continuation.+        fallback' <- do+          case lookup "" bs' of++            -- No match yet.+            Nothing -> pure fallback++            -- Match found!  Remember it, and the state of the input where we found it.+            Just p  -> do+              inp <- getInput+              pure $ setInput inp >> p++        -- Keep trying to find a (longer) match.+        maybe fallback' (match'' fallback' bs') =<< nextCharMaybe  -- | Run a 'LookAhead' computation. The first argument is the error function. runLookAhead :: (forall b. String -> LookAhead b) -> LookAhead a -> Parser a
src/full/Agda/Syntax/Parser/Monad.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable    #-}  module Agda.Syntax.Parser.Monad     ( -- * The parser monad@@ -8,13 +6,13 @@     , ParseState(..)     , ParseError(..), ParseWarning(..)     , LexState-    , LayoutContext(..)+    , LayoutBlock(..), LayoutContext, LayoutStatus(..)+    , Column     , ParseFlags (..)       -- * Running the parser     , initState     , defaultParseFlags     , parse-    , parseFile     , parsePosString     , parseFromSrc       -- * Manipulating the state@@ -23,45 +21,46 @@     , getParseFlags     , getLexState, pushLexState, popLexState       -- ** Layout-    , topContext, popContext, pushContext-    , pushCurrentContext+    , topBlock, popBlock, pushBlock+    , getContext, setContext, modifyContext+    , resetLayoutStatus       -- ** Errors-    , parseError, parseErrorAt, parseError'+    , parseWarning, parseWarningName+    , parseError, parseErrorAt, parseError', parseErrorRange     , lexError     )     where -import Control.Exception (catch)-import Data.Int-import Data.Typeable ( Typeable )-+import Control.DeepSeq+import Control.Exception ( displayException )+import Control.Monad.Except import Control.Monad.State-import Control.Applicative +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.Except ( MonadError(catchError, throwError) )-#if !(MIN_VERSION_mtl(2,2,1))-import Agda.Utils.Except ( Error(noMsg) )-#endif+import Agda.TypeChecking.Positivity.Occurrence ( pattern Mixed ) -import Agda.Utils.FileName-import qualified Agda.Utils.IO.UTF8 as UTF8+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 -#include "undefined.h" import Agda.Utils.Impossible  {--------------------------------------------------------------------------     The parse monad  --------------------------------------------------------------------------} --- | The parse monad. Equivalent to @StateT 'ParseState' (Either 'ParseError')@---   except for the definition of @fail@, which builds a suitable 'ParseError'---   object.-newtype Parser a = P { unP :: ParseState -> ParseResult a }+-- | The parse monad.+newtype Parser a = P { _runP :: StateT ParseState (Either ParseError) a }+  deriving (Functor, Applicative, Monad, MonadState ParseState, MonadError ParseError)  -- | The parser state. Contains everything the parser and the lexer could ever --   need.@@ -72,164 +71,246 @@     , parseInp      :: String                -- ^ the current input     , parsePrevChar :: !Char                 -- ^ the character before the input     , parsePrevToken:: String                -- ^ the previous token-    , parseLayout   :: [LayoutContext]       -- ^ the stack of layout contexts+    , parseLayout   :: LayoutContext         -- ^ the stack of layout blocks+    , parseLayStatus:: LayoutStatus          -- ^ the status of the coming layout block+    , parseLayKw    :: Keyword               -- ^ the keyword for the coming layout block     , parseLexState :: [LexState]            -- ^ the state of the lexer                                              --   (states can be nested so we need a stack)-    , parseFlags    :: ParseFlags            -- ^ currently there are no flags+    , parseFlags    :: ParseFlags            -- ^ parametrization of the parser+    , parseWarnings :: ![ParseWarning]       -- ^ In reverse order.+    , parseAttributes+                    :: !Attributes+      -- ^ Every encountered attribute.     }     deriving Show -{-| To do context sensitive lexing alex provides what is called /start codes/-    in the Alex documentation. It is really an integer representing the state+{-| For context sensitive lexing alex provides what is called /start codes/+    in the Alex documentation.  It is really an integer representing the state     of the lexer, so we call it @LexState@ instead. -} type LexState = Int +-- | The stack of layout blocks.+--+--   When we encounter a layout keyword, we push a 'Tentative' block+--   with 'noColumn'.  This is replaced by aproper column once we+--   reach the next token.+type LayoutContext = [LayoutBlock]+ -- | We need to keep track of the context to do layout. The context---   specifies the indentation (if any) of a layout block. See+--   specifies the indentation columns of the open layout blocks. See --   "Agda.Syntax.Parser.Layout" for more informaton.-data LayoutContext  = NoLayout        -- ^ no layout-                    | Layout Int32    -- ^ layout at specified column+data LayoutBlock+  = Layout Keyword LayoutStatus Column+      -- ^ Layout at specified 'Column', introduced by 'Keyword'.     deriving Show --- | There aren't any parser flags at the moment.+-- | A (layout) column.+type Column = Word32++-- | Status of a layout column (see #1145).+--   A layout column is 'Tentative' until we encounter a new line.+--   This allows stacking of layout keywords.+--+--   Inside a @LayoutContext@ the sequence of 'Confirmed' columns+--   needs to be strictly increasing.+--   'Tentative columns between 'Confirmed' columns need to be+--   strictly increasing as well.+data LayoutStatus+  = Tentative  -- ^ The token defining the layout column was on the same line+               --   as the layout keyword and we have not seen a new line yet.+  | Confirmed  -- ^ We have seen a new line since the layout keyword+               --   and the layout column has not been superseded by+               --   a smaller column.+    deriving (Eq, Show)++-- | Parser flags. data ParseFlags = ParseFlags   { parseKeepComments :: Bool     -- ^ Should comment tokens be returned by the lexer?   }   deriving Show --- | What you get if parsing fails.-data ParseError =+-- | Parse errors: what you get if parsing fails.+data ParseError+   -- | Errors that arise at a specific position in the file-  ParseError-  { errSrcFile   :: !SrcFile-                    -- ^ The file in which the error occurred.-  , errPos       :: !PositionWithoutFile-                    -- ^ Where the error occurred.-  , errInput     :: String-                    -- ^ The remaining input.-  , errPrevToken :: String-                    -- ^ The previous token.-  , errMsg       :: String-                    -- ^ Hopefully an explanation of what happened.-  } |-  -- | Parse errors that concern a range in a file.-  OverlappingTokensError-  { errRange     :: !(Range' SrcFile)-                    -- ^ The range of the bigger overlapping token-  } |-  -- | Parse errors that concern a whole file.-  InvalidExtensionError-  { errPath      :: !AbsolutePath-                    -- ^ The file which the error concerns.-  , errValidExts :: [String]-  } |-  ReadFileError-  { errPath      :: !AbsolutePath-  , errIOError   :: IOError-  }-  deriving (Typeable)+  = ParseError+    { errSrcFile   :: !SrcFile+                      -- ^ The file in which the error occurred.+    , errPos       :: !PositionWithoutFile+                      -- ^ Where the error occurred.+    , errInput     :: String+                      -- ^ The remaining input.+    , errPrevToken :: String+                      -- ^ The previous token.+    , errMsg       :: String+                      -- ^ Hopefully an explanation of what happened.+    } --- | 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-  }+  | OverlappingTokensError+    { errRange     :: !(Range' SrcFile)+                      -- ^ The range of the bigger overlapping token+    } --- | The result of parsing something.-data ParseResult a  = ParseOk ParseState a-                    | ParseFailed ParseError+  -- | Parse errors that concern a whole file.+  | InvalidExtensionError+    { errPath      :: !RangeFile+                      -- ^ The file which the error concerns.+    , errValidExts :: [String]+    }+  | ReadFileError+    { errPath      :: !RangeFile+    , errIOError   :: IOError+    }+  deriving Show -{---------------------------------------------------------------------------    Instances- --------------------------------------------------------------------------}+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         -> () -instance Monad Parser where-  return = pure+-- | 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.+    }+  | 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.+  | MultipleAttributes Range !(Maybe String)+      -- ^ Multiple attributes.+  deriving Show -  P m >>= f = P $ \s -> case m s of-                          ParseFailed e -> ParseFailed e-                          ParseOk s' x  -> unP (f x) s'+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 -  fail msg = P $ \s -> ParseFailed $-                         ParseError  { errSrcFile   = parseSrcFile s-                                     , errPos       = parseLastPos s-                                     , errInput     = parseInp s-                                     , errPrevToken = parsePrevToken s-                                     , errMsg       = msg-                                     }+parseWarningName :: ParseWarning -> WarningName+parseWarningName = \case+  OverlappingTokensWarning{} -> OverlappingTokensWarning_+  MisplacedAttributes{}      -> MisplacedAttributes_+  UnknownPolarity{}          -> UnknownPolarity_+  UnknownAttribute{}         -> UnknownAttribute_+  UnsupportedAttribute{}     -> UnsupportedAttribute_+  MultipleAttributes{}       -> MultipleAttributes_ -instance Functor Parser where-  fmap = liftM+-- | The result of parsing something.+data ParseResult a+  = ParseOk ParseState a+  | ParseFailed ParseError+  deriving Show -instance Applicative Parser where-  pure x = P $ \s -> ParseOk s x-  (<*>)  = ap+-- | Old interface to parser.+unP :: Parser a -> ParseState -> ParseResult a+unP (P m) s = case runStateT m s of+  Left err     -> ParseFailed err+  Right (a, s) -> ParseOk s a -instance MonadError ParseError Parser where-  throwError e = P $ \_ -> ParseFailed e+-- | Throw a parse error at the current position.+parseError :: String -> Parser a+parseError msg = do+  s <- get+  throwError $ ParseError+    { errSrcFile   = parseSrcFile s+    , errPos       = parseLastPos s+    , errInput     = parseInp s+    , errPrevToken = parsePrevToken s+    , errMsg       = msg+    } -  P m `catchError` h = P $ \s -> case m s of-                                   ParseFailed err -> unP (h err) s-                                   m'              -> m'+-- | Records a warning. -instance MonadState ParseState Parser where-  get   = P $ \s -> ParseOk s s-  put s = P $ \_ -> ParseOk s ()+parseWarning :: ParseWarning -> Parser ()+parseWarning w =+  modify' $ \s -> s { parseWarnings = w : parseWarnings s } -instance Show ParseError where-  show = prettyShow+{--------------------------------------------------------------------------+    Instances+ --------------------------------------------------------------------------}  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 <+>-        text "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 <+>-        text "Unsupported extension."-      , text "Supported extensions are:" <+> prettyList errValidExts+      [ (pretty errPath <> colon) <+> "error: [InvalidExtensionError]"+      , "Unsupported extension."+      , "Supported extensions are:" <+> prettyList_ errValidExts       ]   pretty ReadFileError{errPath,errIOError} = vcat-      [ text "Cannot read file" <+> pretty errPath-        -- TODO: `show` should be replaced by `displayException` once we-        -- cease to support versions of GHC under 7.10.-      , text "Error:" <+> text (show errIOError)+      [ "Cannot read file" <+> pretty errPath+      , "Error:" <+> text (showIOException errIOError)       ]  instance HasRange ParseError where-  getRange ParseError{errSrcFile,errPos=p} = posToRange' errSrcFile p p-  getRange OverlappingTokensError{errRange} = errRange-  getRange InvalidExtensionError{errPath} = posToRange p p-    where p = startPos (Just errPath)-  getRange ReadFileError{errPath} = posToRange p p-    where p = startPos (Just errPath)+  getRange err = case err of+      ParseError{ errSrcFile, errPos = p } -> posToRange' errSrcFile p p+      OverlappingTokensError{ errRange }   -> errRange+      InvalidExtensionError{}              -> errPathRange+      ReadFileError{}                      -> errPathRange+    where+    errPathRange = posToRange p p+      where p = startPos $ Just $ errPath err -#if !(MIN_VERSION_mtl(2,2,1))--- Stupid ErrorT!-instance Error ParseError where-  noMsg = __IMPOSSIBLE__-#endif+-- | Does not include printing of the range.+--+instance Pretty ParseWarning where+  pretty = \case -instance Show ParseWarning where-  show = prettyShow+    OverlappingTokensWarning _r ->+      "Multi-line comment spans one or more literate text blocks." -instance Pretty ParseWarning where-  pretty OverlappingTokensWarning{warnRange} = vcat-      [ pretty warnRange <> colon <+>-        text "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."       ]++    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  {--------------------------------------------------------------------------     Running the parser@@ -244,8 +325,14 @@                 , parsePrevChar     = '\n'                 , parsePrevToken    = ""                 , parseLexState     = st-                , parseLayout       = [NoLayout]+                , parseLayout       = []        -- the first block will be from the top-level layout+                , parseLayStatus    = Confirmed -- for the to-be-determined column of the top-level layout+                , parseLayKw        = KwMutual  -- Layout keyword for the top-level layout.+                                                -- Does not mean that the top-level block is a mutual block.+                                                -- Just for better errors on stray @constructor@ decls.                 , parseFlags        = flags+                , parseWarnings     = []+                , parseAttributes   = []                 }   where   pos' = pos { srcFile = () }@@ -253,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.@@ -272,21 +359,6 @@                   ParseResult a parsePosString pos flags st p input = unP p (initStatePos pos flags input st) --- | The most general way of parsing a file. The "Agda.Syntax.Parser" will define---   more specialised functions that supply the 'ParseFlags' and the---   'LexState'.------   Note that Agda source files always use the UTF-8 character---   encoding.-parseFile :: ParseFlags -> [LexState] -> Parser a -> AbsolutePath-          -> IO (ParseResult a)-parseFile flags st p file =-    do  res <- (Right <$> (UTF8.readTextFile (filePath file))) `catch`-          (return . Left . ReadFileError file)-        case res of-          Left  error -> return$ ParseFailed error-          Right input -> return$ parseFromSrc flags st p (Strict.Just file) input- -- | Parses a string as if it were the contents of the given file --   Useful for integrating preprocessors. parseFromSrc :: ParseFlags -> [LexState] -> Parser a -> SrcFile -> String@@ -308,7 +380,7 @@ setPrevToken t = modify $ \s -> s { parsePrevToken = t }  getLastPos :: Parser PositionWithoutFile-getLastPos = get >>= return . parseLastPos+getLastPos = gets parseLastPos  -- | The parse interval is between the last position and the current position. getParseInterval :: Parser Interval@@ -317,28 +389,23 @@   return $ posToInterval (parseSrcFile s) (parseLastPos s) (parsePos s)  getLexState :: Parser [LexState]-getLexState = parseLexState <$> get+getLexState = gets parseLexState -setLexState :: [LexState] -> Parser ()-setLexState ls =-    do  s <- get-        put $ s { parseLexState = ls }+-- UNUSED Liang-Ting Chen 2019-07-16+--setLexState :: [LexState] -> Parser ()+--setLexState ls = modify $ \ s -> s { parseLexState = ls } +modifyLexState :: ([LexState] -> [LexState]) -> Parser ()+modifyLexState f = modify $ \ s -> s { parseLexState = f (parseLexState s) }+ pushLexState :: LexState -> Parser ()-pushLexState l = do s <- getLexState-                    setLexState (l:s)+pushLexState l = modifyLexState (l:)  popLexState :: Parser ()-popLexState = do _:ls <- getLexState-                 setLexState ls+popLexState = modifyLexState $ tailWithDefault __IMPOSSIBLE__  getParseFlags :: Parser ParseFlags-getParseFlags = parseFlags <$> get----- | @parseError = fail@-parseError :: String -> Parser a-parseError = fail+getParseFlags = gets parseFlags   -- | Fake a parse error at the specified position. Used, for instance, when@@ -354,52 +421,47 @@ parseError' :: Maybe PositionWithoutFile -> String -> Parser a parseError' = maybe parseError parseErrorAt +-- | Report a parse error at the beginning of the given 'Range'.+parseErrorRange :: HasRange r => r -> String -> Parser a+parseErrorRange = parseError' . rStart' . getRange + -- | For lexical errors we want to report the current position as the site of --   the error, whereas for parse errors the previous position is the one --   we're interested in (since this will be the position of the token we just --   lexed). This function does 'parseErrorAt' the current position. lexError :: String -> Parser a lexError msg =-    do  p <- parsePos <$> get+    do  p <- gets parsePos         parseErrorAt p msg  {--------------------------------------------------------------------------     Layout  --------------------------------------------------------------------------} -getContext :: Parser [LayoutContext]-getContext = parseLayout <$> get+getContext :: MonadState ParseState m => m LayoutContext+getContext = gets parseLayout -setContext :: [LayoutContext] -> Parser ()-setContext ctx =-    do  s <- get-        put $ s { parseLayout = ctx }+setContext :: LayoutContext -> Parser ()+setContext = modifyContext . const --- | Return the current layout context.-topContext :: Parser LayoutContext-topContext =-    do  ctx <- getContext-        case ctx of-            []  -> parseError "No layout context in scope"-            l:_ -> return l+modifyContext :: (LayoutContext -> LayoutContext) -> Parser ()+modifyContext f = modify $ \ s -> s { parseLayout = f (parseLayout s) } -popContext :: Parser ()-popContext =+-- | Return the current layout block.+topBlock :: Parser (Maybe LayoutBlock)+topBlock = listToMaybe <$> getContext++popBlock :: Parser ()+popBlock =     do  ctx <- getContext         case ctx of             []      -> parseError "There is no layout block to close at this point."             _:ctx   -> setContext ctx -pushContext :: LayoutContext -> Parser ()-pushContext l =-    do  ctx <- getContext-        setContext (l : ctx)+pushBlock :: LayoutBlock -> Parser ()+pushBlock l = modifyContext (l :) --- | Should only be used at the beginning of a file. When we start parsing---   we should be in layout mode. Instead of forcing zero indentation we use---   the indentation of the first token.-pushCurrentContext :: Parser ()-pushCurrentContext =-    do  p <- getLastPos-        pushContext (Layout (posCol p))+-- | When we see a layout keyword, by default we expect a 'Tentative' block.+resetLayoutStatus :: Parser ()+resetLayoutStatus = modify $ \ s -> s { parseLayStatus = Tentative }
src/full/Agda/Syntax/Parser/Parser.y view
@@ -1,1986 +1,1931 @@ {-{-# LANGUAGE TupleSections #-}--{-| The parser is generated by Happy (<http://www.haskell.org/happy>).- -- - Ideally, ranges should be as precise as possible, to get messages that- - emphasize precisely the faulting term(s) upon error.- -- - However, interactive highlighting is only applied at the end of each- - mutual block, keywords are only highlighted once (see- - `TypeChecking.Rules.Decl'). So if the ranges of two declarations- - interleave, one must ensure that keyword ranges are not included in- - the intersection. (Otherwise they are uncolored by the interactive- - highlighting.)- -- -}-module Agda.Syntax.Parser.Parser (-      moduleParser-    , moduleNameParser-    , exprParser-    , exprWhereParser-    , tokensParser-    , splitOnDots  -- only used by the internal test-suite-    ) where--import Control.Monad--import Data.Char-import Data.Functor-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Traversable as T--import Debug.Trace--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.Pretty ()-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Literal--import Agda.TypeChecking.Positivity.Occurrence hiding (tests)--import Agda.Utils.Either hiding (tests)-import Agda.Utils.Hash-import Agda.Utils.List ( spanJust, chopWhen )-import Agda.Utils.Monad-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Agda.Utils.Impossible-#include "undefined.h"--}--%name tokensParser Tokens-%name exprParser Expr-%name exprWhereParser ExprWhere-%name moduleParser File-%name moduleNameParser ModuleName-%name funclauseParser FunClause-%tokentype { Token }-%monad { Parser }-%lexer { lexer } { TokEOF }--%expect 1   -- 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---- 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 $$ }-    '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 $$ }-    'mutual'                  { TokKeyword KwMutual $$ }-    'no-eta-equality'         { TokKeyword KwNoEta $$ }-    'open'                    { TokKeyword KwOpen $$ }-    'pattern'                 { TokKeyword KwPatternSyn $$ }-    'postulate'               { TokKeyword KwPostulate $$ }-    'primitive'               { TokKeyword KwPrimitive $$ }-    'private'                 { TokKeyword KwPrivate $$ }-    'Prop'                    { TokKeyword KwProp $$ }-    'public'                  { TokKeyword KwPublic $$ }-    'quote'                   { TokKeyword KwQuote $$ }-    'quoteContext'            { TokKeyword KwQuoteContext $$ }-    'quoteGoal'               { TokKeyword KwQuoteGoal $$ }-    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }-    'record'                  { TokKeyword KwRecord $$ }-    'renaming'                { TokKeyword KwRenaming $$ }-    'rewrite'                 { TokKeyword KwRewrite $$ }-    'Set'                     { TokKeyword KwSet $$ }-    'syntax'                  { TokKeyword KwSyntax $$ }-    'tactic'                  { TokKeyword KwTactic $$ }-    'to'                      { TokKeyword KwTo $$ }-    'unquote'                 { TokKeyword KwUnquote $$ }-    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }-    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }-    'using'                   { TokKeyword KwUsing $$ }-    'where'                   { TokKeyword KwWhere $$ }-    'with'                    { TokKeyword KwWith $$ }--    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }-    'CATCHALL'                { TokKeyword KwCATCHALL $$ }-    'COMPILED'                { TokKeyword KwCOMPILED $$ }-    'COMPILED_DATA'           { TokKeyword KwCOMPILED_DATA $$ }-    'COMPILED_DATA_UHC'       { TokKeyword KwCOMPILED_DATA_UHC $$ }-    'COMPILED_DECLARE_DATA'   { TokKeyword KwCOMPILED_DECLARE_DATA $$ }-    'COMPILED_EPIC'           { TokKeyword KwCOMPILED_EPIC $$ }-    'COMPILED_EXPORT'         { TokKeyword KwCOMPILED_EXPORT $$ }-    'COMPILED_JS'             { TokKeyword KwCOMPILED_JS $$ }-    'COMPILED_TYPE'           { TokKeyword KwCOMPILED_TYPE $$ }-    'COMPILED_UHC'            { TokKeyword KwCOMPILED_UHC $$ }-    'HASKELL'                 { TokKeyword KwHASKELL $$ }-    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }-    'IMPORT'                  { TokKeyword KwIMPORT $$ }-    'IMPORT_UHC'              { TokKeyword KwIMPORT_UHC $$ }-    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }-    'INLINE'                  { TokKeyword KwINLINE $$ }-    'MEASURE'                 { TokKeyword KwMEASURE $$ }-    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }-    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }-    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }-    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }-    'POLARITY'                { TokKeyword KwPOLARITY $$ }-    'REWRITE'                 { TokKeyword KwREWRITE $$ }-    'STATIC'                  { TokKeyword KwSTATIC $$ }-    'TERMINATING'             { TokKeyword KwTERMINATING $$ }--    setN                      { TokSetN $$ }-    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 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-    : 'abstract'                { TokKeyword KwAbstract $1 }-    | 'codata'                  { TokKeyword KwCoData $1 }-    | 'coinductive'             { TokKeyword KwCoInductive $1 }-    | 'constructor'             { TokKeyword KwConstructor $1 }-    | 'data'                    { TokKeyword KwData $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 }-    | 'overlap'                 { TokKeyword KwOverlap $1 }-    | 'let'                     { TokKeyword KwLet $1 }-    | 'macro'                   { TokKeyword KwMacro $1 }-    | 'module'                  { TokKeyword KwModule $1 }-    | 'mutual'                  { TokKeyword KwMutual $1 }-    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }-    | 'open'                    { TokKeyword KwOpen $1 }-    | 'pattern'                 { TokKeyword KwPatternSyn $1 }-    | 'postulate'               { TokKeyword KwPostulate $1 }-    | 'primitive'               { TokKeyword KwPrimitive $1 }-    | 'private'                 { TokKeyword KwPrivate $1 }-    | 'Prop'                    { TokKeyword KwProp $1 }-    | 'public'                  { TokKeyword KwPublic $1 }-    | 'quote'                   { TokKeyword KwQuote $1 }-    | 'quoteContext'            { TokKeyword KwQuoteContext $1 }-    | 'quoteGoal'               { TokKeyword KwQuoteGoal $1 }-    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }-    | 'record'                  { TokKeyword KwRecord $1 }-    | 'renaming'                { TokKeyword KwRenaming $1 }-    | 'rewrite'                 { TokKeyword KwRewrite $1 }-    | 'Set'                     { TokKeyword KwSet $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 }-    | 'where'                   { TokKeyword KwWhere $1 }-    | 'with'                    { TokKeyword KwWith $1 }--    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }-    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }-    | 'COMPILED'                { TokKeyword KwCOMPILED $1 }-    | 'COMPILED_DATA'           { TokKeyword KwCOMPILED_DATA $1 }-    | 'COMPILED_DATA_UHC'       { TokKeyword KwCOMPILED_DATA_UHC $1 }-    | 'COMPILED_DECLARE_DATA'   { TokKeyword KwCOMPILED_DECLARE_DATA $1 }-    | 'COMPILED_EPIC'           { TokKeyword KwCOMPILED_EPIC $1 }-    | 'COMPILED_EXPORT'         { TokKeyword KwCOMPILED_EXPORT $1 }-    | 'COMPILED_JS'             { TokKeyword KwCOMPILED_JS $1 }-    | 'COMPILED_TYPE'           { TokKeyword KwCOMPILED_TYPE $1 }-    | 'COMPILED_UHC'            { TokKeyword KwCOMPILED_UHC $1 }-    | 'HASKELL'                 { TokKeyword KwHASKELL $1 }-    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }-    | 'IMPORT'                  { TokKeyword KwIMPORT $1 }-    | 'IMPORT_UHC'              { TokKeyword KwIMPORT_UHC $1 }-    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }-    | 'INLINE'                  { TokKeyword KwINLINE $1 }-    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }-    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }-    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }-    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }-    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }-    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }-    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }-    | 'STATIC'                  { TokKeyword KwSTATIC $1 }-    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }--    | setN                      { TokSetN $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 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 :: { ([Pragma], [Declaration]) }-File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }--maybe_vclose : {- empty -} { () }-             | vclose      { () }--{---------------------------------------------------------------------------    Meta rules- --------------------------------------------------------------------------}---- The first token in a file decides the indentation of the top-level layout--- block. Or not. It will if we allow the top-level module to be omitted.--- topen :      {- empty -}     {% pushCurrentContext }---{-  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 : vclose  { () }-      | error   {% popContext }----- 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 : ';'    { $1 }-     | vsemi  { $1 }----- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.-beginImpDir :: { () }-beginImpDir : {- empty -}   {% pushLexState imp_dir }--{---------------------------------------------------------------------------    Helper rules- --------------------------------------------------------------------------}---- An integer. Used in fixity declarations.-Int :: { Integer }-Int : literal   {% case $1 of {-                     LitNat _ i -> return i;-                     _          -> fail $ "Expected integer"-                   }-                }---{---------------------------------------------------------------------------    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 :: { [Name] }-SpaceIds-    : Id SpaceIds { $1 : $2 }-    | Id          { [$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 parseErrorAt (fromJust (rStart' (getRange $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 :: { [Arg Name] }-MaybeDottedIds-    : MaybeDottedId MaybeDottedIds { $1 : $2 }-    | MaybeDottedId                { [$1] }---- Space separated list of one or more identifiers, some of which may--- be surrounded by braces or dotted.-ArgIds :: { [Arg Name] }-ArgIds-    : MaybeDottedId ArgIds            { $1 : $2 }-    | MaybeDottedId                   { [$1] }-    | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { map makeInstance $2 ++ $4 }-    | '{{' MaybeDottedIds DoubleCloseBrace        { map makeInstance $2 }-    | '{' MaybeDottedIds '}' ArgIds   { map hide $2 ++ $4 }-    | '{' MaybeDottedIds '}'          { map hide $2 }-    | '.' '{' SpaceIds '}' ArgIds     { map (hide . setRelevance Irrelevant . defaultArg) $3 ++ $5 }-    | '.' '{' SpaceIds '}'            { map (hide . setRelevance Irrelevant . defaultArg) $3 }-    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { map (makeInstance . setRelevance Irrelevant . defaultArg) $3 ++ $5 }-    | '.' '{{' SpaceIds DoubleCloseBrace          { map (makeInstance . setRelevance Irrelevant . defaultArg) $3 }-    | '..' '{' SpaceIds '}' ArgIds    { map (hide . setRelevance NonStrict . defaultArg) $3 ++ $5 }-    | '..' '{' SpaceIds '}'           { map (hide . setRelevance NonStrict . defaultArg) $3 }-    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { map (makeInstance . setRelevance NonStrict . defaultArg) $3 ++ $5 }-    | '..' '{{' SpaceIds DoubleCloseBrace         { map (makeInstance . setRelevance NonStrict . defaultArg) $3 }--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 }-    | '_'   { Name (getRange $1) [Hole] }--{- 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 :: { [Name] }-SpaceBIds-    : BId SpaceBIds { $1 : $2 }-    | BId           { [$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 :: { [Name] }-CommaBIds : CommaBIdAndAbsurds {-    case $1 of-      Left ns -> ns-      Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern"-    }--CommaBIdAndAbsurds :: { Either [Name] [Expr] }-CommaBIdAndAbsurds : Application {%-    let getName :: Expr -> Maybe Name-        getName (Ident (QName x)) = Just x-        getName (Underscore r _)  = Just (Name r [Hole])-        getName _                 = Nothing--        isAbsurd :: Expr -> Bool-        isAbsurd (Absurd _)                  = True-        isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e-        isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e-        isAbsurd (Paren _ expr)              = isAbsurd expr-        isAbsurd (RawApp _ exprs)            = any isAbsurd exprs-        isAbsurd _                           = False-    in-    if any isAbsurd $1 then return $ Right $1 else-    case mapM getName $1 of-        Just good -> return $ Left good-        Nothing   -> fail $ "expected sequence of bound identifiers"-    }---- 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 :: { [WithHiding Name] }-BIdsWithHiding : Application {%-    let -- interpret an expression as name-        getName :: Expr -> Maybe Name-        getName (Ident (QName x)) = Just x-        getName (Underscore r _)  = Just (Name r [Hole])-        getName _                 = Nothing--        getNames :: Expr -> Maybe [Name]-        getNames (RawApp _ es) = mapM getName es-        getNames e             = singleton `fmap` getName e--        -- interpret an expression as name or list of hidden names-        getName1 :: Expr -> Maybe [WithHiding Name]-        getName1 (Ident (QName x)) = Just [WithHiding NotHidden x]-        getName1 (Underscore r _)  = Just [WithHiding NotHidden $ Name r [Hole]]-        getName1 (HiddenArg _ (Named Nothing e))-                                   = map (WithHiding Hidden) `fmap` getNames e-        getName1 _                 = Nothing--    in-    case mapM getName1 $1 of-        Just good -> return $ concat good-        Nothing   -> fail $ "expected sequence of possibly hidden bound identifiers"-    }----- Space separated list of strings in a pragma.-PragmaStrings :: { [String] }-PragmaStrings-    : {- empty -}           { [] }-    | string PragmaStrings  { snd $1 : $2 }--PragmaString :: { String }-PragmaString-    : string { snd $1 }--Strings :: { [(Interval, String)] }-Strings : {- empty -}    { [] }-        | string Strings { $1 : $2 }--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))-                                              (RawApp (getRange $1) $1)-                                              $3 }-  | Expr1 '=' Expr                      { Equal (getRange ($1, $2, $3)) $1 $3 }-  | Expr1 %prec LOWEST                  { $1 }---- Level 1: Application-Expr1  : WithExprs {% case $1 of-                      { [e]    -> return e-                      ; e : es -> return $ WithApp (fuseRange e es) e es-                      ; []     -> fail "impossible: empty with expressions"-                      }-                   }--WithExprs :: { [Expr] }-WithExprs-  : Application3 '|' WithExprs { RawApp (getRange $1) $1 :  $3 }-  | Application                { [RawApp (getRange $1) $1] }--Application :: { [Expr] }-Application-    : Expr2             { [$1] }-    | Expr3 Application { $1 : $2 }---- Level 2: Lambdas and lets-Expr2-    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }-    | ExtendedOrAbsurdLam          { $1 }-    | 'forall' ForallBindings Expr        { forallPi $2 $3 }-    | 'let' Declarations 'in' Expr { Let (getRange ($1,$2,$3,$4)) $2 $4 }-    | Expr3                        { $1 }-    | 'quoteGoal' Id 'in' Expr     { QuoteGoal (getRange ($1,$2,$3,$4)) $2 $4 }-    | 'tactic' Application3               { Tactic (getRange ($1, $2)) (RawApp (getRange $2) $2) [] }-    | 'tactic' Application3 '|' WithExprs { Tactic (getRange ($1, $2, $3, $4)) (RawApp (getRange $2) $2) $4 }--ExtendedOrAbsurdLam :: { Expr }-ExtendedOrAbsurdLam-    : '\\'  '{' LamClauses '}'     { ExtendedLam (getRange ($1,$2,$3,$4)) (reverse $3) }-    | '\\' 'where' vopen LamClauses close { ExtendedLam (getRange ($1, $2, $4)) (reverse $4) }-    | '\\' AbsurdLamBindings       {% case $2 of-                                       Left (bs, h) -> if null bs then return $ AbsurdLam r h else-                                                       return $ Lam r bs (AbsurdLam r h)-                                                         where r = fuseRange $1 bs-                                       Right es -> do -- it is of the form @\ { p1 ... () }@-                                                     p <- exprToLHS (RawApp (getRange es) es);-                                                     return $ ExtendedLam (fuseRange $1 es)-                                                                     [(p [] [], AbsurdRHS, NoWhere, False)]-                                   }--Application3 :: { [Expr] }-Application3-    : Expr3              { [$1] }-    | Expr3 Application3 { $1 : $2 }---- Level 3: Atoms-Expr3Curly-    : '{' Expr '}'                      { HiddenArg (getRange ($1,$2,$3)) (maybeNamed $2) }-    | '{' '}'                           { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }--Expr3NoCurly-    : QId                               { Ident $1 }-    | literal                           { Lit $1 }-    | '?'                               { QuestionMark (getRange $1) Nothing }-    | '_'                               { Underscore (getRange $1) Nothing }-    | 'Prop'                            { Prop (getRange $1) }-    | 'Set'                             { Set (getRange $1) }-    | 'quote'                           { Quote (getRange $1) }-    | 'quoteTerm'                       { QuoteTerm (getRange $1) }-    | 'quoteContext'                    { QuoteContext (getRange $1) }-    | 'unquote'                         { Unquote (getRange $1) }-    | setN                              { SetN (getRange (fst $1)) (snd $1) }-    | '{{' Expr DoubleCloseBrace                        { InstanceArg (getRange ($1,$2,$3))-                                                          (maybeNamed $2) }-    | '(' Expr ')'                      { Paren (getRange ($1,$2,$3)) $2 }-    | '(|' Expr '|)'                    { IdiomBrackets (getRange ($1,$2,$3)) $2 }-    | '(' ')'                           { Absurd (fuseRange $1 $2) }-    | '{{' DoubleCloseBrace             { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }-    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }-    | '.' Expr3                         { Dot (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 }--Expr3-    : Expr3Curly                        { $1 }-    | Expr3NoCurly                      { $1 }--RecordAssignments :: { RecordAssignments }-RecordAssignments-  : {- empty -}        { [] }-  | RecordAssignments1 { $1 }--RecordAssignments1 :: { RecordAssignments }-RecordAssignments1-  : RecordAssignment                        { [$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 { $1 }--FieldAssignments1 :: { [FieldAssignment] }-FieldAssignments1-  : FieldAssignment                       { [$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 '->' { $1 }--Telescope1-    : TypedBindingss    { {-TeleBind-} $1 }--TypedBindingss :: { [TypedBindings] }-TypedBindingss-    : TypedBindings TypedBindingss { $1 : $2 }-    | TypedBindings                { [$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}-TypedBindings :: { TypedBindings }-TypedBindings-    : '.' '(' 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)) $-                             setHiding Instance $-                             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)) $-                             setHiding Instance $-                             setRelevance NonStrict $3 }-    | '(' TBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }-    | '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($1,$2,$3)) $-                             setHiding Instance $2 }-    | '{' TBind '}'        { 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 :: { TypedBindings }-TBind : CommaBIds ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TypedBindings r $ defaultArg $ TBind r (map (pure . mkBoundName_) $1) $3-  }--- | Colors are not yet allowed in the syntax.---      | CommaBIds ':{' Colors '}' Expr  { ( $3, TBind (getRange ($1,$2,$3,$4,$5)) (map mkBoundName_ $1) $5 ) }-{--Colors :: { [Color] }-Colors : QId Colors { Ident $1 : $2 }-       | QId        { [Ident $1] }--}---- x {y z} _ {v} : A-TBindWithHiding :: { TypedBindings }-TBindWithHiding : BIdsWithHiding ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TypedBindings r $ defaultArg $ TBind r (map (fmap mkBoundName_) $1) $3-  }---- A non-empty sequence of lambda bindings.-LamBindings :: { [LamBinding] }-LamBindings-  : LamBinds '->' {%-      case reverse $1 of-        Left _ : _ -> parseError "Absurd lambda cannot have a body."-        _ : _      -> return [ b | Right b <- $1 ]-        []         -> parsePanic "Empty LamBinds"-      }--AbsurdLamBindings :: { Either ([LamBinding], Hiding) [Expr] }-AbsurdLamBindings-  : LamBindsAbsurd {%-    case $1 of-      Left lb -> case reverse lb of-                   Right _ : _ -> parseError "Missing body for lambda"-                   Left h  : _ -> return $ Left ([ b | Right b <- init lb], h)-                   _           -> parseError "Unsupported variant of lambda"-      Right es -> return $ Right es-    }---- absurd lambda is represented by @Left hiding@-LamBinds :: { [Either Hiding LamBinding] }-LamBinds-  : DomainFreeBinding LamBinds  { map Right $1 ++ $2 }-  | TypedBindings LamBinds      { Right (DomainFull $1) : $2 }-  | DomainFreeBinding           { map Right $1 }-  | TypedBindings               { [Right $ DomainFull $1] }-  | '(' ')'                     { [Left NotHidden] }-  | '{' '}'                     { [Left Hidden] }-  | '{{' DoubleCloseBrace       { [Left Instance] }---- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@-LamBindsAbsurd :: { Either [Either Hiding LamBinding] [Expr] }-LamBindsAbsurd-  : DomainFreeBinding LamBinds  { Left $ map Right $1 ++ $2 }-  | TypedBindings LamBinds      { Left $ Right (DomainFull $1) : $2 }-  | DomainFreeBindingAbsurd     { case $1 of-                                    Left lb -> Left $ map Right lb-                                    Right es -> Right es }-  | TypedBindings               { Left [Right $ DomainFull $1] }-  | '(' ')'                     { Left [Left NotHidden] }-  | '{' '}'                     { Left [Left Hidden] }-  | '{{' DoubleCloseBrace       { Left [Left Instance] }---- FNF, 2011-05-05: No where clauses in extended lambdas for now-NonAbsurdLamClause :: { (LHS,RHS,WhereClause,Bool) }-NonAbsurdLamClause-  : Application3 '->' Expr {% do-      p <- exprToLHS (RawApp (getRange $1) $1) ;-      return (p [] [], RHS $3, NoWhere, False)-        }-  | CatchallPragma Application3 '->' Expr {% do-      p <- exprToLHS (RawApp (getRange $2) $2) ;-      return (p [] [], RHS $4, NoWhere, True)-        }--AbsurdLamClause :: { (LHS,RHS,WhereClause,Bool) }-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 {% do-      p <- exprToLHS (RawApp (getRange $1) $1);-      return (p [] [], AbsurdRHS, NoWhere, False)-        }-  | CatchallPragma Application {% do-      p <- exprToLHS (RawApp (getRange $2) $2);-      return (p [] [], AbsurdRHS, NoWhere, True)-        }--LamClause :: { (LHS,RHS,WhereClause,Bool) }-LamClause-  : NonAbsurdLamClause { $1 }-  | AbsurdLamClause { $1 }---- Parses all extended lambda clauses except for a single absurd clause, which is taken care of--- in AbsurdLambda-LamClauses :: { [(LHS,RHS,WhereClause,Bool)] }-LamClauses-   : LamClauses semi LamClause { $3 : $1 }-   | AbsurdLamClause semi LamClause { [$3, $1] }-   | NonAbsurdLamClause { [$1] }---   | {- empty -} { [] }---ForallBindings :: { [LamBinding] }-ForallBindings-  : TypedUntypedBindings1 '->' { $1 }---- A non-empty sequence of possibly untyped bindings.-TypedUntypedBindings1 :: { [LamBinding] }-TypedUntypedBindings1-  : DomainFreeBinding TypedUntypedBindings1 { $1 ++ $2 }-  | TypedBindings TypedUntypedBindings1     { DomainFull $1 : $2 }-  | DomainFreeBinding                       { $1 }-  | TypedBindings                           { [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 { $1 ++ $2 }-  | TypedBindings TypedUntypedBindings     { DomainFull $1 : $2 }-  |                                        { [] }---- A domain free binding is either x or {x1 .. xn}-DomainFreeBinding :: { [LamBinding] }-DomainFreeBinding-  : DomainFreeBindingAbsurd { case $1 of-                             Left lbs -> lbs-                             Right _ -> fail "expected sequence of bound identifiers, not absurd pattern"-                          }-{-    : BId             { [DomainFree NotHidden Relevant $ mkBoundName_ $1]  }-    | '.' BId           { [DomainFree NotHidden Irrelevant $ mkBoundName_ $2]  }-    | '..' BId          { [DomainFree NotHidden NonStrict $ mkBoundName_ $2]  }-    | '{' CommaBIds '}' { map (DomainFree Hidden Relevant . mkBoundName_) $2 }-    | '{{' CommaBIds DoubleCloseBrace { map (DomainFree (setHiding Instance defaultArgInfo) . mkBoundName_) $2 }-    | '.' '{' CommaBIds '}' { map (DomainFree Hidden Irrelevant . mkBoundName_) $3 }-    | '.' '{{' CommaBIds DoubleCloseBrace { map (DomainFree Instance Irrelevant . mkBoundName_) $3 }-    | '..' '{' CommaBIds '}' { map (DomainFree Hidden NonStrict . mkBoundName_) $3 }-    | '..' '{{' CommaBIds DoubleCloseBrace { map (DomainFree Instance NonStrict . mkBoundName_) $3 }-    | '..' '{{' CommaBIds DoubleCloseBrace { map (DomainFree Instance NonStrict . mkBoundName_) $3 }-  -}---- A domain free binding is either x or {x1 .. xn}-DomainFreeBindingAbsurd :: { Either [LamBinding] [Expr]}-DomainFreeBindingAbsurd-    : BId               { Left [DomainFree defaultArgInfo $ mkBoundName_ $1]  }-    | '.' BId           { Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ $2]  }-    | '..' BId          { Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ $2]  }-    | '{' CommaBIdAndAbsurds '}'-         { mapLeft (map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) $2 }-    | '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) $2 }-    | '.' '{' CommaBIds '}' { Left $ map (DomainFree (setHiding Hidden $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) $3 }-    | '.' '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree (setHiding Instance $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) $3 }-    | '..' '{' CommaBIds '}' { Left $ map (DomainFree (setHiding Hidden $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) $3 }-    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree  (setHiding Instance $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) $3 }---{---------------------------------------------------------------------------    Modules and imports- --------------------------------------------------------------------------}---- Import directives-ImportDirective :: { ImportDirective }-ImportDirective : ImportDirectives {% mergeImportDirectives $1 }--ImportDirectives :: { [ImportDirective] }-ImportDirectives-  : ImportDirective1 ImportDirectives { $1 : $2 }-  | {- empty -}                       { [] }--ImportDirective1 :: { ImportDirective }-  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = True } }-  | 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' Id { Renaming $1 (setImportedName $1 $3) (getRange $2) }---- 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-CommaImportNames :: { [ImportedName] }-CommaImportNames-    : {- empty -}       { [] }-    | CommaImportNames1 { $1 }--CommaImportNames1-    : ImportName                        { [$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 :: { LHS }-LHS : Expr1 RewriteEquations WithExpressions-        {% exprToLHS $1 >>= \p -> return (p $2 $3) }-    | '...' WithPats RewriteEquations WithExpressions-        { Ellipsis (getRange ($1,$2,$3,$4)) $2 $3 $4 }--WithPats :: { [Pattern] }-WithPats : {- empty -}  { [] }-         | '|' Application3 WithPats-                {% exprToPattern (RawApp (getRange $2) $2) >>= \p ->-                   return (p : $3)-                }--WithExpressions :: { [Expr] }-WithExpressions-  : {- empty -} { [] }-  | 'with' Expr-      { case $2 of { WithApp _ e es -> e : es; e -> [e] } }--RewriteEquations :: { [Expr] }-RewriteEquations-  : {- empty -} { [] }-  | 'rewrite' Expr1-      { case $2 of { WithApp _ e es -> e : es; e -> [e] } }---- Where clauses are optional.-WhereClause :: { WhereClause }-WhereClause-    : {- empty -}                      { NoWhere         }-    | 'where' Declarations0            { AnyWhere $2     }-    | 'module' Id 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }-    | 'module' Underscore 'where' Declarations0 { SomeWhere $2 PublicAccess $4 }--ExprWhere :: { ExprWhere }-ExprWhere : Expr WhereClause { ExprWhere $1 $2 }--{---------------------------------------------------------------------------    Different kinds of declarations- --------------------------------------------------------------------------}---- Top-level definitions.-Declaration :: { [Declaration] }-Declaration-    : Fields        {  $1  }-    | FunClause     {  $1  }-    | Data          { [$1] }-    | DataSig       { [$1] }  -- lone data type signature in mutual block-    | Record        { [$1] }-    | RecordSig     { [$1] }  -- lone record signature in mutual block-    | Infix         { [$1] }-    | Mutual        { [$1] }-    | Abstract      { [$1] }-    | Private       { [$1] }-    | Instance      { [$1] }-    | Macro         { [$1] }-    | Postulate     { [$1] }-    | Primitive     { [$1] }-    | Open          {  $1  }---    | Import      { [$1] }-    | ModuleMacro   { [$1] }-    | Module        { [$1] }-    | Pragma        { [$1] }-    | Syntax        { [$1] }-    | PatternSyn    { [$1] }-    | UnquoteDecl   { [$1] }---{---------------------------------------------------------------------------    Individual declarations- --------------------------------------------------------------------------}---- Type signatures of the form "n1 n2 n3 ... : Type", with at least--- one bound name.-TypeSigs :: { [Declaration] }-TypeSigs : SpaceIds ':' Expr { map (\ x -> TypeSig defaultArgInfo 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 :: { [Arg Declaration] }-ArgTypeSigs-  : ArgIds ':' Expr { map (fmap (\ x -> TypeSig defaultArgInfo x $3)) $1 }-  | 'overlap' ArgIds ':' Expr {-      let setOverlap (Arg i x) = Arg i{ argInfoOverlappable = True } x in-      map (setOverlap . fmap (\ x -> TypeSig defaultArgInfo x $4)) $2 }-  | 'instance' ArgTypeSignatures {-    let-      setInstance (TypeSig info x t) = TypeSig (setHiding Instance info) x t-      setInstance _ = __IMPOSSIBLE__ in-    map (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 :: { [Declaration] }-FunClause : LHS RHS WhereClause {% funClauseOrTypeSigs $1 $2 $3 }--RHS :: { RHSOrTypeSigs }-RHS : '=' Expr      { JustRHS (RHS $2) }-    | ':' Expr      { TypeSigsRHS $2 }-    | {- empty -}   { JustRHS AbsurdRHS }---- Data declaration. Can be local.-Data :: { Declaration }-Data : 'data' Id TypedUntypedBindings ':' Expr 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) Inductive $2 $3 (Just $5) $7 }-     | 'codata' Id TypedUntypedBindings ':' Expr 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) CoInductive $2 $3 (Just $5) $7 }--  -- New cases when we already had a DataSig.  Then one can omit the sort.-     | 'data' Id TypedUntypedBindings 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5)) Inductive $2 $3 Nothing $5 }-     | 'codata' Id TypedUntypedBindings 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5)) CoInductive $2 $3 Nothing $5 }---- Data type signature. Found in mutual blocks.-DataSig :: { Declaration }-DataSig : 'data' Id TypedUntypedBindings ':' Expr-  { DataSig (getRange ($1,$2,$3,$4,$5)) Inductive $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 ((x,y,z),ds) = $7 in return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n x y z $3 (Just $5) ds }-       | 'record' Expr3NoCurly TypedUntypedBindings 'where'-            RecordDeclarations-         {% exprToName $2 >>= \ n -> let ((x,y,z),ds) = $5 in return $ Record (getRange ($1,$2,$3,$4,$5)) n x y z $3 Nothing 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 }---- Declaration of record constructor name.-RecordConstructorName :: { (Name, IsInstance) }-RecordConstructorName :                  'constructor' Id        { ($2, NotInstanceDef) }-                      | 'instance' vopen 'constructor' Id vclose { ($4, InstanceDef) }---- Fixity declarations.-Infix :: { Declaration }-Infix : 'infix'  Int SpaceBIds  { Infix (Fixity (getRange ($1,$3)) (Related $2) NonAssoc)   $3 }-      | 'infixl' Int SpaceBIds  { Infix (Fixity (getRange ($1,$3)) (Related $2) LeftAssoc)  $3 }-      | 'infixr' Int SpaceBIds  { Infix (Fixity (getRange ($1,$3)) (Related $2) RightAssoc) $3 }---- Field declarations.-Fields :: { [Declaration] }-Fields : 'field' ArgTypeSignatures-            { let-                inst i | getHiding i == Instance = InstanceDef-                       | otherwise               = NotInstanceDef-                toField (Arg info (TypeSig info' x t)) = Field (inst info') x (Arg info t)-              in map toField $2 }---- Mutually recursive declarations.-Mutual :: { Declaration }-Mutual : 'mutual' Declarations  { Mutual (fuseRange $1 $2) $2 }----- Abstract declarations.-Abstract :: { Declaration }-Abstract : 'abstract' Declarations  { Abstract (fuseRange $1 $2) $2 }----- Private can only appear on the top-level (or rather the module level).-Private :: { Declaration }-Private : 'private' Declarations        { Private (fuseRange $1 $2) UserWritten $2 }----- Instance declarations.-Instance :: { Declaration }-Instance : 'instance' Declarations  { InstanceB (fuseRange $1 $2) $2 }----- Macro declarations.-Macro :: { Declaration }-Macro : 'macro' Declarations { Macro (fuseRange $1 $2) $2 }----- Postulates.-Postulate :: { Declaration }-Postulate : 'postulate' Declarations { Postulate (fuseRange $1 $2) $2 }---- Primitives. Can only contain type signatures.-Primitive :: { Declaration }-Primitive : 'primitive' TypeSignatures  { Primitive (fuseRange $1 $2) $2 }---- Unquoting declarations.-UnquoteDecl :: { Declaration }-UnquoteDecl-  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }-  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) $2 $4 }-  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) $2 $4 }---- Syntax declaration (To declare eg. mixfix binders)-Syntax :: { Declaration }-Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%-  case $2 of-    Name _ [_] -> case mkNotation $3 (map rangedThing $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-  : {- empty -} { [] }-  | LamBinds    {% patternSynArgs $1 }--SimpleIds :: { [RString] }-SimpleIds : SimpleId { [$1] }-          | SimpleIds SimpleId {$1 ++ [$2]}--HoleNames :: { [NamedArg HoleName] }-HoleNames : HoleName { [$1] }-          | HoleNames HoleName {$1 ++ [$2]}--HoleName :: { NamedArg HoleName }-HoleName-  : SimpleTopHole { defaultNamedArg $1 }-  | '{'  SimpleHole '}'  { setHiding Hidden   $ defaultNamedArg $2 }-  | '{{' SimpleHole '}}' { setHiding Instance $ defaultNamedArg $2 }-  | '{'  SimpleId '=' SimpleHole '}'  { setHiding Hidden   $ defaultArg $ named $2 $4 }-  | '{{' SimpleId '=' SimpleHole '}}' { setHiding Instance $ defaultArg $ named $2 $4 }--SimpleTopHole :: { HoleName }-SimpleTopHole-  : SimpleId { ExprHole (rangedThing $1) }-  | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole (rangedThing $3) (rangedThing $5) }-  | '(' '\\' '_'      '->' SimpleId ')' { LambdaHole "_" (rangedThing $5) }--SimpleHole :: { HoleName }-SimpleHole-  : SimpleId { ExprHole (rangedThing $1) }-  | '\\' SimpleId '->' SimpleId { LambdaHole (rangedThing $2) (rangedThing $4) }-  | '\\' '_'      '->' SimpleId { LambdaHole "_" (rangedThing $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 :: { [Declaration] }-Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%-    let-    { doOpen = maybe DontOpen (const DoOpen) $1-    ; m   = $3-    ; es  = $4-    ; dir = $5-    ; r   = getRange (m, es, dir)-    ; mr  = getRange m-    ; unique = hashString $ show $ (Nothing :: 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 [ Id $ stringToRawName $ ".#" ++ show m ++ "-" ++ show unique ]-    ; impStm asR = Import mr m (Just (AsName fresh asR)) DontOpen defaultImportDir-    ; appStm m' es =-        let r = getRange (m, es) in-        Private r Inserted-          [ ModuleMacro r m'-             (SectionApp (getRange es) []-               (RawApp (getRange es) (Ident (QName fresh) : es)))-             doOpen dir-          ]-    ; (initArgs, last2Args) = splitAt (length es - 2) es-    ; parseAsClause = case last2Args of-      { [ Ident (QName (Name asR [Id x]))-        , Ident (QName m')-        ] | rawNameToString x == "as" -> Just (asR, m')-      ; _ -> Nothing-      }-    } in-    case es of-      { [] -> return [Import mr m Nothing doOpen dir]-      ; _ | Just (asR, m') <- parseAsClause ->-              if null initArgs then return-                 [ Import (getRange (m, asR, m', dir)) m-                     (Just (AsName m' asR)) doOpen dir-                 ]-              else return [ impStm asR, appStm m' initArgs ]-          | DontOpen <- doOpen -> parseErrorAt (fromJust $ rStart' $ getRange $2) "An import statement with module instantiation does not actually import the module.  This statement achieves nothing.  Either add the `open' keyword or bind the instantiated module with an `as' clause."-          | otherwise -> return-              [ impStm noRange-              , appStm (noName $ beginningOf $ getRange m) es-              ]-      }-  }-  |'open' ModuleName OpenArgs ImportDirective {-    let-    { m   = $2-    ; es  = $3-    ; dir = $4-    ; r   = getRange (m, es, dir)-    } in-    [ case es of-      { []  -> Open r m dir-      ; _   -> Private r Inserted-                 [ ModuleMacro r (noName $ beginningOf $ getRange m)-                             (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))-                             DoOpen dir-                 ]-      }-    ]-  }-  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {-    let r = getRange $2 in-    [ Private r Inserted-      [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleIFS r $2) DoOpen $6-      ]-    ]-  }--OpenArgs :: { [Expr] }-OpenArgs : {- empty -}    { [] }-         | Expr3 OpenArgs { $1 : $2 }--ModuleApplication :: { [TypedBindings] -> Parser ModuleApplication }-ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->-                    if null ts then return $ RecordModuleIFS (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 (fuseRange $1 $2) (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 }-  | CompiledPragma           { $1 }-  | CompiledExportPragma     { $1 }-  | CompiledDataPragma       { $1 }-  | CompiledDeclareDataPragma { $1 }-  | CompiledTypePragma       { $1 }-  | CompiledEpicPragma       { $1 }-  | CompiledJSPragma         { $1 }-  | CompiledUHCPragma        { $1 }-  | CompiledDataUHCPragma    { $1 }-  | HaskellPragma            { $1 }-  | StaticPragma             { $1 }-  | InlinePragma             { $1 }-  | ImportPragma             { $1 }-  | ImportUHCPragma          { $1 }-  | ImpossiblePragma         { $1 }-  | TerminatingPragma        { $1 }-  | NonTerminatingPragma     { $1 }-  | NoTerminationCheckPragma { $1 }-  | MeasurePragma            { $1 }-  | CatchallPragma           { $1 }-  | DisplayPragma            { $1 }-  | NoPositivityCheckPragma  { $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)) (snd $3) (Ident $4) }-    -- Extra rule to accept keword REWRITE also as built-in:-    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'-      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) "REWRITE" (Ident $4) }--RewritePragma :: { Pragma }-RewritePragma-    : '{-#' 'REWRITE' PragmaQNames '#-}'-      { RewritePragma (getRange ($1,$2,$3,$4)) $3 }--CompiledPragma :: { Pragma }-CompiledPragma-  : '{-#' 'COMPILED' PragmaQName PragmaStrings '#-}'-    { CompiledPragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledExportPragma :: { Pragma }-CompiledExportPragma-  : '{-#' 'COMPILED_EXPORT' PragmaQName PragmaString '#-}'-    { CompiledExportPragma (getRange ($1,$2,$3,$5)) $3 $4 }--CompiledDeclareDataPragma :: { Pragma }-CompiledDeclareDataPragma-  : '{-#' 'COMPILED_DECLARE_DATA' PragmaQName PragmaStrings '#-}'-    { CompiledDeclareDataPragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledTypePragma :: { Pragma }-CompiledTypePragma-  : '{-#' 'COMPILED_TYPE' PragmaQName PragmaStrings '#-}'-    { CompiledTypePragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledDataPragma :: { Pragma }-CompiledDataPragma-  : '{-#' 'COMPILED_DATA' PragmaQName string PragmaStrings '#-}'-    { CompiledDataPragma (getRange ($1,$2,$3,fst $4,$6)) $3 (snd $4) $5 }--CompiledEpicPragma :: { Pragma }-CompiledEpicPragma-  : '{-#' 'COMPILED_EPIC' PragmaQName PragmaStrings '#-}'-    { CompiledEpicPragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledJSPragma :: { Pragma }-CompiledJSPragma-  : '{-#' 'COMPILED_JS' PragmaQName PragmaStrings '#-}'-    { CompiledJSPragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledUHCPragma :: { Pragma }-CompiledUHCPragma-  : '{-#' 'COMPILED_UHC' PragmaQName PragmaStrings '#-}'-    { CompiledUHCPragma (getRange ($1,$2,$3,$5)) $3 (unwords $4) }--CompiledDataUHCPragma :: { Pragma }-CompiledDataUHCPragma-  : '{-#' 'COMPILED_DATA_UHC' PragmaQName string PragmaStrings '#-}'-    { CompiledDataUHCPragma (getRange ($1,$2,$3,fst $4,$6)) $3 (snd $4) $5 }--HaskellPragma :: { Pragma }-HaskellPragma-  : '{-#' 'HASKELL' Strings '#-}' { HaskellCodePragma (getRange ($1, $2, $4)) (recoverLayout $3) }--StaticPragma :: { Pragma }-StaticPragma-  : '{-#' 'STATIC' PragmaQName '#-}'-    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }--InlinePragma :: { Pragma }-InlinePragma-  : '{-#' 'INLINE' PragmaQName '#-}'-    { InlinePragma (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)) }--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 }--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)) }---ImportPragma :: { Pragma }-ImportPragma-  : '{-#' 'IMPORT' string '#-}'-    {% let s = snd $3 in-       if validHaskellModuleName s-       then return $ ImportPragma (getRange ($1,$2,fst $3,$4)) s-       else parseError $ "Malformed module name: " ++ s ++ "."-    }--ImportUHCPragma :: { Pragma }-ImportUHCPragma-  : '{-#' 'IMPORT_UHC' string '#-}'-    {% let s = snd $3 in-       if validHaskellModuleName s-       then return $ ImportUHCPragma (getRange ($1,$2,fst $3,$4)) s-       else parseError $ "Malformed module name: " ++ s ++ "."-    }---ImpossiblePragma :: { Pragma }-  : '{-#' 'IMPOSSIBLE' '#-}'  { ImpossiblePragma (getRange ($1,$2,$3)) }--NoPositivityCheckPragma :: { Pragma }-NoPositivityCheckPragma-  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'-    { NoPositivityCheckPragma (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 }---- 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- --------------------------------------------------------------------------}---- Non-empty list of type signatures, with several identifiers allowed--- for every signature.-TypeSignatures :: { [TypeSignature] }-TypeSignatures-    : vopen TypeSignatures1 close   { reverse $2 }---- Inside the layout block.-TypeSignatures1 :: { [TypeSignature] }-TypeSignatures1-    : TypeSignatures1 semi TypeSigs { reverse $3 ++ $1 }-    | TypeSigs                      { reverse $1 }---- A variant of TypeSignatures which uses ArgTypeSigs instead of--- TypeSigs.-ArgTypeSignatures :: { [Arg TypeSignature] }-ArgTypeSignatures-    : vopen ArgTypeSignatures1 close   { reverse $2 }---- Inside the layout block.-ArgTypeSignatures1 :: { [Arg TypeSignature] }-ArgTypeSignatures1-    : ArgTypeSignatures1 semi ArgTypeSigs { reverse $3 ++ $1 }-    | ArgTypeSigs                         { reverse $1 }---- Record declarations, including an optional record constructor name.-RecordDeclarations :: { ((Maybe (Ranged Induction), Maybe Bool, Maybe (Name, IsInstance)), [Declaration]) }-RecordDeclarations-                                  : vopen RecordDirectives close {% ((,) `fmap` verifyRecordDirectives $2 <*> pure []) }-                                  | vopen RecordDirectives semi Declarations1 close {% ((,) `fmap` verifyRecordDirectives $2 <*> pure $4) }-                                  | vopen Declarations1 close {% ((,) `fmap` verifyRecordDirectives [] <*> pure $2)  }---RecordDirectives :: { [RecordDirective] }-RecordDirectives-                                  : { [] }-                                  | RecordDirectives semi RecordDirective { $3 : $1 }-                                  | RecordDirective { [$1] }--RecordDirective :: { RecordDirective }-RecordDirective-                                  : RecordConstructorName { Constructor $1 }-                                  | RecordInduction       { Induction $1 }-                                  | RecordEta             { Eta $1 }--RecordEta :: { Ranged Bool }-RecordEta-                                  : 'eta-equality' { Ranged (getRange $1) True }-                                  | 'no-eta-equality' { Ranged (getRange $1) False }---- Declaration of record as 'inductive' or 'coinductive'.-RecordInduction :: { Ranged Induction }-RecordInduction-   : 'inductive'   { Ranged (getRange $1) Inductive   }-   | 'coinductive' { Ranged (getRange $1) CoInductive }---- Arbitrary declarations-Declarations :: { [Declaration] }-Declarations-    : vopen Declarations1 close { $2 }---- Arbitrary declarations (possibly empty)-Declarations0 :: { [Declaration] }-Declarations0-    : vopen close  { [] }-    | Declarations { $1 }--Declarations1 :: { [Declaration] }-Declarations1-    : Declaration semi Declarations1 { $1 ++ $3 }-    | Declaration                    { $1 }--TopDeclarations :: { [Declaration] }-TopDeclarations-  : {- empty -}   { [] }-  | Declarations1 { $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] -> ([Pragma], [Declaration])-takeOptionsPragmas = 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.-    (ds0, ds1)                      -> ds0 ++ [Module (getRange ds1) (QName noName_) [] 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) $ fail $ "a name cannot contain two consecutive underscores"-    return $ Name (getRange i) xs-    where-        isValidId Hole   = return ()-        isValidId (Id y) = do-          let x = rawNameToString y-          case parse defaultParseFlags [0] (lexer return) x of-            ParseOk _ (TokId _) -> return ()-            _                   -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"--        -- we know that there are no two Ids in a row-        alternating (Hole : Hole : _) = False-        alternating (_ : xs)          = alternating 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)---- | 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---- | Polarity parser.--polarity :: (Interval, String) -> Parser (Range, Occurrence)-polarity (i, s) =-  case s of-    "_"  -> ret Unused-    "++" -> ret StrictPos-    "+"  -> ret JustPos-    "-"  -> ret JustNeg-    "*"  -> ret Mixed-    _    -> fail $ "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  = genericReplicate (l2 - l1) '\n' ++ genericReplicate (max 0 (c2 - c0)) ' '-      | l1 == l2 = 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 = fail $ "expected " ++ s ++ ", found " ++ s'---- | Build a forall pi (forall x y z -> ...)-forallPi :: [LamBinding] -> Expr -> Expr-forallPi bs e = Pi (map addType bs) e---- | Build a telescoping let (let Ds)-tLet :: Range -> [Declaration] -> TypedBindings-tLet r = TypedBindings r . Arg defaultArgInfo . TLet r---- | Converts lambda bindings to typed bindings.-addType :: LamBinding -> TypedBindings-addType (DomainFull b)   = b-addType (DomainFree info x) = TypedBindings r $ Arg info $ TBind r [pure x] $ Underscore r Nothing-  where r = getRange x--mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective-mergeImportDirectives is = do-  i <- foldl merge (return defaultImportDir) is-  verifyImportDirective i-  where-    merge mi i2 = do-      i1 <- mi-      let err = parseError' (rStart' $ getRange i2) "Cannot mix using and hiding module directives"-      return $ ImportDirective-        { importDirRange = fuseRange i1 i2-        , using          = mappend (using i1) (using i2)-        , hiding         = hiding i1 ++ hiding i2-        , impRenaming    = impRenaming i1 ++ impRenaming i2-        , publicOpen     = publicOpen i1 || publicOpen i2 }---- | Check that an import directive doesn't contain repeated names-verifyImportDirective :: ImportDirective -> Parser ImportDirective-verifyImportDirective i =-    case filter ((>1) . length)-         $ group-         $ sort xs-    of-        []  -> return i-        yss -> let Just pos = rStart' $ getRange $ head $ concat yss in-               parseErrorAt pos $-                "Repeated name" ++ s ++ " in import directive: " ++-                concat (intersperse ", " $ map (show . head) yss)-            where-                s = case yss of-                        [_] -> ""-                        _   -> "s"-    where-        xs = names (using i) ++ hiding i ++ map renFrom (impRenaming i)-        names (Using xs)    = xs-        names UseEverything = []--data RecordDirective-   = Induction (Ranged Induction)-   | Constructor (Name, IsInstance)-   | Eta         (Ranged Bool)-   deriving (Eq,Show)--verifyRecordDirectives :: [RecordDirective] -> Parser (Maybe (Ranged Induction), Maybe Bool, Maybe (Name, IsInstance))-verifyRecordDirectives xs | null rs = return (ltm is, ltm es, ltm cs)-                          | otherwise = let Just pos = rStart' $ (head rs) in-                                          parseErrorAt pos $ "Repeated record directives at: \n" ++ intercalate "\n" (map show rs)-- where-  ltm :: [a] -> Maybe a-  ltm [] = Nothing-  ltm (x:xs) = Just x-  errorFromList [] = []-  errorFromList [x] = []-  errorFromList xs = map getRange xs-  rs = sort (concat ([errorFromList is, errorFromList es', errorFromList cs]))-  is = [ i | Induction i <- xs ]-  es' = [ i | Eta i <- xs ]-  es = map rangedThing es'-  cs = [ i | Constructor i <- xs ]----- | 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 ([Expr] -> [Expr] -> LHS)-exprToLHS e = case e of-  WithApp r e es -> LHS <$> exprToPattern e <*> mapM exprToPattern es-  _              -> LHS <$> exprToPattern e <*> return []---- | Turn an expression into a pattern. Fails if the expression is not a---   valid pattern.-exprToPattern :: Expr -> Parser Pattern-exprToPattern e = do-    let Just pos = rStart' $ getRange e-        failure = parseErrorAt pos $ "Not a valid pattern: " ++ show e-    case e of-        Ident x                 -> return $ IdentP x-        App _ e1 e2             -> AppP <$> exprToPattern e1-                                        <*> T.mapM (T.mapM exprToPattern) e2-        Paren r e               -> ParenP r-                                        <$> exprToPattern e-        Underscore r _          -> return $ WildP r-        Absurd r                -> return $ AbsurdP r-        As r x e                -> AsP r x <$> exprToPattern e-        Dot r (HiddenArg _ e)   -> return $ HiddenP r $ fmap (DotP r UserWritten) e-        Dot r e                 -> return $ DotP r UserWritten e-        Lit l                   -> return $ LitP l-        HiddenArg r e           -> HiddenP r <$> T.mapM exprToPattern e-        InstanceArg r e         -> InstanceP r <$> T.mapM exprToPattern e-        RawApp r es             -> RawAppP r <$> mapM exprToPattern es-        Quote r                 -> return $ QuoteP r-        Rec r es | Just fs <- mapM maybeLeft es -> do-          RecP r <$> T.mapM (T.mapM exprToPattern) fs-        _                       -> failure--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 =-  let Just pos = rStart' $ getRange e in-  parseErrorAt pos $ "Not a valid identifier: " ++ show e--stripSingletonRawApp :: Expr -> Expr-stripSingletonRawApp (RawApp _ [e]) = stripSingletonRawApp e-stripSingletonRawApp e = e--isEqual :: Expr -> Maybe (Expr, Expr)-isEqual e =-  case stripSingletonRawApp e of-    Equal _ a b -> Just (stripSingletonRawApp a, stripSingletonRawApp b)-    _           -> Nothing--maybeNamed :: Expr -> Named_ Expr-maybeNamed e =-  case isEqual e of-    Just (Ident (QName x), b) -> named (Ranged (getRange x) (nameToRawName x)) b-    _                         -> unnamed e--patternSynArgs :: [Either Hiding LamBinding] -> Parser [Arg Name]-patternSynArgs = mapM pSynArg-  where-    pSynArg Left{}                   = parseError "Absurd patterns are not allowed in pattern synonyms"-    pSynArg (Right DomainFull{})     = parseError "Unexpected type signature in pattern synonym argument"-    pSynArg (Right (DomainFree a x))-      | getHiding a `notElem` [Hidden, NotHidden] = parseError $ show (getHiding a) ++ " arguments not allowed to pattern synonyms"-      | getRelevance a /= Relevant                = parseError "Arguments to pattern synonyms must be relevant"-      | otherwise                                 = return $ Arg a (boundName x)--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 [(ArgInfo, Name)]-patternToNames p =-  case p of-    IdentP (QName i)         -> return [(defaultArgInfo, i)]-    WildP r                  -> return [(defaultArgInfo, C.noName r)]-    DotP _ _ (Ident (QName i)) -> return [(setRelevance Irrelevant defaultArgInfo, i)]-    RawAppP _ ps             -> concat <$> mapM patternToNames ps-    _                        -> parseError $-      "Illegal name in type signature: " ++ prettyShow p--funClauseOrTypeSigs :: LHS -> RHSOrTypeSigs -> WhereClause -> Parser [Declaration]-funClauseOrTypeSigs lhs mrhs wh = do-  -- traceShowM lhs-  case mrhs of-    JustRHS rhs   -> return [FunClause lhs rhs wh False]-    TypeSigsRHS e -> case wh of-      NoWhere -> case lhs of-        Ellipsis{}      -> parseError "The ellipsis ... cannot have a type signature"-        LHS _ _ _ (_:_) -> parseError "Illegal: with in type signature"-        LHS _ _ (_:_) _ -> parseError "Illegal: rewrite in type signature"-        LHS _ (_:_) _ _ -> parseError "Illegal: with patterns in type signature"-        LHS p [] [] []  -> map (\ (x, y) -> TypeSig x y e) <$> patternToNames p-      _ -> 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 #-}."+#if  __GLASGOW_HASKELL__ > 800+{-# OPTIONS_GHC -Wno-error=missing-signatures #-}+#endif+{-# LANGUAGE PatternGuards #-}++{-| The parser is generated by Happy (<http://www.haskell.org/happy>).+ -+ - Ideally, ranges should be as precise as possible, to get messages that+ - emphasize precisely the faulting term(s) upon error.+ -+ - However, interactive highlighting is only applied at the end of each+ - mutual block, keywords are only highlighted once (see+ - `TypeChecking.Rules.Decl'). So if the ranges of two declarations+ - interleave, one must ensure that keyword ranges are not included in+ - the intersection. (Otherwise they are uncolored by the interactive+ - highlighting.)+ -+ -}+module Agda.Syntax.Parser.Parser (+      moduleParser+    , moduleNameParser+    , exprParser+    , exprWhereParser+    , tokensParser+    , holeContentParser+    ) 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. -}@@ -5,8 +7,11 @@     ( litString, litChar     ) where +import Data.Bifunctor import Data.Char+import qualified Data.Text as T +import Agda.Syntax.Common (pattern Ranged) import Agda.Syntax.Parser.Alex import Agda.Syntax.Parser.Monad import Agda.Syntax.Parser.Tokens@@ -14,17 +19,14 @@ import Agda.Syntax.Position import Agda.Syntax.Literal -import Agda.Utils.Char   ( decDigit, hexDigit, octDigit )-import Agda.Utils.Tuple  ( (-*-) )- {--------------------------------------------------------------------------     Exported actions  --------------------------------------------------------------------------}  -- | Lex a string literal. Assumes that a double quote has been lexed. litString :: LexAction Token-litString = stringToken '"' (\i s ->-              return $ TokLiteral $ LitString (getRange i) s)+litString = stringToken '"' $ \ i s ->+  return $ TokLiteral $ Ranged (getRange i) $ LitString $ T.pack s  {-| Lex a character literal. Assumes that a single quote has been lexed.  A     character literal is lexed in exactly the same way as a string literal.@@ -33,11 +35,9 @@     the other hand it will only be inefficient if there is a lexical error. -} litChar :: LexAction Token-litChar = stringToken '\'' $ \i s ->-            do  case s of-                    [c] -> return $ TokLiteral $ LitChar (getRange i) c-                    _   -> lexError-                            "character literal must contain a single character"+litChar = stringToken '\'' $ \ i -> \case+  [c] -> return $ TokLiteral $ Ranged (getRange i) $ LitChar c+  _   -> lexError "character literal must contain a single character"   {--------------------------------------------------------------------------@@ -60,7 +60,7 @@ --   character argument is the delimiter (@\"@ for strings and @\'@ for --   characters). stringToken :: Char -> (Interval -> String -> Parser tok) -> LexAction tok-stringToken del mkTok inp inp' n =+stringToken del mkTok = LexAction $ \ inp inp' n ->     do  setLastPos (backupPos $ lexPos inp')         setLexInput inp'         -- TODO: Should setPrevToken be run here? Compare with@@ -103,7 +103,7 @@         case c of             '\\'            -> lexString del s             c | isSpace c   -> lexStringGap del s-            _               -> fail "non-space in string gap"+            _               -> lookAheadError "non-space in string gap"  -- | Lex a single character. lexChar :: LookAhead Char@@ -121,18 +121,18 @@             '^'     -> do c <- eatNextChar                           if c >= '@' && c <= '_'                             then return (chr (ord c - ord '@'))-                            else fail "invalid control character"+                            else lookAheadError "invalid control character" -            'x'     -> readNum isHexDigit 16 hexDigit-            'o'     -> readNum isOctDigit  8 octDigit+            'x'     -> readNum isHexDigit 16 digitToInt+            'o'     -> readNum isOctDigit  8 digitToInt             x | isDigit x-                    -> readNumAcc isDigit 10 decDigit (decDigit x)+                    -> readNumAcc isDigit 10 digitToInt (digitToInt x)              c ->                 -- Try to match the input (starting with c) against the                 -- silly escape codes.-                do  esc <- match' c (map (id -*- return) sillyEscapeChars)-                                    (fail "bad escape code")+                do  esc <- match' c (map (second return) sillyEscapeChars)+                                    (lookAheadError "bad escape code")                     sync                     return esc @@ -142,7 +142,7 @@     do  c <- eatNextChar         if isDigit c             then readNumAcc isDigit base conv (conv c)-            else fail "non-digit in numeral"+            else lookAheadError "non-digit in numeral"  -- | Same as 'readNum' but with an accumulating parameter. readNumAcc :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> LookAhead Char@@ -158,7 +158,7 @@                             sync                             if i >= ord minBound && i <= ord maxBound                                 then return (chr i)-                                else fail "character literal out of bounds"+                                else lookAheadError "character literal out of bounds"  -- | The escape codes. sillyEscapeChars :: [(String, Char)]
src/full/Agda/Syntax/Parser/Tokens.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Parser.Tokens     ( Token(..)     , Keyword(..)@@ -5,44 +7,71 @@     , Symbol(..)     ) where -import Agda.Syntax.Literal (Literal)+import Data.Functor (void)++import Agda.Syntax.Literal (RLiteral) import Agda.Syntax.Position  data Keyword-        = KwLet | KwIn | KwWhere | KwData | KwCoData-        | KwPostulate | KwMutual | KwAbstract | KwPrivate | KwInstance+        = KwLet | KwIn | KwWhere | KwData | KwCoData | KwDo+        | KwPostulate | KwAbstract | KwPrivate | KwInstance+        | KwInterleaved | KwMutual         | KwOverlap         | KwOpen | KwImport | KwModule | KwPrimitive | KwMacro         | KwInfix | KwInfixL | KwInfixR | KwWith | KwRewrite-        | KwSet | KwProp | KwForall | KwRecord | KwConstructor | KwField+        | KwForall | KwRecord | KwConstructor | KwField         | KwInductive | KwCoInductive         | KwEta | KwNoEta         | KwHiding | KwUsing | KwRenaming | KwTo | KwPublic+        | KwOpaque | KwUnfolding         | KwOPTIONS | KwBUILTIN | KwLINE-        | KwCOMPILED_DATA | KwCOMPILED_DECLARE_DATA | KwCOMPILED_TYPE | KwCOMPILED | KwCOMPILED_EXPORT-        | KwHASKELL-        | KwCOMPILED_EPIC | KwCOMPILED_JS | KwCOMPILED_UHC | KwCOMPILED_DATA_UHC-        | KwIMPORT | KwIMPORT_UHC | KwIMPOSSIBLE | KwSTATIC | KwINLINE+        | KwFOREIGN | KwCOMPILE+        | 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-        | KwQuoteGoal | KwQuoteContext | KwQuote | KwQuoteTerm+        | KwOVERLAPPABLE | KwOVERLAPPING | KwOVERLAPS | KwINCOHERENT+        | KwQuote | KwQuoteTerm         | KwUnquote | KwUnquoteDecl | KwUnquoteDef         | KwSyntax         | KwPatternSyn | KwTactic | KwCATCHALL+        | KwVariable         | KwNO_POSITIVITY_CHECK | KwPOLARITY+        | KwNO_UNIVERSE_CHECK     deriving (Eq, Show) +-- | Unconditional layout keywords.+--+-- Some keywords introduce layout only in certain circumstances,+-- these are not included here.+-- layoutKeywords :: [Keyword] layoutKeywords =-    [ KwLet, KwWhere, KwPostulate, KwMutual, KwAbstract, KwPrivate, KwInstance, KwMacro, KwPrimitive, KwField ]+    [ KwAbstract+    , KwDo+    , KwField+    , KwInstance+    , KwLet+    , KwMacro+    , KwMutual+    , KwPostulate+    , KwPrimitive+    , KwPrivate+    , KwVariable+    , KwWhere+    , KwOpaque+    ]  data Symbol         = SymDot | SymSemi | SymVirtualSemi | SymBar         | SymColon | SymArrow | SymEqual | SymLambda         | SymUnderscore | SymQuestionMark   | SymAs         | SymOpenParen        | SymCloseParen-        | SymOpenIdiomBracket | SymCloseIdiomBracket+        | SymOpenIdiomBracket | SymCloseIdiomBracket | SymEmptyIdiomBracket         | SymDoubleOpenBrace  | SymDoubleCloseBrace         | SymOpenBrace        | SymCloseBrace         | SymOpenVirtualBrace | SymCloseVirtualBrace@@ -59,17 +88,18 @@                         -- Non-empty namespace. The intervals for                         -- "A.B.x" correspond to "A.", "B." and "x".           -- Literals-        | TokLiteral    Literal+        | TokLiteral    RLiteral           -- Special symbols         | TokSymbol Symbol Interval           -- Other tokens-        | TokString (Interval, String)  -- arbitrary string, used in pragmas-        | TokSetN (Interval, Integer)+        | TokString (Interval, String)+            -- ^ Arbitrary string (not enclosed in double quotes), used in pragmas.         | TokTeX (Interval, String)+        | TokMarkup (Interval, String)         | TokComment (Interval, String)         | TokDummy      -- Dummy token to make Happy not complain                         -- about overlapping cases.-        | TokEOF+        | TokEOF Interval     deriving (Eq, Show)  instance HasRange Token where@@ -79,8 +109,11 @@   getRange (TokLiteral lit)    = getRange lit   getRange (TokSymbol _ i)     = getRange i   getRange (TokString (i, _))  = getRange i-  getRange (TokSetN (i, _))    = getRange i   getRange (TokTeX (i, _))     = getRange i+  getRange (TokMarkup (i, _))  = getRange i   getRange (TokComment (i, _)) = getRange i   getRange TokDummy            = noRange-  getRange TokEOF              = noRange+  getRange (TokEOF i)          = getRange i++instance HasRangeWithoutFile Token where+  getRangeWithoutFile = void . getRange
src/full/Agda/Syntax/Position.hs view
@@ -1,13 +1,5 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE ScopedTypeVariables        #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE UndecidableInstances #-} -- Due to KILLRANGE vararg typeclass  {-| Position information for syntax. Crucial for giving good error messages. -}@@ -18,35 +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-  , takeI-  , dropI   , getIntervalFile   , iLength   , fuseIntervals-  , setIntervalFile      -- * Ranges   , Range+  , RangeWithoutFile   , Range'(..)   , rangeInvariant   , consecutiveAndSeparated   , intervalsToRange   , intervalToRange+  , rangeFromAbsolutePath   , rangeIntervals   , rangeFile+  , rangeModule'+  , rangeModule   , rightMargin   , noRange   , posToRange, posToRange'@@ -58,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@@ -73,36 +69,41 @@   , interleaveRanges   ) where -import Prelude hiding (null)+import Prelude hiding ( null ) -import Control.Applicative hiding (empty)+import Control.DeepSeq import Control.Monad-import Control.Monad.Writer (runWriter, Writer, tell)+import Control.Monad.Writer (runWriter, tell) -import Data.Foldable (Foldable) 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.Traversable (Traversable)-import Data.Typeable (Typeable) 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)+import Agda.Utils.List2 (List2) import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Permutation+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.TypeLevel (IsBase, All, Domains)+import Agda.Utils.Tuple (sortPair) -#include "undefined.h" import Agda.Utils.Impossible  {--------------------------------------------------------------------------@@ -121,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 (Typeable, 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@@ -143,49 +144,99 @@ 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' () +instance NFData Position where+  rnf = (`seq` ())++instance NFData PositionWithoutFile where+  rnf = (`seq` ())+ -- | 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 (Typeable, 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' () -intervalInvariant :: Ord a => Interval' a -> Bool-intervalInvariant i =-  all positionInvariant [iStart i, iEnd i]-    &&-  iStart i <= iEnd i-    &&-  srcFile (iStart i) == srcFile (iEnd i)+instance NFData Interval where+  rnf = (`seq` ()) --- | Sets the 'srcFile' components of the interval.+instance NFData IntervalWithoutFile where+  rnf = (`seq` ()) -setIntervalFile :: a -> Interval' b -> Interval' a-setIntervalFile f (Interval p1 p2) =-  Interval (p1 { srcFile = f }) (p2 { srcFile = f })+intervalInvariant :: Ord a => Interval' a -> Bool+intervalInvariant i = and+  [ positionInvariant $ iStart i+  , positionInvariant $ iEnd i+  , iStart i <= iEnd i+  ] --- | Gets the 'srcFile' component of the interval. Because of the invariant,---   they are both the same.-getIntervalFile :: Interval' a -> a-getIntervalFile = srcFile . iStart+iStart :: Interval' a -> Position' a+iStart (Interval f s _) = f <$ s +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@@ -197,16 +248,30 @@   = NoRange   | Range !a (Seq IntervalWithoutFile)   deriving-    (Typeable, 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)+ instance Null (Range' a) where   null NoRange = True   null Range{} = False    empty = NoRange +instance Eq a => Semigroup (Range' a) where+  NoRange <> r = r+  r <> NoRange = r+  Range f is <> Range f' is'+    | f /= f'   = __IMPOSSIBLE__+    | otherwise = Range f (is <> is')++instance Eq a => Monoid (Range' a) where+  mempty  = empty+  mappend = (<>)+ -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile]@@ -228,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@@ -247,37 +309,71 @@ 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   deriving (Eq, Ord, HasRange, SetRange, KillRange)  -- | Things that have a range are instances of this class.-class HasRange t where-    getRange :: t -> Range+class HasRange a where+  getRange :: a -> Range +  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 +instance HasRange () where+  getRange _ = noRange+ 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] where-    getRange = foldr fuseRange noRange+instance HasRange a => HasRange [a] +-- | Precondition: The ranges of the list elements must point to the+-- same file (or be empty).+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). instance (HasRange a, HasRange b) => HasRange (a,b) where@@ -308,158 +404,101 @@ instance (HasRange a, HasRange b, HasRange c, HasRange d, HasRange e, HasRange f, HasRange g) => HasRange (a,b,c,d,e,f,g) where     getRange (x,y,z,w,v,u,t) = getRange (x,(y,(z,(w,(v,(u,t)))))) -instance HasRange a => HasRange (Maybe a) where-    getRange Nothing  = noRange-    getRange (Just a) = getRange a- instance (HasRange a, HasRange b) => HasRange (Either a b) where     getRange = either getRange getRange --- | If it is also possible to set the range, this is the class.------   Instances should satisfy @'getRange' ('setRange' r x) == r@.-class HasRange t => SetRange t where-  setRange :: Range -> t -> t+-- | Things that have a 'RangeWithoutFile' are instances of this class. -instance SetRange Range where-  setRange = const+class HasRangeWithoutFile a where+  getRangeWithoutFile :: a -> RangeWithoutFile -instance SetRange a => SetRange [a] where-  setRange r = fmap $ setRange r+  default getRangeWithoutFile :: (Foldable t, HasRangeWithoutFile b, t b ~ a) => a -> RangeWithoutFile+  getRangeWithoutFile = Fold.foldr fuseRangeWithoutFile noRange+  {-# INLINABLE getRangeWithoutFile #-} --- | Killing the range of an object sets all range information to 'noRange'.-class KillRange a where-  killRange :: KillRangeT a+instance HasRangeWithoutFile IntervalWithoutFile where+  getRangeWithoutFile = intervalToRange () -type KillRangeT a = a -> a+instance HasRangeWithoutFile RangeWithoutFile where+    getRangeWithoutFile = id --- | 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 HasRangeWithoutFile () where+  getRangeWithoutFile _ = noRange -killRange1 :: KillRange a => (a -> b) -> a -> b+instance HasRangeWithoutFile Bool where+    getRangeWithoutFile _ = noRange -killRange2 :: (KillRange a, KillRange b) => (a -> b -> c) -> a -> b -> c+-- UNUSED:+-- instance HasRangeWithoutFile (TopLevelModuleName' RangeWithoutFile) where+--   getRangeWithoutFile = moduleNameRange -killRange3 :: (KillRange a, KillRange b, KillRange c) =>-              (a -> b -> c -> d) -> a -> b -> c -> d+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) -killRange4 :: (KillRange a, KillRange b, KillRange c, KillRange d) =>-              (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e+instance (HasRangeWithoutFile a, HasRangeWithoutFile b) => HasRangeWithoutFile (a,b) where+    getRangeWithoutFile = uncurry fuseRangeWithoutFile -killRange5 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e ) =>-              (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f+instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c) => HasRangeWithoutFile (a,b,c) where+    getRangeWithoutFile (x,y,z) = getRangeWithoutFile (x,(y,z)) -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+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))) -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+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)))) -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+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))))) -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+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)))))) -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+instance (HasRangeWithoutFile a, HasRangeWithoutFile b) => HasRangeWithoutFile (Either a b) where+    getRangeWithoutFile = either getRangeWithoutFile getRangeWithoutFile -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+-- | If it is also possible to set the range, this is the class.+--+--   Instances should satisfy @'getRange' ('setRange' r x) == r@.+class HasRange a => SetRange a where+  setRange :: Range -> a -> a -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+  default setRange :: (Functor f, SetRange b, f b ~ a) => Range -> a -> a+  setRange = fmap . setRange -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+instance SetRange Range where+  setRange = const -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+instance SetRange a => SetRange [a]+instance SetRange a => SetRange (Maybe a) -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+-- | Killing the range of an object sets all range information to 'noRange'.+class KillRange a where+  killRange :: KillRangeT a -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+  default killRange :: (Functor f, KillRange b, f b ~ a) => KillRangeT a+  killRange = fmap killRange -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+type KillRangeT a = a -> a -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+class KILLRANGE t b where+  killRangeN :: IsBase t ~ b => All KillRange (Domains t) =>+                t -> t -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 IsBase t ~ 'True => KILLRANGE t 'True where+  {-# INLINE killRangeN #-}+  killRangeN v = v -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)+instance KILLRANGE t (IsBase t) => KILLRANGE (a -> t) 'False where+  {-# INLINE killRangeN #-}+  killRangeN f a = killRangeN (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 @@ -478,145 +517,43 @@ instance KillRange Integer where   killRange = id -#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] where-#else-instance KillRange a => KillRange [a] where-#endif-  killRange = map killRange+instance KillRange Permutation where+  killRange = id  -- | Overlaps with @KillRange [a]@.-#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} KillRange String where-#else-instance KillRange String where-#endif   killRange = id -#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) where-#else-instance KillRange a => KillRange (Map k a) where-#endif-  killRange = fmap killRange+instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a]+instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) -#if __GLASGOW_HASKELL__ >= 710+instance KillRange a => KillRange (Drop a)+instance KillRange a => KillRange (List1 a)+instance KillRange a => KillRange (List2 a)+instance KillRange a => KillRange (Maybe a)+instance KillRange a => KillRange (Strict.Maybe a)+ instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where-#else-instance (Ord a, KillRange a) => KillRange (Set a) where-#endif   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--instance KillRange a => KillRange (Maybe a) where-  killRange = fmap killRange+  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 ---------------------------------------------------------------------------- Showing----------------------------------------------------------------------------- TODO: 'Show' should output Haskell-parseable representations.--- The following instances are deprecated, and Pretty should be used--- instead.  Later, simply derive Show for these types.---- ASR (02 December 2014). This instance is not used anymore (module--- the test suite) when reporting errors. See Issue 1293.-instance Show a => Show (Position' (Strict.Maybe a)) where-  show (Pn (Strict.Just f) _ l c) = show f ++ ":" ++-                                    show l ++ "," ++ show c-  show (Pn Strict.Nothing  _ l c) = show l ++ "," ++ show c--instance Show PositionWithoutFile where-  show p = show (p { srcFile = Strict.Nothing } :: Position)--instance Show IntervalWithoutFile where-  show (Interval s e) = start ++ "-" ++ end-    where-      sl = posLine s-      el = posLine e-      sc = posCol s-      ec = posCol e--      start :: String-      start = show sl ++ "," ++ show sc--      end :: String-      end | sl == el  = show ec-          | otherwise = show el ++ "," ++ show ec--instance Show a => Show (Interval' (Strict.Maybe a)) where-  show i@(Interval s _) = file ++ show (setIntervalFile () i)-    where-      file :: String-      file = case srcFile s of-               Strict.Nothing -> ""-               Strict.Just f  -> show f ++ ":"--instance Show a => Show (Range' (Strict.Maybe a)) where-  show r = case rangeToIntervalWithFile r of-    Nothing -> ""-    Just i  -> show i--instance Show a => Show (Range' (Maybe a)) where-  show = show . fmap Strict.toStrict----------------------------------------------------------------------------- Printing---------------------------------------------------------------------------instance Pretty a => Pretty (Position' (Strict.Maybe a)) where-  pretty (Pn Strict.Nothing  _ l c) = pretty l <> pretty "," <> pretty c-  pretty (Pn (Strict.Just f) _ l c) =-    pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c--instance Pretty PositionWithoutFile where-  pretty p = pretty (p { srcFile = Strict.Nothing } :: Position)--instance Pretty IntervalWithoutFile where-  pretty (Interval s e) = start <> pretty "-" <> 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 = case rangeToIntervalWithFile r of-    Nothing -> empty-    Just i  -> pretty i--instance (Pretty a, HasRange a) => Pretty (PrintRange a) where-  pretty (PrintRange a) = pretty a <+> parens (text "at" <+> pretty (getRange a))- {--------------------------------------------------------------------------     Functions on positions and ranges  --------------------------------------------------------------------------}@@ -631,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@@ -649,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. --@@ -658,23 +602,6 @@ backupPos :: Position' a -> Position' a backupPos (Pn f p l c) = Pn f (p - 1) l (c - 1) --- | Extracts the interval corresponding to the given string, assuming--- that the string starts at the beginning of the given interval.------ Precondition: The string must not be too long for the interval.-takeI :: String -> Interval' a -> Interval' a-takeI s i | genericLength s > iLength i = __IMPOSSIBLE__-          | otherwise = i { iEnd = movePosByString (iStart i) s }---- | Removes the interval corresponding to the given string from the--- given interval, assuming that the string starts at the beginning of--- the interval.------ Precondition: The string must not be too long for the interval.-dropI :: String -> Interval' a -> Interval' a-dropI s i | genericLength s > iLength i = __IMPOSSIBLE__-          | otherwise = i { iStart = movePosByString (iStart i) s }- -- | Converts a file name and two positions to a range. posToRange' ::   a -> PositionWithoutFile -> PositionWithoutFile -> Range' a@@ -694,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@@ -753,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 = head ss, iEnd = last es }-    where-    ss = sort [iStart x, iStart y]-    es = 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'@. --@@ -789,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.@@ -802,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.@@ -816,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@@ -835,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@@ -860,4 +796,3 @@           (a:) <$> go as' bs         else           (b:) <$> go as bs'-
+ src/full/Agda/Syntax/Position.hs-boot view
@@ -0,0 +1,3 @@+module Agda.Syntax.Position where++class KillRange a
src/full/Agda/Syntax/Reflected.hs view
@@ -2,10 +2,16 @@  module Agda.Syntax.Reflected where +import Data.Text (Text)+ import Agda.Syntax.Common import Agda.Syntax.Literal import Agda.Syntax.Abstract.Name+import Agda.Syntax.Internal (Dom) +import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+ type Args       = [Arg Term]  data Elim' a = Apply (Arg a) -- no record projections for now@@ -24,7 +30,7 @@           | Def QName Elims           | Meta MetaId Elims           | Lam Hiding (Abs Term)-          | ExtLam [Clause] Elims+          | ExtLam (List1 Clause) Elims           | Pi (Dom Type) (Abs Type)           | Sort Sort           | Lit Literal@@ -35,18 +41,30 @@  data Sort = SetS Term           | LitS Integer+          | PropS Term+          | PropLitS Integer+          | InfS Integer           | UnknownS   deriving (Show)  data Pattern = ConP QName [Arg Pattern]-             | DotP-             | VarP String+             | DotP Term+             | VarP Int              | LitP Literal-             | AbsurdP+             | AbsurdP Int              | ProjP QName   deriving (Show) -data Clause = Clause [Arg Pattern] Term | AbsurdClause [Arg Pattern]+data Clause+  = Clause+    { clauseTel  :: [(Text, Arg Type)]+    , clausePats :: [Arg Pattern]+    , clauseRHS  :: Term+    }+  | AbsurdClause+    { clauseTel  :: [(Text, Arg Type)]+    , clausePats :: [Arg Pattern]+    }   deriving (Show)  data Definition = FunDef Type [Clause]
src/full/Agda/Syntax/Scope/Base.hs view
@@ -1,989 +1,1517 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-| This module defines the notion of a scope and operations on scopes.--}-module Agda.Syntax.Scope.Base where--import Control.Arrow (first, second, (***))-import Control.Applicative-import Control.DeepSeq-import Control.Monad--import Data.Either (partitionEithers)-import Data.Function-import Data.List as List-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.Typeable (Typeable)---- import Debug.Trace (trace)--import Agda.Benchmarking--import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Abstract.Name as A-import Agda.Syntax.Concrete.Name as C-import qualified Agda.Syntax.Concrete as C--import Agda.Utils.AssocList (AssocList)-import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Pretty-import qualified Agda.Utils.Map as Map--#include "undefined.h"-import Agda.Utils.Impossible---- * Scope representation---- | A scope is a named collection of names partitioned into public and private---   names.-data Scope = Scope-      { scopeName           :: A.ModuleName-      , scopeParents        :: [A.ModuleName]-      , scopeNameSpaces     :: ScopeNameSpaces-      , scopeImports        :: Map C.QName A.ModuleName-      , scopeDatatypeModule :: Bool-      }-  deriving (Typeable, Eq)---- | 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.-  | OnlyQualifiedNS  -- ^ Visible (as qualified) from outside,-                     --   but not exported when opening the module.-                     --   Used for qualified constructors.-  deriving (Typeable, Eq, Bounded, Enum)--type ScopeNameSpaces = [(NameSpaceId, NameSpace)]--localNameSpace :: Access -> NameSpaceId-localNameSpace PublicAccess    = PublicNS-localNameSpace PrivateAccess{} = PrivateNS-localNameSpace OnlyQualified   = OnlyQualifiedNS--nameSpaceAccess :: NameSpaceId -> Access-nameSpaceAccess PrivateNS = PrivateAccess Inserted-nameSpaceAccess _         = PublicAccess---- | Get a 'NameSpace' from 'Scope'.-scopeNameSpace :: NameSpaceId -> Scope -> NameSpace-scopeNameSpace ns = fromMaybe __IMPOSSIBLE__ . lookup ns . scopeNameSpaces---- | A lens for 'scopeNameSpaces'-updateScopeNameSpaces :: (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope-updateScopeNameSpaces f s = s { scopeNameSpaces = f (scopeNameSpaces s) }---- | ``Monadic'' lens (Functor sufficient).-updateScopeNameSpacesM ::-  (Functor m) => (ScopeNameSpaces -> m ScopeNameSpaces) -> Scope -> m Scope-updateScopeNameSpacesM f s = for (f $ scopeNameSpaces s) $ \ x ->-  s { scopeNameSpaces = x }---- | The complete information about the scope at a particular program point---   includes the scope stack, the local variables, and the context precedence.-data ScopeInfo = ScopeInfo-      { scopeCurrent       :: A.ModuleName-      , scopeModules       :: Map A.ModuleName Scope-      , scopeLocals        :: LocalVars-      , scopePrecedence    :: Precedence-      , scopeInverseName   :: Map A.QName [C.QName]-      , scopeInverseModule :: Map A.ModuleName [C.QName]-      , scopeInScope       :: InScopeSet-      }-  deriving Typeable--instance Eq ScopeInfo where-  ScopeInfo c1 m1 l1 p1 _ _ _ == ScopeInfo c2 m2 l2 p2 _ _ _ =-    c1 == c2 && m1 == m2 && l1 == l2 && p1 == p2---- | Local variables.-type LocalVars = AssocList C.Name LocalVar---- | A local variable can be shadowed by an import.---   In case of reference to a shadowed variable, we want to report---   a scope error.-data LocalVar-  = LocalVar    { localVar :: A.Name }-    -- ^ Unique ID of local variable.-  | ShadowedVar { localVar :: A.Name, localShadowedBy :: [AbstractName] }-    -- ^ This local variable is shadowed by one or more imports.-    --   (List not empty).-  deriving (Typeable)--instance Eq LocalVar where-  (==) = (==) `on` localVar--instance Ord LocalVar where-  compare = compare `on` localVar---- | We show shadowed variables as prefixed by a ".", as not in scope.-instance Show LocalVar where-  show (LocalVar    x)    = show x-  show (ShadowedVar x xs) = "." ++ show x---- | Shadow a local name by a non-empty list of imports.-shadowLocal :: [AbstractName] -> LocalVar -> LocalVar-shadowLocal [] _ = __IMPOSSIBLE__-shadowLocal ys (LocalVar    x   ) = ShadowedVar x ys-shadowLocal ys (ShadowedVar x zs) = ShadowedVar x (ys ++ zs)---- | Project name of unshadowed local variable.-notShadowedLocal :: LocalVar -> Maybe A.Name-notShadowedLocal (LocalVar x) = Just x-notShadowedLocal ShadowedVar{} = Nothing---- | Get all locals that are not shadowed __by imports__.-notShadowedLocals :: LocalVars -> AssocList C.Name A.Name-notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x---- | Lens for 'scopeLocals'.-updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo-updateScopeLocals f sc = sc { scopeLocals = f (scopeLocals sc) }--setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo-setScopeLocals vars = updateScopeLocals (const vars)--mapScopeInfo :: (Scope -> Scope) -> ScopeInfo -> ScopeInfo-mapScopeInfo f i = i{ scopeModules = f <$> scopeModules i }----------------------------------------------------------------------------- * Name spaces------ Map concrete names to lists of abstract names.----------------------------------------------------------------------------- | A @NameSpace@ contains the mappings from concrete names that the user can---   write to the abstract fully qualified names that the type checker wants to---   read.-data NameSpace = NameSpace-      { nsNames   :: NamesInScope-        -- ^ Maps concrete names to a list of abstract names.-      , nsModules :: ModulesInScope-        -- ^ Maps concrete module names to a list of abstract module names.-      , nsInScope :: InScopeSet-      }-  deriving (Typeable, Eq)--type ThingsInScope a = Map C.Name [a]-type NamesInScope    = ThingsInScope AbstractName-type ModulesInScope  = ThingsInScope AbstractModule-type InScopeSet      = Set A.QName---- | Set of types consisting of exactly 'AbstractName' and 'AbstractModule'.------   A GADT just for some dependent-types trickery.-data InScopeTag a where-  NameTag   :: InScopeTag AbstractName-  ModuleTag :: InScopeTag AbstractModule---- | Type class for some dependent-types trickery.-class Eq a => InScope a where-  inScopeTag :: InScopeTag a--instance InScope AbstractName where-  inScopeTag = NameTag--instance InScope AbstractModule where-  inScopeTag = ModuleTag---- | @inNameSpace@ selects either the name map or the module name map from---   a 'NameSpace'.  What is selected is determined by result type---   (using the dependent-type trickery).-inNameSpace :: forall a. InScope a => NameSpace -> ThingsInScope a-inNameSpace = case inScopeTag :: InScopeTag a of-  NameTag   -> nsNames-  ModuleTag -> nsModules----------------------------------------------------------------------------- * Decorated names------ - What kind of name? (defined, constructor...)--- - Where does the name come from? (to explain to user)----------------------------------------------------------------------------- | For the sake of parsing left-hand sides, we distinguish---   constructor and record field names from defined names.-data KindOfName-  = ConName        -- ^ Constructor name.-  | FldName        -- ^ Record field name.-  | DefName        -- ^ Ordinary defined name.-  | PatternSynName -- ^ Name of a pattern synonym.-  | MacroName      -- ^ Name of a macro-  | QuotableName   -- ^ A name that can only be quoted.-  deriving (Eq, Show, Typeable, Enum, Bounded)---- | A list containing all name kinds.-allKindsOfNames :: [KindOfName]-allKindsOfNames = [minBound..maxBound]---- | Where does a name come from?------   This information is solely for reporting to the user,---   see 'Agda.Interaction.InteractionTop.whyInScope'.-data WhyInScope-  = Defined-    -- ^ Defined in this module.-  | Opened C.QName WhyInScope-    -- ^ Imported from another module.-  | Applied C.QName WhyInScope-    -- ^ Imported by a module application.-  deriving (Typeable)---- | A decoration of 'Agda.Syntax.Abstract.Name.QName'.-data AbstractName = AbsName-  { anameName    :: A.QName-    -- ^ The resolved qualified name.-  , anameKind    :: KindOfName-    -- ^ The kind (definition, constructor, record field etc.).-  , anameLineage :: WhyInScope-    -- ^ Explanation where this name came from.-  }-  deriving (Typeable)---- | A decoration of abstract syntax module names.-data AbstractModule = AbsModule-  { amodName    :: A.ModuleName-    -- ^ The resolved module name.-  , amodLineage :: WhyInScope-    -- ^ Explanation where this name came from.-  }-  deriving (Typeable)--instance Eq AbstractName where-  (==) = (==) `on` anameName--instance Ord AbstractName where-  compare = compare `on` anameName---- | Van Laarhoven lens on 'anameName'.-lensAnameName :: Functor m => (A.QName -> m A.QName) -> AbstractName -> m AbstractName-lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }--instance Eq AbstractModule where-  (==) = (==) `on` amodName--instance Ord AbstractModule where-  compare = compare `on` amodName---- | Van Laarhoven lens on 'amodName'.-lensAmodName :: Functor m => (A.ModuleName -> m A.ModuleName) -> AbstractModule -> m AbstractModule-lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }---- * Operations on name and module maps.--mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a-mergeNames = Map.unionWith union----------------------------------------------------------------------------- * Operations on name spaces----------------------------------------------------------------------------- | The empty name space.-emptyNameSpace :: NameSpace-emptyNameSpace = NameSpace Map.empty Map.empty Set.empty----- | Map functions over the names and modules in a name space.-mapNameSpace :: (NamesInScope   -> NamesInScope  ) ->-                (ModulesInScope -> ModulesInScope) ->-                (InScopeSet     -> InScopeSet    ) ->-                NameSpace -> NameSpace-mapNameSpace fd fm fs ns =-  ns { nsNames   = fd $ nsNames   ns-     , nsModules = fm $ nsModules ns-     , nsInScope = fs $ nsInScope ns-     }---- | Zip together two name spaces.-zipNameSpace :: (NamesInScope   -> NamesInScope   -> NamesInScope  ) ->-                (ModulesInScope -> ModulesInScope -> ModulesInScope) ->-                (InScopeSet     -> InScopeSet     -> InScopeSet    ) ->-                NameSpace -> NameSpace -> NameSpace-zipNameSpace fd fm fs ns1 ns2 =-  ns1 { nsNames   = nsNames   ns1 `fd` nsNames   ns2-      , nsModules = nsModules ns1 `fm` nsModules ns2-      , nsInScope = nsInScope ns1 `fs` nsInScope ns2-      }---- | Map monadic function over a namespace.-mapNameSpaceM :: Applicative m =>-  (NamesInScope   -> m NamesInScope  ) ->-  (ModulesInScope -> m ModulesInScope) ->-  (InScopeSet     -> m InScopeSet    ) ->-  NameSpace -> m NameSpace-mapNameSpaceM fd fm fs ns = update ns <$> fd (nsNames ns) <*> fm (nsModules ns) <*> fs (nsInScope ns)-  where-    update ns ds ms is = ns { nsNames = ds, nsModules = ms, nsInScope = is }----------------------------------------------------------------------------- * General operations on scopes----------------------------------------------------------------------------- | The empty scope.-emptyScope :: Scope-emptyScope = Scope-  { scopeName           = noModuleName-  , scopeParents        = []-  , scopeNameSpaces     = [ (nsid, emptyNameSpace) | nsid <- [minBound..maxBound] ]-  , scopeImports        = Map.empty-  , scopeDatatypeModule = False-  }---- | The empty scope info.-emptyScopeInfo :: ScopeInfo-emptyScopeInfo = ScopeInfo-  { scopeCurrent       = noModuleName-  , scopeModules       = Map.singleton noModuleName emptyScope-  , scopeLocals        = []-  , scopePrecedence    = TopCtx-  , scopeInverseName   = Map.empty-  , scopeInverseModule = Map.empty-  , scopeInScope       = Set.empty-  }---- | Map functions over the names and modules in a scope.-mapScope :: (NameSpaceId -> NamesInScope   -> NamesInScope  ) ->-            (NameSpaceId -> ModulesInScope -> ModulesInScope) ->-            (NameSpaceId -> InScopeSet    -> InScopeSet     ) ->-            Scope -> Scope-mapScope fd fm fs = updateScopeNameSpaces $ AssocList.mapWithKey mapNS-  where-    mapNS acc = mapNameSpace (fd acc) (fm acc) (fs acc)---- | Same as 'mapScope' but applies the same function to all name spaces.-mapScope_ :: (NamesInScope   -> NamesInScope  ) ->-             (ModulesInScope -> ModulesInScope) ->-             (InScopeSet     -> InScopeSet    ) ->-             Scope -> Scope-mapScope_ fd fm fs = mapScope (const fd) (const fm) (const fs)---- | Same as 'mapScope' but applies the function only on the given name space.-mapScope' :: NameSpaceId -> (NamesInScope   -> NamesInScope  ) ->-                            (ModulesInScope -> ModulesInScope) ->-                            (InScopeSet    -> InScopeSet     ) ->-                            Scope -> Scope-mapScope' i fd fm fs = mapScope (\ j -> if i == j then fd else id)-                                (\ j -> if i == j then fm else id)-                                (\ j -> if i == j then fs else id)---- | Map monadic functions over the names and modules in a scope.-mapScopeM :: Applicative m =>-  (NameSpaceId -> NamesInScope   -> m NamesInScope  ) ->-  (NameSpaceId -> ModulesInScope -> m ModulesInScope) ->-  (NameSpaceId -> InScopeSet     -> m InScopeSet    ) ->-  Scope -> m Scope-mapScopeM fd fm fs = updateScopeNameSpacesM $ AssocList.mapWithKeyM mapNS-  where-    mapNS acc = mapNameSpaceM (fd acc) (fm acc) (fs acc)---- | Same as 'mapScopeM' but applies the same function to both the public and---   private name spaces.-mapScopeM_ :: Applicative m =>-  (NamesInScope   -> m NamesInScope  ) ->-  (ModulesInScope -> m ModulesInScope) ->-  (InScopeSet     -> m InScopeSet    ) ->-  Scope -> m Scope-mapScopeM_ fd fm fs = mapScopeM (const fd) (const fm) (const fs)---- | Zip together two scopes. The resulting scope has the same name as the---   first scope.-zipScope :: (NameSpaceId -> NamesInScope   -> NamesInScope   -> NamesInScope  ) ->-            (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->-            (NameSpaceId -> InScopeSet     -> InScopeSet     -> InScopeSet    ) ->-            Scope -> Scope -> Scope-zipScope fd fm fs s1 s2 =-  s1 { scopeNameSpaces = [ (nsid, zipNS nsid ns1 ns2)-                         | ((nsid, ns1), (nsid', ns2)) <- zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2)-                         , assert (nsid == nsid')-                         ]-     , scopeImports  = Map.union (scopeImports s1) (scopeImports s2)-     }-  where-    assert True  = True-    assert False = __IMPOSSIBLE__-    zipNS acc = zipNameSpace (fd acc) (fm acc) (fs acc)---- | Same as 'zipScope' but applies the same function to both the public and---   private name spaces.-zipScope_ :: (NamesInScope   -> NamesInScope   -> NamesInScope  ) ->-             (ModulesInScope -> ModulesInScope -> ModulesInScope) ->-             (InScopeSet     -> InScopeSet     -> InScopeSet    ) ->-             Scope -> Scope -> Scope-zipScope_ fd fm fs = zipScope (const fd) (const fm) (const fs)---- | Recompute the inScope sets of a scope.-recomputeInScopeSets :: Scope -> Scope-recomputeInScopeSets = updateScopeNameSpaces (map $ second recomputeInScope)-  where-    recomputeInScope ns = ns { nsInScope = Set.unions $ map (Set.fromList . map anameName)-                                         $ Map.elems $ nsNames ns }---- | Filter a scope keeping only concrete names matching the predicates.---   The first predicate is applied to the names and the second to the modules.-filterScope :: (C.Name -> Bool) -> (C.Name -> Bool) -> Scope -> Scope-filterScope pd pm = recomputeInScopeSets .  mapScope_ (Map.filterKeys pd) (Map.filterKeys pm) id-  -- We don't have enough information in the in scope set to do an-  -- incremental update here, so just recompute it from the name map.---- | Return all names in a scope.-allNamesInScope :: InScope a => Scope -> ThingsInScope a-allNamesInScope = namesInScope [minBound..maxBound]--allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access)-allNamesInScope' s =-  foldr1 mergeNames [ map (, nameSpaceAccess ns) <$> namesInScope [ns] s-                    | ns <- [minBound..maxBound] ]---- | Returns the scope's non-private names.-exportedNamesInScope :: InScope a => Scope -> ThingsInScope a-exportedNamesInScope = namesInScope [PublicNS, ImportedNS, OnlyQualifiedNS]--namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a-namesInScope ids s =-  foldr1 mergeNames [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ]--allThingsInScope :: Scope -> NameSpace-allThingsInScope = thingsInScope [minBound..maxBound]--thingsInScope :: [NameSpaceId] -> Scope -> NameSpace-thingsInScope fs s =-  NameSpace { nsNames   = namesInScope fs s-            , nsModules = namesInScope fs s-            , nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ]-            }---- | Merge two scopes. The result has the name of the first scope.-mergeScope :: Scope -> Scope -> Scope-mergeScope = zipScope_ mergeNames mergeNames Set.union---- | Merge a non-empty list of scopes. The result has the name of the first---   scope in the list.-mergeScopes :: [Scope] -> Scope-mergeScopes [] = __IMPOSSIBLE__-mergeScopes ss = foldr1 mergeScope ss---- * Specific operations on scopes---- | Move all names in a scope to the given name space (except never move from---   Imported to Public).-setScopeAccess :: NameSpaceId -> Scope -> Scope-setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns-  where-    zero  = emptyNameSpace-    one   = allThingsInScope s-    imp   = thingsInScope [ImportedNS] s-    noimp = thingsInScope [PublicNS, PrivateNS, OnlyQualifiedNS] s--    ns b = case (a, b) of-      (PublicNS, PublicNS)   -> noimp-      (PublicNS, ImportedNS) -> imp-      _ | a == b             -> one-        | otherwise          -> zero---- | Update a particular name space.-setNameSpace :: NameSpaceId -> NameSpace -> Scope -> Scope-setNameSpace nsid ns = modifyNameSpace nsid $ const ns---- | Modify a particular name space.-modifyNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> Scope -> Scope-modifyNameSpace nsid f = updateScopeNameSpaces $ AssocList.updateAt nsid f---- | Add names to a scope.-addNamesToScope :: NameSpaceId -> C.Name -> [AbstractName] -> Scope -> Scope-addNamesToScope acc x ys s = mergeScope s s1-  where-    s1 = setScopeAccess acc $ setNameSpace PublicNS ns emptyScope-    ns = emptyNameSpace { nsNames   = Map.singleton x ys-                        , nsInScope = Set.fromList (map anameName ys) }---- | Add a name to a scope.-addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope-addNameToScope acc x y s = addNamesToScope acc x [y] s---- | Remove a name from a scope. Caution: does not update the nsInScope set.---   This is only used by rebindName and in that case we add the name right---   back (but with a different kind).-removeNameFromScope :: NameSpaceId -> C.Name -> Scope -> Scope-removeNameFromScope ns x s = mapScope remove (const id) (const id) s-  where-    remove ns' | ns' /= ns = id-               | otherwise = Map.delete x---- | Add a module to a scope.-addModuleToScope :: NameSpaceId -> C.Name -> AbstractModule -> Scope -> Scope-addModuleToScope acc x m s = mergeScope s s1-  where-    s1 = setScopeAccess acc $ setNameSpace PublicNS ns emptyScope-    ns = emptyNameSpace { nsModules = Map.singleton x [m] }---- When we get here we cannot have both using and hiding-type UsingOrHiding = Either C.Using [C.ImportedName]--usingOrHiding :: C.ImportDirective -> UsingOrHiding-usingOrHiding i =-  case (using i, hiding i) of-    (UseEverything, xs) -> Right xs-    (u, [])             -> Left u-    _                   -> __IMPOSSIBLE__---- | Apply an 'ImportDirective' to a scope.-applyImportDirective :: C.ImportDirective -> Scope -> Scope-applyImportDirective dir s = mergeScope usedOrHidden renamed-  where-    usedOrHidden = useOrHide (hideLHS (impRenaming dir) $ usingOrHiding dir) s-    renamed      = rename (impRenaming dir) $ useOrHide useRenamedThings s--    useRenamedThings = Left $ Using $ map renFrom $ impRenaming dir--    hideLHS :: [C.Renaming] -> UsingOrHiding -> UsingOrHiding-    hideLHS _   i@(Left _) = i-    hideLHS ren (Right xs) = Right $ xs ++ map renFrom ren--    useOrHide :: UsingOrHiding -> Scope -> Scope-    useOrHide (Right xs)        s = filterNames notElem notElem xs s-    useOrHide (Left (Using xs)) s = filterNames elem    elem    xs s-    useOrHide _                 _ = __IMPOSSIBLE__--    filterNames :: (C.Name -> [C.Name] -> Bool) ->-                   (C.Name -> [C.Name] -> Bool) ->-                   [C.ImportedName] -> Scope -> Scope-    filterNames pd pm xs = filterScope (`pd` ds) (`pm` ms)-      where-        ds = [ x | ImportedName   x <- xs ]-        ms = [ m | ImportedModule m <- xs ]--    -- Renaming-    rename :: [C.Renaming] -> Scope -> Scope-    rename rho = mapScope_ (Map.mapKeys $ ren drho)-                           (Map.mapKeys $ ren mrho)-                           id-      where-        (drho, mrho) = partitionEithers $ for rho $ \case-          Renaming (ImportedName   x) (ImportedName   y) _ -> Left  (x,y)-          Renaming (ImportedModule x) (ImportedModule y) _ -> Right (x,y)-          _ -> __IMPOSSIBLE__--        ren r x = fromMaybe x $ lookup x r---- | Rename the abstract names in a scope.-renameCanonicalNames :: Map A.QName A.QName -> Map A.ModuleName A.ModuleName ->-                        Scope -> Scope-renameCanonicalNames renD renM = mapScope_ renameD renameM (Set.map newName)-  where-    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---- | Remove private name space of a scope.------   Should be a right identity for 'exportedNamesInScope'.---   @exportedNamesInScope . restrictPrivate == exportedNamesInScope@.-restrictPrivate :: Scope -> Scope-restrictPrivate s = setNameSpace PrivateNS emptyNameSpace-                  $ s { scopeImports = Map.empty }---- | Remove private things from the given module from a scope.-restrictLocalPrivate :: ModuleName -> Scope -> Scope-restrictLocalPrivate m = mapScope' PrivateNS (Map.mapMaybe rName) (Map.mapMaybe rMod)-                                             (Set.filter (not . (`isInModule` m)))-  where-    check p x = x <$ guard (p x)-    rName as = check (not . null) $ filter (not . (`isInModule`    m) . anameName) as-    rMod  as = check (not . null) $ filter (not . (`isSubModuleOf` m) . amodName)  as---- | Remove names that can only be used qualified (when opening a scope)-removeOnlyQualified :: Scope -> Scope-removeOnlyQualified s = setNameSpace OnlyQualifiedNS emptyNameSpace s---- | Add an explanation to why things are in scope.-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  }---- | Get the public parts of the public modules of a scope-publicModules :: ScopeInfo -> Map A.ModuleName Scope-publicModules scope = Map.filterWithKey (\ m _ -> reachable m) allMods-  where-    -- Get all modules in the ScopeInfo.-    allMods   = Map.map restrictPrivate $ scopeModules scope-    root      = scopeCurrent scope--    modules s = map amodName $ concat $ Map.elems $ allNamesInScope s--    chase m = m : concatMap chase ms-      where ms = maybe __IMPOSSIBLE__ modules $ Map.lookup m allMods--    reachable = (`elem` chase root)--publicNames :: ScopeInfo -> Set AbstractName-publicNames scope =-  Set.fromList $ concat $ Map.elems $-  exportedNamesInScope $ mergeScopes $ Map.elems $ publicModules scope--everythingInScope :: ScopeInfo -> NameSpace-everythingInScope scope = allThingsInScope $ mergeScopes $-    (s0 :) $ map look $ scopeParents s0-  where-    look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope-    s0     = look $ scopeCurrent scope---- | 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 $ scopeCurrent scope-    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 $ 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 $ scopeModules scope---- | Get all concrete names in scope. Includes bound variables.-concreteNamesInScope :: ScopeInfo -> Set C.QName-concreteNamesInScope scope =-  Set.unions [ build allNamesInScope root, imported, locals ]-  where-    current = moduleScope $ scopeCurrent scope-    root    = mergeScopes $ current : map moduleScope (scopeParents current)--    locals  = Set.fromList [ C.QName x | (x, _) <- scopeLocals scope ]--    imported = Set.unions-               [ qual c (build exportedNamesInScope $ moduleScope a)-               | (c, a) <- Map.toList $ scopeImports root ]-    qual c = Set.map (q c)-      where-        q (C.QName x)  = C.Qual x-        q (C.Qual m x) = C.Qual m . q 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 ]--    moduleScope :: A.ModuleName -> Scope-    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope---- | Look up a name in the scope-scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a]-scopeLookup q scope = map fst $ scopeLookup' q scope--scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]-scopeLookup' q scope = nubBy ((==) `on` fst) $ findName q root ++ maybeToList topImports ++ imports-  where--    -- 1. Finding a name in the current scope and its parents.--    moduleScope :: A.ModuleName -> Scope-    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope--    current :: Scope-    current = moduleScope $ scopeCurrent scope--    root    :: Scope-    root    = mergeScopes $ current : map moduleScope (scopeParents current)--    -- | 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.Qual x q -> do-        let -- | Get the modules named @x@ in scope @s@.-            mods :: [A.ModuleName]-            mods = amodName . fst <$> lookupName 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]-            defs = mnameFromList . qnameToList . anameName . fst <$> lookupName 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-        -- if we just consider the modules:-        m <- mods-        -- The feature is on if we consider also the data and record types:-        -- trace ("mods ++ defs = " ++ show (mods ++ defs)) $ do-        -- m <- nub $ mods ++ defs -- record types will appear both as a mod and a def-        -- Get the scope of module m, if any, and remove its private definitions.-        let ss  = Map.lookup m $ scopeModules scope-            ss' = restrictPrivate <$> ss-        -- trace ("ss  = " ++ show ss ) $ do-        -- 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-  = AmbiguousAnything-      -- ^ Used for instance arguments to check whether a name is in scope,-      --   but we do not care whether is is ambiguous-  | AmbiguousConProjs-      -- ^ Ambiguous constructors or projections.-  | AmbiguousNothing-  deriving (Eq)--isNameInScope :: A.QName -> ScopeInfo -> Bool-isNameInScope q scope =-  billToPure [ Scoping, InverseScopeLookup ] $-  Set.member q (scopeInScope scope)---- | Find the concrete names that map (uniquely) to a given abstract name.---   Sort by length, shortest first.--inverseScopeLookup :: Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookup = inverseScopeLookup' AmbiguousConProjs--inverseScopeLookup' :: AllowAmbiguousNames -> Either A.ModuleName A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookup' amb name scope = billToPure [ Scoping , InverseScopeLookup ] $-  -- trace ("importMap = " ++ show importMap) $-  -- trace ("moduleMap = " ++ show moduleMap) $-  case name of-    Left  m -> best $ filter unambiguousModule $ findModule m-    Right q -> best $ filter unambiguousName   $ findName q-  where-    findName   x = fromMaybe [] $ Map.lookup x (scopeInverseName scope)-    findModule x = fromMaybe [] $ Map.lookup x (scopeInverseModule scope)--    len :: C.QName -> Int-    len (C.QName _)  = 1-    len (C.Qual _ x) = 1 + len x--    best :: [C.QName] -> [C.QName]-    best = sortBy (compare `on` len)--    unique :: forall a . [a] -> Bool-    unique []      = __IMPOSSIBLE__-    unique [_]     = True-    unique (_:_:_) = False--    unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule])-    unambiguousName   q = amb == AmbiguousAnything-        || unique xs-        || amb == AmbiguousConProjs-           && (all ((ConName ==) . anameKind) xs-            || all ((FldName ==) . anameKind) xs)-      where xs = scopeLookup q scope--recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo-recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $-  scope { scopeInverseName   = nameMap-        , scopeInverseModule = Map.fromList [ (x, findModule x) | x <- Map.keys moduleMap ++ Map.keys importMap ]-        , scopeInScope       = Set.unions $ map (scopeSet . snd) scopes-        }-  where-    this = scopeCurrent scope-    current = this : scopeParents (moduleScope this)-    scopes  = [ (m, restrict m s) | (m, s) <- Map.toList (scopeModules scope) ]--    moduleScope :: A.ModuleName -> Scope-    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope--    restrict m s | m `elem` current = s-                 | otherwise = restrictPrivate s--    scopeSet     s = Set.unions $ map (namespaceSet . snd) $ scopeNameSpaces s-    namespaceSet s = nsInScope s--    internalName :: C.QName -> Bool-    internalName C.QName{} = False-    internalName (C.Qual m n) = intern m || internalName n-      where-      -- Recognize fresh names created Parser.y-      intern (C.Name _ [ C.Id ('.' : '#' : _) ]) = True-      intern _ = False--    findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]-    findName table q = do-      (m, x) <- fromMaybe [] $ Map.lookup q table-      if m `elem` current-        then return (C.QName x)-        else do-          y <- findModule m-          let z = C.qualify y x-          guard $ not $ internalName z-          return z--    findModule :: A.ModuleName -> [C.QName]-    findModule q = findName moduleMap q ++-                   fromMaybe [] (Map.lookup q importMap)--    importMap = Map.fromListWith (++) $ do-      (m, s) <- scopes-      (x, y) <- Map.toList $ scopeImports s-      return (y, [x])--    moduleMap = Map.fromListWith (++) $ do-      (m, s)  <- scopes-      (x, ms) <- Map.toList (allNamesInScope s)-      q       <- amodName <$> ms-      return (q, [(m, x)])--    nameMap = Map.fromListWith (++) $ do-      (m, s)  <- scopes-      (x, ms) <- Map.toList (allNamesInScope s)-      q       <- anameName <$> ms-      if elem m current-        then return (q, [C.QName x])-        else do-          y <- findModule m-          let z = C.qualify y x-          guard $ not $ internalName z-          return (q, [z])---- | Find the concrete names that map (uniquely) to a given abstract qualified name.---   Sort by length, shortest first.-inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookupName x = inverseScopeLookup (Right x)--inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName]-inverseScopeLookupName' ambCon x = inverseScopeLookup' ambCon (Right x)---- | Find the concrete names that map (uniquely) to a given abstract module name.---   Sort by length, shortest first.-inverseScopeLookupModule :: A.ModuleName -> ScopeInfo -> [C.QName]-inverseScopeLookupModule x = inverseScopeLookup (Left x)----------------------------------------------------------------------------- * (Debug) printing---------------------------------------------------------------------------instance Show AbstractName where-  show = show . anameName--instance Show AbstractModule where-  show = show . amodName--instance Show NameSpaceId where-  show nsid = case nsid of-    PublicNS        -> "public"-    PrivateNS       -> "private"-    ImportedNS      -> "imported"-    OnlyQualifiedNS -> "only-qualified"--instance Show NameSpace where-  show (NameSpace names mods _) =-    unlines $-      blockOfLines "names"   (map pr $ Map.toList names) ++-      blockOfLines "modules" (map pr $ Map.toList mods)-    where-      pr :: (Show a, Show b) => (a,b) -> String-      pr (x, y) = show x ++ " --> " ++ show y--instance Show Scope where-  show (scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps }) =-    unlines $-      [ "scope " ++ show name ] ++ ind (-        concat [ blockOfLines (show nsid) (lines $ show $ scopeNameSpace nsid scope)-               | nsid <- [minBound..maxBound] ]-      ++ blockOfLines "imports"  (case Map.keys imps of-                                    [] -> []-                                    ks -> [ show ks ]-                                 )-      )-    where ind = map ("  " ++)---- | Add first string only if list is non-empty.-blockOfLines :: String -> [String] -> [String]-blockOfLines _  [] = []-blockOfLines hd ss = hd : map ("  " ++) ss--instance Show ScopeInfo where-  show (ScopeInfo this mods locals ctx _ _ _) =-    unlines $-      [ "ScopeInfo"-      , "  current = " ++ show this-      ] ++-      (if null locals then [] else [ "  locals  = " ++ show locals ]) ++-      [ "  context = " ++ show ctx-      , "  modules"-      ] ++ map ("    "++) (relines . map show $ Map.elems mods)-    where-      relines = filter (not . null) . lines . unlines----------------------------------------------------------------------------- * Boring instances---------------------------------------------------------------------------instance KillRange ScopeInfo where-  killRange m = m--instance HasRange AbstractName where-  getRange = getRange . anameName--instance SetRange AbstractName where-  setRange r x = x { anameName = setRange r $ anameName x }++{-| This module defines the notion of a scope and operations on scopes.+-}+module Agda.Syntax.Scope.Base where++import Prelude hiding ( null, length )++import Control.Arrow (first, second, (&&&))+import Control.DeepSeq+import Control.Monad++import Data.Either (partitionEithers)+import Data.Foldable ( length, toList )+import Data.Function (on)+import qualified Data.List as List+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.Semigroup ( Semigroup(..) )++import GHC.Generics (Generic)++import Agda.Benchmarking++import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Fixity+import Agda.Syntax.Abstract.Name as A+import Agda.Syntax.Concrete.Name as C+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Fixity as C++import Agda.Utils.AssocList (AssocList)+import qualified Agda.Utils.AssocList as AssocList+import Agda.Utils.Functor+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.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++import Agda.Utils.Impossible++-- * Scope representation++-- | A scope is a named collection of names partitioned into public and private+--   names.+data Scope = Scope+      { scopeName           :: A.ModuleName+      , scopeParents        :: [A.ModuleName]+      , scopeNameSpaces     :: ScopeNameSpaces+      , scopeImports        :: Map C.QName A.ModuleName+      , scopeDatatypeModule :: Maybe DataOrRecordModule+      }+  deriving (Eq, Show, Generic)++data DataOrRecordModule+  = IsDataModule+  | IsRecordModule+  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 (Eq, Bounded, Enum, Show, Generic)++allNameSpaces :: [NameSpaceId]+allNameSpaces = [minBound..maxBound]++type ScopeNameSpaces = [(NameSpaceId, NameSpace)]++localNameSpace :: Access -> NameSpaceId+localNameSpace PublicAccess    = PublicNS+localNameSpace PrivateAccess{} = PrivateNS++nameSpaceAccess :: NameSpaceId -> Access+nameSpaceAccess PrivateNS = privateAccessInserted+nameSpaceAccess _         = PublicAccess++-- | Get a 'NameSpace' from 'Scope'.+scopeNameSpace :: NameSpaceId -> Scope -> NameSpace+scopeNameSpace ns = fromMaybe __IMPOSSIBLE__ . lookup ns . scopeNameSpaces++-- | A lens for 'scopeNameSpaces'+updateScopeNameSpaces :: (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope+updateScopeNameSpaces f s = s { scopeNameSpaces = f (scopeNameSpaces s) }++-- | ``Monadic'' lens (Functor sufficient).+updateScopeNameSpacesM ::+  (Functor m) => (ScopeNameSpaces -> m ScopeNameSpaces) -> Scope -> m Scope+updateScopeNameSpacesM f s = for (f $ scopeNameSpaces s) $ \ x ->+  s { scopeNameSpaces = x }++-- | The complete information about the scope at a particular program point+--   includes the scope stack, the local variables, and the context precedence.+data ScopeInfo = ScopeInfo+      { _scopeCurrent       :: A.ModuleName+      , _scopeModules       :: Map A.ModuleName Scope+      , _scopeVarsToBind    :: LocalVars     -- ^ The variables that will be bound at the end+                                             --   of the current block of variables (i.e. clause).+                                             --   We collect them here instead of binding them+                                             --   immediately so we can avoid shadowing between+                                             --   variables in the same variable block.+      , _scopeLocals        :: LocalVars+      , _scopePrecedence    :: !PrecedenceStack+      , _scopeInverseName   :: NameMap+      , _scopeInverseModule :: ModuleMap+      , _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 (Show, Generic)++-- | For the sake of highlighting, the '_scopeInverseName' map also stores+--   the 'KindOfName' of an @A.QName@.+data NameMapEntry = NameMapEntry+  { qnameKind     :: KindOfName     -- ^ The 'anameKind'.+  , qnameConcrete :: List1 C.QName  -- ^ Possible renderings of the abstract name.+  }+  deriving (Show, Generic)++-- | Invariant: the 'KindOfName' components should be equal+--   whenever we have to concrete renderings of an abstract name.+instance Semigroup NameMapEntry where+  NameMapEntry k xs <> NameMapEntry _ ys = NameMapEntry k (xs <> ys)++type NameMap   = Map A.QName      NameMapEntry+type ModuleMap = Map A.ModuleName [C.QName]+-- type ModuleMap = Map A.ModuleName (List1 C.QName)++instance Eq ScopeInfo where+  ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ _ =+    c1 == c2 && m1 == m2 && v1 == v2 && l1 == l2 && p1 == p2++-- | Local variables.+type LocalVars = AssocList C.Name LocalVar++-- | 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 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"+    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.+data LocalVar = LocalVar+  { localVar           :: A.Name+    -- ^ Unique ID of local variable.+  , localBindingSource :: BindingSource+    -- ^ Kind of binder used to introduce the variable (@λ@, @let@, ...).+  , localShadowedBy    :: [AbstractName]+     -- ^ If this list is not empty, the local variable is+     --   shadowed by one or more imports.+  }+  deriving (Show, Generic)++instance Eq LocalVar where+  (==) = (==) `on` localVar++instance Ord LocalVar where+  compare = compare `on` localVar++-- | We show shadowed variables as prefixed by a ".", as not in scope.+instance Pretty LocalVar where+  pretty (LocalVar x _ []) = pretty x+  pretty (LocalVar x _ xs) = "." P.<> pretty x++-- | Shadow a local name by a non-empty list of imports.+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+ | PatternBound _ <- localBindingSource x =+   x { localBindingSource = LambdaBound }+ | otherwise                     = x++-- | Project name of unshadowed local variable.+notShadowedLocal :: LocalVar -> Maybe A.Name+notShadowedLocal (LocalVar x _ []) = Just x+notShadowedLocal _ = Nothing++-- | Get all locals that are not shadowed __by imports__.+notShadowedLocals :: LocalVars -> AssocList C.Name A.Name+notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x++-- | Lenses for ScopeInfo components+scopeCurrent :: Lens' ScopeInfo A.ModuleName+scopeCurrent f s =+  f (_scopeCurrent s) <&>+  \x -> s { _scopeCurrent = x }++scopeModules :: Lens' ScopeInfo (Map A.ModuleName Scope)+scopeModules f s =+  f (_scopeModules s) <&>+  \x -> s { _scopeModules = x }++scopeVarsToBind :: Lens' ScopeInfo LocalVars+scopeVarsToBind f s =+  f (_scopeVarsToBind s) <&>+  \x -> s { _scopeVarsToBind = x }++scopeLocals :: Lens' ScopeInfo LocalVars+scopeLocals f s =+  f (_scopeLocals s) <&>+  \x -> s { _scopeLocals = x }++scopePrecedence :: Lens' ScopeInfo PrecedenceStack+scopePrecedence f s =+  f (_scopePrecedence s) <&>+  \x -> s { _scopePrecedence = x }++scopeInverseName :: Lens' ScopeInfo NameMap+scopeInverseName f s =+  f (_scopeInverseName s) <&>+  \x -> s { _scopeInverseName = x }++scopeInverseModule :: Lens' ScopeInfo ModuleMap+scopeInverseModule f s =+  f (_scopeInverseModule s) <&>+  \x -> s { _scopeInverseModule = x }++scopeInScope :: Lens' ScopeInfo InScopeSet+scopeInScope f s =+  f (_scopeInScope s) <&>+  \x -> s { _scopeInScope = x }++scopeFixities :: Lens' ScopeInfo C.Fixities+scopeFixities f s =+  f (_scopeFixities s) <&>+  \x -> s { _scopeFixities = x }++scopePolarities :: Lens' ScopeInfo C.Polarities+scopePolarities f s =+  f (_scopePolarities s) <&>+  \x -> s { _scopePolarities = x }++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 }+  where+  -- Andreas, 2019-08-18: strict matching avoids space leak, see #1829.+  f' !fixs !pols = f (fixs, pols)+  -- Andrea comments on https://github.com/agda/agda/issues/1829#issuecomment-522312084+  -- on a naive version without the bang patterns:+  --+  -- useScope (because of useR) forces the result of projecting the+  -- lens, this usually prevents retaining the whole structure when we+  -- only need a field.  However your combined lens adds an extra layer+  -- of laziness with the pairs, so the actual projections remain+  -- unforced.+  --+  -- I guess scopeFixitiesAndPolarities could add some strictness when building the pair?++-- | Lens for 'scopeVarsToBind'.+updateVarsToBind :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo+updateVarsToBind = over scopeVarsToBind++setVarsToBind :: LocalVars -> ScopeInfo -> ScopeInfo+setVarsToBind = set scopeVarsToBind++-- | Lens for 'scopeLocals'.+updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo+updateScopeLocals = over scopeLocals++setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo+setScopeLocals = set scopeLocals++------------------------------------------------------------------------+-- * Name spaces+--+-- Map concrete names to lists of abstract names.+------------------------------------------------------------------------++-- | A @NameSpace@ contains the mappings from concrete names that the user can+--   write to the abstract fully qualified names that the type checker wants to+--   read.+data NameSpace = NameSpace+      { nsNames   :: NamesInScope+        -- ^ Maps concrete names to a list of abstract names.+      , nsModules :: ModulesInScope+        -- ^ Maps concrete module names to a list of abstract module names.+      , nsInScope :: InScopeSet+        -- ^ All abstract names targeted by a concrete name in scope.+        --   Computed by 'recomputeInScopeSets'.+      }+  deriving (Eq, Show, Generic)++type ThingsInScope a = Map C.Name (List1 a)+type NamesInScope    = ThingsInScope AbstractName+type ModulesInScope  = ThingsInScope AbstractModule+type InScopeSet      = Set A.QName++-- | Set of types consisting of exactly 'AbstractName' and 'AbstractModule'.+--+--   A GADT just for some dependent-types trickery.+data InScopeTag a where+  NameTag   :: InScopeTag AbstractName+  ModuleTag :: InScopeTag AbstractModule++-- | Type class for some dependent-types trickery.+class Ord a => InScope a where+  inScopeTag :: InScopeTag a++instance InScope AbstractName where+  inScopeTag = NameTag++instance InScope AbstractModule where+  inScopeTag = ModuleTag++-- | @inNameSpace@ selects either the name map or the module name map from+--   a 'NameSpace'.  What is selected is determined by result type+--   (using the dependent-type trickery).+inNameSpace :: forall a. InScope a => NameSpace -> ThingsInScope a+inNameSpace = case inScopeTag :: InScopeTag a of+  NameTag   -> nsNames+  ModuleTag -> nsModules++-- | Non-dependent tag for name or module.+data NameOrModule = NameNotModule | ModuleNotName+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)++------------------------------------------------------------------------+-- * Decorated names+--+-- - What kind of name? (defined, constructor...)+-- - Where does the name come from? (to explain to user)+------------------------------------------------------------------------++-- | For the sake of parsing left-hand sides, we distinguish+--   constructor and record field names from defined names.++-- Note: order does matter in this enumeration, see 'isDefName'.+data KindOfName+  = ConName                  -- ^ Constructor name ('Inductive' or don't know).+  | CoConName                -- ^ Constructor name (definitely 'CoInductive').+  | FldName                  -- ^ Record field name.+  | PatternSynName           -- ^ Name of a pattern synonym.+  | GeneralizeName           -- ^ Name to be generalized+  | DisallowedGeneralizeName -- ^ Generalizable variable from a let open+  | MacroName                -- ^ Name of a macro+  | QuotableName             -- ^ A name that can only be quoted.+  -- Previous category @DefName@:+  -- (Refined in a flat manner as Enum and Bounded are not hereditary.)+  | DataName                 -- ^ Name of a @data@.+  | RecName                  -- ^ Name of a @record@.+  | FunName                  -- ^ Name of a defined function.+  | AxiomName                -- ^ Name of a @postulate@.+  | 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, 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+  CoConName -> Just CoInductive+  _ -> Nothing++conKindOfName :: Induction -> KindOfName+conKindOfName = \case+  Inductive   -> ConName+  CoInductive -> CoConName++-- | For ambiguous constructors, we might have both alternatives of 'Induction'.+--   In this case, we default to 'ConName'.+conKindOfName' :: Foldable t => t Induction -> KindOfName+conKindOfName' = conKindOfName . approxConInduction++-- | For ambiguous constructors, we might have both alternatives of 'Induction'.+--   In this case, we default to 'Inductive'.+approxConInduction :: Foldable t => t Induction -> Induction+approxConInduction = fromMaybe Inductive . exactConInduction++exactConInduction :: Foldable t => t Induction -> Maybe Induction+exactConInduction is = case toList is of+  [CoInductive] -> Just CoInductive+  [Inductive]   -> Just Inductive+  _ -> Nothing++-- | Only return @[Co]ConName@ if no ambiguity.+exactConName :: Foldable t => t Induction -> Maybe KindOfName+exactConName = fmap conKindOfName . exactConInduction++-- | A set of 'KindOfName', for the sake of 'elemKindsOfNames'.+data KindsOfNames+  = AllKindsOfNames+  | SomeKindsOfNames   (Set KindOfName)  -- ^ Only these kinds.+  | ExceptKindsOfNames (Set KindOfName)  -- ^ All but these Kinds.++elemKindsOfNames :: KindOfName -> KindsOfNames -> Bool+elemKindsOfNames k = \case+  AllKindsOfNames       -> True+  SomeKindsOfNames   ks -> k `Set.member` ks+  ExceptKindsOfNames ks -> k `Set.notMember` ks++allKindsOfNames :: KindsOfNames+allKindsOfNames = AllKindsOfNames++someKindsOfNames :: [KindOfName] -> KindsOfNames+someKindsOfNames = SomeKindsOfNames . Set.fromList++exceptKindsOfNames :: [KindOfName] -> KindsOfNames+exceptKindsOfNames = ExceptKindsOfNames . Set.fromList++-- | Decorate something with 'KindOfName'++data WithKind a = WithKind+  { theKind     :: KindOfName+  , kindedThing :: a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++-- | Where does a name come from?+--+--   This information is solely for reporting to the user,+--   see 'Agda.Interaction.InteractionTop.whyInScope'.+data WhyInScope+  = Defined+    -- ^ Defined in this module.+  | Opened C.QName WhyInScope+    -- ^ Imported from another module.+  | Applied C.QName WhyInScope+    -- ^ Imported by a module application.+  deriving (Show, Generic)++-- | A decoration of 'Agda.Syntax.Abstract.Name.QName'.+data AbstractName = AbsName+  { anameName    :: A.QName+    -- ^ The resolved qualified name.+  , anameKind    :: KindOfName+    -- ^ The kind (definition, constructor, record field etc.).+  , anameLineage :: WhyInScope+    -- ^ Explanation where this name came from.+  , anameMetadata :: NameMetadata+    -- ^ Additional information needed during scope checking. Currently used+    --   for generalized data/record params.+  }+  deriving (Show, Generic)++data NameMetadata = NoMetadata+                  | GeneralizedVarsMetadata (Map A.QName A.Name)+  deriving (Show, Generic)++-- | A decoration of abstract syntax module names.+data AbstractModule = AbsModule+  { amodName    :: A.ModuleName+    -- ^ The resolved module name.+  , amodLineage :: WhyInScope+    -- ^ Explanation where this name came from.+  }+  deriving (Show, Generic)++instance Eq AbstractName where+  (==) = (==) `on` anameName++instance Ord AbstractName where+  compare = compare `on` anameName++instance LensFixity AbstractName where+  lensFixity = lensAnameName . lensFixity++-- | Van Laarhoven lens on 'anameName'.+lensAnameName :: Lens' AbstractName A.QName+lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }++instance Eq AbstractModule where+  (==) = (==) `on` amodName++instance Ord AbstractModule where+  compare = compare `on` amodName++-- | Van Laarhoven lens on 'amodName'.+lensAmodName :: Lens' AbstractModule A.ModuleName+lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }+++data ResolvedName+  = -- | Local variable bound by λ, Π, module telescope, pattern, @let@.+    VarName+    { resolvedVar           :: A.Name+    , resolvedBindingSource :: BindingSource    -- ^ What kind of binder?+    }++  | -- | Function, data/record type, postulate.+    DefinedName Access AbstractName A.Suffix -- ^ 'anameKind' can be 'DefName', 'MacroName', 'QuotableName'.++  | -- | Record field name.  Needs to be distinguished to parse copatterns.+    FieldName (List1 AbstractName)       -- ^ @('FldName' ==) . 'anameKind'@ for all names.++  | -- | Data or record constructor name.+    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 (Show, Eq, Generic)++instance Pretty ResolvedName where+  pretty = \case+    VarName x b          -> pretty b <+> "variable" <+> pretty x+    DefinedName a x s    -> pretty a      <+> (pretty x <> pretty s)+    FieldName xs         -> "field"       <+> pretty xs+    ConstructorName _ xs -> "constructor" <+> pretty xs+    PatternSynResName x  -> "pattern"     <+> pretty x+    UnknownName          -> "<unknown name>"++instance Pretty A.Suffix where+  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 List1.union++mergeNamesMany :: Eq a => [ThingsInScope a] -> ThingsInScope a+mergeNamesMany = Map.unionsWith List1.union++------------------------------------------------------------------------+-- * Operations on name spaces+------------------------------------------------------------------------++-- | The empty name space.+emptyNameSpace :: NameSpace+emptyNameSpace = NameSpace Map.empty Map.empty Set.empty+++-- | Map functions over the names and modules in a name space.+mapNameSpace :: (NamesInScope   -> NamesInScope  ) ->+                (ModulesInScope -> ModulesInScope) ->+                (InScopeSet     -> InScopeSet    ) ->+                NameSpace -> NameSpace+mapNameSpace fd fm fs ns =+  ns { nsNames   = fd $ nsNames   ns+     , nsModules = fm $ nsModules ns+     , nsInScope = fs $ nsInScope ns+     }++-- | Zip together two name spaces.+zipNameSpace :: (NamesInScope   -> NamesInScope   -> NamesInScope  ) ->+                (ModulesInScope -> ModulesInScope -> ModulesInScope) ->+                (InScopeSet     -> InScopeSet     -> InScopeSet    ) ->+                NameSpace -> NameSpace -> NameSpace+zipNameSpace fd fm fs ns1 ns2 =+  ns1 { nsNames   = nsNames   ns1 `fd` nsNames   ns2+      , nsModules = nsModules ns1 `fm` nsModules ns2+      , nsInScope = nsInScope ns1 `fs` nsInScope ns2+      }++-- | Map monadic function over a namespace.+mapNameSpaceM :: Applicative m =>+  (NamesInScope   -> m NamesInScope  ) ->+  (ModulesInScope -> m ModulesInScope) ->+  (InScopeSet     -> m InScopeSet    ) ->+  NameSpace -> m NameSpace+mapNameSpaceM fd fm fs ns = update ns <$> fd (nsNames ns) <*> fm (nsModules ns) <*> fs (nsInScope ns)+  where+    update ns ds ms is = ns { nsNames = ds, nsModules = ms, nsInScope = is }++------------------------------------------------------------------------+-- * General operations on scopes+------------------------------------------------------------------------++instance Null Scope where+  empty = emptyScope+  -- -- 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+  -- -- 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+emptyScope = Scope+  { scopeName           = noModuleName+  , scopeParents        = []+  , scopeNameSpaces     = [ (nsid, emptyNameSpace) | nsid <- allNameSpaces ]+      -- Note (Andreas, 2019-08-19):  Cannot have [] here because+      -- zipScope assumes all NameSpaces to be present and in the same order.+  , scopeImports        = Map.empty+  , scopeDatatypeModule = Nothing+  }++-- | The empty scope info.+emptyScopeInfo :: ScopeInfo+emptyScopeInfo = ScopeInfo+  { _scopeCurrent       = noModuleName+  , _scopeModules       = Map.singleton noModuleName emptyScope+  , _scopeVarsToBind    = []+  , _scopeLocals        = []+  , _scopePrecedence    = []+  , _scopeInverseName   = Map.empty+  , _scopeInverseModule = Map.empty+  , _scopeInScope       = Set.empty+  , _scopeFixities      = Map.empty+  , _scopePolarities    = Map.empty+  , _scopeRecords       = Map.empty+  }++-- | Map functions over the names and modules in a scope.+mapScope :: (NameSpaceId -> NamesInScope   -> NamesInScope  ) ->+            (NameSpaceId -> ModulesInScope -> ModulesInScope) ->+            (NameSpaceId -> InScopeSet    -> InScopeSet     ) ->+            Scope -> Scope+mapScope fd fm fs = updateScopeNameSpaces $ AssocList.mapWithKey mapNS+  where+    mapNS acc = mapNameSpace (fd acc) (fm acc) (fs acc)++-- | Same as 'mapScope' but applies the same function to all name spaces.+mapScope_ :: (NamesInScope   -> NamesInScope  ) ->+             (ModulesInScope -> ModulesInScope) ->+             (InScopeSet     -> InScopeSet    ) ->+             Scope -> Scope+mapScope_ fd fm fs = mapScope (const fd) (const fm) (const fs)++-- | Same as 'mapScope' but applies the function only on the given name space.+mapScopeNS :: NameSpaceId+           -> (NamesInScope   -> NamesInScope  )+           -> (ModulesInScope -> ModulesInScope)+           -> (InScopeSet    -> InScopeSet     )+           -> Scope -> Scope+mapScopeNS nsid fd fm fs = modifyNameSpace nsid $ mapNameSpace fd fm fs++-- | Map monadic functions over the names and modules in a scope.+mapScopeM :: Applicative m =>+  (NameSpaceId -> NamesInScope   -> m NamesInScope  ) ->+  (NameSpaceId -> ModulesInScope -> m ModulesInScope) ->+  (NameSpaceId -> InScopeSet     -> m InScopeSet    ) ->+  Scope -> m Scope+mapScopeM fd fm fs = updateScopeNameSpacesM $ AssocList.mapWithKeyM mapNS+  where+    mapNS acc = mapNameSpaceM (fd acc) (fm acc) (fs acc)++-- | Same as 'mapScopeM' but applies the same function to both the public and+--   private name spaces.+mapScopeM_ :: Applicative m =>+  (NamesInScope   -> m NamesInScope  ) ->+  (ModulesInScope -> m ModulesInScope) ->+  (InScopeSet     -> m InScopeSet    ) ->+  Scope -> m Scope+mapScopeM_ fd fm fs = mapScopeM (const fd) (const fm) (const fs)++-- | Zip together two scopes. The resulting scope has the same name as the+--   first scope.+zipScope :: (NameSpaceId -> NamesInScope   -> NamesInScope   -> NamesInScope  ) ->+            (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->+            (NameSpaceId -> InScopeSet     -> InScopeSet     -> InScopeSet    ) ->+            Scope -> Scope -> Scope+zipScope fd fm fs s1 s2 =+  s1 { scopeNameSpaces =+         [ (nsid, zipNS nsid ns1 ns2)+         | ((nsid, ns1), (nsid', ns2)) <-+             fromMaybe __IMPOSSIBLE__ $+               zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2)+         , assert (nsid == nsid')+         ]+     , scopeImports  = (Map.union `on` scopeImports)  s1 s2+     }+  where+    assert True  = True+    assert False = __IMPOSSIBLE__+    zipNS acc = zipNameSpace (fd acc) (fm acc) (fs acc)++-- | Same as 'zipScope' but applies the same function to both the public and+--   private name spaces.+zipScope_ :: (NamesInScope   -> NamesInScope   -> NamesInScope  ) ->+             (ModulesInScope -> ModulesInScope -> ModulesInScope) ->+             (InScopeSet     -> InScopeSet     -> InScopeSet    ) ->+             Scope -> Scope -> Scope+zipScope_ fd fm fs = zipScope (const fd) (const fm) (const fs)++-- | Recompute the inScope sets of a scope.+recomputeInScopeSets :: Scope -> Scope+recomputeInScopeSets = updateScopeNameSpaces (map $ second recomputeInScope)+  where+    recomputeInScope ns = ns { nsInScope = allANames $ nsNames ns }+    allANames :: NamesInScope -> InScopeSet+    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.+filterScope :: (C.Name -> Bool) -> (C.Name -> Bool) -> Scope -> Scope+filterScope pd pm = recomputeInScopeSets .  mapScope_ (Map.filterKeys pd) (Map.filterKeys pm) id+  -- We don't have enough information in the in scope set to do an+  -- incremental update here, so just recompute it from the name map.++-- | Return all names in a scope.+allNamesInScope :: InScope a => Scope -> ThingsInScope a+allNamesInScope = mergeNamesMany . map (inNameSpace . snd) . scopeNameSpaces++allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access)+allNamesInScope' s =+  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]++namesInScope :: InScope a => [NameSpaceId] -> Scope -> ThingsInScope a+namesInScope ids s =+  mergeNamesMany [ inNameSpace (scopeNameSpace nsid s) | nsid <- ids ]++allThingsInScope :: Scope -> NameSpace+allThingsInScope s =+  NameSpace { nsNames   = allNamesInScope s+            , nsModules = allNamesInScope s+            , nsInScope = Set.unions $ map (nsInScope . snd) $ scopeNameSpaces s+            }++thingsInScope :: [NameSpaceId] -> Scope -> NameSpace+thingsInScope fs s =+  NameSpace { nsNames   = namesInScope fs s+            , nsModules = namesInScope fs s+            , nsInScope = Set.unions [ nsInScope $ scopeNameSpace nsid s | nsid <- fs ]+            }++-- | Merge two scopes. The result has the name of the first scope.+mergeScope :: Scope -> Scope -> Scope+mergeScope = zipScope_ mergeNames mergeNames Set.union++-- | Merge a non-empty list of scopes. The result has the name of the first+--   scope in the list.+mergeScopes :: [Scope] -> Scope+mergeScopes [] = __IMPOSSIBLE__+mergeScopes ss = foldr1 mergeScope ss++-- * Specific operations on scopes++-- | Move all names in a scope to the given name space (except never move from+--   Imported to Public).+setScopeAccess :: NameSpaceId -> Scope -> Scope+setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns+  where+    zero  = emptyNameSpace+    one   = allThingsInScope s+    imp   = thingsInScope [ImportedNS] s+    noimp = thingsInScope [PublicNS, PrivateNS] s++    ns b = case (a, b) of+      (PublicNS, PublicNS)   -> noimp+      (PublicNS, ImportedNS) -> imp+      _ | a == b             -> one+        | otherwise          -> zero++-- | Update a particular name space.+setNameSpace :: NameSpaceId -> NameSpace -> Scope -> Scope+setNameSpace nsid ns = modifyNameSpace nsid $ const ns++-- | Modify a particular name space.+modifyNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> Scope -> Scope+modifyNameSpace nsid f = updateScopeNameSpaces $ AssocList.updateAt nsid f++-- | Add a name to a scope.+addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope+addNameToScope nsid x y =+  mapScopeNS nsid+    (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++-- | Remove a name from a scope. Caution: does not update the nsInScope set.+--   This is only used by rebindName and in that case we add the name right+--   back (but with a different kind).+removeNameFromScope :: NameSpaceId -> C.Name -> Scope -> Scope+removeNameFromScope nsid x = mapScopeNS nsid (Map.delete x) id id++-- | 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 List1.union) x (singleton m)++-- | When we get here we cannot have both @using@ and @hiding@.+data UsingOrHiding+  = UsingOnly  [C.ImportedName]+  | HidingOnly [C.ImportedName]++usingOrHiding :: C.ImportDirective -> UsingOrHiding+usingOrHiding i =+  case (using i, hiding i) of+    (UseEverything, ys) -> HidingOnly ys+    (Using xs     , []) -> UsingOnly  xs+    _                   -> __IMPOSSIBLE__++-- | Apply an 'ImportDirective' to a scope:+--+--   1. rename keys (C.Name) according to @renaming@;+--+--   2. for untouched keys, either of+--+--      a) remove keys according to @hiding@, or+--      b) filter keys according to @using@.+--+--   Both steps could be done in one pass, by first preparing key-filtering+--   functions @C.Name -> Maybe C.Name@ for defined names and module names.+--   However, the penalty of doing it in two passes should not be too high.+--   (Doubling the run time.)+applyImportDirective :: C.ImportDirective -> Scope -> Scope+applyImportDirective dir = fst . applyImportDirective_ dir++-- | Version of 'applyImportDirective' that also returns sets of name+--   and module name clashes introduced by @renaming@ to identifiers+--   that are already imported by @using@ or lack of @hiding@.+applyImportDirective_+  :: C.ImportDirective+  -> Scope+  -> (Scope, (Set C.Name, Set C.Name)) -- ^ Merged scope, clashing names, clashing module names.+applyImportDirective_ dir@(ImportDirective{ impRenaming }) s+  | null dir  = (s, (empty, empty))+      -- Since each run of applyImportDirective rebuilds the scope+      -- with cost O(n log n) time, it makes sense to test for the identity.+  | otherwise = (recomputeInScopeSets $ mergeScope sUse sRen, (nameClashes, moduleClashes))+  where+    -- Names kept via using/hiding.+    sUse :: Scope+    sUse = useOrHide (usingOrHiding dir) s++    -- Things kept (under a different name) via renaming.+    sRen :: Scope+    sRen = rename impRenaming s++    -- Which names are considered to be defined by a module?+    -- The ones actually defined there publicly ('publicNS')+    -- and the ones imported publicly ('ImportedNS')?+    exportedNSs = [PublicNS, ImportedNS]++    -- Name clashes introduced by the @renaming@ clause.+    nameClashes :: Set C.Name+    nameClashes = Map.keysSet rNames `Set.intersection` Map.keysSet uNames+      -- NB: `intersection` returns a subset of the first argument.+      -- To get the correct error location, i.e., in the @renaming@ clause+      -- rather than at the definition location, we neet to return+      -- names from the @renaming@ clause.  (Issue #4154.)+      where+      uNames, rNames :: NamesInScope+      uNames = namesInScope exportedNSs sUse+      rNames = namesInScope exportedNSs sRen++    -- Module name clashes introduced by the @renaming@ clause.++    -- Note: need to cut and paste because of 'InScope' dependent types trickery.+    moduleClashes :: Set C.Name+    moduleClashes = Map.keysSet uModules `Set.intersection` Map.keysSet rModules+      where+      uModules, rModules :: ModulesInScope+      uModules = namesInScope exportedNSs sUse+      rModules = namesInScope exportedNSs sRen+++    -- Restrict scope by directive.+    useOrHide :: UsingOrHiding -> Scope -> Scope+    useOrHide (UsingOnly  xs) = filterNames Set.member xs+       -- Filter scope, keeping only xs.+    useOrHide (HidingOnly xs) = filterNames Set.notMember $ map renFrom impRenaming ++ xs+       -- Filter out xs and the to be renamed names from scope.++    -- Filter scope by (`rel` xs).+    -- O(n * log (length xs)).+    filterNames :: (C.Name -> Set C.Name -> Bool) -> [C.ImportedName] ->+                   Scope -> Scope+    filterNames rel xs = filterScope (`rel` Set.fromList ds) (`rel` Set.fromList ms)+      where+        (ds, ms) = partitionEithers $ for xs $ \case+          ImportedName   x -> Left x+          ImportedModule m -> Right m++    -- Apply a renaming to a scope.+    -- O(n * (log n + log (length rho))).+    rename :: [C.Renaming] -> Scope -> Scope+    rename rho = mapScope_ (updateFxs .+                            updateThingsInScope (AssocList.apply drho))+                           (updateThingsInScope (AssocList.apply mrho))+                           id+      where+        (drho, mrho) = partitionEithers $ for rho $ \case+          Renaming (ImportedName   x) (ImportedName   y) _fx _ -> Left  (x, y)+          Renaming (ImportedModule x) (ImportedModule y) _fx _ -> Right (x, y)+          _ -> __IMPOSSIBLE__++        fixities :: AssocList C.Name Fixity+        fixities = (`mapMaybe` rho) $ \case+          Renaming _ (ImportedName y) (Just fx)  _ -> Just (y, fx)+          _ -> Nothing++        -- Update fixities of abstract names targeted by renamed imported identifies.+        updateFxs :: NamesInScope -> NamesInScope+        updateFxs m = foldl upd m fixities+          where+          -- Update fixity of all abstract names targeted by concrete name y.+          upd m (y, fx) = Map.adjust (fmap $ set lensFixity fx) y m++        updateThingsInScope+          :: forall a. SetBindingSite a+          => (C.Name -> Maybe C.Name)+          -> ThingsInScope a -> ThingsInScope a+        updateThingsInScope f = Map.fromListWith __IMPOSSIBLE__ . mapMaybe upd . Map.toAscList+          where+          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.+renameCanonicalNames :: Map A.QName A.QName -> Map A.ModuleName A.ModuleName ->+                        Scope -> Scope+renameCanonicalNames renD renM = mapScope_ renameD renameM (Set.map newName)+  where+    newName x = Map.findWithDefault x x renD+    newMod  x = Map.findWithDefault x x renM++    renameD = Map.map $ fmap $ over lensAnameName newName+    renameM = Map.map $ fmap $ over lensAmodName  newMod++-- | Remove private name space of a scope.+--+--   Should be a right identity for 'exportedNamesInScope'.+--   @exportedNamesInScope . restrictPrivate == exportedNamesInScope@.+restrictPrivate :: Scope -> Scope+restrictPrivate s = setNameSpace PrivateNS emptyNameSpace+                  $ s { scopeImports = Map.empty }++-- | Remove private things from the given module from a scope.+restrictLocalPrivate :: ModuleName -> Scope -> Scope+restrictLocalPrivate m =+  mapScopeNS PrivateNS+    (Map.mapMaybe rName)+    (Map.mapMaybe rMod)+    (Set.filter (not . (`isInModule` m)))+  where+    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+withoutPrivates scope = over scopeModules (fmap $ restrictLocalPrivate m) scope+  where+  m = scope ^. scopeCurrent++-- | Disallow using generalized variables from the scope+disallowGeneralizedVars :: Scope -> Scope+disallowGeneralizedVars = mapScope_ ((fmap . fmap) disallow) id id+  where+    disallow a = a { anameKind = disallowGen (anameKind a) }+    disallowGen GeneralizeName = DisallowedGeneralizeName+    disallowGen k              = k++-- | Add an explanation to why things are in scope.+inScopeBecause :: (WhyInScope -> WhyInScope) -> Scope -> Scope+inScopeBecause f = mapScope_ mapName mapMod id+  where+    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+publicModules scope = Map.filterWithKey (\ m _ -> reachable m) allMods+  where+    -- Get all modules in the ScopeInfo.+    allMods   = Map.map restrictPrivate $ scope ^. scopeModules+    root      = scope ^. scopeCurrent++    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++    reachable = (`elem` chase root)++publicNames :: ScopeInfo -> Set AbstractName+publicNames scope =+  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+  where+    look m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules+    s0     = look $ scope ^. scopeCurrent++everythingInScopeQualified :: ScopeInfo -> NameSpace+everythingInScopeQualified scope =+  allThingsInScope $ mergeScopes $+    chase Set.empty scopes+  where+    s0      = look $ scope ^. scopeCurrent+    scopes  = s0 : map look (scopeParents s0)+    look m  = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules+    lookP   = restrictPrivate . look++    -- We start with the current module and all its parents and look through+    -- all their imports and submodules.+    chase seen [] = []+    chase seen (s : ss)+      | Set.member name seen = chase seen ss+      | otherwise = s : chase (Set.insert name seen) (imports ++ submods ++ ss)+      where+        -- #4166: only include things that are actually in scope here+        inscope x _ = isInScope x == InScope+        name    = scopeName s+        imports = map lookP $ Map.elems $ scopeImports s+        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 id allNamesInScope root, imported, locals ]+  where+    current = moduleScope $ scope ^. scopeCurrent+    root    = mergeScopes $ current : map moduleScope (scopeParents current)++    locals  = Set.fromList [ C.QName x | (x, _) <- scope ^. scopeLocals ]++    imported = Set.unions+               [ build (qual c) exportedNamesInScope $ moduleScope a+               | (c, a) <- Map.toList $ scopeImports root+               ]+      where+        qual (C.QName x)  = C.Qual x+        qual (C.Qual m x) = C.Qual m . qual x++    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++-- | Look up a name in the scope+scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a]+scopeLookup q scope = map fst $ scopeLookup' q scope++scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]+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++    allScopes :: [Scope]+    allScopes = current : map moduleScope (scopeParents current) where+      current = moduleScope $ scope ^. scopeCurrent++    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  -> findNameInScope x s+      C.Qual x q -> do+        let -- Get the modules named @x@ in scope @s@.+            mods :: [A.ModuleName]+            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 <$> 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+        -- if we just consider the modules:+        m <- mods+        -- The feature is on if we consider also the data and record types:+        -- trace ("mods ++ defs = " ++ show (mods ++ defs)) $ do+        -- m <- nub $ mods ++ defs -- record types will appear both as a mod and a def+        -- Get the scope of module m, if any, and remove its private definitions.+        let ss  = Map.lookup m $ scope ^. scopeModules+            ss' = restrictPrivate <$> ss+        -- trace ("ss  = " ++ show ss ) $ do+        -- trace ("ss' = " ++ show ss') $ do+        s' <- maybeToList ss'+        findName q s'+++-- * Inverse look-up++data AllowAmbiguousNames+  = AmbiguousAnything+      -- ^ Used for instance arguments to check whether a name is in scope,+      --   but we do not care whether is is ambiguous+  | AmbiguousConProjs+      -- ^ Ambiguous constructors, projections, or pattern synonyms.+  | AmbiguousNothing+  deriving (Eq)++isNameInScope :: A.QName -> ScopeInfo -> Bool+isNameInScope q scope =+  billToPure [ Scoping, InverseScopeLookup ] $+  Set.member q (scope ^. scopeInScope)++isNameInScopeUnqualified :: A.QName -> ScopeInfo -> Bool+isNameInScopeUnqualified q scope =+  case inverseScopeLookupName' AmbiguousNothing q scope of+    C.QName{} : _ -> True -- NOTE: inverseScopeLookupName' puts unqualified names first+    _             -> False++-- | Find the concrete names that map (uniquely) to a given abstract qualified name.+--   Sort by number of modules in the qualified name, unqualified names first.+inverseScopeLookupName :: A.QName -> ScopeInfo -> [C.QName]+inverseScopeLookupName = inverseScopeLookupName' AmbiguousConProjs++inverseScopeLookupName' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> [C.QName]+inverseScopeLookupName' amb q scope =+  maybe [] (List1.toList . qnameConcrete) $ inverseScopeLookupName'' amb q scope++-- | A version of 'inverseScopeLookupName' that also delivers the 'KindOfName'.+--   Used in highlighting.+inverseScopeLookupName'' :: AllowAmbiguousNames -> A.QName -> ScopeInfo -> Maybe NameMapEntry+inverseScopeLookupName'' amb q scope = billToPure [ Scoping , InverseScopeLookup ] $ do+  NameMapEntry k xs <- Map.lookup q (scope ^. scopeInverseName)+  NameMapEntry k <$> do List1.nonEmpty $ best $ List1.filter unambiguousName xs+  where+    best :: [C.QName] -> [C.QName]+    best = List.sortOn $ length . C.qnameParts++    unique :: forall a . [a] -> Bool+    unique []      = __IMPOSSIBLE__+    unique [_]     = True+    unique (_:_:_) = False++    unambiguousName :: C.QName -> Bool+    unambiguousName q = or+      [ amb == AmbiguousAnything+      , unique xs+      , amb == AmbiguousConProjs && or+          [ all (isJust . isConName) (k:ks)+          , k `elem` [ FldName, PatternSynName ] && all (k ==) ks+          ]+      ]+      where+      xs   = scopeLookup q scope+      k:ks = map anameKind xs++-- | Find the concrete names that map (uniquely) to a given abstract module name.+--   Sort by length, shortest first.+inverseScopeLookupModule :: A.ModuleName -> ScopeInfo -> [C.QName]+inverseScopeLookupModule = inverseScopeLookupModule' AmbiguousNothing++inverseScopeLookupModule' :: AllowAmbiguousNames -> A.ModuleName -> ScopeInfo -> [C.QName]+inverseScopeLookupModule' amb m scope = billToPure [ Scoping , InverseScopeLookup ] $+  best $ filter unambiguousModule $ findModule m+  where+    findModule m = fromMaybe [] $ Map.lookup m (scope ^. scopeInverseModule)++    best :: [C.QName] -> [C.QName]+    best = List.sortOn $ length . C.qnameParts++    unique :: forall a . [a] -> Bool+    unique []      = __IMPOSSIBLE__+    unique [_]     = True+    unique (_:_:_) = False++    unambiguousModule q = amb == AmbiguousAnything || unique (scopeLookup q scope :: [AbstractModule])++recomputeInverseScopeMaps :: ScopeInfo -> ScopeInfo+recomputeInverseScopeMaps scope = billToPure [ Scoping , InverseScopeLookup ] $+  scope { _scopeInverseName   = nameMap+        , _scopeInverseModule = Map.fromList [ (x, findModule x) | x <- Map.keys moduleMap ++ Map.keys importMap ]+        , _scopeInScope       = nsInScope $ everythingInScopeQualified scope+        }+  where+    this = scope ^. scopeCurrent+    current = this : scopeParents (moduleScope this)+    scopes  = [ (m, restrict m s) | (m, s) <- Map.toList (scope ^. scopeModules) ]++    moduleScope :: A.ModuleName -> Scope+    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules++    restrict m s | m `elem` current = s+                 | otherwise = restrictPrivate s++    internalName :: C.QName -> Bool+    internalName C.QName{} = False+    internalName (C.Qual m n) = intern m || internalName n+      where+      -- Recognize fresh names created Parser.y+      intern (C.Name _ _ (C.Id ('.' : '#' : _) :| [])) = True+      intern _ = False++    findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]+    findName table q = do+      (m, x) <- fromMaybe [] $ Map.lookup q table+      if m `elem` current+        then return (C.QName x)+        else do+          y <- findModule m+          let z = C.qualify y x+          guard $ not $ internalName z+          return z++    findModule :: A.ModuleName -> [C.QName]+    findModule q = findName moduleMap q +++                   fromMaybe [] (Map.lookup q importMap)++    importMap = Map.fromListWith (++) $ do+      (m, s) <- scopes+      (x, y) <- Map.toList $ scopeImports s+      return (y, singleton x)++    moduleMap = Map.fromListWith (++) $ do+      (m, s)  <- scopes+      (x, ms) <- Map.toList (allNamesInScope s)+      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) <$> List1.toList ms+      let ret z = return (q, NameMapEntry k $ singleton z)+      if m `elem` current+        then ret $ C.QName x+        else do+          y <- findModule m+          let z = C.qualify y x+          guard $ not $ internalName z+          ret z++------------------------------------------------------------------------+-- * Update binding site+------------------------------------------------------------------------++-- | Set the 'nameBindingSite' in an abstract name.+class SetBindingSite a where+  setBindingSite :: Range -> a -> a++  default setBindingSite+    :: (SetBindingSite b, Functor t, t b ~ a)+    => Range -> a -> a+  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 }++instance SetBindingSite A.QName where+  setBindingSite r x = x { qnameName = setBindingSite r $ qnameName x }++-- | Sets the binding site of all names in the path.+instance SetBindingSite A.ModuleName where+  setBindingSite r (MName x) = MName $ setBindingSite r x++instance SetBindingSite AbstractName where+  setBindingSite r x = x { anameName = setBindingSite r $ anameName x }++instance SetBindingSite AbstractModule where+  setBindingSite r x = x { amodName = setBindingSite r $ amodName x }+++------------------------------------------------------------------------+-- * (Debug) printing+------------------------------------------------------------------------++instance Pretty AbstractName where+  pretty = pretty . anameName++instance Pretty AbstractModule where+  pretty = pretty . amodName++instance Pretty NameSpaceId where+  pretty = text . \case+    PublicNS        -> "public"+    PrivateNS       -> "private"+    ImportedNS      -> "imported"++instance Pretty NameSpace where+  pretty = vcat . prettyNameSpace++prettyNameSpace :: NameSpace -> [Doc]+prettyNameSpace (NameSpace names mods _) =+    blockOfLines "names"   (map pr $ Map.toList names) +++    blockOfLines "modules" (map pr $ Map.toList mods)+  where+    pr :: (Pretty a, Pretty b) => (a,b) -> Doc+    pr (x, y) = pretty x <+> "-->" <+> pretty y++instance Pretty Scope where+  pretty scope@Scope{ scopeName = name, scopeParents = parents, scopeImports = imps } =+    vcat $ concat+      [ [ "scope" <+> pretty name ]+      , scopeNameSpaces scope >>= \ (nsid, ns) -> do+          block (pretty nsid) $ prettyNameSpace ns+      , ifNull (Map.keys imps) [] {-else-} $ \ ks ->+          block "imports" [ prettyList ks ]+      ]+    where+    block :: Doc -> [Doc] -> [Doc]+    block hd = map (nest 2) . blockOfLines hd++-- | Add first string only if list is non-empty.+blockOfLines :: Doc -> [Doc] -> [Doc]+blockOfLines _  [] = []+blockOfLines hd ss = hd : map (nest 2) ss++instance Pretty ScopeInfo where+  pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _ _) = vcat $ concat+    [ [ "ScopeInfo"+      , nest 2 $ "current =" <+> pretty this+      ]+    , [ nest 2 $ "toBind  =" <+> pretty locals | not (null toBind) ]+    , [ nest 2 $ "locals  =" <+> pretty locals | not (null locals) ]+    , [ nest 2 $ "context =" <+> pretty ctx+      , nest 2 $ "modules"+      ]+    , map (nest 4 . pretty) $ Map.elems mods+    ]++------------------------------------------------------------------------+-- * Boring instances+------------------------------------------------------------------------++instance KillRange ScopeInfo where+  killRange m = m++instance HasRange AbstractName where+  getRange = getRange . anameName++instance SetRange AbstractName where+  setRange r x = x { anameName = setRange r $ anameName x }++instance NFData Scope+instance NFData DataOrRecordModule+instance NFData NameSpaceId+instance NFData ScopeInfo+instance NFData KindOfName+instance NFData NameMapEntry+instance NFData BindingSource+instance NFData LocalVar+instance NFData NameSpace+instance NFData NameOrModule+instance NFData WhyInScope+instance NFData AbstractName+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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                      #-} {-# LANGUAGE NondecreasingIndentation #-}  {-| The scope monad with operations.@@ -6,69 +5,109 @@  module Agda.Syntax.Scope.Monad where -import Prelude hiding (mapM)-import Control.Arrow (first, second, (***))+import Prelude hiding (null)++import Control.Arrow ((***))+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 Control.Monad hiding (mapM, forM)-import Control.Monad.Writer hiding (mapM, forM)-import Control.Monad.State hiding (mapM, forM) -import Data.List as List+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) import qualified Data.Set as Set import Data.Traversable hiding (for) +import Agda.Interaction.Options+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 import Agda.Syntax.Abstract.Name as A import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract (ScopeCopyInfo(..), initCopyInfo)+import Agda.Syntax.Abstract (ScopeCopyInfo(..)) import Agda.Syntax.Concrete as C-import Agda.Syntax.Scope.Base+import Agda.Syntax.Concrete.Fixity+import Agda.Syntax.Concrete.Definitions ( DeclarationWarning(..) ,DeclarationWarning'(..) )+  -- TODO: move the relevant warnings out of there+import Agda.Syntax.Scope.Base as A -import Agda.TypeChecking.Monad.Base+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.Options+import Agda.TypeChecking.Monad.Trace+import Agda.TypeChecking.Positivity.Occurrence ( PragmaPolarities, Occurrence )+import Agda.TypeChecking.Warnings ( warning, warning' )  import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.Function+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Functor+import Agda.Utils.Lens import Agda.Utils.List+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.Null (unlessNull)-import Agda.Utils.Pretty-import Agda.Utils.Size-import Agda.Utils.Tuple+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.Suffix as C -#include "undefined.h" import Agda.Utils.Impossible +--------------------------------------------------------------------------- -- * The scope checking monad+---------------------------------------------------------------------------  -- | To simplify interaction between scope checking and type checking (in --   particular when chasing imports), we use the same monad. type ScopeM = TCM --- * Errors+-- Debugging -isDatatypeModule :: A.ModuleName -> ScopeM Bool-isDatatypeModule m = do-   sc <- getScope-   return $ maybe __IMPOSSIBLE__ scopeDatatypeModule (Map.lookup m (scopeModules sc))+printLocals :: Int -> String -> ScopeM ()+printLocals v s = verboseS "scope.top" v $ do+  locals <- getLocalVars+  reportSLn "scope.top" v $ s ++ " " ++ prettyShow locals +scopeWarning' :: CallStack -> DeclarationWarning' -> ScopeM ()+scopeWarning' loc = warning' loc . NicifierIssue . DeclarationWarning loc++scopeWarning :: HasCallStack => DeclarationWarning' -> ScopeM ()+scopeWarning = withCallerCallStack scopeWarning'++--------------------------------------------------------------------------- -- * General operations+--------------------------------------------------------------------------- -getCurrentModule :: ScopeM A.ModuleName-getCurrentModule = setRange noRange . scopeCurrent <$> getScope+isDatatypeModule :: ReadTCState m => A.ModuleName -> m (Maybe DataOrRecordModule)+isDatatypeModule m = do+   scopeDatatypeModule . Map.findWithDefault __IMPOSSIBLE__ m <$> useScope scopeModules -setCurrentModule :: A.ModuleName -> ScopeM ()-setCurrentModule m = modifyScope $ \s -> s { scopeCurrent = m }+getCurrentModule :: ReadTCState m => m A.ModuleName+getCurrentModule = setRange noRange <$> useScope scopeCurrent -withCurrentModule :: A.ModuleName -> ScopeM a -> ScopeM a+setCurrentModule :: MonadTCState m => A.ModuleName -> m ()+setCurrentModule m = modifyScope $ set scopeCurrent m++withCurrentModule :: (ReadTCState m, MonadTCState m) => A.ModuleName -> m a -> m a withCurrentModule new action = do   old <- getCurrentModule   setCurrentModule new@@ -87,19 +126,22 @@ getNamedScope :: A.ModuleName -> ScopeM Scope getNamedScope m = do   scope <- getScope-  case Map.lookup m (scopeModules scope) of+  case Map.lookup m (scope ^. scopeModules) of     Just s  -> return s     Nothing -> do-      reportSLn "" 0 $ "ERROR: In scope\n" ++ show scope ++ "\nNO SUCH SCOPE " ++ show m+      reportSLn "" 0 $ "ERROR: In scope\n" ++ prettyShow scope ++ "\nNO SUCH SCOPE " ++ prettyShow m       __IMPOSSIBLE__  getCurrentScope :: ScopeM Scope getCurrentScope = getNamedScope =<< getCurrentModule --- | Create a new module with an empty scope (Bool is True if it is a datatype module)-createModule :: Bool -> A.ModuleName -> ScopeM ()+-- | Create a new module with an empty scope.+--   If the module is not new (e.g. duplicate @import@),+--   don't erase its contents.+--   (@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@@ -107,11 +149,14 @@                       , scopeDatatypeModule = b }   -- Andreas, 2015-07-02: internal error if module is not new.   -- Ulf, 2016-02-15: It's not new if multiple imports (#1770).-  modifyScopes $ Map.insertWith const m sm+  -- Andreas, 2020-05-18, issue #3933:+  -- If it is not new (but apparently did not clash),+  -- we do not erase its contents for reasons of monotonicity.+  modifyScopes $ Map.insertWith mergeScope m sm  -- | Apply a function to the scope map. modifyScopes :: (Map A.ModuleName Scope -> Map A.ModuleName Scope) -> ScopeM ()-modifyScopes f = modifyScope $ \s -> s { scopeModules = f $ scopeModules s }+modifyScopes = modifyScope . over scopeModules  -- | Apply a function to the given scope. modifyNamedScope :: A.ModuleName -> (Scope -> Scope) -> ScopeM ()@@ -139,22 +184,15 @@ modifyCurrentNameSpace acc f = modifyCurrentScope $ updateScopeNameSpaces $   AssocList.updateAt acc f -setContextPrecedence :: Precedence -> ScopeM ()-setContextPrecedence p = modifyScope_ $ \s -> s { scopePrecedence = p }--getContextPrecedence :: ScopeM Precedence-getContextPrecedence = scopePrecedence <$> getScope+setContextPrecedence :: PrecedenceStack -> ScopeM ()+setContextPrecedence = modifyScope_ . set scopePrecedence -withContextPrecedence :: Precedence -> ScopeM a -> ScopeM a-withContextPrecedence p m = do-  p' <- getContextPrecedence-  setContextPrecedence p-  x <- m-  setContextPrecedence p'-  return x+withContextPrecedence :: ReadTCState m => Precedence -> m a -> m a+withContextPrecedence p =+  locallyTCState (stScope . scopePrecedence) $ pushPrecedence p -getLocalVars :: ScopeM LocalVars-getLocalVars = scopeLocals <$> getScope+getLocalVars :: ReadTCState m => m LocalVars+getLocalVars = useScope scopeLocals  modifyLocalVars :: (LocalVars -> LocalVars) -> ScopeM () modifyLocalVars = modifyScope_ . updateScopeLocals@@ -164,13 +202,79 @@  -- | Run a computation without changing the local variables. withLocalVars :: ScopeM a -> ScopeM a-withLocalVars m = do-  vars <- getLocalVars-  x    <- m-  setLocalVars vars+withLocalVars = bracket_ getLocalVars setLocalVars++-- | Run a computation outside some number of local variables and add them back afterwards. This+--   lets you bind variables in the middle of the context and is used when binding generalizable+--   variables (#3735).+outsideLocalVars :: Int -> ScopeM a -> ScopeM a+outsideLocalVars n m = do+  inner <- take n <$> getLocalVars+  modifyLocalVars (drop n)+  x <- m+  modifyLocalVars (inner ++)   return x +-- | Check that the newly added variable have unique names.++withCheckNoShadowing :: ScopeM a -> ScopeM a+withCheckNoShadowing = bracket_ getLocalVars $ \ lvarsOld ->+  checkNoShadowing lvarsOld =<< getLocalVars++checkNoShadowing :: LocalVars  -- ^ Old local scope+                 -> LocalVars  -- ^ New local scope+                 -> ScopeM ()+checkNoShadowing old new = do+  opts <- pragmaOptions+  when (ShadowingInTelescope_ `Set.member`+          (optWarningMode opts ^. warningSet)) $ do+    -- LocalVars is currnently an AssocList so the difference between+    -- two local scope is the left part of the new one.+    let diff = dropEnd (length old) new+    -- Filter out the underscores.+    let newNames = filter (not . isNoName) $ AssocList.keys diff+    -- Associate each name to its occurrences.+    let nameOccs1 :: [(C.Name, List1 Range)]+        nameOccs1 = Map.toList $ Map.fromListWith (<>) $ map pairWithRange newNames+    -- Warn if we have two or more occurrences of the same name.+    let nameOccs2 :: [(C.Name, List2 Range)]+        nameOccs2 = mapMaybe (traverseF List2.fromList1Maybe) nameOccs1+    caseList nameOccs2 (return ()) $ \ c conflicts -> do+      scopeWarning $ ShadowingInTelescope $ c :| conflicts+  where+    pairWithRange :: C.Name -> (C.Name, List1 Range)+    pairWithRange n = (n, singleton $ getRange n)++getVarsToBind :: ScopeM LocalVars+getVarsToBind = useScope scopeVarsToBind++addVarToBind :: C.Name -> LocalVar -> ScopeM ()+addVarToBind x y = modifyScope_ $ updateVarsToBind $ AssocList.insert x y++-- | After collecting some variable names in the scopeVarsToBind,+--   bind them all simultaneously.+bindVarsToBind :: ScopeM ()+bindVarsToBind = do+  vars <- getVarsToBind+  modifyLocalVars (vars ++)+  printLocals 30 "bound variables:"+  modifyScope_ $ setVarsToBind []++annotateDecls :: ReadTCState m => m [A.Declaration] -> m A.Declaration+annotateDecls m = do+  ds <- m+  s  <- getScope+  return $ A.ScopedDecl s ds++annotateExpr :: ReadTCState m => m A.Expr -> m A.Expr+annotateExpr m = do+  e <- m+  s <- getScope+  return $ A.ScopedExpr s e++--------------------------------------------------------------------------- -- * Names+---------------------------------------------------------------------------  -- | Create a fresh abstract name from a concrete name. --@@ -183,8 +287,10 @@   return $ A.Name     { nameId          = i     , nameConcrete    = x+    , nameCanonical   = x     , nameBindingSite = getRange x     , nameFixity      = fx+    , nameIsRecordName = False     }  -- | @freshAbstractName_ = freshAbstractName noFixity'@@@ -198,18 +304,25 @@   m <- getCurrentModule   return $ A.qualify m y --- * Resolving names+freshAbstractQName' :: C.Name -> ScopeM A.QName+freshAbstractQName' x = do+  fx <- getConcreteFixity x+  freshAbstractQName fx x -data ResolvedName-  = VarName A.Name-  | DefinedName Access AbstractName-  | FieldName [AbstractName]-      -- ^ record fields names need to be distinguished to parse copatterns-  | ConstructorName [AbstractName]-  | PatternSynResName AbstractName-  | UnknownName-  deriving (Show, Eq)+-- | Create a concrete name that is not yet in scope.+-- | NOTE: See @chooseName@ in @Agda.Syntax.Translation.AbstractToConcrete@ for similar logic.+-- | NOTE: See @withName@ in @Agda.Syntax.Translation.ReflectedToAbstract@ for similar logic.+freshConcreteName :: Range -> Int -> String -> ScopeM C.Name+freshConcreteName r i s = do+  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 +---------------------------------------------------------------------------+-- * Resolving names+---------------------------------------------------------------------------+ -- | Look up the abstract name referred to by a given concrete name. resolveName :: C.QName -> ScopeM ResolvedName resolveName = resolveName' allKindsOfNames Nothing@@ -221,114 +334,233 @@ --   Then, we can ignore conflicting definitions of that name --   of a different kind. (See issue 822.) resolveName' ::-  [KindOfName] -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName-resolveName' kinds names x = do+  KindsOfNames -> Maybe (Set1 A.Name) -> C.QName -> ScopeM ResolvedName+resolveName' kinds names x = runExceptT (tryResolveName kinds names x) >>= \case+  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 :: 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 $ scopeLocals scope-      retVar y = return $ VarName $ y { nameConcrete = unqualify x }-      aName    = A.qnameName . anameName+  let+    vars = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals+    throwAmb = throwError . IllegalAmbiguity   case lookup x vars of-    -- Case: we have a local variable x.-    Just (LocalVar y)  -> retVar y-    -- Case: ... but is (perhaps) shadowed by some imports.-    Just (ShadowedVar y ys) -> case names of-      Nothing -> shadowed ys-      Just ns -> case filter (\y -> aName y `Set.member` ns) ys of-        [] -> retVar y-        ys -> shadowed ys-      where-      shadowed ys =-        typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys++    -- Case: we have a local variable x, but is (perhaps) shadowed by some imports ys.+    Just var@(LocalVar y b ys) ->+      -- We may ignore the imports filtered out by the @names@ filter.+      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 of one of the given kinds-      let filtKind = filter $ \ y -> anameKind (fst y) `elem` kinds-      -- Consider only names in the given set of names-          filtName = filter $ \ y -> maybe True (Set.member (aName (fst y))) names-      case filtKind $ filtName $ scopeLookup' x scope of-        [] -> return UnknownName+      -- Consider only names that are in the given set of names and+      -- are of one of the given kinds+      let filtKind = filter $ (`elemKindsOfNames` kinds) . anameKind . fst+          possibleNames z = filtKind $ filterNames fst $ scopeLookup' z scope+      -- If the name has a suffix, also consider the possibility that+      -- the base name is in scope (e.g. the builtin sorts `Set` and `Prop`).+      canHaveSuffix <- canHaveSuffixTest+      let (xsuffix, xbase) = (C.lensQNameName . nameSuffix) (,Nothing) x+          possibleBaseNames = filter (canHaveSuffix . anameName . fst) $ possibleNames xbase+          suffixedNames = (,) <$> fromConcreteSuffix xsuffix <*> nonEmpty possibleBaseNames+      case (nonEmpty $ possibleNames x) of+        Just ds  | Just ks <- traverse (isConName . anameKind . fst) ds+                     -- all names resolve to a constructor name+                 , isNothing suffixedNames ->+          return $ ConstructorName (Set1.fromList ks) $ fmap (upd . fst) ds -        ds       | all ((==ConName) . anameKind . fst) ds ->-          return $ ConstructorName $ map (upd . fst) ds+        Just ds  | all ((FldName ==) . anameKind . fst) ds , isNothing suffixedNames ->+          return $ FieldName $ fmap (upd . fst) ds -        ds       | all ((==FldName) . anameKind . fst) ds ->-          return $ FieldName $ map (upd . fst) ds+        Just ds  | all ((PatternSynName ==) . anameKind . fst) ds , isNothing suffixedNames ->+          return $ PatternSynResName $ fmap (upd . fst) ds -        [(d, a)] | anameKind d == PatternSynName ->-          return $ PatternSynResName $ upd d+        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) -        [(d, a)] ->-          return $ DefinedName a $ upd d+        -- 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 -        ds -> typeError $ AmbiguousName x (map (anameName . fst) ds)+          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 , (d1,_) :| (d2,_) : sds) ->+            throwAmb $ AmbiguousDeclName $ List2 d1 d2 $ map fst sds+   where+  -- @names@ intended semantics: a filter on names.+  -- @Nothing@: don't filter out anything.+  -- @Just ns@: filter by membership in @ns@.+  filterNames :: forall a. (a -> AbstractName) -> [a] -> [a]+  filterNames = case names of+    Nothing -> \ f -> id+    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   updateConcreteName d@(AbsName { anameName = A.QName qm qn }) x =     d { anameName = A.QName (setRange (getRange x) qm) (qn { nameConcrete = x }) }+  fromConcreteSuffix = \case+    Nothing              -> Nothing+    Just C.Prime{}       -> Nothing+    Just (C.Index i)     -> Just $ A.Suffix i+    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.+canHaveSuffixTest :: HasBuiltins m => m (A.QName -> Bool)+canHaveSuffixTest = do+  builtinProp <- getBuiltinName' builtinProp+  builtinSet  <- getBuiltinName' builtinSet+  builtinSSet <- getBuiltinName' builtinStrictSet+  builtinPropOmega <- getBuiltinName' builtinPropOmega+  builtinSetOmega <- getBuiltinName' builtinSetOmega+  builtinSSetOmega <- getBuiltinName' builtinSSetOmega+  return $ \x -> Just x `elem` [builtinProp, builtinSet, builtinSSet, builtinPropOmega, builtinSetOmega, builtinSSetOmega]+ -- | Look up a module in the scope. resolveModule :: C.QName -> ScopeM AbstractModule resolveModule x = do   ms <- scopeLookup x <$> getScope-  case ms of-    [AbsModule m why] -> return $ AbsModule (m `withRangesOfQ` x) why-    []                -> typeError $ NoSuchModule x-    ms                -> typeError $ AmbiguousModule x (map amodName ms)+  caseMaybe (nonEmpty ms) (typeError $ NoSuchModule x) $ \ case+    AbsModule m why :| [] -> return $ AbsModule (m `withRangeOf` x) why+    ms                    -> typeError $ AmbiguousModule x (fmap amodName ms) +-- | Get the fixity of a not yet bound name.+getConcreteFixity :: C.Name -> ScopeM Fixity'+getConcreteFixity x = Map.findWithDefault noFixity' x <$> useScope scopeFixities++-- | Get the polarities of a not yet bound name.+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+  throwMultiplePolarityPragmas xs     = case xs of+    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.+computeFixitiesAndPolarities :: DoWarn -> [C.Declaration] -> ScopeM a -> ScopeM a+computeFixitiesAndPolarities warn ds cont = do+  fp <- fixitiesAndPolarities warn ds+  -- Andreas, 2019-08-16:+  -- Since changing fixities and polarities does not affect the name sets,+  -- we do not need to invoke @modifyScope@ here+  -- (which does @recomputeInverseScopeMaps@).+  -- A simple @locallyScope@ is sufficient.+  locallyScope scopeFixitiesAndPolarities (const fp) cont+ -- | 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   r <- resolveName' allKindsOfNames (Just ns) x   case r of-    VarName y           -> return $ namesToNotation x y-    DefinedName _ d     -> return $ notation d+    VarName y _         -> return $ namesToNotation x y+    DefinedName _ d _   -> return $ notation d     FieldName ds        -> return $ oneNotation ds-    ConstructorName ds  -> return $ oneNotation ds-    PatternSynResName n -> return $ notation n+    ConstructorName _ ds-> return $ oneNotation ds+    PatternSynResName n -> return $ oneNotation n     UnknownName         -> __IMPOSSIBLE__   where     notation = namesToNotation x . qnameName . anameName-    oneNotation ds =-      case mergeNotations $ map notation ds of-        [n] -> n-        _   -> __IMPOSSIBLE__+    oneNotation = List1.head . mergeNotations . fmap notation +--------------------------------------------------------------------------- -- * Binding names+--------------------------------------------------------------------------- --- | Bind a variable. The abstract name is supplied as the second argument.-bindVariable :: C.Name -> A.Name -> ScopeM ()-bindVariable x y = modifyScope_ $ updateScopeLocals $ AssocList.insert x $ LocalVar y+-- | Bind a variable.+bindVariable+  :: A.BindingSource -- ^ @λ@, @Π@, @let@, ...?+  -> C.Name          -- ^ Concrete name.+  -> A.Name          -- ^ Abstract name.+  -> ScopeM ()+bindVariable b x y = modifyLocalVars $ AssocList.insert x $ LocalVar y b [] +-- | Temporarily unbind a variable. Used for non-recursive lets.+unbindVariable :: C.Name -> ScopeM a -> ScopeM a+unbindVariable x = bracket_ (getLocalVars <* modifyLocalVars (AssocList.delete x)) (modifyLocalVars . const)+ -- | Bind a defined name. Must not shadow anything. bindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()-bindName acc kind x y = do+bindName acc kind x y = bindName' acc kind NoMetadata x y++bindName' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM ()+bindName' acc kind meta x y = whenJustM (bindName'' acc kind meta x y) typeError++-- | Bind a name. Returns the 'TypeError' if exists, but does not throw it.+bindName'' :: Access -> KindOfName -> NameMetadata -> C.Name -> A.QName -> ScopeM (Maybe TypeError)+bindName'' acc kind meta x y = do+  when (isNoName x) $ modifyScopes $ Map.map $ removeNameFromScope PrivateNS x   r  <- resolveName (C.QName x)-  ys <- case r of-    -- Binding an anonymous declaration always succeeds.-    -- In case it's not the first one, we simply remove the one that came before-    UnknownName   | isNoName x -> success-    DefinedName{} | isNoName x -> success <* modifyCurrentScope (removeNameFromScope PrivateNS x)-    DefinedName _ d     -> clash $ anameName d-    VarName z           -> clash $ A.qualify (mnameFromList []) z-    FieldName       ds  -> ambiguous FldName ds-    ConstructorName ds  -> ambiguous ConName ds-    PatternSynResName n -> clash $ anameName n-    UnknownName         -> success+  let y' :: Either TypeError AbstractName+      y' = case r of+        -- Binding an anonymous declaration always succeeds.+        -- In case it's not the first one, we simply remove the one that came before+        _ | isNoName x      -> success+        DefinedName _ d _   -> clash $ anameName d+        VarName z _         -> clash $ A.qualify_ z+        FieldName       ds  -> ambiguous (== FldName) ds+        ConstructorName i ds-> ambiguous (isJust . isConName) ds+        PatternSynResName n -> ambiguous (== PatternSynName) n+        UnknownName         -> success   let ns = if isNoName x then PrivateNS else localNameSpace acc-  modifyCurrentScope $ addNamesToScope ns x ys+  traverse_ (modifyCurrentScope . addNameToScope ns x) y'+  pure $ either Just (const Nothing) y'   where-    success = return [ AbsName y kind Defined ]-    clash   = typeError . ClashingDefinition (C.QName x)+    success = Right $ AbsName y kind Defined meta+    clash n = Left $ ClashingDefinition (C.QName x) n Nothing -    ambiguous k ds@(d:_) =-      if kind == k && all ((==k) . anameKind) ds-      then success else clash $ anameName d-    ambiguous k [] = __IMPOSSIBLE__+    ambiguous f ds =+      if f kind && all (f . anameKind) ds+      then success else clash $ anameName (List1.head ds)  -- | Rebind a name. Use with care! --   Ulf, 2014-06-29: Currently used to rebind the name defined by an@@ -336,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.@@ -349,7 +587,51 @@ 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+---------------------------------------------------------------------------  -- | Clear the scope of any no names. stripNoNames :: ScopeM ()@@ -361,7 +643,7 @@  data ScopeMemo = ScopeMemo   { memoNames   :: A.Ren A.QName-  , memoModules :: [(ModuleName, (ModuleName, Bool))]+  , memoModules :: Map ModuleName (ModuleName, Bool)     -- ^ Bool: did we copy recursively? We need to track this because we don't     --   copy recursively when creating new modules for reexported functions     --   (issue1985), but we might need to copy recursively later.@@ -370,18 +652,28 @@ memoToScopeInfo :: ScopeMemo -> ScopeCopyInfo memoToScopeInfo (ScopeMemo names mods) =   ScopeCopyInfo { renNames   = names-                , renModules = [ (x, y) | (x, (y, _)) <- mods ] }+                , 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. copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, ScopeCopyInfo)-copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo [] [])+copyScope oldc new0 s = (inScopeBecause (Applied oldc) *** memoToScopeInfo) <$> runStateT (copy new0 s) (ScopeMemo mempty mempty)   where     copy :: A.ModuleName -> Scope -> WSM Scope     copy new s = do-      lift $ reportSLn "scope.copy" 20 $ "Copying scope " ++ show old ++ " to " ++ show new-      lift $ reportSLn "scope.copy" 50 $ show s+      lift $ reportSLn "scope.copy" 20 $ "Copying scope " ++ prettyShow old ++ " to " ++ prettyShow new+      lift $ reportSLn "scope.copy" 50 $ prettyShow s       s0 <- lift $ getNamedScope new       -- Delete private names, then copy names and modules. Recompute inScope       -- set rather than trying to copy it.@@ -409,18 +701,25 @@             _ -> lensAnameName f d          -- Adding to memo structure.-        addName x y     = modify $ \ i -> i { memoNames   = (x, y)        : memoNames   i }-        addMod  x y rec = modify $ \ i -> i { memoModules = (x, (y, rec)) : filter ((/= x) . fst) (memoModules i) }+        addName x y     = modify $ \ i -> i { memoNames   = Map.insertWith (<>) x (pure y) (memoNames i) }+        addMod  x y rec = modify $ \ i -> i { memoModules = Map.insert x (y, rec) (memoModules i) }          -- Querying the memo structure.-        findName x = lookup x <$> gets memoNames-        findMod  x = lookup x <$> gets memoModules+        findName x = gets (Map.lookup x . memoNames) -- NB:: Defined but not used+        findMod  x = gets (Map.lookup x . memoModules)          refresh :: A.Name -> WSM A.Name         refresh x = do           i <- lift fresh-          return $ x { nameId = i }+          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@@ -441,9 +740,9 @@           -- would break the invariant that all functions in a module share the           -- module telescope. Instead we copy M1.M2.X to M.M2.X for a fresh           -- module M2 that gets the right telescope.-          m <- case x `isInModule` old of-                 True  -> return new'-                 False -> renMod' False (qnameModule x)+          m <- if x `isInModule` old+                 then return new'+                 else renMod' False (qnameModule x)                           -- Don't copy recursively here, we only know that the                           -- current name x should be copied.           -- Generate a fresh name for the target.@@ -454,8 +753,10 @@           -- For now, we just set their range           -- to the new module name's one, which fixes issue 1619.           y <- setRange rnew . A.qualify m <$> refresh (qnameName x)-          lift $ reportSLn "scope.copy" 50 $ "  Copying " ++ show x ++ " to " ++ show y+          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@@ -473,8 +774,7 @@             -- Ulf (issue 1985): If copying a reexported module we put it at the             -- top-level, to make sure we don't mess up the invariant that all             -- (abstract) names M.f share the argument telescope of M.-            let newM | x `isSubModuleOf` old = newL-                     | otherwise             = mnameToList new0+            let newM = if x `isLtChildModuleOf` old then newL else mnameToList new0              y <- do                -- Andreas, Jesper, 2015-07-02: Issue 1597@@ -486,14 +786,14 @@                --   return $ A.mnameFromList $ newL ++ suffix                -- Ulf, 2016-02-22: #1726                -- We still need to copy modules from 'open public'. Same as in renName.-               y <- refresh (last $ A.mnameToList x)+               y <- refresh $ lastWithDefault __IMPOSSIBLE__ $ A.mnameToList x                return $ A.mnameFromList $ newM ++ [y]             -- Andreas, Jesper, 2015-07-02: Issue 1597             -- Don't copy a module over itself, it will just be emptied of its contents.             if (x == y) then return x else do-            lift $ reportSLn "scope.copy" 50 $ "  Copying module " ++ show x ++ " to " ++ show y+            lift $ reportSLn "scope.copy" 50 $ "  Copying module " ++ prettyShow x ++ " to " ++ prettyShow y             addMod x y rec-            lift $ createModule False y+            lift $ createModule Nothing y             -- We need to copy the contents of included modules recursively (only when 'rec')             when rec $ copyRec x y             return y@@ -503,35 +803,106 @@               s  <- withCurrentModule' y $ copy y s0               lift $ modifyNamedScope y (const s) +---------------------------------------------------------------------------+-- * Import directives+---------------------------------------------------------------------------++-- | Warn about useless fixity declarations in @renaming@ directives.+--   Monadic for the sake of error reporting.+checkNoFixityInRenamingModule :: [C.Renaming] -> ScopeM ()+checkNoFixityInRenamingModule ren = do+  whenJust (nonEmpty $ mapMaybe rangeOfUselessInfix ren) $ \ rs -> do+    setCurrentRange rs $ do+      warning $ FixityInRenamingModule rs+  where+  rangeOfUselessInfix :: C.Renaming -> Maybe Range+  rangeOfUselessInfix = \case+    Renaming ImportedModule{} _ mfx _ -> getRange <$> mfx+    _ -> Nothing++-- | Check that an import directive doesn't contain repeated names.+verifyImportDirective :: [C.ImportedName] -> C.HidingDirective -> C.RenamingDirective -> ScopeM ()+verifyImportDirective usn hdn 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.-applyImportDirectiveM :: C.QName -> C.ImportDirective -> Scope -> ScopeM (A.ImportDirective, Scope)-applyImportDirectiveM m dir@ImportDirective{ impRenaming = ren, using = u, hiding = h } scope = do-    -- Translate exported names to abstract syntax.-    -- Raise error if unsuccessful.-    caseMaybe mNamesA doesntExport $ \ namesA -> do+--+--   Monadic for the sake of error reporting.+applyImportDirectiveM+  :: C.QName                           -- ^ Name of the scope, only for error reporting.+  -> C.ImportDirective                 -- ^ Description of how scope is to be modified.+  -> Scope                             -- ^ Input scope.+  -> ScopeM (A.ImportDirective, Scope) -- ^ Scope-checked description, output scope.+applyImportDirectiveM m (ImportDirective rng usn' hdn' ren' public) scope0 = do -    let extraModules =-          [ x | ImportedName x <- names,-                let mx = ImportedModule x,-                 not $ doesntExist mx,-                 notElem mx names ]-        dir' = addExtraModules extraModules dir+    -- Module names do not come with fixities, thus, we should complain if the+    -- user has supplied fixity annotations to @renaming module@ clauses.+    checkNoFixityInRenamingModule ren' -    dir' <- sanityCheck dir'+    -- Andreas, 2020-06-06, issue #4707+    -- Duplicates in @using@ directive are dropped with a warning.+    usingList <- discardDuplicatesInUsing usn' +    -- The following check was originally performed by the parser.+    -- The Great Ulf Himself added the check back in the dawn of time+    -- (5ba14b647b9bd175733f9563e744176425c39126)+    -- when Agda 2 wasn't even believed to exist yet.+    verifyImportDirective usingList hdn' ren'++    -- 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'+    () <- 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+    let usn = filter notMissing usingList        -- remove missingExports from usn'+    let hdn = filter notMissing hdn'             -- remove missingExports from hdn'+    let ren = filter (notMissing . renFrom) ren'                   -- and from ren'+    let dir = ImportDirective rng (mapUsing (const usn) usn') hdn ren public++    -- Convenient shorthands for defined names and names brought into scope:+    let names        = map renFrom ren ++ hdn ++ usn+    let definedNames = map renTo ren+    let targetNames  = usn ++ definedNames++    -- Efficient test of (`elem` names):+    let inNames      = (names `hasElem`)++    -- Efficient test of whether a module import should be added to the import+    -- of a definition (like a data or record definition).+    let extra x = inNames (ImportedName   x)+               && notMissing (ImportedModule x)+               && (not . inNames $ ImportedModule x)+                  -- The last test implies that @hiding (module M)@ prevents @module M@+                  -- from entering the @using@ list in @addExtraModule@.++    dir' <- sanityCheck (not . inNames) $ addExtraModules extra dir+     -- Check for duplicate imports in a single import directive.     -- @dup@ : To be imported names that are mentioned more than once.-    let dup = targetNames \\ nub targetNames-    unless (null dup) $ typeError $ DuplicateImports m dup+    () <- List1.unlessNull (allDuplicates targetNames) $ \ dup ->+      typeError $ DuplicateImports m dup      -- Apply the import directive.-    let scope' = applyImportDirective dir' scope+    let (scope', (nameClashes, moduleClashes)) = applyImportDirective_ dir' scope +    -- Andreas, 2019-11-08, issue #4154, report clashes+    -- introduced by the @renaming@.+    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 = head . 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@@ -542,144 +913,170 @@     return (adir, scope') -- TODO Issue 1714: adir    where-    -- | Names in the @using@ directive.-    usingNames :: [ImportedName]-    usingNames = case u of-      Using  xs     -> xs-      UseEverything -> []--    -- | All names from the imported module mentioned in the import directive.-    names :: [ImportedName]-    names = map renFrom ren ++ h ++ usingNames--    -- | Names defined by the import (targets of renaming).-    definedNames :: [ImportedName]-    definedNames = map renTo ren+    -- Andreas, 2020-06-23, issue #4773, fixing regression in 2.5.1.+    -- Import directive may not mention private things.+    -- ```agda+    --   module M where private X = Set+    --   module N = M using (X)+    -- ```+    -- Further, modules (N) need not copy private things (X) from other+    -- modules (M) ever, since they cannot legally referred to+    -- (neither through qualification (N.X) nor open N).+    -- Thus, we can unconditionally remove private definitions+    -- before we apply the import directive.+    scope = restrictPrivate scope0 -    -- | Names to be in scope after import.-    targetNames :: [ImportedName]-    targetNames = definedNames ++ usingNames+    -- Return names in the @using@ directive, discarding duplicates.+    -- Monadic for the sake of throwing warnings.+    discardDuplicatesInUsing :: C.Using -> ScopeM [C.ImportedName]+    discardDuplicatesInUsing = \case+      UseEverything -> return []+      Using  xs     -> do+        let (ys, dups) = nubAndDuplicatesOn id xs+        List1.unlessNull dups $ warning . DuplicateUsing+        return ys -    sanityCheck dir =-      case (using dir, hiding dir) of-        (Using xs, ys) -> do-          let uselessHiding = [ x | x@ImportedName{} <- ys ] ++-                              [ x | x@(ImportedModule y) <- ys, ImportedName y `notElem` names ]-          unless (null uselessHiding) $ typeError $ GenericError $ "Hiding " ++ intercalate ", " (map show uselessHiding)-                                                                ++ " has no effect"+    -- If both @using@ and @hiding@ directive are present,+    -- the hiding directive may only contain modules whose twins are mentioned.+    -- Monadic for the sake of error reporting.+    sanityCheck notMentioned = \case+      dir@(ImportDirective{ using = Using{}, hiding = ys }) -> do+          let useless = \case+                ImportedName{}   -> True+                ImportedModule y -> notMentioned (ImportedName y)+          () <- 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 = [] }-        _ -> return dir+      dir -> return dir -    addExtraModules :: [C.Name] -> C.ImportDirective -> C.ImportDirective+    addExtraModules :: (C.Name -> Bool) -> C.ImportDirective -> C.ImportDirective     addExtraModules extra dir =-      dir{ using =-              case using dir of-                Using xs      -> Using $ concatMap addExtra xs-                UseEverything -> UseEverything-         , hiding      = concatMap addExtra      (hiding dir)-         , impRenaming = concatMap extraRenaming (impRenaming dir)+      dir{ using       = mapUsing (concatMap addExtra) $ using dir+         , hiding      = concatMap addExtra            $ hiding dir+         , impRenaming = concatMap extraRenaming       $ impRenaming dir          }       where-        addExtra f@(ImportedName y) | elem y extra = [f, ImportedModule y]+        addExtra f@(ImportedName y) | extra y = [f, ImportedModule y]         addExtra m = [m] -        extraRenaming r@(Renaming from to rng) =-          case (from, to) of-            (ImportedName y, ImportedName z) | elem y extra ->-              [r, Renaming (ImportedModule y) (ImportedModule z) rng]-            _ -> [r]+        extraRenaming = \case+          r@(Renaming (ImportedName y) (ImportedName z) _fixity rng) | extra y ->+             [ r , Renaming (ImportedModule y) (ImportedModule z) Nothing rng ]+          r -> [r] -    -- | Names and modules (abstract) in scope before the import.+    -- Names and modules (abstract) in scope before the import.     namesInScope   = (allNamesInScope scope :: ThingsInScope AbstractName)     modulesInScope = (allNamesInScope scope :: ThingsInScope AbstractModule)--    -- | AST versions of the concrete names from the imported module.-    --   @Nothing@ is one of the names is not exported.-    mNamesA = forM names $ \case-      ImportedName x   -> ImportedName   . (x,) . setRange (getRange x) . anameName . head <$> Map.lookup x namesInScope-      ImportedModule x -> ImportedModule . (x,) . setRange (getRange x) . amodName  . head <$> Map.lookup x modulesInScope--    head = headWithDefault __IMPOSSIBLE__--    -- For the sake of the error message, we (re)compute the list of unresolved names.-    doesntExport = do-      -- Names @xs@ mentioned in the import directive @dir@ but not in the @scope@.-      let xs = filter doesntExist names-      reportSLn "scope.import.apply" 20 $ "non existing names: " ++ show xs-      typeError $ ModuleDoesntExport m xs--    doesntExist (ImportedName   x) = isNothing $ Map.lookup x namesInScope-    doesntExist (ImportedModule x) = isNothing $ Map.lookup x modulesInScope+    concreteNamesInScope = (Map.keys namesInScope ++ Map.keys modulesInScope :: [C.Name]) --- | A finite map for @ImportedName@s.-lookupImportedName-  :: (Eq a, Eq b)-  => ImportedName' a b-  -> [ImportedName' (a,c) (b,d)]-  -> ImportedName' c d-lookupImportedName (ImportedName x) = loop where-  loop [] = __IMPOSSIBLE__-  loop (ImportedName (y,z) : _) | x == y = ImportedName z-  loop (_ : ns) = loop ns-lookupImportedName (ImportedModule x) = loop where-  loop [] = __IMPOSSIBLE__-  loop (ImportedModule (y,z) : _) | x == y = ImportedModule z-  loop (_ : ns) = loop ns+    -- AST versions of the concrete names passed as an argument.+    -- We get back a pair consisting of a list of missing exports first,+    -- and a list of successful imports second.+    checkExist :: [ImportedName] -> ([ImportedName], [ImportedName' (C.Name, A.QName) (C.Name, A.ModuleName)])+    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 (List1 b) -> Either err b+        resolve err x m = maybe (Left err) (Right . List1.head) $ Map.lookup x m  -- | Translation of @ImportDirective@. mapImportDir-  :: (Eq a, Eq b)-  => [ImportedName' (a,c) (b,d)]  -- ^ Translation of imported names.-  -> [ImportedName' (a,c) (b,d)]  -- ^ Translation of names defined by this import.-  -> ImportDirective' a b-  -> ImportDirective' c d-mapImportDir src tgt (ImportDirective r u h ren open) =+  :: (Ord n1, Ord m1)+  => [ImportedName' (n1,n2) (m1,m2)]  -- ^ Translation of imported names.+  -> [ImportedName' (n1,n2) (m1,m2)]  -- ^ Translation of names defined by this import.+  -> ImportDirective' n1 m1+  -> ImportDirective' n2 m2+mapImportDir src0 tgt0 (ImportDirective r u h ren open) =   ImportDirective r-    (mapUsing src u)-    (map (`lookupImportedName` src) h)-    (map (mapRenaming src tgt) ren) open+    (mapUsing (map (lookupImportedName src)) u)+    (map (lookupImportedName src) h)+    (map (mapRenaming src tgt) ren)+    open+  where+  src = importedNameMapFromList src0+  tgt = importedNameMapFromList tgt0 --- | Translation of @Using or Hiding@.-mapUsing-  :: (Eq a, Eq b)-  => [ImportedName' (a,c) (b,d)] -- ^ Translation of names in @using@ or @hiding@ list.-  -> Using' a b-  -> Using' c d-mapUsing src UseEverything = UseEverything-mapUsing src (Using  xs) = Using $ map (`lookupImportedName` src) xs+-- | A finite map for @ImportedName@s. +data ImportedNameMap n1 n2 m1 m2 = ImportedNameMap+  { inameMap   :: Map n1 n2+  , imoduleMap :: Map m1 m2+  }++-- | Create a 'ImportedNameMap'.+importedNameMapFromList+  :: (Ord n1, Ord m1)+  => [ImportedName' (n1,n2) (m1,m2)]+  -> ImportedNameMap n1 n2 m1 m2+importedNameMapFromList = foldr (flip add) $ ImportedNameMap Map.empty Map.empty+  where+  add (ImportedNameMap nm mm) = \case+    ImportedName   (x,y) -> ImportedNameMap (Map.insert x y nm) mm+    ImportedModule (x,y) -> ImportedNameMap nm (Map.insert x y mm)++-- | Apply a 'ImportedNameMap'.+lookupImportedName+  :: (Ord n1, Ord m1)+  => ImportedNameMap n1 n2 m1 m2+  -> ImportedName' n1 m1+  -> ImportedName' n2 m2+lookupImportedName (ImportedNameMap nm mm) = \case+    ImportedName   x -> ImportedName   $ Map.findWithDefault __IMPOSSIBLE__ x nm+    ImportedModule x -> ImportedModule $ Map.findWithDefault __IMPOSSIBLE__ x mm+ -- | Translation of @Renaming@. mapRenaming-  ::  (Eq a, Eq b)-  => [ImportedName' (a,c) (b,d)]  -- ^ Translation of 'renFrom' names.-  -> [ImportedName' (a,c) (b,d)]  -- ^ Translation of 'rento' names.-  -> Renaming' a b-  -> Renaming' c d-mapRenaming src tgt (Renaming from to r) =-  Renaming (lookupImportedName from src) (lookupImportedName to tgt) r+  ::  (Ord n1, Ord m1)+  => ImportedNameMap n1 n2 m1 m2  -- ^ Translation of 'renFrom' names and module names.+  -> ImportedNameMap n1 n2 m1 m2  -- ^ Translation of 'rento'   names and module names.+  -> Renaming' n1 m1  -- ^ Renaming before translation (1).+  -> Renaming' n2 m2  -- ^ Renaming after  translation (2).+mapRenaming src tgt (Renaming from to fixity r) =+  Renaming (lookupImportedName src from) (lookupImportedName tgt to) fixity r +---------------------------------------------------------------------------+-- * Opening a module+---------------------------------------------------------------------------++data OpenKind = LetOpenModule | TopOpenModule++noGeneralizedVarsIfLetOpen :: OpenKind -> Scope -> Scope+noGeneralizedVarsIfLetOpen TopOpenModule = id+noGeneralizedVarsIfLetOpen LetOpenModule = disallowGeneralizedVars+ -- | Open a module.-openModule_ :: C.QName -> C.ImportDirective -> ScopeM A.ImportDirective-openModule_ cm dir = do+openModule_ :: OpenKind -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective+openModule_ kind cm dir = openModule kind Nothing cm dir++-- | Open a module, possibly given an already resolved module name.+openModule :: OpenKind -> Maybe A.ModuleName  -> C.QName -> C.ImportDirective -> ScopeM A.ImportDirective+openModule kind mam cm dir = do   current <- getCurrentModule-  m <- amodName <$> resolveModule cm-  let acc | not (publicOpen dir)      = PrivateNS-          | m `isSubModuleOf` current = PublicNS-          | otherwise                 = ImportedNS+  m <- caseMaybe mam (amodName <$> resolveModule cm) return+  let acc | Nothing <- publicOpen dir     = PrivateNS+          | m `isLtChildModuleOf` current = PublicNS+          | otherwise                     = ImportedNS    -- Get the scope exported by module to be opened.-  (adir, s') <- applyImportDirectiveM cm dir . inScopeBecause (Opened cm) . removeOnlyQualified . restrictPrivate =<< getNamedScope m+  (adir, s') <- applyImportDirectiveM cm dir . inScopeBecause (Opened cm) .+                noGeneralizedVarsIfLetOpen kind =<< getNamedScope m   let s  = setScopeAccess acc s'   let ns = scopeNameSpace acc s-  checkForClashes ns   modifyCurrentScope (`mergeScope` s)+  -- Andreas, 2018-06-03, issue #3057:+  -- If we simply check for ambiguous exported identifiers _after_+  -- importing the new identifiers into the current scope, we also+  -- catch the case of importing an ambiguous identifier.+  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 = List.intersect locals newdefs-    reportSLn "scope.locals" 10 $ "opening module shadows the following locals vars: " ++ show shadowed+        shadowed = locals `List.intersect` newdefs+    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@@ -691,25 +1088,26 @@   where     -- Only checks for clashes that would lead to the same     -- name being exported twice from the module.-    checkForClashes new = when (publicOpen dir) $ do--        old <- allThingsInScope . restrictPrivate <$> (getNamedScope =<< getCurrentModule)+    checkForClashes = when (isJust $ publicOpen dir) $ do -        let defClashes = Map.toList $ Map.intersectionWith (,) (nsNames new) (nsNames old)-            modClashes = Map.toList $ Map.intersectionWith (,) (nsModules new) (nsModules old)+        exported <- allThingsInScope . restrictPrivate <$> (getNamedScope =<< getCurrentModule) -            -- No ambiguity if concrete identifier is mapped to-            -- single, identical abstract identifiers.-            realClash (_, ([x],[y])) = x /= y-            realClash _              = True+        -- Get all exported concrete names that are mapped to at least 2 abstract names+        let defClashes = filter (\ (_c, as) -> length as >= 2) $ Map.toList $ nsNames exported+            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 (_, (qs0, qs1)) = not $ all (== ConName) ks || all (==FldName) ks-              where ks = map anameKind $ qs0 ++ qs1+            -- 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 -> realClash x && defClash x) defClashes) $-          \ ((x, (_, q:_)) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q)+        () <- List1.unlessNull (filter defClash defClashes) $+          \ ((x, q :| _) :| _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing -        unlessNull (filter realClash modClashes) $ \ ((_, (m0:_, m1:_)) : _) ->-          typeError $ ClashingModule (amodName m0) (amodName m1)+        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,1084 +1,1890 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE UndecidableInstances   #-}---- {-# OPTIONS -fwarn-unused-binds #-}--{-| The translation of abstract syntax to concrete syntax has two purposes.-    First it allows us to pretty print abstract syntax values without having to-    write a dedicated pretty printer, and second it serves as a sanity check-    for the concrete to abstract translation: translating from concrete to-    abstract and then back again should be (more or less) the identity.--}-module Agda.Syntax.Translation.AbstractToConcrete-    ( ToConcrete(..)-    , toConcreteCtx-    , abstractToConcrete_-    , abstractToConcreteEnv-    , runAbsToCon-    , RangeAndPragma(..)-    , abstractToConcreteCtx-    , withScope-    , makeEnv-    , AbsToCon, DontTouchMe, Env-    , noTakenNames-    ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import Control.Monad.Reader--import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Traversable (traverse)-import Data.Void--import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Info-import Agda.Syntax.Internal (MetaId(..))-import Agda.Syntax.Fixity-import Agda.Syntax.Concrete as C-import Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views as AV-import Agda.Syntax.Scope.Base--import Agda.TypeChecking.Monad.State (getScope)-import Agda.TypeChecking.Monad.Base  (TCM, NamedMeta(..))-import Agda.TypeChecking.Monad.Options--import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.Either-import Agda.Utils.Functor-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Singleton-import Agda.Utils.Tuple-import Agda.Utils.Pretty (prettyShow)--#include "undefined.h"-import Agda.Utils.Impossible---- Environment --------------------------------------------------------------data Env = Env { takenNames   :: Set C.Name-               , currentScope :: ScopeInfo-               }--defaultEnv :: Env-defaultEnv = Env { takenNames   = Set.empty-                 , currentScope = emptyScopeInfo-                 }--makeEnv :: ScopeInfo -> Env-makeEnv scope = Env { takenNames   = Set.union vars defs-                    , currentScope = scope-                    }-  where-    vars  = Set.fromList $ map fst $ scopeLocals scope-    defs  = Map.keysSet $ nsNames $ everythingInScope scope--currentPrecedence :: AbsToCon Precedence-currentPrecedence = asks $ scopePrecedence . currentScope--withPrecedence :: Precedence -> AbsToCon a -> AbsToCon a-withPrecedence p = local $ \e ->-  e { currentScope = (currentScope e) { scopePrecedence = p } }--withScope :: ScopeInfo -> AbsToCon a -> AbsToCon a-withScope scope = local $ \e -> e { currentScope = scope }--noTakenNames :: AbsToCon a -> AbsToCon a-noTakenNames = local $ \e -> e { takenNames = Set.empty }---- The Monad ------------------------------------------------------------------ | We put the translation into TCM in order to print debug messages.-type AbsToCon = ReaderT Env TCM--runAbsToCon :: AbsToCon c -> TCM c-runAbsToCon m = do-  scope <- getScope-  runReaderT m (makeEnv scope)--abstractToConcreteEnv :: ToConcrete a c => Env -> a -> TCM c-abstractToConcreteEnv flags a = runReaderT (toConcrete a) flags--abstractToConcreteCtx :: ToConcrete a c => Precedence -> a -> TCM c-abstractToConcreteCtx ctx x = do-  scope <- getScope-  let scope' = scope { scopePrecedence = ctx }-  abstractToConcreteEnv (makeEnv scope') x--abstractToConcrete_ :: ToConcrete a c => a -> TCM c-abstractToConcrete_ = runAbsToCon . toConcrete---- 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---   correct), we should get a non-qualified name when translating back to a---   concrete name, but I suspect the scope isn't always perfect. In these---   cases we just throw away the qualified part. It's just for pretty printing---   anyway...-unsafeQNameToName :: C.QName -> C.Name-unsafeQNameToName = C.unqualify--lookupName :: A.Name -> AbsToCon C.Name-lookupName x = do-  names <- asks $ scopeLocals . currentScope-  case lookup x $ mapMaybe (\ (c,x) -> (,c) <$> notShadowedLocal x) names of-      Just y  -> return y-      Nothing -> return $ nameConcrete x--lookupQName :: AllowAmbiguousNames -> A.QName -> AbsToCon C.QName-lookupQName ambCon x = do-  ys <- inverseScopeLookupName' ambCon x <$> asks currentScope-  lift $ reportSLn "scope.inverse" 100 $-    "inverse looking up abstract name " ++ show x ++ " yields " ++ show ys-  case ys of-    (y : _) -> return y-    [] -> do-      let y = qnameToConcrete x-      if isUnderscore y-        -- -- || any (isUnderscore . A.nameConcrete) (A.mnameToList $ A.qnameModule x)-        then return y-        else return $ C.Qual (C.Name noRange [Id empty]) y-        -- this is what happens for names that are not in scope (private names)--lookupModule :: A.ModuleName -> AbsToCon C.QName-lookupModule (A.MName []) = return $ C.QName $ C.Name noRange [Id "-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-  -- frontmatter or module telescope of the top level module.-  -- In this case, we print it as an invalid module name.-  -- (Should only affect debug printing.)-lookupModule x =-    do  scope <- asks currentScope-        case inverseScopeLookupModule x scope of-            (y : _) -> return y-            []      -> return $ mnameToConcrete x-                -- this is what happens for names that are not in scope (private names)--bindName :: A.Name -> (C.Name -> AbsToCon a) -> AbsToCon a-bindName x ret = do-  names <- asks takenNames-  let y = nameConcrete x-  case (Set.member y names) of-    _ | isNoName y -> ret y-    True           -> bindName (nextName x) ret-    False          ->-        local (\e -> e { takenNames   = Set.insert y $ takenNames e-                       , currentScope = (`updateScopeLocals` currentScope e) $-                           AssocList.insert y (LocalVar x)-                       }-              ) $ ret y---- Dealing with precedences --------------------------------------------------- | General bracketing function.-bracket' ::    (e -> e)             -- ^ the bracketing function-            -> (Precedence -> Bool) -- ^ Should we bracket things-                                    --   which have the given-                                    --   precedence?-            -> e -> AbsToCon e-bracket' paren needParen e =-    do  p <- currentPrecedence-        return $ if needParen p then paren e else e---- | Expression bracketing-bracket :: (Precedence -> Bool) -> AbsToCon C.Expr -> AbsToCon C.Expr-bracket par m =-    do  e <- m-        bracket' (Paren (getRange e)) par e---- | Pattern bracketing-bracketP_ :: (Precedence -> Bool) -> AbsToCon C.Pattern -> AbsToCon C.Pattern-bracketP_ par m =-    do  e <- m-        bracket' (ParenP (getRange e)) par e--{- UNUSED--- | Pattern bracketing-bracketP :: (Precedence -> 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--}---- 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 i x m = do-  ds <- m-  return $ fixDecl ++ synDecl ++ ds- where fixDecl = [C.Infix (theFixity $ defFixity i) [x] | theFixity (defFixity i) /= noFixity]-       synDecl = [C.Syntax x (theNotation (defFixity i))]--{- UNUSED-withInfixDecls :: [(DefInfo, C.Name)] -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]-withInfixDecls = foldr (.) id . map (uncurry withInfixDecl)--}---- Dealing with private definitions ------------------------------------------- | Add @abstract@, @private@, @instance@ modifiers.-withAbstractPrivate :: DefInfo -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]-withAbstractPrivate i m =-    priv (defAccess i)-      . abst (defAbstract i)-      . addInstanceB (defInstance i == InstanceDef)-      <$> m-    where-        priv (PrivateAccess UserWritten)-                         ds = [ C.Private  (getRange ds) UserWritten ds ]-        priv _           ds = ds-        abst AbstractDef ds = [ C.Abstract (getRange ds) ds ]-        abst ConcreteDef ds = ds--addInstanceB :: Bool -> [C.Declaration] -> [C.Declaration]-addInstanceB True  ds = [ C.InstanceB (getRange ds) ds ]-addInstanceB False ds = ds---- The To Concrete Class ----------------------------------------------------class ToConcrete a c | a -> c where-    toConcrete :: a -> AbsToCon c-    bindToConcrete :: a -> (c -> AbsToCon b) -> AbsToCon b--    toConcrete     x     = bindToConcrete x return-    bindToConcrete x ret = ret =<< toConcrete x---- | Translate something in a context of the given precedence.-toConcreteCtx :: ToConcrete a c => Precedence -> a -> AbsToCon c-toConcreteCtx p x = withPrecedence p $ toConcrete x---- | Translate something in a context of the given precedence.-bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b-bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret---- | Translate something in the top context.-toConcreteTop :: ToConcrete a c => a -> AbsToCon c-toConcreteTop = toConcreteCtx TopCtx---- | Translate something in the top context.-bindToConcreteTop :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b-bindToConcreteTop = bindToConcreteCtx TopCtx---- | Translate something in a context indicated by 'Hiding' info.-toConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> AbsToCon c-toConcreteHiding h =-  case getHiding h of-    NotHidden -> toConcrete-    Hidden    -> toConcreteTop-    Instance  -> toConcreteTop---- | Translate something in a context indicated by 'Hiding' info.-bindToConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> (c -> AbsToCon b) -> AbsToCon b-bindToConcreteHiding h =-  case getHiding h of-    NotHidden -> bindToConcrete-    Hidden    -> bindToConcreteTop-    Instance  -> bindToConcreteTop---- General instances --------------------------------------------------------instance ToConcrete a c => ToConcrete [a] [c] where-    toConcrete     = mapM toConcrete-    bindToConcrete = thread bindToConcrete--instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (Either a1 a2) (Either c1 c2) where-    toConcrete = traverseEither toConcrete toConcrete-    bindToConcrete (Left x) ret =-        bindToConcrete x $ \x ->-        ret (Left x)-    bindToConcrete (Right y) ret =-        bindToConcrete y $ \y ->-        ret (Right y)--instance (ToConcrete a1 c1, ToConcrete a2 c2) => ToConcrete (a1,a2) (c1,c2) where-    toConcrete (x,y) = liftM2 (,) (toConcrete x) (toConcrete y)-    bindToConcrete (x,y) ret =-        bindToConcrete x $ \x ->-        bindToConcrete y $ \y ->-        ret (x,y)--instance (ToConcrete a1 c1, ToConcrete a2 c2, ToConcrete a3 c3) =>-         ToConcrete (a1,a2,a3) (c1,c2,c3) where-    toConcrete (x,y,z) = reorder <$> toConcrete (x,(y,z))-        where-            reorder (x,(y,z)) = (x,y,z)--    bindToConcrete (x,y,z) ret = bindToConcrete (x,(y,z)) $ ret . reorder-        where-            reorder (x,(y,z)) = (x,y,z)--instance ToConcrete a c => ToConcrete (Arg a) (Arg c) where-    toConcrete (Arg i a) = Arg i <$> toConcreteHiding i a--    bindToConcrete (Arg info x) ret =-      bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $-        ret . Arg info--instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where-  toConcrete     (WithHiding h a) = WithHiding h <$> toConcreteHiding h a-  bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a ->-    ret $ WithHiding h a--instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where-    toConcrete (Named n x) = Named n <$> toConcrete x-    bindToConcrete (Named n x) ret = bindToConcrete x $ ret . Named n--newtype DontTouchMe a = DontTouchMe a--instance ToConcrete (DontTouchMe a) a where-    toConcrete (DontTouchMe x) = return x---- Names --------------------------------------------------------------------instance ToConcrete A.Name C.Name where-  toConcrete       = lookupName-  bindToConcrete x = bindName x--instance ToConcrete A.QName C.QName where-  toConcrete = lookupQName AmbiguousConProjs--instance ToConcrete A.ModuleName C.QName where-  toConcrete = lookupModule---- Expression instance ------------------------------------------------------instance ToConcrete A.Expr C.Expr where-    toConcrete (Var x)            = Ident . C.QName <$> toConcrete x-    toConcrete (Def x)            = Ident <$> toConcrete x-    toConcrete (Proj ProjPrefix (AmbQ (x:_))) = Ident <$> toConcrete x-    toConcrete (Proj _          (AmbQ (x:_))) =-      C.Dot (getRange x) . Ident <$> toConcrete x-    toConcrete Proj{}             = __IMPOSSIBLE__-    toConcrete (A.Macro x)        = Ident <$> toConcrete x-    toConcrete (Con (AmbQ (x:_))) = Ident <$> toConcrete x-    toConcrete (Con (AmbQ []))    = __IMPOSSIBLE__-        -- 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)-    toConcrete (A.Lit (LitQName r x)) = do-      x <- lookupQName AmbiguousNothing x-      bracket appBrackets $ return $-        C.App r (C.Quote r) (defaultNamedArg $ C.Ident x)-    toConcrete (A.Lit l)            = return $ C.Lit l--    -- Andreas, 2014-05-17  We print question marks with their-    -- interaction id, in case @metaNumber /= Nothing@-    toConcrete (A.QuestionMark i ii)= return $-      C.QuestionMark (getRange i) $-        interactionId ii <$ metaNumber i--    toConcrete (A.Underscore i)     = return $-      C.Underscore (getRange i) $-        prettyShow . NamedMeta (metaNameSuggestion i) . MetaId . metaId <$> metaNumber i--    toConcrete (A.Dot i e) =-      C.Dot (getRange i) <$> toConcrete e--    toConcrete e@(A.App i e1 e2)    =-        tryToRecoverOpApp e-        -- or fallback to App-        $ bracket appBrackets-        $ do e1' <- toConcreteCtx FunctionCtx e1-             e2' <- toConcreteCtx ArgumentCtx e2-             return $ C.App (getRange i) e1' e2'--    toConcrete (A.WithApp i e es) =-      bracket withAppBrackets $ do-        e <- toConcreteCtx WithFunCtx e-        es <- mapM (toConcreteCtx WithArgCtx) es-        return $ C.WithApp (getRange i) e es--    toConcrete (A.AbsurdLam i h) =-      bracket lamBrackets $ return $ C.AbsurdLam (getRange i) h-    toConcrete e@(A.Lam i _ _)      =-        bracket lamBrackets-        $ case lamView e of-            (bs, e) ->-                bindToConcrete (map makeDomainFree bs) $ \bs -> do-                    e  <- toConcreteTop e-                    return $ C.Lam (getRange i) (concat bs) e-        where-            lamView (A.Lam _ b@(A.DomainFree _ _) e) =-                case lamView e of-                    ([], e)                        -> ([b], e)-                    (bs@(A.DomainFree _ _ : _), e) -> (b:bs, e)-                    _                              -> ([b], e)-            lamView (A.Lam _ b@(A.DomainFull _) e) =-                case lamView e of-                    ([], e)                        -> ([b], e)-                    (bs@(A.DomainFull _ : _), e)   -> (b:bs, e)-                    _                              -> ([b], e)-            lamView e = ([], e)-    toConcrete (A.ExtendedLam i di qname cs) =-        bracket lamBrackets $ do-          decls <- concat <$> toConcrete cs-          let namedPat np = case getHiding np of-                 NotHidden -> namedArg np-                 Hidden    -> C.HiddenP noRange (unArg np)-                 Instance  -> C.InstanceP noRange (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.RawAppP r (_:es)) = return $ C.RawAppP r es-              removeApp (C.AppP (C.IdentP _) np) = return $ namedPat np-              removeApp (C.AppP p np) = do-                p <- removeApp p-                return $ C.AppP p np-              removeApp p = do-                lift $ reportSLn "extendedlambda" 50 $ "abstractToConcrete removeApp p = " ++ show p-                return p -- __IMPOSSIBLE__ -- Andreas, this is actually not impossible, my strictification exposed this sleeping bug-          let decl2clause (C.FunClause lhs rhs wh ca) = do-                let p = lhsOriginalPattern lhs-                lift $ reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p = " ++ show p-                p' <- removeApp p-                lift $ reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p' = " ++ show p'-                return (lhs{ lhsOriginalPattern = p' }, rhs, wh, ca)-              decl2clause _ = __IMPOSSIBLE__-          C.ExtendedLam (getRange i) <$> mapM decl2clause decls-    toConcrete (A.Pi _ [] e) = toConcrete e-    toConcrete t@(A.Pi i _ _)  = case piTel t of-      (tel, e) ->-        bracket piBrackets-        $ bindToConcrete tel $ \b' -> do-             e' <- toConcreteTop e-             return $ C.Pi (concat b') e'-      where-        piTel (A.Pi _ tel e) = (tel ++) -*- id $ piTel e-        piTel e              = ([], e)--    toConcrete (A.Fun i a b) =-        bracket piBrackets-        $ do a' <- toConcreteCtx (if irr then DotPatternCtx else FunctionSpaceDomainCtx) a-             b' <- toConcreteTop b-             return $ C.Fun (getRange i) (addRel a' $ mkArg a') b'-        where-            irr        = getRelevance a `elem` [Irrelevant, NonStrict]-            addRel a e = case getRelevance a of-                           Irrelevant -> addDot a e-                           NonStrict  -> addDot a (addDot a e)-                           _          -> e-            addDot a e = C.Dot (getRange a) e-            mkArg (Arg info e) = case getHiding info of-                                          Hidden    -> HiddenArg   (getRange e) (unnamed e)-                                          Instance  -> InstanceArg (getRange e) (unnamed e)-                                          NotHidden -> e--    toConcrete (A.Set i 0)  = return $ C.Set (getRange i)-    toConcrete (A.Set i n)  = return $ C.SetN (getRange i) n-    toConcrete (A.Prop i)   = return $ C.Prop (getRange i)--    toConcrete (A.Let i ds e) =-        bracket lamBrackets-        $ bindToConcrete ds $ \ds' -> do-             e'  <- toConcreteTop e-             return $ C.Let (getRange i) (concat ds') e'--    toConcrete (A.Rec i fs) =-      bracket appBrackets $ do-        C.Rec (getRange i) . map (fmap (\x -> ModuleAssignment x [] defaultImportDir)) <$> toConcreteTop fs--    toConcrete (A.RecUpdate i e fs) =-      bracket appBrackets $ do-        C.RecUpdate (getRange i) <$> toConcrete e <*> toConcreteTop fs--    toConcrete (A.ETel tel) = do-      tel <- concat <$> toConcrete tel-      return $ C.ETel tel--    toConcrete (A.ScopedExpr _ e) = toConcrete e--    toConcrete (A.QuoteGoal i x e) =-      bracket lamBrackets $-        bindToConcrete x $ \ x' -> do-            e' <- toConcrete e-            return $ C.QuoteGoal (getRange i) x' e'-    toConcrete (A.QuoteContext i) = return $ C.QuoteContext (getRange i)-    toConcrete (A.Quote i) = return $ C.Quote (getRange i)-    toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i)-    toConcrete (A.Unquote i) = return $ C.Unquote (getRange i)-    toConcrete (A.Tactic i e xs ys) = do-      e' <- toConcrete e-      xs' <- toConcrete xs-      ys' <- toConcrete ys-      let r      = getRange i-          rawtac = foldl (C.App r) e' xs'-      return $ C.Tactic (getRange i) rawtac (map namedArg ys')--    -- 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-       where r = getRange e-    toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete n--makeDomainFree :: A.LamBinding -> A.LamBinding-makeDomainFree b@(A.DomainFull (A.TypedBindings r (Arg info (A.TBind _ [WithHiding h x] t)))) =-  case unScope t of-    A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree (mapHiding (mappend h) info) x-    _ -> b-makeDomainFree b = b--instance ToConcrete a c => ToConcrete (FieldAssignment' a) (FieldAssignment' c) where-    toConcrete = traverse toConcrete---- Binder instances ---------------------------------------------------------instance ToConcrete A.LamBinding [C.LamBinding] where-    bindToConcrete (A.DomainFree info x) ret = bindToConcrete x $ ret . (:[]) . C.DomainFree info . mkBoundName_-    bindToConcrete (A.DomainFull b)      ret = bindToConcrete b $ ret . map C.DomainFull--instance ToConcrete A.TypedBindings [C.TypedBindings] where-  bindToConcrete (A.TypedBindings r bs) ret =-    bindToConcrete bs $ \cbs ->-    ret (map (C.TypedBindings r) $ recoverLabels bs cbs)-    where-      recoverLabels :: Arg A.TypedBinding -> Arg C.TypedBinding -> [Arg C.TypedBinding]-      recoverLabels b cb-        | getHiding b == NotHidden = [cb]   -- We don't care about labels for explicit args-        | otherwise = traverse (recover (unArg b)) cb--      recover (A.TBind _ xs _) (C.TBind r ys e) = tbind r e (zipWith label xs ys)-      recover A.TLet{}         c@C.TLet{}       = [c]-      recover _ _ = __IMPOSSIBLE__--      tbinds r e [] = []-      tbinds r e xs = [ C.TBind r xs e ]--      tbind r e xs =-        case span ((\ x -> boundLabel x == boundName x) . dget) xs of-          (xs, x:ys) -> tbinds r e xs ++ [ C.TBind r [x] e ] ++ tbind r e ys-          (xs, [])   -> tbinds r e xs--      label x = fmap $ \ y -> y { boundLabel = nameConcrete $ dget x }--instance ToConcrete A.TypedBinding C.TypedBinding where-    bindToConcrete (A.TBind r xs e) ret =-        bindToConcrete xs $ \ xs -> do-        e <- toConcreteTop e-        ret $ C.TBind r (map (fmap mkBoundName_) xs) e-    bindToConcrete (A.TLet r lbs) ret =-        bindToConcrete lbs $ \ ds -> do-        ret $ C.TLet r $ concat ds--instance ToConcrete LetBinding [C.Declaration] where-    bindToConcrete (LetBind i info x t e) ret =-        bindToConcrete x $ \x ->-        do (t,(e, [], [], [])) <- toConcrete (t, A.RHS e Nothing)-           ret $ addInstanceB (getHiding info == Instance) $-               [ C.TypeSig info x t-               , C.FunClause (C.LHS (C.IdentP $ C.QName x) [] [] [])-                             e C.NoWhere False-               ]-    -- 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-      x' <- unqualify <$> toConcrete x-      modapp <- toConcrete modapp-      let r = getRange modapp-          open = maybe DontOpen id $ minfoOpenShort i-          dir  = maybe defaultImportDir{ importDirRange = r } id $ 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 ]-    bindToConcrete (LetOpen i x _) ret = do-      x' <- toConcrete x-      let dir = maybe defaultImportDir id $ 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 []--data AsWhereDecls = AsWhereDecls [A.Declaration]--instance ToConcrete AsWhereDecls WhereClause where-  bindToConcrete (AsWhereDecls []) ret = ret C.NoWhere-  bindToConcrete (AsWhereDecls ds@[Section _ am _ _]) 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 else SomeWhere cm PublicAccess) $ ds'-    local (openModule' am defaultImportDir id) $ ret wh'-  bindToConcrete (AsWhereDecls ds) ret =-    ret . AnyWhere =<< declsToConcrete ds--mergeSigAndDef :: [C.Declaration] -> [C.Declaration]-mergeSigAndDef (C.RecordSig _ x bs e : C.Record r y ind eta c _ Nothing fs : ds)-  | x == y = C.Record r y ind eta c bs (Just e) fs : mergeSigAndDef ds-mergeSigAndDef (C.DataSig _ _ x bs e : C.Data r i y _ Nothing cs : ds)-  | x == y = C.Data r i y bs (Just e) cs : mergeSigAndDef ds-mergeSigAndDef (d : ds) = d : mergeSigAndDef ds-mergeSigAndDef [] = []--openModule' :: A.ModuleName -> C.ImportDirective -> (Scope -> Scope) -> Env -> Env-openModule' x dir restrict env = env{currentScope = sInfo{scopeModules = mods'}}-  where sInfo = currentScope env-        amod  = scopeCurrent sInfo-        mods  = scopeModules sInfo-        news  = setScopeAccess PrivateNS-                $ applyImportDirective dir-                $ maybe emptyScope restrict-                $ Map.lookup x mods-        mods' = Map.update (Just . (`mergeScope` news)) amod mods----- Declaration instances ----------------------------------------------------declsToConcrete :: [A.Declaration] -> AbsToCon [C.Declaration]-declsToConcrete ds = mergeSigAndDef . concat <$> toConcrete ds--instance ToConcrete A.RHS (C.RHS, [C.Expr], [C.Expr], [C.Declaration]) where-    toConcrete (A.RHS e (Just c)) = return (C.RHS c, [], [], [])-    toConcrete (A.RHS e Nothing) = do-      e <- toConcrete e-      return (C.RHS e, [], [], [])-    toConcrete A.AbsurdRHS = return (C.AbsurdRHS, [], [], [])-    toConcrete (A.WithRHS _ es cs) = do-      es <- toConcrete es-      cs <- concat <$> toConcrete cs-      return (C.AbsurdRHS, [], es, cs)-    toConcrete (A.RewriteRHS xeqs rhs wh) = do-      wh <- declsToConcrete wh-      (rhs, eqs', es, whs) <- toConcrete rhs-      unless (null eqs')-        __IMPOSSIBLE__-      eqs <- toConcrete $ map snd xeqs-      return (rhs, eqs, es, wh ++ whs)--instance ToConcrete (Maybe A.QName) (Maybe C.Name) where-  toConcrete Nothing = return Nothing-  toConcrete (Just x) = do-    x' <- toConcrete (qnameName x)-    return $ Just x'--instance ToConcrete (Constr A.Constructor) C.Declaration where-  toConcrete (Constr (A.ScopedDecl scope [d])) =-    withScope scope $ toConcrete (Constr d)-  toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do-    x' <- unsafeQNameToName <$> toConcrete x-    t' <- toConcreteTop t-    return $ C.TypeSig info x' t'-  toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__-  toConcrete (Constr d) = head <$> toConcrete d--instance ToConcrete a C.LHS => ToConcrete (A.Clause' a) [C.Declaration] where-  toConcrete (A.Clause lhs _ rhs wh catchall) =-      bindToConcrete lhs $ \lhs ->-        case lhs of-          C.LHS p wps _ _ -> do-            bindToConcrete (AsWhereDecls wh)  $ \wh' -> do-                (rhs', eqs, with, wcs) <- toConcreteTop rhs-                return $ FunClause (C.LHS p wps eqs with) rhs' wh' catchall : wcs-          C.Ellipsis {} -> __IMPOSSIBLE__-          -- TODO: Is the case above impossible? Previously there was-          -- no code for it, but GHC 7's completeness checker spotted-          -- that the case was not covered.--instance ToConcrete A.ModuleApplication C.ModuleApplication where-  toConcrete (A.SectionApp tel y es) = do-    y  <- toConcreteCtx FunctionCtx y-    bindToConcrete tel $ \tel -> do-      es <- toConcreteCtx ArgumentCtx es-      let r = fuseRange y es-      return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es)--  toConcrete (A.RecordModuleIFS recm) = do-    recm <- toConcrete recm-    return $ C.RecordModuleIFS (getRange recm) recm--instance ToConcrete A.Declaration [C.Declaration] where-  toConcrete (ScopedDecl scope ds) =-    withScope scope (declsToConcrete ds)--  toConcrete (Axiom _ i info mp x t) = do-    x' <- unsafeQNameToName <$> toConcrete x-    withAbstractPrivate i $-      withInfixDecl i x'  $ do-      t' <- toConcreteTop t-      return $-        (case mp of-           Nothing   -> []-           Just occs -> [C.Pragma (PolarityPragma noRange x' occs)]) ++-        [C.Postulate (getRange i) [C.TypeSig info x' t']]--  toConcrete (A.Field i x t) = do-    x' <- unsafeQNameToName <$> toConcrete x-    withAbstractPrivate i $-      withInfixDecl i x'  $ do-      t' <- toConcreteTop t-      return [C.Field (defInstance i) x' t']--  toConcrete (A.Primitive i x t) = do-    x' <- unsafeQNameToName <$> toConcrete x-    withAbstractPrivate i $-      withInfixDecl i x'  $ do-      t' <- toConcreteTop t-      return [C.Primitive (getRange i) [C.TypeSig defaultArgInfo x' t']]-        -- Primitives are always relevant.--  toConcrete (A.FunDef i _ _ cs) =-    withAbstractPrivate i $ concat <$> toConcrete cs--  toConcrete (A.DataSig i x bs t) =-    withAbstractPrivate i $-    bindToConcrete bs $ \tel' -> do-      x' <- unsafeQNameToName <$> toConcrete x-      t' <- toConcreteTop t-      return [ C.DataSig (getRange i) Inductive x' (map C.DomainFull $ concat tel') t' ]--  toConcrete (A.DataDef i x bs cs) =-    withAbstractPrivate i $-    bindToConcrete (map makeDomainFree bs) $ \tel' -> do-      (x',cs') <- (unsafeQNameToName -*- id) <$> toConcrete (x, map Constr cs)-      return [ C.Data (getRange i) Inductive x' (concat tel') Nothing cs' ]--  toConcrete (A.RecSig i x bs t) =-    withAbstractPrivate i $-    bindToConcrete bs $ \tel' -> do-      x' <- unsafeQNameToName <$> toConcrete x-      t' <- toConcreteTop t-      return [ C.RecordSig (getRange i) x' (map C.DomainFull $ concat tel') t' ]--  toConcrete (A.RecDef  i x ind eta c bs t cs) =-    withAbstractPrivate i $-    bindToConcrete (map makeDomainFree bs) $ \tel' -> do-      (x',cs') <- (unsafeQNameToName -*- id) <$> toConcrete (x, map Constr cs)-      return [ C.Record (getRange i) x' ind eta Nothing (concat tel') Nothing cs' ]--  toConcrete (A.Mutual i ds) = declsToConcrete ds--  toConcrete (A.Section i x tel ds) = do-    x <- toConcrete x-    bindToConcrete tel $ \tel -> do-      ds <- declsToConcrete ds-      return [ C.Module (getRange i) x (concat tel) ds ]--  toConcrete (A.Apply i 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 ]--  toConcrete (A.Import i x _) = do-    x <- toConcrete x-    let open = maybe DontOpen id $ minfoOpenShort i-        dir  = maybe defaultImportDir id $ minfoDirective i-    return [ C.Import (getRange i) x Nothing open dir]--  toConcrete (A.Pragma i p)     = do-    p <- toConcrete $ RangeAndPragma (getRange i) p-    return [C.Pragma p]--  toConcrete (A.Open i x _) = do-    x <- toConcrete x-    return [C.Open (getRange i) x defaultImportDir]--  toConcrete (A.PatternSynDef x xs p) = do-    C.QName x <- toConcrete x-    bindToConcrete xs $ \xs -> (:[]) . C.PatternSyn (getRange x) x xs <$> toConcrete (vacuous p :: A.Pattern)--  toConcrete (A.UnquoteDecl _ i xs e) = do-    let unqual (C.QName x) = return x-        unqual _           = __IMPOSSIBLE__-    xs <- mapM (unqual <=< toConcrete) xs-    (:[]) . C.UnquoteDecl (getRange i) xs <$> toConcrete e--  toConcrete (A.UnquoteDef i xs e) = do-    let unqual (C.QName x) = return x-        unqual _           = __IMPOSSIBLE__-    xs <- mapM (unqual <=< toConcrete) xs-    (:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete e---data RangeAndPragma = RangeAndPragma Range A.Pragma--instance ToConcrete RangeAndPragma C.Pragma where-  toConcrete (RangeAndPragma r p) = case p of-    A.OptionsPragma xs  -> return $ C.OptionsPragma r xs-    A.BuiltinPragma b e      -> C.BuiltinPragma r b <$> toConcrete e-    A.BuiltinNoDefPragma b x -> C.BuiltinPragma r b . C.Ident <$>-      toConcrete x-    A.RewritePragma x        -> C.RewritePragma r . singleton <$> toConcrete x-    A.CompiledTypePragma x hs -> do-      x <- toConcrete x-      return $ C.CompiledTypePragma r x hs-    A.CompiledDataPragma x hs hcs -> do-      x <- toConcrete x-      return $ C.CompiledDataPragma r x hs hcs-    A.CompiledDeclareDataPragma x hs -> do-      x <- toConcrete x-      return $ C.CompiledDeclareDataPragma r x hs-    A.CompiledPragma x hs -> do-      x <- toConcrete x-      return $ C.CompiledPragma r x hs-    A.CompiledExportPragma x hs -> do-      x <- toConcrete x-      return $ C.CompiledExportPragma r x hs-    A.CompiledEpicPragma x e -> do-      x <- toConcrete x-      return $ C.CompiledEpicPragma r x e-    A.CompiledJSPragma x e -> do-      x <- toConcrete x-      return $ C.CompiledJSPragma r x e-    A.CompiledUHCPragma x cr -> do-      x <- toConcrete x-      return $ C.CompiledUHCPragma r x cr-    A.CompiledDataUHCPragma x crd crcs -> do-      x <- toConcrete x-      return $ C.CompiledDataUHCPragma r x crd crcs-    A.StaticPragma x -> C.StaticPragma r <$> toConcrete x-    A.InlinePragma x -> C.InlinePragma r <$> toConcrete x-    A.DisplayPragma f ps rhs ->-      C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) (AmbQ [f]) ps) <*> toConcrete rhs---- Left hand sides ----------------------------------------------------------instance ToConcrete A.SpineLHS C.LHS where-  bindToConcrete lhs = bindToConcrete (A.spineToLhs lhs :: A.LHS)--instance ToConcrete A.LHS C.LHS where-    bindToConcrete (A.LHS i lhscore wps) ret = do-      bindToConcreteCtx TopCtx lhscore $ \lhs ->-        bindToConcreteCtx TopCtx wps $ \wps ->-          ret $ C.LHS lhs wps [] []--instance ToConcrete A.LHSCore C.Pattern where-  bindToConcrete = bindToConcrete . lhsCoreToPattern--appBrackets' :: [arg] -> Precedence -> Bool-appBrackets' []    _   = False-appBrackets' (_:_) ctx = appBrackets ctx--newtype BindingPattern = BindingPat A.Pattern-newtype FreshName = FreshenName A.Name--instance ToConcrete FreshName A.Name where-  bindToConcrete (FreshenName x) ret = bindToConcrete x $ \ y -> ret x{ nameConcrete = y }---- Takes care of freshening and binding pattern variables, but doesn't actually--- translate anything to Concrete.-instance ToConcrete BindingPattern A.Pattern where-  bindToConcrete (BindingPat p) ret =-    case p of-      A.VarP x               -> bindToConcrete (FreshenName x) $ ret . A.VarP-      A.WildP{}              -> ret p-      A.ProjP{}              -> ret p-      A.AbsurdP{}            -> ret p-      A.LitP{}               -> ret p-      A.DotP{}               -> ret p-      A.ConP i c args        -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.ConP i c-      A.DefP i f args        -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.DefP i f-      A.PatternSynP i f args -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.PatternSynP i f-      A.RecP i args          -> bindToConcrete ((map . fmap)        BindingPat args) $ ret . A.RecP i-      A.AsP i x p            -> bindToConcrete (FreshenName x) $ \ x ->-                                bindToConcrete (BindingPat p)  $ \ p ->-                                ret (A.AsP i x p)--instance ToConcrete A.Pattern C.Pattern where-  bindToConcrete p ret = do-    prec <- currentPrecedence-    bindToConcrete (BindingPat p) (ret <=< withPrecedence prec . toConcrete)-  toConcrete p =-    case p of-      A.VarP x ->-        C.IdentP . C.QName <$> toConcrete x--      A.WildP i ->-        return $ C.WildP (getRange i)--      A.ConP i (AmbQ []) args        -> __IMPOSSIBLE__-      A.ConP i xs@(AmbQ (x:_)) args  -> tryOp x (A.ConP i xs) args--      A.ProjP _ _ (AmbQ []) -> __IMPOSSIBLE__-      A.ProjP i ProjPrefix xs@(AmbQ (x:_)) -> C.IdentP <$> toConcrete x-      A.ProjP i _ xs@(AmbQ (x:_)) -> C.DotP (getRange x) UserWritten . C.Ident <$> toConcrete x--      A.DefP i (AmbQ []) _ -> __IMPOSSIBLE__-      A.DefP i xs@(AmbQ (x:_)) args -> tryOp x (A.DefP i xs)  args--      A.AsP i x p -> do-        (x, p) <- toConcreteCtx ArgumentCtx (x,p)-        return $ C.AsP (getRange i) x p--      A.AbsurdP i ->-        return $ C.AbsurdP (getRange i)--      A.LitP (LitQName r x) -> do-        x <- lookupQName AmbiguousNothing x-        bracketP_ appBrackets $ return $ C.AppP (C.QuoteP r) (defaultNamedArg (C.IdentP x))-      A.LitP l ->-        return $ C.LitP l--      A.DotP i o e -> do-        c <- toConcreteCtx DotPatternCtx e-        case c of-          -- Andreas, 2016-02-04 print ._ pattern as _ pattern,-          -- following the fusing of WildP and ImplicitP.-          C.Underscore{} -> return $ C.WildP $ getRange i-          _ -> return $ C.DotP (getRange i) o c--      A.PatternSynP i n _ ->-        -- Ulf, 2016-11-29: This doesn't seem right. The underscore is a list-        -- of arguments, which we shouldn't really throw away! I guess this-        -- case is __IMPOSSIBLE__?-        C.IdentP <$> toConcrete n--      A.RecP i as ->-        C.RecP (getRange i) <$> mapM (traverse toConcrete) as-    where-    tryOp :: A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> AbsToCon C.Pattern-    tryOp x f args = do-      -- Andreas, 2016-02-04, Issue #1792-      -- To prevent failing of tryToRecoverOpAppP for overapplied operators,-      -- we take off the exceeding arguments first-      -- and apply them pointwise with C.AppP later.-      let (args1, args2) = splitAt (numHoles x) args-      let funCtx = if null args2 then id else withPrecedence FunctionCtx-      funCtx (tryToRecoverOpAppP $ f args1) >>= \case-        Just c  -> applyTo args2 c-        Nothing -> applyTo args . C.IdentP =<< toConcrete x-    -- Note: applyTo [] c = return c-    applyTo args c = bracketP_ (appBrackets' args) $ do-      foldl C.AppP c <$> toConcreteCtx ArgumentCtx args----- Helpers for recovering C.OpApp --------------------------------------------data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName--cOpApp :: Range -> C.QName -> A.Name -> [C.Expr] -> C.Expr-cOpApp r x n es =-  C.OpApp r x (Set.singleton n)-          (map (defaultNamedArg . noPlaceholder . Ordinary) es)--tryToRecoverOpApp :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr-tryToRecoverOpApp e def = caseMaybeM (recoverOpApp bracket cOpApp view e) def return-  where-    view e = do-      let Application hd args = AV.appView e-      case hd of-        Var x            -> Just (HdVar x, args)-        Def f            -> Just (HdDef f, args)-        Con (AmbQ (c:_)) -> Just (HdCon c, args)-        Con (AmbQ [])    -> __IMPOSSIBLE__-        _                -> Nothing--tryToRecoverOpAppP :: A.Pattern -> AbsToCon (Maybe C.Pattern)-tryToRecoverOpAppP = recoverOpApp bracketP_ opApp view-  where-    opApp r x n ps =-      C.OpAppP r x (Set.singleton n) (map defaultNamedArg ps)--    view p = case p of-      ConP _ (AmbQ (c:_)) ps -> Just (HdCon c, ps)-      DefP _ (AmbQ (f:_)) ps -> Just (HdDef f, ps)-      _ -> __IMPOSSIBLE__-      -- ProjP _ _ (AmbQ (d:_))   -> Just (HdDef d, [])   -- ? Andreas, 2016-04-21-      -- _                      -> Nothing--recoverOpApp :: (ToConcrete a c, HasRange c)-  => ((Precedence -> Bool) -> AbsToCon c -> AbsToCon c)-  -> (Range -> C.QName -> A.Name -> [c] -> c)-  -> (a -> Maybe (Hd, [NamedArg a]))-  -> a-  -> AbsToCon (Maybe c)-recoverOpApp bracket opApp view e = case view e of-  Nothing -> mDefault-  Just (hd, args)-    | all notHidden args  -> do-      let  args' = map namedArg args-      case hd of-        HdVar  n-          | isNoName n    -> mDefault-          | otherwise     -> doQNameHelper id        C.QName  n args'-        HdDef qn          -> doQNameHelper qnameName id      qn args'-        HdCon qn          -> doQNameHelper qnameName id      qn args'-    | otherwise           -> mDefault-  where-  mDefault = return Nothing--  doQNameHelper fixityHelper conHelper n as = do-    x <- conHelper <$> toConcrete n-    doQName (theFixity $ nameFixity n') x n' as (C.nameParts $ C.unqualify x)-    where-      n' = fixityHelper n--  -- fall-back (wrong number of arguments or no holes)-  doQName _ x _ es xs-    | null es                 = mDefault-    | length es /= numHoles x = mDefault--  -- binary case-  doQName fixity x n as xs-    | Hole <- head xs-    , Hole <- last xs = do-        let a1  = head as-            an  = last as-            as' = case as of-                    as@(_ : _ : _) -> init $ tail as-                    _              -> __IMPOSSIBLE__-        e1 <- toConcreteCtx (LeftOperandCtx fixity) a1-        es <- mapM (toConcreteCtx InsideOperandCtx) as'-        en <- toConcreteCtx (RightOperandCtx fixity) an-        Just <$> do-          bracket (opBrackets fixity) $-            return $ opApp (getRange (e1, en)) x n ([e1] ++ es ++ [en])--  -- prefix-  doQName fixity x n as xs-    | Hole <- last xs = do-        let an  = last as-            as' = case as of-                    as@(_ : _) -> init as-                    _          -> __IMPOSSIBLE__-        es <- mapM (toConcreteCtx InsideOperandCtx) as'-        en <- toConcreteCtx (RightOperandCtx fixity) an-        Just <$> do-          bracket (opBrackets fixity) $-            return $ opApp (getRange (n, en)) x n (es ++ [en])--  -- postfix-  doQName fixity x n as xs-    | Hole <- head xs = do-        let a1  = head as-            as' = tail as-        e1 <- toConcreteCtx (LeftOperandCtx fixity) a1-        es <- mapM (toConcreteCtx InsideOperandCtx) as'-        Just <$> do-          bracket (opBrackets fixity) $-            return $ opApp (getRange (e1, n)) x n ([e1] ++ es)--  -- roundfix-  doQName _ x n as xs = do-    es <- mapM (toConcreteCtx InsideOperandCtx) as-    Just <$> do-      bracket roundFixBrackets $-        return $ opApp (getRange x) x n es---- Some instances that are related to interaction with users -------------instance ToConcrete InteractionId C.Expr where-    toConcrete (InteractionId i) = return $ C.QuestionMark noRange (Just i)--instance ToConcrete NamedMeta C.Expr where-    toConcrete i = do-      return $ C.Underscore noRange (Just $ prettyShow i)+-- {-# OPTIONS -fwarn-unused-binds #-}++{-| The translation of abstract syntax to concrete syntax has two purposes.+    First it allows us to pretty print abstract syntax values without having to+    write a dedicated pretty printer, and second it serves as a sanity check+    for the concrete to abstract translation: translating from concrete to+    abstract and then back again should be (more or less) the identity.+-}+module Agda.Syntax.Translation.AbstractToConcrete+    ( ToConcrete(..)+    , toConcreteCtx+    , MonadAbsToCon+    , abstractToConcrete_+    , abstractToConcreteCtx+    , abstractToConcreteHiding+    , abstractToConcreteQName+    , abstractToConcreteScope+    , abstractToConcreteTelescope+    , abstractToConcreteUnqualify+    , RangeAndPragma(..)+    , noTakenNames+    ) where++import Prelude hiding (null)++import Control.Monad.Except ( runExceptT )+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )+import Control.Monad.State  ( StateT(..), runStateT )++import Data.Bifunctor       ( first )+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Foldable as Fold+import Data.Void+import Data.List (sortBy)+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+import qualified Agda.Syntax.Internal as I+import Agda.Syntax.Fixity+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Pattern as C+import Agda.Syntax.Concrete.Glyph+import Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Views as A+import Agda.Syntax.Abstract.Pattern as A+import Agda.Syntax.Abstract.PatternSynonyms+import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Monad ( tryResolveName )++import Agda.TypeChecking.Monad.State (getScope, getAllPatternSyns)+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+import Agda.Utils.Either+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 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++---------------------------------------------------------------------------+-- * The Interface+---------------------------------------------------------------------------++-- | 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+  let noScopeCheck b = b `elem` [builtinZero, builtinSuc]+      name (I.Def q _)   = Just q+      name (I.Con q _ _) = Just (I.conName q)+      name _             = Nothing+      builtin b = getBuiltin' b >>= \ case+        Just v | Just q <- name v,+                 noScopeCheck b || isNameInScope q scope -> return [(b, q)]+        _                                                -> return []+  ctxVars <- getContextNames'+  letVars <- Map.keys <$> asksTC envLetBindings+  let vars = ctxVars ++ letVars++  -- pick concrete names for in-scope names now so we don't+  -- accidentally shadow them+  forM_ (scope ^. scopeLocals) $ \(y , x) -> do+    pickConcreteName (localVar x) y++  builtinList <- concat <$> mapM builtin [ builtinFromNat, builtinFromString, builtinFromNeg, builtinZero, builtinSuc ]+  foldPatSyns <- optPrintPatternSynonyms <$> pragmaOptions+  return $+    Env { takenVarNames = Set.fromList vars+        , takenDefNames = defs+        , currentScope = scope+        , 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)++    usefulDef C.NoName{} _ = False+    usefulDef C.Name{} names = all notGeneralizeName names++    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+addBinding y x e =+  e { takenVarNames = Set.insert x $ takenVarNames e+    , currentScope = (`updateScopeLocals` currentScope e) $+        AssocList.insert y (LocalVar x __IMPOSSIBLE__ [])+    }++---------------------------------------------------------------------------+-- * Service functions+---------------------------------------------------------------------------++currentPrecedence :: MonadToConcrete m => m PrecedenceStack+currentPrecedence = asks $ (^. scopePrecedence) . currentScope++preserveInteractionIds :: MonadToConcrete m => m a -> m a+preserveInteractionIds = local $ \ e -> e { preserveIIds = True }++localPrecedenceStack :: MonadToConcrete m+  => (PrecedenceStack -> PrecedenceStack) -> m a -> m a+localPrecedenceStack f = local \ env ->+  env{ currentScope = over scopePrecedence f (currentScope env) }++withPrecedence' :: MonadToConcrete m => PrecedenceStack -> m a -> m a+withPrecedence' = localPrecedenceStack . const++withPrecedence :: MonadToConcrete m => Precedence -> m a -> m a+withPrecedence = localPrecedenceStack . pushPrecedence++withScope :: MonadToConcrete m => ScopeInfo -> m a -> m a+withScope scope = local $ \e -> e { currentScope = scope }++noTakenNames :: MonadToConcrete m => m a -> m a+noTakenNames = local $ \e -> e { takenVarNames = Set.empty }++dontFoldPatternSynonyms :: MonadToConcrete m => m a -> m a+dontFoldPatternSynonyms = local $ \ e -> e { foldPatternSynonyms = False }++doUnqualifyOutOfScopeNames :: MonadToConcrete m => m a -> m a+doUnqualifyOutOfScopeNames = local $ \ e -> e { unqualifyOutOfScopeNames = True }++-- | 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++-- | 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++-- | 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+---------------------------------------------------------------------------++-- | Names in abstract syntax are fully qualified, but the concrete syntax+--   requires non-qualified names in places. In theory (if all scopes are+--   correct), we should get a non-qualified name when translating back to a+--   concrete name, but I suspect the scope isn't always perfect. In these+--   cases we just throw away the qualified part. It's just for pretty printing+--   anyway...+unsafeQNameToName :: C.QName -> C.Name+unsafeQNameToName = C.unqualify++-- | 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 = 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:+    loop [] = case qnameToConcrete x of+      -- 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 :: 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+  -- frontmatter or module telescope of the top level module.+  -- In this case, we print it as an invalid module name.+  -- (Should only affect debug printing.)+lookupModule x =+    do  scope <- asks currentScope+        case inverseScopeLookupModule x scope of+            (y : _) -> return y+            []      -> return $ mnameToConcrete x+                -- this is what happens for names that are not in scope (private names)++-- | Is this concrete name currently in use by a particular abstract+--   name in the current scope?+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 = 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+---  concrete name(s), the new name is only used when all previous+---  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 $ 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 = Set1.toSet' . Map.lookup x <$> useR stShadowingNames++toConcreteName :: MonadToConcrete m => A.Name -> m C.Name+toConcreteName x | y <- nameConcrete x , isNoName y = return y+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)++    -- case: we haven't picked a concrete name yet, or all previously+    -- picked names are shadowed, so we pick a new name now+    loop [] = do+      y <- chooseName x+      pickConcreteName x y+      return y++    -- Is 'y' a good concrete name for abstract name 'x'?+    isGoodName :: MonadToConcrete m => A.Name -> C.Name -> m Bool+    isGoodName x y = do+      zs <- asks (Set.toList . takenVarNames)+      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 :: 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+    reportSLn "toConcrete.bindName" 80 $+      "name " ++ C.nameToRawName (nameConcrete x) ++ " already in scope, so not renaming"+    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++        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)+      , "names already taken:      " <+> prettyList_ (Set.toList taken)+      , "names to avoid:           " <+> prettyList_ (Set.toList toAvoid)+      , "concrete name chosen:     " <+> text (C.nameToRawName y)+      ]+    return y++  where+    takenNames :: MonadToConcrete m => m (Set RawName)+    takenNames = do+      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 :: 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' :: 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+---------------------------------------------------------------------------++-- | General bracketing function.+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 :: 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_ :: MonadToConcrete m => (PrecedenceStack -> Bool) -> m C.Pattern -> m C.Pattern+bracketP_ par m =+    do  e <- m+        bracket' (ParenP (getRange e)) par e++-- | Applications where the argument is a lambda without parentheses need+--   parens more often than other applications.+isLambda :: NamedArg A.Expr -> Bool+isLambda e | notVisible e = False+isLambda e =+  case unScope $ namedArg e of+    A.Lam{}         -> True+    A.AbsurdLam{}   -> True+    A.ExtendedLam{} -> True+    _               -> False++---------------------------------------------------------------------------+-- ** 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 :: 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+            | theFixity (defFixity i) /= noFixity+            ]+  synDecl = [ C.Syntax x $ theNotation $ defFixity i ]++---------------------------------------------------------------------------+-- ** Dealing with private definitions+---------------------------------------------------------------------------++-- | Add @abstract@, @private@, @instance@ modifiers.+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 kwr UserWritten)+                         ds = [ C.Private kwr UserWritten ds ]+        priv _           ds = ds+        abst AbstractDef ds = [ C.Abstract empty ds ]+        abst ConcreteDef ds = ds++addInstanceB :: Maybe KwRange -> [C.Declaration] -> [C.Declaration]+addInstanceB (Just r) ds = [ C.InstanceB r ds ]+addInstanceB Nothing  ds = ds++---------------------------------------------------------------------------+-- * The To Concrete Class+---------------------------------------------------------------------------++class ToConcrete a where+    type ConOfAbs a+    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+    -- the second one). Perhaps they (it) should be removed.+    toConcrete     x     = bindToConcrete x return+    bindToConcrete x ret = ret =<< toConcrete x++    {-# MINIMAL toConcrete | bindToConcrete #-}++-- | Translate something in a context of the given precedence.+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 :: 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 :: MonadToConcrete m => ToConcrete a => a -> m (ConOfAbs a)+toConcreteTop = toConcreteCtx TopCtx++-- | Translate something in the top context.+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 :: MonadToConcrete m => (LensHiding h, ToConcrete a) => h -> a -> m (ConOfAbs a)+toConcreteHiding h =+  case getHiding h of+    NotHidden  -> toConcrete+    Hidden     -> toConcreteTop+    Instance{} -> toConcreteTop++-- | Translate something in a context indicated by 'Hiding' info.+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++-- Base type instances ------------------------------------------------------++instance ToConcrete () where+  type ConOfAbs () = ()+  toConcrete = pure++instance ToConcrete Bool where+  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)++instance ToConcrete a => ToConcrete (List1 a) where+    type ConOfAbs (List1 a) = List1 (ConOfAbs a)++    toConcrete     = mapM toConcrete+    -- Andreas, 2017-04-11, Issue #2543+    -- The naive `thread'ing does not work as we have to undo+    -- changes to the Precedence.+    -- bindToConcrete = thread bindToConcrete+    bindToConcrete (a :| as) ret = do+      p <- currentPrecedence  -- save precedence+      bindToConcrete a $ \ c ->+        withPrecedence' p $ -- reset precedence+          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)++    toConcrete = traverseEither toConcrete toConcrete+    bindToConcrete (Left x) ret =+        bindToConcrete x $ \x ->+        ret (Left x)+    bindToConcrete (Right y) ret =+        bindToConcrete y $ \y ->+        ret (Right y)++instance (ToConcrete a1, ToConcrete a2) => ToConcrete (a1, a2) where+    type ConOfAbs (a1, a2) = (ConOfAbs a1, ConOfAbs a2)++    toConcrete (x,y) = liftM2 (,) (toConcrete x) (toConcrete y)+    bindToConcrete (x,y) ret =+        bindToConcrete x $ \x ->+        bindToConcrete y $ \y ->+        ret (x,y)++instance (ToConcrete a1, ToConcrete a2, ToConcrete a3) => ToConcrete (a1,a2,a3) where+    type ConOfAbs (a1, a2, a3) = (ConOfAbs a1, ConOfAbs a2, ConOfAbs a3)++    toConcrete (x,y,z) = reorder <$> toConcrete (x,(y,z))+        where+            reorder (x,(y,z)) = (x,y,z)++    bindToConcrete (x,y,z) ret = bindToConcrete (x,(y,z)) $ ret . reorder+        where+            reorder (x,(y,z)) = (x,y,z)++-- Decorations ------------------------------------------------------------++instance ToConcrete a => ToConcrete (Arg a) where+    type ConOfAbs (Arg a) = Arg (ConOfAbs a)++    toConcrete (Arg i a) = Arg i <$> toConcreteHiding i a++    bindToConcrete (Arg info x) ret =+      bindToConcreteHiding info x $ ret . Arg info++instance ToConcrete a => ToConcrete (WithHiding a) where+  type ConOfAbs (WithHiding a) = WithHiding (ConOfAbs a)++  toConcrete     (WithHiding h a) = WithHiding h <$> toConcreteHiding h a+  bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a ->+    ret $ WithHiding h a++instance ToConcrete a => ToConcrete (Named name a)  where+    type ConOfAbs (Named name a) = Named name (ConOfAbs a)+    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+  type ConOfAbs A.Name = C.Name++  toConcrete       = toConcreteName+  bindToConcrete x = bindName x++instance ToConcrete BindName where+  type ConOfAbs BindName = C.BoundName++  toConcrete       = fmap C.mkBoundName_ . toConcreteName . unBind+  bindToConcrete x = bindName (unBind x) . (. C.mkBoundName_)++instance ToConcrete A.QName where+  type ConOfAbs A.QName = C.QName++  toConcrete = lookupQName AmbiguousConProjs++instance ToConcrete A.ModuleName where+  type ConOfAbs A.ModuleName = C.QName+  toConcrete = lookupModule++instance ToConcrete AbstractName where+  type ConOfAbs AbstractName = C.QName+  toConcrete = toConcrete . anameName++-- | Assumes name is not 'UnknownName'.+instance ToConcrete ResolvedName where+  type ConOfAbs ResolvedName = C.QName++  toConcrete = \case+    VarName x _          -> C.QName <$> toConcrete x+    DefinedName _ x s    -> addSuffixConcrete s $ toConcrete x+    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+addSuffixConcrete A.NoSuffix x = x+addSuffixConcrete (A.Suffix i) x = do+  glyphMode <- optUseUnicode <$> pragmaOptions+  addSuffixConcrete' glyphMode i <$> x++addSuffixConcrete' :: UnicodeOrAscii -> Integer -> C.QName -> C.QName+addSuffixConcrete' glyphMode i = set (C.lensQNameName . nameSuffix) suffix+  where+    suffix = Just $ case glyphMode of+      UnicodeOk -> Subscript $ fromInteger i+      AsciiOnly -> Index $ fromInteger i++-- Expression instance ----------------------------------------------------++instance ToConcrete A.Expr where+    type ConOfAbs A.Expr = C.Expr++    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)+    toConcrete e@(A.Lit i (LitQName x)) = tryToRecoverPatternSyn e $ do+      x <- lookupQName AmbiguousNothing x+      let r = getRange i+      bracket appBrackets $ return $+        C.App r (C.Quote r) (defaultNamedArg $ C.Ident x)+    toConcrete e@(A.Lit i l) = tryToRecoverPatternSyn e $ return $ C.Lit (getRange i) l++    -- Andreas, 2014-05-17  We print question marks with their+    -- interaction id, in case @metaNumber /= Nothing@+    -- Ulf, 2017-09-20  ... or @preserveIIds == True@.+    toConcrete (A.QuestionMark i ii) = do+      preserve <- asks preserveIIds+      return $ C.QuestionMark (getRange i) $+                 interactionId ii <$ guard (preserve || isJust (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 empty <$> toConcrete e++    toConcrete e@(A.App i e1 e2) = do+      is <- isBuiltinFun+      -- Special printing of desugared overloaded literals:+      --  fromNat 4        --> 4+      --  fromNeg 4        --> -4+      --  fromString "foo" --> "foo"+      -- Only when the corresponding conversion function is in scope and was+      -- inserted by the system.+      case (getHead e1, namedArg e2) of+        (Just (HdDef q), l@A.Lit{})+          | any (is q) [builtinFromNat, builtinFromString], visible e2,+            getOrigin i == Inserted -> toConcrete l+        (Just (HdDef q), A.Lit r (LitNat n))+          | q `is` builtinFromNeg, visible e2,+            getOrigin i == Inserted -> toConcrete (A.Lit r (LitNat (-n)))+        _ ->+          tryToRecoverPatternSyn e+          $ tryToRecoverOpApp e+          $ tryToRecoverNatural e+          -- or fallback to App+          $ bracket (appBrackets' $ preferParenless (appParens i) && isLambda e2)+          $ do e1' <- toConcreteCtx FunctionCtx e1+               e2' <- toConcreteCtx (ArgumentCtx $ appParens i) e2+               return $ C.App (getRange i) e1' e2'++    toConcrete (A.WithApp i e es) =+      bracket withAppBrackets $ do+        e <- toConcreteCtx WithFunCtx e+        es <- mapM (toConcreteCtx WithArgCtx) es+        return $ C.WithApp (getRange i) e es++    toConcrete (A.AbsurdLam i h) =+      bracket lamBrackets $ return $ C.AbsurdLam (getRange i) h+    toConcrete e@(A.Lam i _ _) =+      tryToRecoverOpApp e $   -- recover sections+        bindToConcrete (fmap makeDomainFree bs) $ \ bs' -> do+          List1.ifNull (catMaybes bs')+            {-then-} (toConcrete e')+            {-else-} $ \ bs -> bracket lamBrackets $+              C.Lam (getRange i) bs <$> toConcreteTop e'+      where+          (bs, e') = lamView e+          -- #3238 GA: We drop the hidden lambda abstractions which have+          -- been inserted by the machine rather than the user. This means+          -- that the result of lamView may actually be an empty list of+          -- binders.+          lamView :: A.Expr -> ([A.LamBinding], A.Expr)+          lamView (A.Lam _ b@(A.DomainFree _ x) e)+            | isInsertedHidden x = lamView e+            | otherwise = case lamView e of+              (bs@(A.DomainFree{} : _), e) -> (b:bs, e)+              _                            -> ([b] , e)+          lamView (A.Lam _ b@(A.DomainFull A.TLet{}) e) = case lamView e of+            (bs@(A.DomainFull _ : _), e) -> (b:bs, e)+            _                            -> ([b], e)+          lamView (A.Lam _ (A.DomainFull (A.TBind r t xs ty)) e) =+            case List1.filter (not . isInsertedHidden) xs of+              []    -> lamView e+              x:xs' -> let b = A.DomainFull (A.TBind r t (x :| xs') ty) in+                case lamView e of+                  (bs@(A.DomainFull _ : _), e) -> (b:bs, e)+                  _                            -> ([b], e)+          lamView e = ([], e)+    toConcrete (A.ExtendedLam i di erased qname cs) =+        bracket lamBrackets $ do+          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 (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 :: 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 p np)            = removeApp p <&> (++ [namedPat np])+              -- Andreas, 2018-06-18, issue #3136+              -- Empty pattern list also allowed in extended lambda,+              -- thus, we might face the unapplied .extendedlambda identifier.+              removeApp x@C.IdentP{} = return []++              removeApp p = do+                reportSLn "extendedlambda" 50 $ "abstractToConcrete removeApp p = " ++ show p+                return [p] -- __IMPOSSIBLE__+                  -- Andreas, this is actually not impossible,+                  -- my strictification exposed this sleeping bug+          let decl2clause (C.FunClause (C.LHS p [] []) rhs C.NoWhere ca) = do+                reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda pattern p = " ++ show p+                ps <- removeApp p+                reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps+                return $ LamClause ps rhs ca+              decl2clause _ = __IMPOSSIBLE__+          C.ExtendedLam (getRange i) erased <$>+            mapM decl2clause decls++    toConcrete (A.Pi _ tel1 e0) = do+      let (tel, e) = piTel1 tel1 e0+      bracket piBrackets $+         bindToConcrete tel $ \ tel' ->+           C.makePi (List1.catMaybes tel') <$> toConcreteTop e+      where+        piTel1 tel e         = first (List1.appendList tel) $ piTel e+        piTel (A.Pi _ tel e) = first List1.toList $ piTel1 tel e+        piTel e              = ([], e)++    toConcrete (A.Generalized _ e) = C.Generalized <$> toConcrete e++    toConcrete (A.Fun i a b) =+        bracket piBrackets+        $ do a' <- toConcreteCtx ctx a+             b' <- toConcreteTop b+             -- 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 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)+                                          NotHidden  -> e++    toConcrete (A.Let i ds e) =+        bracket lamBrackets+        $ bindToConcrete ds $ \ds' -> do+             e'  <- toConcreteTop e+             return $ C.mkLet (getRange i) (concat ds') e'++    toConcrete (A.Rec kwr i fs) =+      bracket appBrackets $ do+        C.Rec kwr (getRange i) . map (fmap (\x -> ModuleAssignment x [] defaultImportDir)) <$> toConcreteTop fs++    toConcrete (A.RecUpdate kwr i e fs) =+      bracket appBrackets $ do+        C.RecUpdate kwr (getRange i) <$> toConcrete e <*> toConcreteTop fs++    toConcrete (A.ScopedExpr _ e) = toConcrete e+    toConcrete (A.Quote i) = return $ C.Quote (getRange i)+    toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i)+    toConcrete (A.Unquote i) = return $ C.Unquote (getRange i)++    -- 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 empty . C.Paren r  <$> toConcrete e+       where r = getRange e+    toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete (headAmbQ n)++makeDomainFree :: A.LamBinding -> A.LamBinding+makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) =+  case unScope t of+    A.Underscore A.MetaInfo{metaNumber = Nothing} ->+      A.DomainFree (tbTacticAttr tac) x+    _ -> b+makeDomainFree b = b+++-- Binder instances -------------------------------------------------------++-- If there is no label we set it to the bound name, to make renaming the bound+-- name safe.+forceNameIfHidden :: NamedArg A.Binder -> NamedArg A.Binder+forceNameIfHidden x+  | isJust $ getNameOf  x = x+  | visible x             = x+  | otherwise             = setNameOf (Just name) x+  where+    name = WithOrigin Inserted+         $ Ranged (getRange x)+         $ C.nameToRawName $ nameConcrete+         $ unBind $ A.binderName $ namedArg x++instance ToConcrete a => ToConcrete (A.Binder' a) where+  type ConOfAbs (A.Binder' a) = C.Binder' (ConOfAbs a)++  bindToConcrete (A.Binder p o a) ret =+    bindToConcrete a $ \ a ->+    bindToConcrete p $ \ p ->+    ret $ C.Binder p o a++instance ToConcrete A.LamBinding where+    type ConOfAbs A.LamBinding = Maybe C.LamBinding++    bindToConcrete (A.DomainFree t x) ret = do+      t <- traverse toConcrete t+      let setTac x = x { bnameTactic = t }+      bindToConcrete (forceNameIfHidden x) $+        ret . Just . C.DomainFree . updateNamedArg (fmap setTac)+    bindToConcrete (A.DomainFull b) ret = bindToConcrete b $ ret . fmap C.DomainFull++instance ToConcrete A.TypedBinding where+    type ConOfAbs A.TypedBinding = Maybe C.TypedBinding++    bindToConcrete (A.TBind r t xs e) ret = do+        tac <- traverse toConcrete (tbTacticAttr t)+        bindToConcrete (fmap forceNameIfHidden xs) $ \ xs -> do+          e <- toConcreteTop e+          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+        ret $ C.mkTLet r $ concat ds++instance ToConcrete A.LetBinding where+    type ConOfAbs A.LetBinding = [C.Declaration]++    bindToConcrete (A.LetBind i info x t e) ret =+      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 empty ]+    bindToConcrete (LetApply i erased x modapp _ _) ret = do+      x' <- unqualify <$> toConcrete x+      modapp <- toConcrete modapp+      let r = getRange modapp+          open = fromMaybe DontOpen $ minfoOpenShort i+          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) 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 ]++instance ToConcrete A.WhereDeclarations where+  type ConOfAbs A.WhereDeclarations = WhereClause++  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 && 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 =+    ret . AnyWhere noRange =<< toConcrete d++mergeSigAndDef :: [C.Declaration] -> [C.Declaration]+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 [] = []++openModule' :: A.ModuleName -> C.ImportDirective -> (Scope -> Scope) -> Env -> Env+openModule' x dir restrict env = env{currentScope = set scopeModules mods' sInfo}+  where sInfo = currentScope env+        amod  = sInfo ^. scopeCurrent+        mods  = sInfo ^. scopeModules+        news  = setScopeAccess PrivateNS+                $ applyImportDirective dir+                $ maybe emptyScope restrict+                $ Map.lookup x mods+        mods' = Map.update (Just . (`mergeScope` news)) amod mods+++-- Declaration instances --------------------------------------------------++declsToConcrete :: MonadToConcrete m => [A.Declaration] -> m [C.Declaration]+declsToConcrete ds = mergeSigAndDef . concat <$> toConcrete ds++instance ToConcrete A.RHS where+    type ConOfAbs A.RHS = (C.RHS, [C.RewriteEqn], [C.WithExpr], [C.Declaration])++    toConcrete (A.RHS e (Just c)) = return (C.RHS c, [], [], [])+    toConcrete (A.RHS e Nothing) = do+      e <- toConcrete e+      return (C.RHS e, [], [], [])+    toConcrete A.AbsurdRHS = return (C.AbsurdRHS, [], [], [])+    toConcrete (A.WithRHS _ es cs) = do+      es <- do es <- toConcrete es+               forM es $ \ (Named n e) -> do+                 n <- traverse toConcrete n+                 pure $ Named (C.boundName <$> n) e+      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+      unless (null eqs') __IMPOSSIBLE__+      eqs <- toConcrete xeqs+      return (rhs, eqs, es, wh ++ whs)++instance (ToConcrete p, ToConcrete a) => ToConcrete (RewriteEqn' qn A.BindName p a) where+  type ConOfAbs (RewriteEqn' qn A.BindName p a) = (RewriteEqn' () C.Name (ConOfAbs p) (ConOfAbs a))++  toConcrete = \case+    Rewrite es    -> Rewrite <$> mapM (toConcrete . (\ (_, e) -> ((),e))) es+    Invert qn pes -> fmap (Invert ()) $ forM pes $ \ (Named n pe) -> do+      pe <- toConcrete pe+      n  <- fmap C.boundName <$> toConcrete n+      pure $ Named n pe+    LeftLet pes -> LeftLet <$> mapM toConcrete pes++instance ToConcrete (Constr A.Constructor) where+  type ConOfAbs (Constr A.Constructor) = C.Declaration++  toConcrete (Constr (A.ScopedDecl scope [d])) =+    withScope scope $ toConcrete (Constr d)+  toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do+    x' <- unsafeQNameToName <$> toConcrete x+    t' <- toConcreteTop t+    return $ C.TypeSig info empty x' t'+  toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__+  toConcrete (Constr d) = headWithDefault __IMPOSSIBLE__ <$> toConcrete d++instance (ToConcrete a, ConOfAbs a ~ C.LHS) => ToConcrete (A.Clause' a) where+  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++instance ToConcrete A.ModuleApplication where+  type ConOfAbs A.ModuleApplication = C.ModuleApplication++  toConcrete (A.SectionApp tel y es) = do+    y  <- toConcreteCtx FunctionCtx y+    bindToConcrete tel $ \ tel -> do+      es <- toConcreteCtx argumentCtx_ es+      let r = fuseRange 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]++  toConcrete (ScopedDecl scope ds) =+    withScope scope (declsToConcrete ds)++  toConcrete (A.Axiom _ i info mp x t) = do+    x' <- unsafeQNameToName <$> toConcrete x+    withAbstractPrivate i $+      withInfixDecl i x'  $ do+      t' <- toConcreteTop t+      return $+        (case mp of+           Nothing   -> []+           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 <- toConcrete (defTactic i)+    withAbstractPrivate i $+      withInfixDecl i x'  $ do+      t' <- toConcreteTop 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 <- toConcrete (defTactic i)+    withAbstractPrivate i $+      withInfixDecl i x'  $ do+      t' <- toConcreteTop t+      return [C.FieldSig (A.defInstance i) tac x' t']++  toConcrete (A.Primitive i x t) = do+    x' <- unsafeQNameToName <$> toConcrete x+    withAbstractPrivate i $+      withInfixDecl i x'  $ do+      t' <- traverse toConcreteTop t+      return [C.Primitive empty [C.TypeSig (argInfo t') empty x' (unArg t')]]+        -- Primitives are always relevant.++  toConcrete (A.FunDef i _ cs) =+    withAbstractPrivate i $ List1.concat <$> toConcrete cs++  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) erased x'+                 (map C.DomainFull $ catMaybes tel') t' ]++  toConcrete (A.DataDef i x uc bs cs) =+    withAbstractPrivate i $+    bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do+      (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)+      return [ C.DataDef (getRange i) x' (catMaybes tel') cs' ]++  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) 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' dirs (catMaybes tel') cs' ]++  toConcrete (A.Mutual i ds) = pure . C.Mutual empty <$> declsToConcrete ds++  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) erased x (catMaybes tel) ds ]++  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) erased x modapp open dir ]++  toConcrete (A.Import i x _) = do+    x <- toConcrete x+    let open = fromMaybe DontOpen $ minfoOpenShort i+        dir  = fromMaybe defaultImportDir $ minfoDirective i+    return [ C.Import (getRange i) x Nothing open dir]++  toConcrete (A.Pragma i p)     = do+    p <- toConcrete $ RangeAndPragma (getRange i) p+    return [C.Pragma p]++  toConcrete (A.Open i x _) = do+    x <- toConcrete x+    return [C.Open (getRange i) x defaultImportDir]++  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+        unqual _           = __IMPOSSIBLE__+    xs <- mapM (unqual <=< toConcrete) xs+    (:[]) . C.UnquoteDecl (getRange i) xs <$> toConcrete e++  toConcrete (A.UnquoteDef i xs e) = do+    let unqual (C.QName x) = return x+        unqual _           = __IMPOSSIBLE__+    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++instance ToConcrete RangeAndPragma where+  type ConOfAbs RangeAndPragma = C.Pragma++  toConcrete (RangeAndPragma r p) = case p of+    A.OptionsPragma xs  -> return $ C.OptionsPragma r xs+    A.BuiltinPragma b x       -> C.BuiltinPragma r b <$> toConcrete x+    A.BuiltinNoDefPragma b _kind x -> C.BuiltinPragma r b <$> toConcrete x+    A.RewritePragma r' x      -> C.RewritePragma r r' <$> toConcrete x+    A.CompilePragma b x s -> do+      x <- toConcrete x+      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++-- Left hand sides --------------------------------------------------------++instance ToConcrete A.SpineLHS where+  type ConOfAbs A.SpineLHS = C.LHS++  bindToConcrete lhs = bindToConcrete (A.spineToLhs lhs :: A.LHS)++instance ToConcrete A.LHS where+    type ConOfAbs A.LHS = C.LHS++    bindToConcrete (A.LHS i lhscore) ret = do+      bindToConcreteCtx TopCtx lhscore $ \ lhs ->+          ret $ C.LHS (reintroduceEllipsis (lhsEllipsis i) lhs) [] []++instance ToConcrete A.LHSCore where+  type ConOfAbs A.LHSCore = C.Pattern+  bindToConcrete = bindToConcrete . lhsCoreToPattern++appBracketsArgs :: [arg] -> PrecedenceStack -> Bool+appBracketsArgs []    _   = False+appBracketsArgs (_:_) ctx = appBrackets ctx++-- Auxiliary wrappers for processing the bindings in patterns in the right order.+newtype UserPattern a  = UserPattern a+newtype SplitPattern a = SplitPattern a+newtype BindingPattern = BindingPat A.Pattern+newtype FreshenName = FreshenName BindName++instance ToConcrete FreshenName where+  type ConOfAbs FreshenName = A.Name+  bindToConcrete (FreshenName BindName{ unBind = x }) ret = bindToConcrete x $ \ y -> ret x { nameConcrete = y }++-- Pass 1: (Issue #2729)+-- Takes care of binding the originally user-written pattern variables, but doesn't actually+-- translate anything to Concrete.+instance ToConcrete (UserPattern A.Pattern) where+  type ConOfAbs (UserPattern A.Pattern) = A.Pattern++  bindToConcrete (UserPattern p) ret = do+    reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 1)" ++ show p+    case p of+      A.VarP bx -> do+        let x = unBind bx+        case isInScope x of+          InScope            -> bindName' x $ ret $ A.VarP bx+          C.NotInScope       -> bindName x $ \y ->+                                ret $ A.VarP $ mkBindName $ x { nameConcrete = y }+      A.WildP{}              -> ret p+      A.ProjP{}              -> ret p+      A.AbsurdP{}            -> ret p+      A.LitP{}               -> ret p+      A.DotP{}               -> ret p+      A.EqualP{}             -> ret p+      -- Andreas, 2017-09-03, issue #2729:+      -- Do not go into patterns generated by case-split here!+      -- They are treated in a second pass.+      A.ConP i c args+        | conPatOrigin i == ConOSplit -> ret p+        | 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 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++instance ToConcrete (UserPattern (NamedArg A.Pattern)) where+  type ConOfAbs (UserPattern (NamedArg A.Pattern)) = NamedArg A.Pattern++  bindToConcrete (UserPattern np) ret =+    case getOrigin np of+      CaseSplit -> ret np+      _         -> bindToConcrete (fmap (fmap UserPattern) np) ret++-- Pass 2a: locate case-split pattern.  Don't bind anything!+instance ToConcrete (SplitPattern A.Pattern) where+  type ConOfAbs (SplitPattern A.Pattern) = A.Pattern++  bindToConcrete (SplitPattern p) ret = do+    reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 2a)" ++ show p+    case p of+      A.VarP x               -> ret p+      A.WildP{}              -> ret p+      A.ProjP{}              -> ret p+      A.AbsurdP{}            -> ret p+      A.LitP{}               -> ret p+      A.DotP{}               -> ret p+      A.EqualP{}             -> ret p+      -- Andreas, 2017-09-03, issue #2729:+      -- For patterns generated by case-split here, switch to freshening & binding.+      A.ConP i c args+        | conPatOrigin i == ConOSplit+                             -> bindToConcrete ((map . fmap . fmap) BindingPat args) $ ret . A.ConP i c+        | 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 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++instance ToConcrete (SplitPattern (NamedArg A.Pattern)) where+  type ConOfAbs (SplitPattern (NamedArg A.Pattern)) = NamedArg A.Pattern+  bindToConcrete (SplitPattern np) ret =+    case getOrigin np of+      CaseSplit -> bindToConcrete (fmap (fmap BindingPat  ) np) ret+      _         -> bindToConcrete (fmap (fmap SplitPattern) np) ret+++-- Pass 2b:+-- Takes care of freshening and binding pattern variables introduced by case split.+-- Still does not translate anything to Concrete.+instance ToConcrete BindingPattern where+  type ConOfAbs BindingPattern = A.Pattern+  bindToConcrete (BindingPat p) ret = do+    reportSLn "toConcrete.pat" 100 $ "binding pattern (pass 2b)" ++ show p+    case p of+      A.VarP x               -> bindToConcrete (FreshenName x) $ ret . A.VarP . mkBindName+      A.WildP{}              -> ret p+      A.ProjP{}              -> ret p+      A.AbsurdP{}            -> ret p+      A.LitP{}               -> ret p+      A.DotP{}               -> ret p+      A.EqualP{}             -> ret p+      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 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++instance ToConcrete A.Pattern where+  type ConOfAbs A.Pattern = C.Pattern++  bindToConcrete p ret = do+    prec <- currentPrecedence+    bindToConcrete (UserPattern p) $ \ p -> do+      bindToConcrete (SplitPattern p) $ \ p -> do+        ret =<< do withPrecedence' prec $ toConcrete p+  toConcrete p =+    case p of+      A.VarP 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 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++      A.AsP i x p -> do+        (x, p) <- toConcreteCtx argumentCtx_ (x, p)+        return $ C.AsP (getRange i) (C.boundName x) p++      A.AbsurdP i ->+        return $ C.AbsurdP (getRange i)++      A.LitP i (LitQName x) -> do+        x <- lookupQName AmbiguousNothing 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 empty r . C.Paren r <$> toConcreteCtx TopCtx e+        where r = getRange i++      -- gallais, 2019-02-12, issue #3491+      -- Print p as .(p) if p is a variable but there is a projection of the+      -- same name in scope.+      A.DotP i e@(A.Var v) -> do+        let r = getRange i+        -- Erase @v@ to a concrete name and resolve it back to check whether+        -- we have a conflicting field name.+        cn <- toConcreteName v+        resolveName (someKindsOfNames [FldName]) Nothing (C.QName cn) >>= \ case+          -- 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 empty r . C.Paren r <$> toConcrete (A.Var v)+          Right _ -> printDotDefault i e+          Left _ -> __IMPOSSIBLE__++      A.DotP i e -> printDotDefault i e++      A.EqualP i es -> do+        C.EqualP (getRange i) <$> toConcrete es++      A.PatternSynP i n args -> tryOp (headAmbQ n) (A.PatternSynP i n) args++      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++    where++    printDotDefault :: MonadToConcrete m => PatInfo -> A.Expr -> m C.Pattern+    printDotDefault i e = do+      c <- toConcreteCtx DotPatternCtx e+      let r = getRange i+      case c of+        -- Andreas, 2016-02-04 print ._ pattern as _ pattern,+        -- following the fusing of WildP and ImplicitP.+        C.Underscore{} -> return $ C.WildP r+        _ -> return $ C.DotP empty r c++    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,+      -- we take off the exceeding arguments first+      -- and apply them pointwise with C.AppP later.+      let (args1, args2) = splitAt (numHoles x) args+      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 True =<< toConcrete x+    -- Note: applyTo [] c = return c+    applyTo args c = bracketP_ (appBracketsArgs args) $ do+      foldl C.AppP c <$>+        (mapM avoidPun =<< toConcreteCtx argumentCtx_ args)++    -- 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 :: 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 -> 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+    explore isZero isSuc k (A.App _ (A.Con c) t) | Just f <- getUnambiguous c, isSuc f+                                                = (explore isZero isSuc $! k + 1) (namedArg t)+    explore isZero isSuc k (A.Con c) | Just x <- getUnambiguous c, isZero x = Just k+    explore isZero isSuc k (A.Lit _ (LitNat l)) = Just (k + l)+    explore _ _ _ _                             = Nothing++-- Helpers for recovering C.OpApp ------------------------------------------++data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName | HdSyn A.QName++data MaybeSection a+  = YesSection+  | NoSection a+  deriving (Eq, Show, Functor, Foldable, Traversable)++fromNoSection :: a -> MaybeSection a -> a+fromNoSection fallback = \case+  YesSection  -> fallback+  NoSection x -> x++instance HasRange a => HasRange (MaybeSection a) where+  getRange = \case+    YesSection  -> noRange+    NoSection a -> getRange a++getHead :: A.Expr -> Maybe Hd+getHead (Var x)          = Just (HdVar x)+getHead (Def f)          = Just (HdDef f)+getHead (Proj o f)       = Just (HdDef $ headAmbQ f)+getHead (Con c)          = Just (HdCon $ headAmbQ c)+getHead (A.PatternSyn n) = Just (HdSyn $ headAmbQ n)+getHead _                = Nothing++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.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+    placeholder (YesSection , pos ) = Placeholder pos+    placeholder (NoSection e, _pos) = noPlaceholder (Ordinary e)++tryToRecoverOpApp :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr+tryToRecoverOpApp e def = fromMaybeM def $+  recoverOpApp bracket (isLambda . defaultNamedArg) cOpApp view e+  where+    view :: A.Expr -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Expr))])+    view e+        -- Do we have a series of inserted lambdas?+      | Just xs@(_:_) <- traverse insertedName bs =+        (,) <$> getHead hd <*> sectionArgs (map (unBind . A.binderName) xs) args+      where+        LamView     bs body = A.lamView e+        Application hd args = A.appView' body++        -- Only inserted domain-free visible lambdas come from sections.+        insertedName (A.DomainFree _ x)+          | getOrigin x == Inserted && visible x = Just $ namedArg x+        insertedName _ = Nothing++        -- Build section arguments. Need to check that:+        -- lambda bound variables appear in the right order and only as+        -- top-level arguments.+        sectionArgs :: [A.Name] -> [NamedArg (AppInfo, A.Expr)] -> Maybe [NamedArg (MaybeSection (AppInfo, A.Expr))]+        sectionArgs xs = go xs+          where+            noXs = getAll . foldExpr (\ case A.Var x -> All (x `notElem` xs)+                                             _       -> All True) . snd . namedArg+            go [] [] = return []+            go (y : ys) (arg : args)+              | visible arg+              , A.Var y' <- snd $ namedArg arg+              , y == y' = (fmap (YesSection <$) arg :) <$> go ys args+            go ys (arg : args)+              | visible arg, noXs arg = ((fmap . fmap) NoSection arg :) <$> go ys args+            go _ _ = Nothing++    view e = (, (map . fmap . fmap) NoSection args) <$> getHead hd+      where Application hd args = A.appView' e++tryToRecoverOpAppP :: MonadToConcrete m => A.Pattern -> m (Maybe C.Pattern)+tryToRecoverOpAppP p = do+  res <- recoverOpApp bracketP_ (const False) (const opApp) view p+  reportS "print.op" 90+    [ "tryToRecoverOpApp"+    , "in:  " ++ show p+    , "out: " ++ show res+    ]+  return res+  where+    opApp r x n ps = C.OpAppP r x (singleton n) $+      fmap (defaultNamedArg . fromNoSection __IMPOSSIBLE__) $+      -- `view` does not generate any `Nothing`s+      ps++    appInfo = defaultAppInfo_++    view :: A.Pattern -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, A.Pattern))])+    view = \case+      ConP _        cs ps -> Just (HdCon (headAmbQ cs), (map . fmap . fmap) (NoSection . (appInfo,)) ps)+      DefP _        fs ps -> Just (HdDef (headAmbQ fs), (map . fmap . fmap) (NoSection . (appInfo,)) ps)+      PatternSynP _ ns ps -> Just (HdSyn (headAmbQ ns), (map . fmap . fmap) (NoSection . (appInfo,)) ps)+      _                   -> Nothing+      -- ProjP _ _ d   -> Just (HdDef (headAmbQ d), [])   -- ? Andreas, 2016-04-21++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+  -> (Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@+  -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))+  -> a+  -> m (Maybe c)+recoverOpApp bracket isLam opApp view e = case view e of+  Nothing -> mDefault+  Just (hd, args)+    | all visible args    -> do+      let  args' = map namedArg args+      case hd of+        HdVar  n+          | isNoName n    -> mDefault+          | otherwise     -> doQNameHelper (Left n) args'+        HdDef qn+          | isExtendedLambdaName qn+                          -> mDefault+          | otherwise     -> doQNameHelper (Right qn) args'+        -- HdDef qn          -> doQNameHelper (Right qn) args'+        HdCon qn          -> doQNameHelper (Right qn) args'+        HdSyn qn          -> doQNameHelper (Right qn) args'+    | otherwise           -> mDefault+  where+  mDefault = return Nothing++  skipParens :: MaybeSection (AppInfo, a) -> Bool+  skipParens = \case+     YesSection       -> False+     NoSection (i, e) -> isLam e && preferParenless (appParens i)++  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, 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 nk fx x n' as (C.nameParts $ C.unqualify x)++  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 nk _ x _ as xs+    | length as /= numHoles x = mDefault++  -- binary case+  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+        Just <$> do+          bracket (opBrackets' (skipParens an) fixity) $ do+            e1 <- traverse (toConcreteCtx (LeftOperandCtx fixity) . snd) a1+            es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'+            en <- traverse (uncurry $ toConcreteCtx . RightOperandCtx fixity . appParens) an+            return $ opApp nk (getRange (e1, en)) x n (e1 :| es ++ [en])++  -- prefix+  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 nk (getRange (n, en)) x n (List1.snoc es en)++  -- postfix+  doQName nk fixity x n as xs+    | Hole <- List1.head xs = do+        let a1  = List1.head as+            as' = List1.tail as+        e1 <- traverse (toConcreteCtx (LeftOperandCtx fixity) . snd) a1+        es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'+        Just <$> do+          bracket (opBrackets fixity) $+            return $ opApp nk (getRange (e1, n)) x n (e1 :| es)++  -- roundfix+  doQName nk _ x n as _ = do+    es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as+    Just <$> do+      bracket roundFixBrackets $+        return $ opApp nk (getRange x) x n es++-- Recovering pattern synonyms --------------------------------------------++-- | Recover pattern synonyms for expressions.+tryToRecoverPatternSyn :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr+tryToRecoverPatternSyn e fallback+  | userWritten e = fallback+  | litOrCon e    = recoverPatternSyn apply matchPatternSyn e fallback+  | otherwise     = fallback+  where+    userWritten (A.App info _ _) = getOrigin info == UserWritten+    userWritten _                = False  -- this means we always use pattern synonyms for nullary constructors++    -- Only literals or constructors can head pattern synonym definitions+    litOrCon e =+      case A.appView e of+        Application Con{}   _ -> True+        Application A.Lit{} _ -> True+        _                     -> False++    apply c args = A.unAppView $ Application (A.PatternSyn $ unambiguous c) args++-- | Recover pattern synonyms in patterns.+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 :: 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+    psyns  <- getAllPatternSyns+    scope  <- getScope+    reportSLn "toConcrete.patsyn" 100 $ render $ hsep $+      [ "Scope when attempting to recover pattern synonyms:"+      , pretty scope+      ]+    let isConP ConP{} = True    -- #2828: only fold pattern synonyms with+        isConP _      = False   --        constructor rhs+        cands = [ (q, args, score rhs)+                | (q, psyndef@(_, rhs)) <- reverse $ Map.toList psyns+                , isConP rhs+                , Just args <- [match psyndef e]+                -- #3879: only fold pattern synonyms with an unqualified concrete name in scope+                -- Note that we only need to consider the head of the inverse lookup result: they+                -- are already sorted from shortest to longest!+                , C.QName{} <- Fold.toList $ listToMaybe $ inverseScopeLookupName q scope+                ]+        cmp (_, _, x) (_, _, y) = compare y x+    reportSLn "toConcrete.patsyn" 50 $ render $ hsep $+      [ "Found pattern synonym candidates:"+      , prettyList_ $ map (\ (q,_,_) -> q) cands+      ]+    case sortBy cmp cands of+      (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.+    score :: Pattern' Void -> Int+    score = getSum . foldAPattern con+      where con ConP{} = 1+            con _      = 0++-- Some instances that are related to interaction with users -----------++instance ToConcrete InteractionId where+    type ConOfAbs InteractionId = C.Expr+    toConcrete (InteractionId i) = return $ C.QuestionMark noRange (Just i)++instance ToConcrete NamedMeta where+    type ConOfAbs NamedMeta = C.Expr+    toConcrete i =+      C.Underscore noRange . Just . render <$> prettyTCM i
src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs view
@@ -1,2171 +1,3685 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE UndecidableInstances   #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif--{-| 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(..)-    , OldName(..)-    , TopLevel(..)-    , TopLevelInfo(..)-    , topLevelModuleName-    , AbstractRHS-    , NewModuleName, OldModuleName-    , NewName, OldQName-    , LeftHandSide, RightHandSide-    , PatName, APatName, LetDef, LetDefs-    ) where--import Prelude hiding (mapM, null)-import Control.Applicative-import Control.Monad.Reader hiding (mapM)--import Data.Foldable (Foldable, traverse_)-import Data.Traversable (mapM, traverse)-import Data.List ((\\), nub, foldl')-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Maybe-import Data.Void--import Agda.Syntax.Concrete as C hiding (topLevelModuleName)-import Agda.Syntax.Concrete.Generic-import Agda.Syntax.Concrete.Operators-import Agda.Syntax.Abstract as A-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.Notation-import Agda.Syntax.Scope.Base-import Agda.Syntax.Scope.Monad-import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete)-import Agda.Syntax.IdiomBrackets--import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)-import qualified Agda.TypeChecking.Monad.Benchmark as Bench-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.Options-import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern)-import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin)--import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)-import Agda.TypeChecking.Pretty hiding (pretty, prettyA)--import Agda.Interaction.FindFile (checkModuleName)--- import Agda.Interaction.Imports  -- for type-checking in ghci-import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)-import Agda.Interaction.Options--import Agda.Utils.Either-import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-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.Tuple-import Agda.Interaction.FindFile ( rootNameModule )--#include "undefined.h"-import Agda.Utils.Impossible-import Agda.ImpossibleTest (impossibleTest)--{---------------------------------------------------------------------------    Exceptions- --------------------------------------------------------------------------}---- notAModuleExpr e = typeError $ NotAModuleExpr e--notAnExpression :: C.Expr -> ScopeM A.Expr-notAnExpression e = typeError $ NotAnExpression e--nothingAppliedToHiddenArg :: C.Expr -> ScopeM A.Expr-nothingAppliedToHiddenArg e = typeError $ NothingAppliedToHiddenArg e--nothingAppliedToInstanceArg :: C.Expr -> ScopeM A.Expr-nothingAppliedToInstanceArg e = typeError $ NothingAppliedToInstanceArg e--notAValidLetBinding :: NiceDeclaration -> ScopeM a-notAValidLetBinding d = typeError $ NotAValidLetBinding d---- Debugging--printLocals :: Int -> String -> ScopeM ()-printLocals v s = verboseS "scope.top" v $ do-  locals <- getLocalVars-  reportSLn "scope.top" v $ s ++ " " ++ show locals--{---------------------------------------------------------------------------    Helpers- --------------------------------------------------------------------------}--annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration-annotateDecl m = annotateDecls $ (:[]) <$> m--annotateDecls :: ScopeM [A.Declaration] -> ScopeM A.Declaration-annotateDecls m = do-  ds <- m-  s  <- getScope-  return $ ScopedDecl s ds--annotateExpr :: ScopeM A.Expr -> ScopeM A.Expr-annotateExpr m = do-  e <- m-  s <- getScope-  return $ ScopedExpr s e---- | Make sure that each variable occurs only once.-checkPatternLinearity :: [A.Pattern' e] -> ScopeM ()-checkPatternLinearity ps = do-  unlessNull (duplicates $ map nameConcrete $ patternVars ps) $ \ ys -> do-    typeError $ RepeatedVariablesInPattern ys--class PatternVars a where-  patternVars :: a -> [A.Name]--instance PatternVars a => PatternVars [a] where-  patternVars = concatMap patternVars--instance PatternVars a => PatternVars (Arg a) where-  patternVars = patternVars . unArg--instance PatternVars a => PatternVars (Named n a) where-  patternVars = patternVars . namedThing--instance PatternVars a => PatternVars (C.FieldAssignment' a) where-  patternVars = patternVars . (^. exprFieldA)--instance PatternVars (A.Pattern' e) where-  patternVars p = case p of-      A.VarP x               -> [x]-      A.ConP _ _ args        -> patternVars args-      A.ProjP _ _ _          -> []-      A.WildP _              -> []-      A.AsP _ x p            -> x : patternVars p-      A.DotP _ _ _           -> []-      A.AbsurdP _            -> []-      A.LitP _               -> []-      A.DefP _ _ args        -> patternVars args-        -- Projection pattern, @args@ should be empty unless we have-        -- indexed records.-      A.PatternSynP _ _ args -> patternVars args-      A.RecP _ fs            -> patternVars fs----- | Make sure that there are no dot patterns (called on pattern synonyms).-noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)-noDotPattern err = dot-  where-    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)-    dot p = case p of-      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{}               -> typeError $ GenericError err-      A.AbsurdP i            -> pure $ A.AbsurdP i-      A.LitP l               -> pure $ A.LitP 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---- | Compute the type of the record constructor (with bogus target type)-recordConstructorType :: [NiceDeclaration] -> ScopeM C.Expr-recordConstructorType fields = build <$> mapM validForLet fs-  where-    -- drop all declarations after the last field declaration-    fs = reverse $ dropWhile notField $ reverse fields--    notField NiceField{} = False-    notField _           = True--    -- | Check that declarations before last field can be handled-    --   by current translation into let.-    ---    --   Sometimes a declaration is valid with minor modifications.-    validForLet :: NiceDeclaration -> ScopeM NiceDeclaration-    validForLet d = do-      let failure = traceCall (SetRange $ getRange d) $-            typeError $ NotValidBeforeField d-      case d of--        -- Andreas, 2013-11-08-        -- Turn @open public@ into just @open@, since we cannot have an-        -- @open public@ in a @let@.  Fixes issue #532.-        C.NiceOpen r m dir ->-          return $ C.NiceOpen r m dir{ publicOpen = False }--        C.NiceModuleMacro r p x modapp open dir ->-          return $ C.NiceModuleMacro r p x modapp open dir{ publicOpen = False }--        C.NiceField{} ->-          return d--        C.NiceMutual _ _ _-          [ C.FunSig _ _ _ _ _instanc macro _info _ _ _-          , C.FunDef _ _ _ abstract _ _-             [ C.Clause _top _catchall (C.LHS _p [] [] []) (C.RHS _rhs) NoWhere [] ]-          ] | abstract /= AbstractDef && macro /= MacroDef ->-          -- TODO: this is still too generous, we also need to check that _p-          -- is only variable patterns.-          return d--        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.DataDef{}           -> failure-        C.RecDef{}            -> failure-        C.NicePatternSyn{}    -> failure-        C.NiceUnquoteDecl{}   -> failure-        C.NiceUnquoteDef{}    -> failure--    build fs =-      let (ds1, ds2) = span notField fs-      in  lets (concatMap notSoNiceDeclarations ds1) $ fld ds2--    -- Turn a field declaration into a the domain of a Pi-type-    fld [] = C.SetN noRange 0 -- todo: nicer-    fld (NiceField r f _ _ _ x (Arg info e) : fs) =-        C.Pi [C.TypedBindings r $ Arg info (C.TBind r [pure $ mkBoundName x f] e)] $ build fs-      where r = getRange x-    fld _ = __IMPOSSIBLE__--    -- Turn non-field declarations into a let binding.-    -- Smart constructor for C.Let:-    lets [] c = c-    lets ds c = C.Let (getRange ds) ds c--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' <- toAbstract tel-    -- Scope check the old module name and the module args.-    (m1, args') <- toAbstract (OldModuleName m, args)-    -- Drop constructors (OnlyQualified) if there are arguments. The record constructor-    -- isn't properly in the record module, so copying it will lead to badness.-    let noRecConstr | null args = id-                    | otherwise = removeOnlyQualified-    -- 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 (noRecConstr s)-    -- Set the current scope to @s'@-    modifyCurrentScope $ const s'-    printScope "mod.inst" 20 "copied source module"-    reportSLn "scope.mod.inst" 30 $ show (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.RecordModuleIFS _ 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 (removeOnlyQualified s)-    modifyCurrentScope $ const s'--    printScope "mod.inst" 20 "copied record module"-    return (A.RecordModuleIFS m1, copyInfo, adir)---- | @checkModuleMacro mkApply range access concreteName modapp open dir@------   Preserves local variables.--checkModuleMacro-  :: (Pretty c, ToConcrete a c)-  => (ModuleInfo-      -> ModuleName-      -> A.ModuleApplication-      -> ScopeCopyInfo-      -> A.ImportDirective-      -> a)-  -> Range-  -> Access-  -> C.Name-  -> C.ModuleApplication-  -> OpenShortHand-  -> C.ImportDirective-  -> ScopeM [a]-checkModuleMacro apply r p x modapp open dir = do-    reportSDoc "scope.decl" 70 $ vcat $-      [ text $ "scope checking ModuleMacro " ++ prettyShow x-      ]-    notPublicWithoutOpen open dir--    m0 <- toAbstract (NewModuleName x)-    reportSDoc "scope.decl" 90 $ text "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 = False }-                               , 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 $ text "after mod app: trying to print m0 ..."-    reportSDoc "scope.decl" 90 $ text "after mod app: m0 =" <+> prettyA m0--    bindModule p x m0-    reportSDoc "scope.decl" 90 $ text "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   -> openModule_ (C.QName x) openDir-    printScope "mod.inst" 20 $ show open-    reportSDoc "scope.decl" 90 $ text "after open   : m0 =" <+> prettyA m0--    stripNoNames-    printScope "mod.inst" 10 $ "after stripping"-    reportSDoc "scope.decl" 90 $ text "after stripNo: m0 =" <+> prettyA m0--    let m      = m0 `withRangesOf` [x]-        adecls = [ 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       = " ++ show m-    reportSLn  "scope.decl" 90 $ "modapp' = " ++ show modapp'-    reportSLn  "scope.decl" 90 $ show $ pretty copyInfo-    reportSDoc "scope.decl" 70 $ vcat $-      map (nest 2 . prettyA) adecls-    return adecls-  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 ()-notPublicWithoutOpen DoOpen   dir = return ()-notPublicWithoutOpen DontOpen dir = when (publicOpen dir) $ typeError $-  GenericError-    "The public keyword must only be used together with the open keyword"---- | 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 -> C.QName -> C.ImportDirective                -- ^ Arguments of 'NiceOpen'-  -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'-checkOpen r x dir = do-  reportSDoc "scope.decl" 70 $ vcat $-    [ text $ "scope checking NiceOpen " ++ prettyShow x-    ]--  m <- toAbstract (OldModuleName x)-  printScope "open" 20 $ "opening " ++ show x-  adir <- openModule_ 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)--{---------------------------------------------------------------------------    Translation- --------------------------------------------------------------------------}--concreteToAbstract_ :: ToAbstract c a => c -> ScopeM a-concreteToAbstract_ x = toAbstract x--concreteToAbstract :: ToAbstract c a => ScopeInfo -> c -> ScopeM a-concreteToAbstract scope x = withScope_ scope (toAbstract x)---- | Things that can be translated to abstract syntax are instances of this---   class.-class ToAbstract concrete abstract | concrete -> abstract where-    toAbstract :: concrete -> ScopeM abstract---- | 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 concrete abstract =>-                 Precedence -> concrete -> ScopeM abstract-toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c--toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a-toAbstractTopCtx = toAbstractCtx TopCtx--toAbstractHiding :: (LensHiding h, ToAbstract c a) => h -> c -> ScopeM a-toAbstractHiding h = toAbstractCtx $ hiddenArgumentCtx $ getHiding h--setContextCPS :: Precedence -> (a -> ScopeM b) ->-                 ((a -> ScopeM b) -> ScopeM b) -> ScopeM b-setContextCPS p ret f = do-  p' <- getContextPrecedence-  withContextPrecedence p $ f $ withContextPrecedence p' . ret--localToAbstractCtx :: ToAbstract concrete abstract =>-                     Precedence -> concrete -> (abstract -> ScopeM a) -> ScopeM a-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 a => c -> (a -> 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 a => c -> (a -> ScopeM b) -> ScopeM (b, ScopeInfo)-localToAbstract' x ret = do-  scope <- getScope-  withScope scope $ ret =<< toAbstract x--instance (ToAbstract c1 a1, ToAbstract c2 a2) => ToAbstract (c1,c2) (a1,a2) where-  toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y--instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) =>-         ToAbstract (c1,c2,c3) (a1,a2,a3) where-    toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))-        where-            flatten (x,(y,z)) = (x,y,z)--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} ToAbstract c a => ToAbstract [c] [a] where-#else-instance ToAbstract c a => ToAbstract [c] [a] where-#endif-  toAbstract = mapM toAbstract--instance (ToAbstract c1 a1, ToAbstract c2 a2) =>-         ToAbstract (Either c1 c2) (Either a1 a2) where-    toAbstract = traverseEither toAbstract toAbstract--instance ToAbstract c a => ToAbstract (Maybe c) (Maybe a) where-  toAbstract = traverse toAbstract---- Names --------------------------------------------------------------------newtype NewName a = NewName a-data OldQName     = OldQName 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.-newtype OldName a = OldName a-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) A.Name where-  toAbstract (NewName x) = do-    y <- freshAbstractName_ x-    bindVariable x y-    return y--instance ToAbstract (NewName C.BoundName) A.Name where-  toAbstract (NewName BName{ boundName = x, bnameFixity = fx }) = do-    y <- freshAbstractName fx x-    bindVariable x y-    return y--instance ToAbstract OldQName A.Expr where-  toAbstract (OldQName x ns) = do-    qx <- resolveName' allKindsOfNames ns x-    reportSLn "scope.name" 10 $ "resolved " ++ show x ++ ": " ++ show qx-    case qx of-      VarName x'          -> return $ A.Var x'-      DefinedName _ d     -> return $ nameExpr d-      FieldName     ds    -> return $ A.Proj ProjPrefix $ AmbQ (map anameName ds)-      ConstructorName ds  -> return $ A.Con $ AmbQ (map anameName ds)-      UnknownName         -> notInScope x-      PatternSynResName d -> return $ nameExpr d--data APatName = VarPatName A.Name-              | ConPatName [AbstractName]-              | PatternSynPatName AbstractName--instance ToAbstract PatName APatName where-  toAbstract (PatName x ns) = do-    reportSLn "scope.pat" 10 $ "checking pattern name: " ++ show x-    rx <- resolveName' [ConName, PatternSynName] ns x-          -- Andreas, 2013-03-21 ignore conflicting names which cannot-          -- be meant since we are in a pattern-    z  <- case (rx, x) of-      -- TODO: warn about shadowing-      (VarName y,       C.QName x)                          -> return $ Left x -- typeError $ RepeatedVariableInPattern y x-      (FieldName d,     C.QName x)                          -> return $ Left x-      (DefinedName _ d, C.QName x) | DefName == anameKind d -> return $ Left x-      (UnknownName,     C.QName x)                          -> return $ Left x-      (ConstructorName ds, _)                               -> return $ Right (Left ds)-      (PatternSynResName d, _)                              -> return $ Right (Right d)-      _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x-    case z of-      Left x  -> do-        reportSLn "scope.pat" 10 $ "it was a var: " ++ show x-        p <- VarPatName <$> toAbstract (NewName x)-        printLocals 10 "bound it:"-        return p-      Right (Left ds) -> do-        reportSLn "scope.pat" 10 $ "it was a con: " ++ show (map anameName ds)-        return $ ConPatName ds-      Right (Right d) -> do-        reportSLn "scope.pat" 10 $ "it was a pat syn: " ++ show (anameName d)-        return $ PatternSynPatName d--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 (Show a, ToQName a) => ToAbstract (OldName a) A.QName where-  toAbstract (OldName x) = do-    rx <- resolveName (toQName x)-    case rx of-      DefinedName _ d     -> return $ anameName d-      -- We can get the cases below for DISPLAY pragmas-      ConstructorName (d : _) -> return $ anameName d   -- We'll throw out this one, so it doesn't matter which one we pick-      ConstructorName []      -> __IMPOSSIBLE__-      FieldName (d:_)         -> return $ anameName d-      FieldName []            -> __IMPOSSIBLE__-      PatternSynResName d     -> return $ anameName d-      VarName x               -> typeError $ GenericError $ "Not a defined name: " ++ show x-      UnknownName             -> notInScope (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 . mnameFromList . (:[]) <$> freshAbstractName_ x--checkForModuleClash :: C.Name -> ScopeM ()-checkForModuleClash x = do-  ms <- scopeLookup (C.QName x) <$> getScope-  unless (null ms) $ do-    reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ show ms-    setCurrentRange x $-      typeError $ ShadowedModule x $-                map ((`withRangeOf` x) . amodName) ms--instance ToAbstract NewModuleName A.ModuleName where-  toAbstract (NewModuleName x) = do-    checkForModuleClash x-    m <- getCurrentModule-    y <- freshQModule m x-    createModule False y-    return y--instance ToAbstract NewModuleQName A.ModuleName where-  toAbstract (NewModuleQName m) = toAbs noModuleName m-    where-      toAbs m (C.QName x)  = do-        y <- freshQModule m x-        createModule False y-        return y-      toAbs m (C.Qual x q) = do-        m' <- freshQModule m x-        toAbs m' q--instance ToAbstract OldModuleName A.ModuleName where-  toAbstract (OldModuleName q) = setCurrentRange q $ do-    amodName <$> resolveModule q---- Expressions ---------------------------------------------------------------- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.-mkNamedArg :: C.Expr -> NamedArg C.Expr-mkNamedArg (C.HiddenArg   _ e) = Arg (setHiding Hidden defaultArgInfo) e-mkNamedArg (C.InstanceArg _ e) = Arg (setHiding Instance 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 (setHiding Hidden info) $ namedThing e-mkArg' info (C.InstanceArg _ e) = Arg (setHiding Instance info) $ namedThing e-mkArg' info e                   = Arg (setHiding NotHidden info) e---- | By default, arguments are @Relevant@.-mkArg :: C.Expr -> Arg C.Expr-mkArg e = mkArg' defaultArgInfo e----- | Parse a possibly dotted C.Expr as A.Expr.  Bool = True if dotted.-toAbstractDot :: Precedence -> C.Expr -> ScopeM (A.Expr, Bool)-toAbstractDot prec e = do-    reportSLn "scope.irrelevance" 100 $ "toAbstractDot: " ++ (render $ pretty e)-    traceCall (ScopeCheckExpr e) $ case e of--      C.Dot _ e -> do-        e <- toAbstractCtx prec e-        return (e, True)--      C.RawApp r es -> do-        e <- parseApplication es-        toAbstractDot prec e--      C.Paren _ e -> toAbstractDot TopCtx e--      e -> do-        e <- toAbstractCtx prec e-        return (e, False)---- | Translate concrete expression under at least one binder into nested---   lambda abstraction in abstract syntax.-toAbstractLam :: Range -> [C.LamBinding] -> C.Expr -> Precedence -> ScopeM A.Expr-toAbstractLam r bs e ctx = do-  -- Translate the binders-  localToAbstract (map (C.DomainFull . makeDomainFull) bs) $ \ bs -> do-    -- Translate the body-    e <- toAbstractCtx ctx e-    -- We have at least one binder.  Get first @b@ and rest @bs@.-    caseList bs __IMPOSSIBLE__ $ \ b bs -> do-      return $ 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 -> [(C.LHS, C.RHS, WhereClause, Bool)] -> ScopeM A.Expr-scopeCheckExtendedLam r cs = do-  whenM isInsideDotPattern $-    genericError "Extended lambdas are not allowed in dot patterns"--  -- Find an unused name for the extended lambda definition.-  cname <- nextlamname r 0 extendedLambdaName-  name  <- freshAbstractName_ cname-  reportSLn "scope.extendedLambda" 10 $ "new extended lambda name: " ++ show name-  qname <- qualifyName_ name-  bindName (PrivateAccess Inserted) DefName cname qname--  -- Compose a function definition an scope check it.-  a <- aModeToDef <$> asks envAbstractMode-  let-    insertApp (C.RawAppP r es) = C.RawAppP r $ IdentP (C.QName cname) : es-    insertApp (C.IdentP q    ) = C.RawAppP r $ IdentP (C.QName cname) : [C.IdentP q]-      where r = getRange q-    insertApp _ = __IMPOSSIBLE__-    d = C.FunDef r [] noFixity' {-'-} a __IMPOSSIBLE__ cname $-          for cs $ \ (lhs, rhs, wh, ca) -> -- wh == NoWhere, see parser for more info-            C.Clause cname ca (mapLhsOriginalPattern insertApp lhs) rhs wh []-  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 qname' cs-    _ -> __IMPOSSIBLE__--  where-    -- Get a concrete name that is not yet in scope.-    nextlamname :: Range -> Int -> String -> ScopeM C.Name-    nextlamname r i s = do-      let cname = C.Name r [Id $ stringToRawName $ s ++ show i]-      rn <- resolveName $ C.QName cname-      case rn of-        UnknownName -> return cname-        _           -> nextlamname r (i+1) s----instance ToAbstract C.Expr A.Expr where-  toAbstract e =-    traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of--  -- Names-      Ident x -> toAbstract (OldQName x Nothing)--  -- Literals-      C.Lit l@(LitNat r n) -> do-        let builtin | n < 0     = Just <$> primFromNeg    -- negative literals are only allowed if FROMNEG is defined-                    | otherwise = getBuiltin' builtinFromNat-            l'   = LitNat r (abs n)-            info = ExprRange r-        conv <- builtin-        case conv of-          Just (I.Def q _) -> return $ A.App info (A.Def q) $ defaultNamedArg (A.Lit l')-          _                -> return $ A.Lit l--      C.Lit l@(LitString r s) -> do-        conv <- getBuiltin' builtinFromString-        let info = ExprRange r-        case conv of-          Just (I.Def q _) -> return $ A.App info (A.Def q) $ defaultNamedArg (A.Lit l)-          _                -> return $ A.Lit l--      C.Lit l -> return $ A.Lit l--  -- 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 = maybe Nothing __IMPOSSIBLE__ n-                    , metaNameSuggestion = fromMaybe "" n-                    }--  -- Raw application-      C.RawApp r es -> do-        e <- parseApplication es-        toAbstract e--  -- Application-      C.App r e1 e2 -> do-        e1 <- toAbstractCtx FunctionCtx e1-        e2 <- toAbstractCtx ArgumentCtx e2-        return $ A.App (ExprRange r) 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 cs -> scopeCheckExtendedLam r cs--  -- Relevant and irrelevant non-dependent function type-      C.Fun r e1 e2 -> do-        Arg info (e0, dotted) <- traverse (toAbstractDot FunctionSpaceDomainCtx) $ mkArg e1-        let e1 = Arg ((if dotted then setRelevance Irrelevant else id) info) e0-        e2 <- toAbstractCtx TopCtx e2-        return $ A.Fun (ExprRange r) e1 e2--  -- Dependent function type-      e0@(C.Pi tel e) ->-        localToAbstract tel $ \tel -> do-        e    <- toAbstractCtx TopCtx e-        let info = ExprRange (getRange e0)-        return $ A.Pi info tel e--  -- Sorts-      C.Set _    -> return $ A.Set (ExprRange $ getRange e) 0-      C.SetN _ n -> return $ A.Set (ExprRange $ getRange e) n-      C.Prop _   -> return $ A.Prop $ ExprRange $ getRange e--  -- Let-      e0@(C.Let _ ds 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.Let info ds' e--  -- Record construction-      C.Rec r fs  -> do-        fs' <- toAbstractCtx TopCtx fs-        let ds'  = [ d | Right (_, ds) <- fs', d <- ds ]-            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 e ->-        toAbstractCtx TopCtx =<< parseIdiomBrackets r e--  -- 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 '='"--  -- Quoting-      C.QuoteGoal _ x e -> do-        x' <- toAbstract (NewName x)-        e' <- toAbstract e-        return $ A.QuoteGoal (ExprRange $ getRange e) x' e'-      C.QuoteContext r -> return $ A.QuoteContext (ExprRange r)-      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 es -> do-        let AppView e' args = appView e-        e' : es <- toAbstract (e' : es)-        args    <- toAbstract args-        return $ A.Tactic (ExprRange r) e' args (map defaultNamedArg es)--  -- DontCare-      C.DontCare e -> A.DontCare <$> toAbstract e--instance ToAbstract C.ModuleAssignment (A.ModuleName, [A.LetBinding]) where-  toAbstract (C.ModuleAssignment m es i)-    | null es && isDefaultImportDir i = (\x-> (x, [])) <$> toAbstract (OldModuleName m)-    | otherwise = do-        x <- C.NoName (getRange m) <$> fresh-        r <- checkModuleMacro LetApply (getRange (m, es, i)) PublicAccess x-                          (C.SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))-                          DontOpen i-        case r of-          (LetApply _ m' _ _ _ : _) -> return (m', r)-          _ -> __IMPOSSIBLE__--instance ToAbstract c a => ToAbstract (FieldAssignment' c) (FieldAssignment' a) where-  toAbstract = traverse toAbstract--instance ToAbstract C.LamBinding A.LamBinding where-  toAbstract (C.DomainFree info x) = A.DomainFree info <$> toAbstract (NewName x)-  toAbstract (C.DomainFull tb)     = A.DomainFull <$> toAbstract tb--makeDomainFull :: C.LamBinding -> C.TypedBindings-makeDomainFull (C.DomainFull b)      = b-makeDomainFull (C.DomainFree info x) =-  C.TypedBindings r $ Arg info $ C.TBind r [pure x] $ C.Underscore r Nothing-  where r = getRange x--instance ToAbstract C.TypedBindings A.TypedBindings where-  toAbstract (C.TypedBindings r bs) = A.TypedBindings r <$> toAbstract bs--instance ToAbstract C.TypedBinding A.TypedBinding where-  toAbstract (C.TBind r xs t) = do-    t' <- toAbstractCtx TopCtx t-    xs' <- toAbstract $ map (fmap NewName) xs-    return $ A.TBind r xs' t'-  toAbstract (C.TLet r ds) = A.TLet r <$> toAbstract (LetDefs ds)---- | Scope check a module (top level function).----scopeCheckNiceModule-  :: Range-  -> Access-  -> C.Name-  -> C.Telescope-  -> ScopeM [A.Declaration]-  -> ScopeM [A.Declaration]-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_ [] $-        scopeCheckNiceModule_--  | otherwise = do-        scopeCheckNiceModule_-  where-    -- The actual workhorse:-    scopeCheckNiceModule_ = 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)-      ds <- 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_ (C.QName name) $-          defaultImportDir { publicOpen = p == PublicAccess }-      return ds---- | Check whether a telescope has open declarations or module macros.-telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool-telHasOpenStmsOrModuleMacros = any yesBinds-  where-    yesBinds (C.TypedBindings _ tb) = yesBind $ unArg tb-    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 isLetBinds-  where-    isLetBinds (C.TypedBindings _ tb) = isLetBind $ unArg tb-    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 ()--{- From ghc 7.2, there is LANGUAGE DefaultSignatures-  default ensureNoLetStms :: Foldable t => t a -> ScopeM ()-  ensureNoLetStms = traverse_ ensureNoLetStms--}--instance EnsureNoLetStms C.TypedBinding where-  ensureNoLetStms tb =-    case tb of-      C.TLet{}  -> typeError $ IllegalLetInTelescope tb-      C.TBind{} -> return ()--instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where-  ensureNoLetStms = traverse_ ensureNoLetStms--instance EnsureNoLetStms a => EnsureNoLetStms (TypedBindings' a) where-  ensureNoLetStms = traverse_ ensureNoLetStms--instance EnsureNoLetStms a => EnsureNoLetStms [a] where-  ensureNoLetStms = traverse_ ensureNoLetStms----- | Returns the scope inside the checked module.-scopeCheckModule-  :: Range-  -> 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])-scopeCheckModule r x qm tel checkDs = do-  printScope "module" 20 $ "checking module " ++ show 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 tel-    withCurrentModule qm $ do-      -- pushScope m-      -- qm <- getCurrentModule-      printScope "module" 20 $ "inside module " ++ show x-      ds    <- checkDs-      scope <- getScope-      return (scope, [ A.Section info (qm `withRangesOfQ` x) tel ds ])--  -- Binding is done by the caller-  printScope "module" 20 $ "after module " ++ show x-  return res-  where-    info = ModuleInfo r noRange Nothing Nothing Nothing---- | 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 topLevel = scopeCurrent (topLevelScope topLevel)---- | 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]) TopLevelInfo where-    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 return $ C.QName $ C.Name noRange [Id $ stringToRawName $ rootNameModule file]-                -- 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) file $ Just expectedMName-                  return m0-          setTopLevelModule m-          am           <- toAbstract (NewModuleQName m)-          -- Scope check the declarations outside-          outsideDecls <- toAbstract outsideDecls-          (insideScope, insideDecls) <- scopeCheckModule r m am tel $-             toAbstract insideDecls-          let scope = mapScopeInfo (restrictLocalPrivate am) insideScope-          setScope scope-          return $ TopLevelInfo (outsideDecls ++ insideDecls) scope--        -- We already inserted the missing top-level module, see-        -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',-        -- thus, this case is impossible:-        _ -> __IMPOSSIBLE__---- | runs Syntax.Concrete.Definitions.niceDeclarations on main module-niceDecls :: [C.Declaration] -> ScopeM [NiceDeclaration]-niceDecls ds = case runNice $ niceDeclarations ds of-  Left e   -> throwError $ Exception (getRange e) $ pretty e-  Right ds -> return ds--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where-#else-instance ToAbstract [C.Declaration] [A.Declaration] where-#endif-  toAbstract ds = do-    -- When --safe is active the termination checker (Issue 586) and-    -- positivity checker (Issue 1614) may not be switched off, and-    -- polarities may not be assigned.-    ds <- ifM (optSafe <$> commandLineOptions)-              (mapM (noNoTermCheck >=> noNoPositivityCheck >=> noPolarity) ds)-              (return ds)-    toAbstract =<< niceDecls ds-   where-    -- ASR (31 December 2015). We don't pattern-match on-    -- @NoTerminationCheck@ because the @NO_TERMINATION_CHECK@ pragma-    -- was removed. See Issue 1763.-    noNoTermCheck :: C.Declaration -> TCM C.Declaration-    noNoTermCheck (C.Pragma (C.TerminationCheckPragma r NonTerminating)) =-      typeError $ SafeFlagNonTerminating-    noNoTermCheck (C.Pragma (C.TerminationCheckPragma r Terminating)) =-      typeError $ SafeFlagTerminating-    noNoTermCheck d = return d--    noNoPositivityCheck :: C.Declaration -> TCM C.Declaration-    noNoPositivityCheck (C.Pragma (C.NoPositivityCheckPragma _)) =-      typeError $ SafeFlagNoPositivityCheck-    noNoPositivityCheck d = return d--    noPolarity :: C.Declaration -> TCM C.Declaration-    noPolarity (C.Pragma C.PolarityPragma{}) = typeError SafeFlagPolarity-    noPolarity d                             = return d--newtype LetDefs = LetDefs [C.Declaration]-newtype LetDef = LetDef NiceDeclaration--instance ToAbstract LetDefs [A.LetBinding] where-  toAbstract (LetDefs ds) =-    concat <$> (toAbstract =<< map LetDef <$> niceDecls ds)--instance ToAbstract LetDef [A.LetBinding] where-  toAbstract (LetDef d) =-    case d of-      NiceMutual _ _ _ d@[C.FunSig _ fx _ _ 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."-              (x', e) <- letToAbstract cl-              t <- toAbstract t-              x <- toAbstract (NewName $ mkBoundName x fx)-              -- If InstanceDef set info to Instance-              let info' | instanc == InstanceDef = setHiding Instance info-                        | otherwise              = 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 (setRange (getRange x') x)-                     , A.LetBind (LetRange $ getRange d) info' x t e-                     ]--      -- irrefutable let binding, like  (x , y) = rhs-      NiceFunClause r PublicAccess ConcreteDef termCheck catchall d@(C.FunClause lhs@(C.LHS p [] [] []) (C.RHS rhs) NoWhere ca) -> do-        mp  <- setCurrentRange p $-                 (Right <$> parsePattern p)-                   `catchError`-                 (return . Left)-        case mp of-          Right p -> do-            rhs <- toAbstract rhs-            p   <- toAbstract p-            checkPatternLinearity [p]-            p   <- toAbstract p-            return [ 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 p of-              Nothing -> throwError err-              Just x  -> toAbstract $ LetDef $ NiceMutual r termCheck True-                [ C.FunSig r noFixity' PublicAccess ConcreteDef NotInstanceDef NotMacroDef defaultArgInfo termCheck x (C.Underscore (getRange x) Nothing)-                , C.FunDef r __IMPOSSIBLE__ __IMPOSSIBLE__ ConcreteDef __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 _ (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.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.RawAppP{}            = __IMPOSSIBLE__-              definedName C.AppP{}               = __IMPOSSIBLE__-              definedName C.OpAppP{}             = __IMPOSSIBLE__--      -- You can't open public in a let-      NiceOpen r x dirs | not (publicOpen dirs) -> do-        m    <- toAbstract (OldModuleName x)-        adir <- openModule_ x dirs-        let minfo = ModuleInfo-              { minfoRange  = r-              , minfoAsName = Nothing-              , minfoAsTo   = renamingRange dirs-              , minfoOpenShort = Nothing-              , minfoDirective = Just dirs-              }-        return [A.LetOpen minfo m adir]--      NiceModuleMacro r p x modapp open dir | not (publicOpen dir) ->-        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need-        -- to be private-        checkModuleMacro LetApply r (PrivateAccess Inserted) x modapp open dir--      _   -> notAValidLetBinding d-    where-        letToAbstract (C.Clause top catchall clhs@(C.LHS p [] [] []) (C.RHS rhs) NoWhere []) = do-{--            p    <- parseLHS top p-            localToAbstract (snd $ lhsArgs p) $ \args ->--}-            (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"--            e <- localToAbstract args $ \args ->-                do  rhs <- toAbstract rhs-                    foldM lambda rhs (reverse args)  -- just reverse because these 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.DomainFree info 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.DomainFree info x) e-            where-                i' = ExprRange (fuseRange i e)-        lambda _ _ = notAValidLetBinding d--newtype Blind a = Blind { unBlind :: a }--instance ToAbstract (Blind a) (Blind a) where-  toAbstract = return---- The only reason why we return a list is that open declarations disappears.--- For every other declaration we get a singleton list.-instance ToAbstract NiceDeclaration A.Declaration where--  toAbstract d = annotateDecls $-    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 -> local $ \ e -> e { envAbstractMode = aDefToMode a }) $-    case d of--  -- Axiom (actual postulate)-    C.Axiom r f p a i rel _ x t -> do-      -- check that we do not postulate in --safe mode-      clo <- commandLineOptions-      when (optSafe clo) (typeError (SafeFlagPostulate x))-      -- check the postulate-      toAbstractNiceAxiom A.NoFunSig NotMacroDef d--  -- Fields-    C.NiceField r f p a i 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-      t' <- toAbstractCtx TopCtx $ mapExpr maskIP t-      y  <- freshAbstractQName f x-      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-      when (getHiding t /= Instance && argInfoOverlappable (argInfo t)) $-        genericError "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"-      return [ A.Field (mkDefInfoInstance x f p a i NotMacroDef r) y t' ]--  -- Primitive function-    PrimitiveFunction r f p a x t -> do-      t' <- toAbstractCtx TopCtx t-      y  <- freshAbstractQName f x-      bindName p DefName x y-      return [ A.Primitive (mkDefInfo x f p a r) y t' ]--  -- Definitions (possibly mutual)-    NiceMutual r termCheck pc ds -> do-      ds' <- toAbstract ds-      -- We only termination check blocks that do not have a measure.-      return [ A.Mutual (MutualInfo termCheck pc r) ds' ]--    C.NiceRecSig r f p a _pc x ls t -> do-      ensureNoLetStms ls-      withLocalVars $ do-        ls' <- toAbstract (map makeDomainFull ls)-        t'  <- toAbstract t-        x'  <- freshAbstractQName f x-        bindName p DefName x x'-        return [ A.RecSig (mkDefInfo x f p a r) x' ls' t' ]--    C.NiceDataSig r f p a _pc x ls t -> withLocalVars $ do-        printScope "scope.data.sig" 20 ("checking DataSig for " ++ show x)-        ensureNoLetStms ls-        ls' <- toAbstract (map makeDomainFull ls)-        t'  <- toAbstract t-        x'  <- freshAbstractQName f x-        {- -- Andreas, 2012-01-16: remember number of parameters-        bindName p (DataName (length ls)) x x' -}-        bindName p DefName x x'-        return [ A.DataSig (mkDefInfo x f p a r) x' ls' t' ]--  -- Type signatures-    C.FunSig r f p a i m rel tc x t ->-        toAbstractNiceAxiom A.FunSig m (C.Axiom r f p a i rel Nothing x t)--  -- Function definitions-    C.FunDef r ds f a tc x cs -> do-        printLocals 10 $ "checking def " ++ show x-        (x',cs) <- toAbstract (OldName x,cs)-        let delayed = NotDelayed-        -- (delayed, cs) <- translateCopatternClauses cs -- TODO-        return [ A.FunDef (mkDefInfo x f PublicAccess a r) x' delayed cs ]--  -- Uncategorized function clauses-    C.NiceFunClause r acc abs termCheck catchall (C.FunClause lhs rhs wcls ca) ->-      genericError $-        "Missing type signature for left hand side " ++ show lhs-    C.NiceFunClause{} -> __IMPOSSIBLE__--  -- Data definitions-    C.DataDef r f a _ x pars cons -> withLocalVars $ do-        printScope "scope.data.def" 20 ("checking DataDef for " ++ show x)-        ensureNoLetStms pars-        -- Check for duplicate constructors-        do cs <- mapM conName cons-           let dups = nub $ cs \\ nub cs-               bad  = filter (`elem` dups) cs-           unless (distinct cs) $-             setCurrentRange bad $-                typeError $ DuplicateConstructors dups--        pars <- toAbstract pars-        DefinedName p ax <- resolveName (C.QName x)-        let x' = anameName ax-        -- Create the module for the qualified constructors-        checkForModuleClash x -- disallow shadowing previously defined modules-        let m = mnameFromList $ qnameToList x'-        createModule True m-        bindModule p x m  -- make it a proper module-        cons <- toAbstract (map (ConstrDecl NoRec m a p) cons)-        -- Open the module-        -- openModule_ (C.QName x) defaultImportDir{ publicOpen = True }-        printScope "data" 20 $ "Checked data " ++ show x-        return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' pars cons ]-      where-        conName (C.Axiom _ _ _ _ _ _ _ c _) = return c-        conName d = errorNotConstrDecl d--  -- Record definitions (mucho interesting)-    C.RecDef r f a _ x ind eta cm pars fields -> do-      ensureNoLetStms pars-      withLocalVars $ do-        -- Check that the generated module doesn't clash with a previously-        -- defined module-        checkForModuleClash x-        pars   <- toAbstract pars-        DefinedName p ax <- resolveName (C.QName x)-        let x' = anameName ax-        -- We scope check the fields a first time when putting together-        -- the type of the constructor.-        contel <- toAbstract =<< recordConstructorType fields-        m0     <- getCurrentModule-        let m = A.qualifyM m0 $ mnameFromList [ last $ qnameToList x' ]-        printScope "rec" 15 "before record"-        createModule False m-        -- We scope check the fields a second time, as actual fields.-        afields <- withCurrentModule m $ do-          afields <- toAbstract fields-          printScope "rec" 15 "checked fields"-          return afields-        bindModule p x m-        cm' <- mapM (\(ThingWithFixity c f, _) -> bindConstructorName m c f a p YesRec) cm-        let inst = caseMaybe cm NotInstanceDef snd-        printScope "rec" 15 "record complete"-        return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' ind eta cm' pars contel afields ]--    NiceModule r p a x@(C.QName name) tel ds -> do-      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checking NiceModule " ++ prettyShow x-        ]--      adecls <- traceCall (ScopeCheckDeclaration $ NiceModule r p a x tel []) $ do-        scopeCheckNiceModule r p name tel $ toAbstract ds--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModule " ++ prettyShow x-        ] ++ map (nest 2 . prettyA) adecls-      return adecls--    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-        ]--      adecls <- checkModuleMacro Apply r p x modapp open dir--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModuleMacro " ++ prettyShow x-        ] ++ map (nest 2 . prettyA) adecls-      return adecls--    NiceOpen r x dir -> do-      (minfo, m, adir) <- checkOpen r x dir-      return [A.Open minfo m adir]--    NicePragma r p -> do-      ps <- toAbstract p-      return $ map (A.Pragma r) ps--    NiceImport r x as open dir -> setCurrentRange r $ do-      notPublicWithoutOpen open dir--      -- 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-        printScope "import" 10 "before import:"-        (m, i) <- scopeCheckImport m-        printScope "import" 10 $ "scope checked import: " ++ show i-        -- We don't want the top scope of the imported module (things happening-        -- before the module declaration)-        return (m, Map.delete noModuleName i)--      -- Merge the imported scopes with the current scopes-      modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i--      -- Bind the desired module name to the right abstract name.-      case as of-        Nothing -> bindQModule (PrivateAccess Inserted) x m-        Just y  -> bindModule (PrivateAccess Inserted) (asName y) m--      printScope "import" 10 "merged imported sig:"--      -- Open if specified, otherwise apply import directives-      let (name, theAsSymbol, theAsName) = case as of-            Nothing -> (x,                  noRange,   Nothing)-            Just a  -> (C.QName (asName a), asRange a, Just (asName a))-      adir <- case open of-        DoOpen   -> do-          (_minfo, _m, adir) <- checkOpen r name dir-          return adir-        -- If not opening, import directives are applied to the original scope.-        DontOpen -> modifyNamedScopeM m $ applyImportDirectiveM x dir-      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 fxs p a i tc xs e -> do-      ys <- zipWithM freshAbstractQName fxs xs-      zipWithM_ (bindName p QuotableName) xs ys-      e <- toAbstract e-      zipWithM_ (rebindName p DefName) xs ys-      let mi = MutualInfo tc True 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 fxs p a tc xs e -> do-      ys <- mapM (toAbstract . OldName) xs-      zipWithM_ (rebindName p QuotableName) xs ys-      e <- toAbstract e-      zipWithM_ (rebindName p DefName) xs ys-      return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ]--    NicePatternSyn r fx n as p -> do-      reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ show r-      defn@(as, p) <- withLocalVars $ do-         p  <- toAbstract =<< parsePatternSyn p-         checkPatternLinearity [p]-         let err = "Dot patterns are not allowed in pattern synonyms. Use '_' instead."-         p <- noDotPattern err p-         as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as-         unlessNull (patternVars p \\ map unArg as) $ \ xs -> do-           typeError . GenericDocError =<< do-             text "Unbound variables in pattern synonym: " <+>-               sep (map prettyA xs)-         return (as, p)-      y <- freshAbstractQName fx n-      bindName PublicAccess PatternSynName n y-      modifyPatternSyns (Map.insert y defn)-      return [A.PatternSynDef y as p]   -- only for highlighting-      where unVarName (VarName a) = return a-            unVarName _           = typeError $ UnusedVariableInPatternSynonym--    where-      -- checking postulate or type sig. without checking safe flag-      toAbstractNiceAxiom funSig isMacro (C.Axiom r f p a i info mp x t) = do-        t' <- toAbstractCtx TopCtx t-        y  <- freshAbstractQName f x-        let kind | isMacro == MacroDef = MacroName-                 | otherwise           = DefName-        bindName p kind x y-        return [ A.Axiom funSig (mkDefInfoInstance x f p a i isMacro r) info mp y t' ]-      toAbstractNiceAxiom _ _ _ = __IMPOSSIBLE__---data IsRecordCon = YesRec | NoRec-data ConstrDecl = ConstrDecl IsRecordCon A.ModuleName IsAbstract Access C.NiceDeclaration--bindConstructorName :: ModuleName -> C.Name -> Fixity'-> IsAbstract ->-                       Access -> IsRecordCon -> ScopeM A.QName-bindConstructorName m x f a p record = do-  -- 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, record) of-            (AbstractDef, _) -> PrivateAccess Inserted-            (_, YesRec)      -> OnlyQualified   -- record constructors aren't really in the record module-            _                -> PublicAccess--instance ToAbstract ConstrDecl A.Declaration where-  toAbstract (ConstrDecl record m a p d) = do-    case d of-      C.Axiom r f p1 a1 i info Nothing 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-        y <- bindConstructorName m x f a p record-        printScope "con" 15 "bound constructor"-        return $ A.Axiom NoFunSig (mkDefInfoInstance x f p a i NotMacroDef r)-                         info Nothing y t'-      C.Axiom _ _ _ _ _ _ (Just _) _ _ -> __IMPOSSIBLE__-      _ -> errorNotConstrDecl d--errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a-errorNotConstrDecl d = typeError . GenericDocError $-        P.text "Illegal declaration in data type definition " P.$$-        P.nest 2 (P.vcat $ map pretty (notSoNiceDeclarations d))--instance ToAbstract C.Pragma [A.Pragma] where-  toAbstract (C.ImpossiblePragma _) = impossibleTest-  toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]-  toAbstract (C.RewritePragma _ []) = [] <$ warning EmptyRewritePragma-  toAbstract (C.RewritePragma _ xs) = concat <$> do-   forM xs $ \ x -> do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x          -> return [ A.RewritePragma x ]-      A.Proj _ (AmbQ [x]) -> return [ A.RewritePragma x ]-      A.Proj _ x       -> genericError $ "REWRITE used on ambiguous name " ++ show x-      A.Con (AmbQ [x]) -> return [ A.RewritePragma x ]-      A.Con x          -> genericError $ "REWRITE used on ambiguous name " ++ show x-      A.Var x          -> genericError $ "REWRITE used on parameter " ++ show x ++ " instead of on a defined symbol"-      _       -> __IMPOSSIBLE__-  toAbstract (C.CompiledDeclareDataPragma _ x hs) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.CompiledDeclareDataPragma x hs ]-      _       -> fail $ "Bad compiled type: " ++ show x  -- TODO: error message-  toAbstract (C.CompiledTypePragma _ x hs) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.CompiledTypePragma x hs ]-      _       -> genericError $ "Bad compiled type: " ++ prettyShow x  -- TODO: error message-  toAbstract (C.CompiledDataPragma _ x hs hcs) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.CompiledDataPragma x hs hcs ]-      _       -> genericError $ "Not a datatype: " ++ prettyShow x  -- TODO: error message-  toAbstract (C.CompiledPragma _ x hs) = do-    e <- toAbstract $ OldQName x Nothing-    y <- case e of-          A.Def x -> return x-          A.Proj _ (AmbQ [x]) -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12)-          A.Proj _ x -> genericError $ "COMPILED on ambiguous name " ++ show x-          A.Con _ -> genericError "Use COMPILED_DATA for constructors" -- TODO-          _       -> __IMPOSSIBLE__-    return [ A.CompiledPragma y hs ]-  toAbstract (C.CompiledExportPragma _ x hs) = do-    e <- toAbstract $ OldQName x Nothing-    y <- case e of-          A.Def x -> return x-          _       -> __IMPOSSIBLE__-    return [ A.CompiledExportPragma y hs ]-  toAbstract (C.CompiledEpicPragma _ x ep) = do-    e <- toAbstract $ OldQName x Nothing-    y <- case e of-          A.Def x -> return x-          _       -> __IMPOSSIBLE__-    return [ A.CompiledEpicPragma y ep ]-  toAbstract (C.CompiledJSPragma _ x ep) = do-    e <- toAbstract $ OldQName x Nothing-    y <- case e of-          A.Def x -> return x-          A.Proj _ (AmbQ [x]) -> return x-          A.Proj _ x -> genericError $-            "COMPILED_JS used on ambiguous name " ++ prettyShow x-          A.Con (AmbQ [x]) -> return x-          A.Con x -> genericError $-            "COMPILED_JS used on ambiguous name " ++ prettyShow x-          _       -> __IMPOSSIBLE__-    return [ A.CompiledJSPragma y ep ]-  toAbstract (C.CompiledUHCPragma _ x cr) = do-    e <- toAbstract $ OldQName x Nothing-    y <- case e of-          A.Def x -> return x-          _       -> __IMPOSSIBLE__-    return [ A.CompiledUHCPragma y cr ]-  toAbstract (C.CompiledDataUHCPragma _ x crd crcs) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.CompiledDataUHCPragma x crd crcs ]-      _       -> fail $ "Bad compiled type: " ++ show x  -- TODO: error message-  toAbstract (C.StaticPragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ (AmbQ [x]) -> 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.InlinePragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ (AmbQ [x]) -> return x-          A.Proj _ x -> genericError $-            "INLINE used on ambiguous name " ++ prettyShow x-          _        -> genericError "Target of INLINE pragma should be a function"-      return [ A.InlinePragma y ]-  toAbstract (C.BuiltinPragma _ b e) | isUntypedBuiltin b = do-    bindUntypedBuiltin b =<< toAbstract e-    return []-  toAbstract (C.BuiltinPragma _ b e) = do-    -- Andreas, 2015-02-14-    -- Some builtins cannot be given a valid Agda type,-    -- thus, they do not come with accompanying postulate or definition.-    if b `elem` builtinsNoDef then do-      case e of-        C.Ident q@(C.QName x) -> do-          unlessM ((UnknownName ==) <$> resolveName q) $ genericError $-            "BUILTIN " ++ b ++ " declares an identifier " ++-            "(no longer expects an already defined identifier)"-          y <- freshAbstractQName noFixity' x-          bindName PublicAccess DefName x y-          return [ A.BuiltinNoDefPragma b y ]-        _ -> genericError $-          "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " ++-          "but found expression " ++ prettyShow e-    else do-      e <- toAbstract e-      return [ A.BuiltinPragma b e ]-  toAbstract (C.ImportPragma _ i) = do-    addHaskellImport i-    return []-  toAbstract (C.ImportUHCPragma _ i) = do-    addHaskellImportUHC i-    return []-  toAbstract (C.HaskellCodePragma _ s) = do-    addInlineHaskell s-    return []-  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 _ (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 [x']-        DefinedName _ d     -> return . (False,) $ anameName d-        FieldName     [d]    -> return . (False,) $ anameName d-        FieldName ds         -> genericError $ "Ambiguous projection " ++ show top ++ ": " ++ show (map anameName ds)-        ConstructorName [d] -> return . (False,) $ anameName d-        ConstructorName ds  -> genericError $ "Ambiguous constructor " ++ show top ++ ": " ++ show (map anameName ds)-        UnknownName         -> notInScope top-        PatternSynResName d -> return . (True,) $ anameName d--    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) hd-              | otherwise = A.DefP (PatRange $ getRange lhs) (A.AmbQ [hd])-      p <- expandPatternSynonyms $ mkP ps-      case p of-        A.DefP _ (A.AmbQ [hd]) ps -> return (hd, ps)-        A.ConP _ (A.AmbQ [hd]) ps -> return (hd, ps)-        A.PatternSynP{} -> __IMPOSSIBLE__-        _ -> err--    rhs <- toAbstract rhs-    return [A.DisplayPragma hd ps rhs]--  -- Termination checking pragmes are handled by the nicifier-  toAbstract C.TerminationCheckPragma{} = __IMPOSSIBLE__--  toAbstract C.CatchallPragma{}         = __IMPOSSIBLE__--  -- No positivity checking pragmas are handled by the nicifier.-  toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__--  -- Polarity pragmas are handled by the niceifier.-  toAbstract C.PolarityPragma{} = __IMPOSSIBLE__--instance ToAbstract C.Clause A.Clause where-  toAbstract (C.Clause top _ C.Ellipsis{} _ _ _) = genericError "bad '...'" -- TODO: error message-  toAbstract (C.Clause top catchall lhs@(C.LHS p wps eqs with) rhs wh wcs) = withLocalVars $ do-    -- Andreas, 2012-02-14: need to reset local vars before checking subclauses-    vars <- getLocalVars-    let wcs' = for wcs $ \ c -> setLocalVars vars $> c-    lhs' <- toAbstract $ LeftHandSide (C.QName top) p wps-    printLocals 10 "after lhs:"-    let (whname, whds) = case wh of-          NoWhere        -> (Nothing, [])-          -- Andreas, 2016-07-17 issues #2081 and #2101-          -- where-declarations are automatically private.-          -- This allows their type signature to be checked InAbstractMode.-          AnyWhere ds    -> (Nothing, [C.Private noRange Inserted ds])-          -- Named where-modules do not default to private.-          SomeWhere m a ds -> (Just (m, a), ds)--    let isTerminationPragma :: C.Declaration -> Bool-        isTerminationPragma (C.Private _ _ ds) = any isTerminationPragma ds-        isTerminationPragma (C.Pragma (TerminationCheckPragma _ _)) = True-        isTerminationPragma _                                       = False--    if not (null eqs)-      then do-        rhs <- toAbstract =<< toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs whds)-        return $ A.Clause lhs' [] rhs [] catchall-      else do-        -- ASR (16 November 2015) Issue 1137: We ban termination-        -- pragmas inside `where` clause.-        when (any isTerminationPragma whds) $-             genericError "Termination pragmas are not allowed inside where clauses"--        -- the right hand side is checked inside the module of the local definitions-        (rhs, ds) <- whereToAbstract (getRange wh) whname whds $-                      toAbstractCtx TopCtx (RightHandSide eqs with wcs' rhs [])-        rhs <- toAbstract rhs-        return $ A.Clause lhs' [] rhs ds catchall--whereToAbstract :: Range -> Maybe (C.Name, Access) -> [C.Declaration] -> ScopeM a -> ScopeM (a, [A.Declaration])-whereToAbstract _ _      []   inner = (,[]) <$> inner-whereToAbstract r whname whds inner = do-  -- 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-  let tel = []-  old <- getCurrentModule-  am  <- toAbstract (NewModuleName m)-  (scope, ds) <- scopeCheckModule r (C.QName m) am tel $ toAbstract 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_ (C.QName m) $-      defaultImportDir { publicOpen = True }-  return (x, ds)--data RightHandSide = RightHandSide-  { rhsRewriteEqn :: [C.RewriteEqn]    -- ^ @rewrite e@ (many)-  , rhsWithExpr   :: [C.WithExpr]      -- ^ @with e@ (many)-  , rhsSubclauses :: [ScopeM C.Clause] -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)-  , rhs           :: C.RHS-  , rhsWhereDecls :: [C.Declaration]-  }--data AbstractRHS-  = AbsurdRHS'-  | WithRHS' [A.Expr] [ScopeM C.Clause]  -- ^ The with clauses haven't been translated yet-  | RHS' A.Expr C.Expr-  | RewriteRHS' [A.Expr] AbstractRHS [A.Declaration]--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 AbstractRHS A.RHS where-  toAbstract AbsurdRHS'            = return A.AbsurdRHS-  toAbstract (RHS' e c)            = return $ A.RHS e $ Just c-  toAbstract (RewriteRHS' eqs rhs wh) = do-    auxs <- replicateM (length eqs) $ withFunctionName "rewrite-"-    rhs  <- toAbstract rhs-    return $ RewriteRHS (zip auxs eqs) rhs wh-  toAbstract (WithRHS' es cs) = do-    aux <- withFunctionName "with-"-    A.WithRHS aux es <$> do toAbstract =<< sequence cs--instance ToAbstract RightHandSide AbstractRHS where-  toAbstract (RightHandSide eqs@(_:_) es cs rhs wh) = do-    eqs <- toAbstractCtx TopCtx eqs-                 -- TODO: remember named where-    (rhs, ds) <- whereToAbstract (getRange wh) Nothing wh $-                  toAbstract (RightHandSide [] es cs rhs [])-    return $ RewriteRHS' eqs rhs ds-  toAbstract (RightHandSide [] [] (_ : _) _ _)        = __IMPOSSIBLE__-  toAbstract (RightHandSide [] (_ : _) _ (C.RHS _) _) = typeError $ BothWithAndRHS-  toAbstract (RightHandSide [] [] [] rhs [])          = toAbstract rhs-  toAbstract (RightHandSide [] es cs C.AbsurdRHS [])  = do-    es <- toAbstractCtx TopCtx es-    return $ WithRHS' es cs-  -- TODO: some of these might be possible-  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS (_ : _)) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] [] [] (C.RHS _) (_ : _))       = __IMPOSSIBLE__-  toAbstract (RightHandSide [] [] [] C.AbsurdRHS (_ : _))     = __IMPOSSIBLE__--instance ToAbstract C.RHS AbstractRHS where-    toAbstract C.AbsurdRHS = return $ AbsurdRHS'-    toAbstract (C.RHS e)   = RHS' <$> toAbstract e <*> pure e--data LeftHandSide = LeftHandSide C.QName C.Pattern [C.Pattern]--instance ToAbstract LeftHandSide A.LHS where-    toAbstract (LeftHandSide top lhs wps) =-      traceCall (ScopeCheckLHS top lhs) $ do-        lhscore <- parseLHS top lhs-        reportSLn "scope.lhs" 5 $ "parsed lhs: " ++ show lhscore-        printLocals 10 "before lhs:"-        -- error if copattern parsed but --no-copatterns option-        unlessM (optCopatterns <$> pragmaOptions) $-          case lhscore of-            C.LHSProj{} -> typeError $ NeedOptionCopatterns-            C.LHSHead{} -> return ()-        -- scope check patterns except for dot patterns-        lhscore <- toAbstract lhscore-        reportSLn "scope.lhs" 5 $ "parsed lhs patterns: " ++ show lhscore-        wps  <- toAbstract =<< mapM parsePattern wps-        checkPatternLinearity $ lhsCoreAllPatterns lhscore ++ wps-        printLocals 10 "checked pattern:"-        -- scope check dot patterns-        lhscore <- toAbstract lhscore-        reportSLn "scope.lhs" 5 $ "parsed lhs dot patterns: " ++ show lhscore-        wps     <- toAbstract wps-        printLocals 10 "checked dots:"-        return $ A.LHS (LHSRange $ getRange (lhs, wps)) lhscore wps---- does not check pattern linearity-instance ToAbstract C.LHSCore (A.LHSCore' C.Expr) where-    toAbstract (C.LHSHead x ps) = do-        x    <- withLocalVars $ setLocalVars [] >> toAbstract (OldName x)-        args <- toAbstract ps-        return $ A.LHSHead x args-    toAbstract c@(C.LHSProj d ps1 l ps2) = do-        unless (null ps1) $ typeError $ GenericDocError $-          P.text "Ill-formed projection pattern" P.<+> P.pretty (foldl C.AppP (C.IdentP d) ps1)-        qx <- resolveName d-        ds <- case qx of-                FieldName [] -> __IMPOSSIBLE__-                FieldName ds -> return $ map anameName ds-                UnknownName -> notInScope d-                _           -> genericError $-                  "head of copattern needs to be a field identifier, but "-                  ++ show d ++ " isn't one"-        A.LHSProj (AmbQ ds) <$> toAbstract l <*> toAbstract ps2--instance ToAbstract c a => ToAbstract (WithHiding c) (WithHiding a) where-  toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a--instance ToAbstract c a => ToAbstract (Arg c) (Arg a) where-    toAbstract (Arg info e) =-        Arg info <$> toAbstractHiding info e--instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where-    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) (A.LHSCore' A.Expr) where-    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---- 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) (A.Pattern' A.Expr) where-    toAbstract (A.VarP x)             = return $ A.VarP x-    toAbstract (A.ConP i ds as)       = A.ConP i ds <$> mapM toAbstract as-    toAbstract (A.ProjP i o ds)       = return $ A.ProjP i o ds-    toAbstract (A.DefP i x as)        = A.DefP i x <$> mapM toAbstract as-    toAbstract (A.WildP i)            = return $ A.WildP i-    toAbstract (A.AsP i x p)          = A.AsP i x <$> toAbstract p-    toAbstract (A.DotP i o e)         = A.DotP i o <$> insideDotPattern (toAbstract e)-    toAbstract (A.AbsurdP i)          = return $ A.AbsurdP i-    toAbstract (A.LitP l)             = return $ A.LitP l-    toAbstract (A.PatternSynP i x as) = A.PatternSynP i x <$> mapM toAbstract as-    toAbstract (A.RecP i fs)          = A.RecP i <$> mapM (traverse toAbstract) fs--resolvePatternIdentifier ::-  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)-resolvePatternIdentifier r x ns = do-  px <- toAbstract (PatName x ns)-  case px of-    VarPatName y        -> return $ VarP y-    ConPatName ds       -> return $ ConP (ConPatInfo ConOCon $ PatRange r)-                                         (AmbQ $ map anameName ds)-                                         []-    PatternSynPatName d -> return $ PatternSynP (PatRange r)-                                                (anameName d) []--instance ToAbstract C.Pattern (A.Pattern' C.Expr) where--    toAbstract (C.IdentP x) =-      resolvePatternIdentifier (getRange x) x Nothing--    toAbstract (AppP (QuoteP _) p)-      | IdentP x <- namedArg p,-        getHiding p == NotHidden = do-      e <- toAbstract (OldQName x Nothing)-      let quoted (A.Def x) = return x-          quoted (A.Macro x) = return x-          quoted (A.Proj _ (AmbQ [x])) = return x-          quoted (A.Proj _ (AmbQ xs))  = genericError $ "quote: Ambigous name: " ++ show xs-          quoted (A.Con (AmbQ [x])) = return x-          quoted (A.Con (AmbQ xs))  = genericError $ "quote: Ambigous name: " ++ show xs-          quoted (A.ScopedExpr _ e) = quoted e-          quoted _                  = genericError $ "quote: not a defined name"-      A.LitP . LitQName (getRange x) <$> quoted e--    toAbstract (QuoteP r) =-      genericError "quote must be applied to an identifier"--    toAbstract p0@(AppP p q) = do-        (p', q') <- toAbstract (p, q)-        case p' of-            ConP i x as        -> return $ ConP (i {patInfo = info}) x (as ++ [q'])-            ProjP i o x        -> typeError $ InvalidPattern p0-            DefP _ x as        -> return $ DefP info x (as ++ [q'])-            PatternSynP _ x as -> return $ PatternSynP info x (as ++ [q'])-            _                  -> typeError $ InvalidPattern p0-        where-            r = getRange p0-            info = PatRange r--    toAbstract p0@(OpAppP r op ns ps) = do-        p  <- resolvePatternIdentifier (getRange op) op (Just ns)-        ps <- toAbstract ps-        case p of-          ConP        i x as -> return $ ConP (i {patInfo = info}) x (as ++ ps)-          DefP        _ x as -> return $ DefP               info   x (as ++ ps)-          PatternSynP _ x as -> return $ PatternSynP        info   x (as ++ ps)-          _                  -> __IMPOSSIBLE__-        where-        info = PatRange r--    -- 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 l)       = return $ A.LitP l-    toAbstract p0@(C.AsP r x p) = do-        x <- toAbstract (NewName x)-        p <- toAbstract p-        return $ A.AsP info x p-        where-            info = PatRange r-    -- we have to do dot patterns at the end-    toAbstract p0@(C.DotP r o e) = return $ A.DotP info o e-        where info = PatRange r-    toAbstract p0@(C.AbsurdP r) = return $ A.AbsurdP info-        where info = PatRange r-    toAbstract (C.RecP r fs) = A.RecP (PatRange r) <$>-      mapM (traverse toAbstract) fs---- | 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 ->-                   [NamedArg (MaybePlaceholder (OpApp C.Expr))] ->-                   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 = 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 arg = A.App (ExprRange (fuseRange e arg)) e arg--    -- Translate an argument.-    toAbsOpArg :: Precedence ->-                  NamedArg (Either A.Expr (OpApp C.Expr)) ->-                  ScopeM (NamedArg A.Expr)-    toAbsOpArg cxt =-      traverse $ traverse $ either return (toAbstractOpArg cxt)--    -- 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-        e <- toAbsOpArg (RightOperandCtx f) e-        return [e]-    right _ _     _  = __IMPOSSIBLE__--    replacePlaceholders ::-      [NamedArg (MaybePlaceholder (OpApp 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 = argInfo a-        (ls, ns) <- replacePlaceholders as-        return ( A.DomainFree i 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+ --------------------------------------------------------------------------}++-- | Content of interaction hole.++instance ToAbstract C.HoleContent where+  type AbsOfCon C.HoleContent = A.HoleContent+  toAbstract = \case+    HoleContentExpr e     -> HoleContentExpr <$> toAbstract e+    HoleContentRewrite es -> HoleContentRewrite <$> toAbstract es
src/full/Agda/Syntax/Translation/InternalToAbstract.hs view
@@ -1,1030 +1,1605 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE UndecidableInstances   #-}--{-|-    Translating from internal syntax to abstract syntax. Enables nice-    pretty printing of internal syntax.--    TODO--        - numbers on metas-        - fake dependent functions to independent functions-        - meta parameters-        - shadowing--}-module Agda.Syntax.Translation.InternalToAbstract-  ( Reify(..)-  , NamedClause(..)-  , reifyPatterns-  ) where--import Prelude hiding (mapM_, mapM, null)-import Control.Applicative hiding (empty)-import Control.Monad.State hiding (mapM_, mapM)-import Control.Monad.Reader hiding (mapM_, mapM)--import Data.Foldable (foldMap)-import Data.List hiding (null, sort)-import qualified Data.Map as Map-import Data.Maybe-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Traversable (traverse, mapM)-import qualified Data.Traversable as Trav--import Agda.Syntax.Literal-import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)-import Agda.Syntax.Info as Info-import Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Pretty-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern as I-import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName)--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Reduce-import {-# SOURCE #-} Agda.TypeChecking.Records-import Agda.TypeChecking.CompiledClause (CompiledClauses(Fail))-import Agda.TypeChecking.DisplayForm-import Agda.TypeChecking.Level-import {-# SOURCE #-} Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Free-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.DropArgs--import Agda.Interaction.Options ( optPostfixProjections )--import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Function-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty hiding ((<>))-import Agda.Utils.Singleton-import Agda.Utils.Size-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible---- Composition of reified applications ---------------------------------------- | Drops hidden arguments unless --show-implicit.-napps :: Expr -> [NamedArg Expr] -> TCM Expr-napps e = nelims e . map I.Apply---- | Drops hidden arguments unless --show-implicit.-apps :: Expr -> [Arg Expr] -> TCM Expr-apps e = elims e . map I.Apply---- Composition of reified eliminations ---------------------------------------- | Drops hidden arguments unless --show-implicit.-nelims :: Expr -> [I.Elim' (Named_ Expr)] -> TCM Expr-nelims e [] = return e-nelims e (I.Apply arg : es) = do-  arg <- reify arg  -- This replaces the arg by _ if irrelevant-  dontShowImp <- not <$> showImplicitArguments-  let hd | notVisible arg && dontShowImp = e-         | otherwise                     = A.App noExprInfo e arg-  nelims hd es-nelims e (I.Proj o@ProjPrefix d  : es) =-  nelims (A.App noExprInfo (A.Proj o $ AmbQ [d]) $ defaultNamedArg e) es-nelims e (I.Proj o d  : es) =-  nelims (A.App noExprInfo e (defaultNamedArg $ A.Proj o $ AmbQ [d])) es---- | Drops hidden arguments unless --show-implicit.-elims :: Expr -> [I.Elim' Expr] -> TCM Expr-elims e = nelims e . map (fmap unnamed)---- Omitting information -----------------------------------------------------noExprInfo :: ExprInfo-noExprInfo = ExprRange noRange---- Conditional reification to omit terms that are not shown ----------------reifyWhenE :: Reify i Expr => Bool -> i -> TCM Expr-reifyWhenE True  i = reify i-reifyWhenE False t = return underscore---- Reification --------------------------------------------------------------class Reify i a | i -> a where-    reify     ::         i -> TCM a--    --   @reifyWhen False@ should produce an 'underscore'.-    --   This function serves to reify hidden/irrelevant things.-    reifyWhen :: Bool -> i -> TCM a-    reifyWhen _ = reify--instance Reify Name Name where-    reify = return--instance Reify Expr Expr where-    reifyWhen = reifyWhenE-    reify = return--instance Reify MetaId Expr where-    reifyWhen = reifyWhenE-    reify x@(MetaId n) = liftTCM $ do-      b <- asks envPrintMetasBare-      mi  <- mvInfo <$> lookupMeta x-      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-                 }-          underscore = return $ A.Underscore mi'-      caseMaybeM (isInteractionMeta x) underscore $ \ ii@InteractionId{} ->-          return $ A.QuestionMark mi' ii---- Does not print with-applications correctly:--- instance Reify DisplayTerm Expr where---   reifyWhen = reifyWhenE---   reify d = reifyTerm False $ dtermToTerm d--instance Reify DisplayTerm Expr where-  reifyWhen = reifyWhenE-  reify d = case d of-    DTerm v -> reifyTerm False v-    DDot  v -> reify v-    DCon c ci vs -> apps (A.Con (AmbQ [conName c])) =<< 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---- | @reifyDisplayForm f vs fallback@---   tries to rewrite @f vs@ with a display form for @f@.---   If successful, reifies the resulting display term,---   otherwise, does @fallback@.-reifyDisplayForm :: QName -> I.Elims -> TCM A.Expr -> TCM A.Expr-reifyDisplayForm f es fallback = do-  ifNotM displayFormsEnabled fallback $ {- else -} do-    caseMaybeM (liftTCM $ displayForm f es) fallback reify---- | @reifyDisplayFormP@ tries to recursively---   rewrite a lhs with a display form.------   Note: we are not necessarily in the empty context upon entry!-reifyDisplayFormP :: A.SpineLHS -> TCM A.SpineLHS-reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =-  ifNotM displayFormsEnabled (return lhs) $ {- else -} do-    -- Try to rewrite @f 0 1 2 ... |ps|-1@ to a dt.-    -- Andreas, 2014-06-11  Issue 1177:-    -- I thought we need to add the placeholders for ps to the context,-    -- because otherwise displayForm will not raise the display term-    -- and we will have variable clashes.-    -- But apparently, it has no influence...-    -- Ulf, can you add an explanation?-    md <- liftTCM $ -- addContext (replicate (length ps) "x") $-      displayForm f $ zipWith (\ p i -> I.Apply $ p $> I.var i) ps [0..]-    reportSLn "reify.display" 60 $-      "display form of " ++ show f ++ " " ++ show ps ++ " " ++ show wps ++ ":\n  " ++ show md-    case md of-      Just d  | okDisplayForm d -> do-        -- In the display term @d@, @var i@ should be a placeholder-        -- for the @i@th pattern of @ps@.-        -- Andreas, 2014-06-11:-        -- Are we sure that @d@ did not use @var i@ otherwise?-        lhs' <- displayLHS (map namedArg ps) wps d-        reportSDoc "reify.display" 70 $ do-          doc <- prettyA lhs'-          return $ vcat-            [ text "rewritten lhs to"-            , text "  lhs' = " <+> doc-            ]-        reifyDisplayFormP lhs'-      _ -> do-        reportSLn "reify.display" 70 $ "display form absent or not valid as lhs"-        return lhs-  where-    -- Andreas, 2015-05-03: Ulf, please comment on what-    -- is the idea behind okDisplayForm.-    -- Ulf, 2016-04-15: okDisplayForm should return True if the display form-    -- can serve as a valid left-hand side. That means checking that it is a-    -- defined name applied to valid lhs eliminators (projections or-    -- applications to constructor patterns).-    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--    okDisplayTerm (DTerm v) = okTerm v-    okDisplayTerm DDot{}    = True-    okDisplayTerm DCon{}    = True-    okDisplayTerm DDef{}    = False-    okDisplayTerm _         = False--    okDElim (I.Apply v) = okDisplayTerm $ unArg v-    okDElim I.Proj{}    = True--    okToDropE (I.Apply v) = okToDrop v-    okToDropE I.Proj{}    = False--    okToDrop arg = notVisible arg && case ignoreSharing $ unArg arg of-      I.Var _ []   -> True-      I.DontCare{} -> True  -- no matching on irrelevant things.  __IMPOSSIBLE__ anyway?-      I.Level{}    -> True  -- no matching on levels. __IMPOSSIBLE__ anyway?-      _ -> False--    okArg = okTerm . unArg--    okElim (I.Apply a) = okArg a-    okElim (I.Proj{})  = True--    okTerm (I.Var _ []) = True-    okTerm (I.Con c ci vs) = all okArg vs-    okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms-    okTerm _            = False--    -- Flatten a dt into (parentName, parentElims, withArgs).-    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)-    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 _ = __IMPOSSIBLE__--    displayLHS :: [A.Pattern] -> [A.Pattern] -> DisplayTerm -> TCM A.SpineLHS-    displayLHS ps wps d = do-        let (f, vs, es) = flattenWith d-        ds <- mapM (namedArg <.> elimToPat) es-        vs <- mapM elimToPat vs-        return $ SpineLHS i f vs (ds ++ wps)-      where-        argToPat arg = fmap unnamed <$> traverse termToPat arg-        elimToPat (I.Apply arg) = argToPat arg-        elimToPat (I.Proj o d)  = return $ defaultNamedArg $ A.ProjP patNoRange o $ AmbQ [d]--        termToPat :: DisplayTerm -> TCM A.Pattern--        termToPat (DTerm (I.Var n [])) = return $ case ps !!! n of-                                           Nothing -> __IMPOSSIBLE__-                                           Just p  -> p--        termToPat (DCon c ci vs)          = tryRecPFromConP =<< do-           A.ConP (ConPatInfo ci patNoRange) (AmbQ [conName c]) <$> mapM argToPat vs--        termToPat (DTerm (I.Con c ci vs)) = tryRecPFromConP =<< do-           A.ConP (ConPatInfo ci patNoRange) (AmbQ [conName c]) <$> mapM (argToPat . fmap DTerm) vs--        termToPat (DTerm (I.Def _ [])) = return $ A.WildP patNoRange-        termToPat (DDef _ [])          = return $ A.WildP patNoRange--        termToPat (DDot v)             = A.DotP patNoRange Inserted <$> termToExpr v-        termToPat v                    = A.DotP patNoRange Inserted <$> reify v -- __IMPOSSIBLE__--        len = genericLength ps--        argsToExpr = mapM (traverse termToExpr)--        -- TODO: restructure this to avoid having to repeat the code for reify-        termToExpr :: Term -> TCM A.Expr-        termToExpr v = do-          reportSLn "reify.display" 60 $ "termToExpr " ++ show v-          -- After unSpine, a Proj elimination is __IMPOSSIBLE__!-          case unSpine v of-            I.Con c ci vs ->-              apps (A.Con (AmbQ [conName c])) =<< argsToExpr vs-            I.Def f es -> do-              let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es-              apps (A.Def f) =<< argsToExpr vs-            I.Var n es -> do-              let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es-              -- Andreas, 2014-06-11  Issue 1177-              -- due to β-normalization in substitution,-              -- even the pattern variables @n < len@ can be-              -- applied to some args @vs@.-              e <- if n < len-                   then return $ A.patternToExpr $ ps !! n-                   else reify (I.var (n - len))-              apps e =<< argsToExpr vs-            _ -> return underscore--instance Reify Literal Expr where-  reifyWhen = reifyWhenE-  reify l = return (A.Lit l)--instance Reify Term Expr where-  reifyWhen = reifyWhenE-  reify v = reifyTerm True v--reifyTerm :: Bool -> Term -> TCM Expr-reifyTerm expandAnonDefs0 v = do-  metasBare <- asks envPrintMetasBare-  -- 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)-  v <- ignoreSharing <$> instantiate v-  case applyUnless metasBare (unSpine' pred) v of-    I.Var n es   -> do-        x  <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n)-        elims (A.Var x) =<< reify es-    I.Def x es   -> do-      reifyDisplayForm x es $ reifyDef expandAnonDefs x es-    I.Con c ci vs -> do-      let x = conName c-      isR <- isGeneratedRecordConstructor x-      case isR || ci == ConORec of-        True -> do-          showImp <- showImplicitArguments-          let keep (a, v) = showImp || notHidden a-          r  <- getConstructorData x-          xs <- getRecordFieldNames r-          vs <- map unArg <$> reify vs-          return $ A.Rec noExprInfo $ map (Left . uncurry FieldAssignment . mapFst unArg) $ filter keep $ zip xs vs-        False -> reifyDisplayForm x (map I.Apply vs) $ do-          def <- getConstInfo x-          let Constructor{conPars = np} = theDef def-          -- if we are the the module that defines constructor x-          -- then we have to drop at least the n module parameters-          n  <- getDefFreeVars x-          -- the number of parameters is greater (if the data decl has-          -- extra parameters) or equal (if not) to n-          when (n > np) __IMPOSSIBLE__-          let h = A.Con (AmbQ [x])-          if null vs then return h else do-            es <- reify vs-            -- 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-            -- with the parameter arguments which can be supplied in abstract syntax-            ---            -- Andreas, 2012-09-17: this does not remove all sources of confusion,-            -- since parameters could have the same name as regular arguments-            -- (see for example the parameter {i} to Data.Star.Star, which is also-            -- the first argument to the cons).-            -- @data Star {i}{I : Set i} ... where cons : {i :  I} ...@-            if np == 0 then apps h es else do-              -- Get name of first argument from type of constructor.-              -- Here, we need the reducing version of @telView@-              -- because target of constructor could be a definition-              -- expanding into a function type.  See test/succeed/NameFirstIfHidden.agda.-              TelV tel _ <- telView (defType def)-              let (pars, rest) = splitAt np $ telToList tel-              case rest of-                -- Andreas, 2012-09-18-                -- If the first regular constructor argument is hidden,-                -- we keep the parameters to avoid confusion.-                (Dom info _ : _) | notVisible info -> do-                  let us = for (drop n pars) $ \ (Dom ai _) ->-                             -- setRelevance Relevant $-                             hideOrKeepInstance $ Arg ai underscore-                  apps h $ us ++ es  -- Note: unless --show-implicit, @apps@ will drop @us@.-                -- otherwise, we drop all parameters-                _ -> apps h es----    I.Lam info b | isAbsurdBody b -> return $ A. AbsurdLam noExprInfo $ getHiding info-    I.Lam info b    -> do-      (x,e) <- reify b-      return $ A.Lam noExprInfo (DomainFree info x) e-      -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda-    I.Lit l        -> reify l-    I.Level l      -> reify l-    I.Pi a b       -> case b of-        NoAbs _ b'-          | notHidden 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).-          | 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-          (x, b) <- reify b-          return $ A.Pi noExprInfo [TypedBindings noRange $ Arg info (TBind noRange [pure x] 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 <- asks envPrintDomainFreePi-          return $ and [df, freeIn 0 b, closed a]--    I.Sort s     -> reify s-    I.MetaV x es -> do-      x' <- reify x-      ifM (asks envPrintMetasBare) {-then-} (return x') {-else-} $-        elims x' =<< reify es-    I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v-    I.Shared p   -> reifyTerm expandAnonDefs $ derefPtr p-  where-    -- Andreas, 2012-10-20  expand a copy if not in scope-    -- to improve error messages.-    -- Don't do this if we have just expanded into a display form,-    -- otherwise we loop!-    reifyDef :: Bool -> QName -> I.Elims -> TCM Expr-    reifyDef True x es =-      ifM (not . null . inverseScopeLookupName x <$> getScope) (reifyDef' x es) $ do-      r <- reduceDefCopy x es-      case r of-        YesReduction _ v -> do-          reportSLn "reify.anon" 60 $ unlines-            [ "reduction on defined ident. in anonymous module"-            , "x = " ++ show x-            , "v = " ++ show v-            ]-          reify v-        NoReduction () -> do-          reportSLn "reify.anon" 60 $ unlines-            [ "no reduction on defined ident. in anonymous module"-            , "x  = " ++ show x-            , "es = " ++ show es-            ]-          reifyDef' x es-    reifyDef _ x es = reifyDef' x es--    reifyDef' :: QName -> I.Elims -> TCM Expr-    reifyDef' x es = do-      reportSLn "reify.def" 60 $ "reifying call to " ++ show x-      -- We should drop this many arguments from the local context.-      n <- getDefFreeVars x-      -- If the definition is not (yet) in the signature,-      -- we just do the obvious.-      let fallback = elims (A.Def x) =<< reify (drop n es)-      caseMaybeM (tryMaybe $ getConstInfo x) fallback $ \ defn -> do-      let def = theDef defn--      -- Check if we have an absurd lambda.-      case def of-       Function{ funCompiled = Just Fail, funClauses = [cl] }-                | isAbsurdLambdaName x -> do-                  -- get hiding info from last pattern, which should be ()-                  let h = getHiding $ last $ namedClausePats cl-                  elims (A.AbsurdLam noExprInfo h) =<< reify (drop n es)--      -- Otherwise (no absurd lambda):-       _ -> do--        -- Andrea(s), 2016-07-06-        -- Extended lambdas are not considered to be projection like,-        -- as they are mutually recursive with their parent.-        -- Thus we do not have to consider padding them.--        -- Check whether we have an extended lambda and display forms are on.-        df <- displayFormsEnabled-        toppars <- size <$> do lookupSection $ qnameModule x-        let extLam = case def of-             Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__-             Function{ funExtLam = Just (ExtLamInfo h nh) } -> Just (toppars + h + nh)-             _ -> Nothing-        case extLam of-          Just pars | df -> reifyExtLam x pars (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-              -- This is tricky:-              --  * getDefFreeVars x tells us how many arguments-              --    are part of the local context-              --  * some of those arguments might have been dropped-              --    due to projection likeness-              --  * when showImplicits is on we'd like to see the dropped-              --    projection arguments--              TelV tel _ <- telViewUpTo np (defType defn)-              let (as, rest) = splitAt (np - 1) $ telToList tel-                  dom = fromMaybe __IMPOSSIBLE__ $ headMaybe rest--              -- These are the dropped projection arguments-              scope <- getScope-              let underscore = A.Underscore $ Info.emptyMetaInfo { metaScope = scope }-              let pad = for as $ \ (Dom ai (x, _)) ->-                    Arg ai $ Named (Just $ unranged x) underscore--              -- Now pad' ++ es' = drop n (pad ++ es)-              let pad' = drop n pad-                  es'  = drop (max 0 (n - size pad)) es-              -- Andreas, 2012-04-21: get rid of hidden underscores {_} and {{_}}-              -- Keep non-hidden arguments of the padding.-              ---              -- Andreas, 2016-12-20, issue #2348:-              -- Let @padTail@ be the list of arguments of the padding-              -- (*) after the last visible argument of the padding, and-              -- (*) with the same visibility as the first regular argument.-              -- If @padTail@ is not empty, we need to-              -- print the first regular argument with name.-              -- We further have to print all elements of @padTail@-              -- which have the same name and visibility of the-              -- first regular argument.-              showImp <- showImplicitArguments--              -- Get the visible arguments of the padding and the rest-              -- after the last visible argument.-              let (padVisNamed, padRest) = filterAndRest visible pad'--              -- Remove the names from the visible arguments.-              let padVis  = map (fmap (unnamed . namedThing)) padVisNamed--              -- Keep only the rest with the same visibility of @dom@...-              let padTail = filter ((getHiding dom ==) . getHiding) padRest--              -- ... and even the same name.-              let padSame = filter ((Just (fst (unDom dom)) ==) . fmap rangedThing . nameOf . unArg) padTail--              return $ if null padTail || not showImp-                then (padVis           , map (fmap unnamed) es')-                else (padVis ++ padSame, nameFirstIfHidden dom es')--            -- If it is not a projection(-like) function, we need no padding.-            _ -> return ([], map (fmap unnamed) $ drop n es)-           let hd = foldl' (A.App noExprInfo) (A.Def x) pad-           nelims hd =<< reify nes--    -- Andreas, 2016-07-06 Issue #2047--    -- With parameter refinement, the "parameter" patterns of an extended-    -- lambda can now be different from variable patterns.  If we just drop-    -- them (plus the associated arguments to the extended lambda), we produce-    -- something--    -- * that violates internal invariants.  In particular, the permutation-    --   dbPatPerm from the patterns to the telescope can no longer be-    --   computed.  (And in fact, dropping from the start of the telescope is-    --   just plainly unsound then.)--    -- * prints the wrong thing (old fix for #2047)--    -- What we do now, is more sound, although not entirely satisfying:-    -- When the "parameter" patterns of an external lambdas are not variable-    -- patterns, we fall back to printing the internal function created for the-    -- extended lambda, instead trying to construct the nice syntax.--    reifyExtLam :: QName -> Int -> [I.Clause] -> I.Elims -> TCM Expr-    reifyExtLam x npars cls es = do-      reportSLn "reify.def" 10 $ "reifying extended lambda " ++ show x-      reportSLn "reify.def" 50 $ show $ nest 2 $ vcat-        [ text "npars =" <+> pretty npars-        , text "es    =" <+> fsep (map (prettyPrec 10) es)-        , text "def   =" <+> vcat (map pretty cls) ]-      -- As extended lambda clauses live in the top level, we add the whole-      -- section telescope to the number of parameters.-      let (pars, rest) = splitAt npars es-      -- Since we applying the clauses to the parameters,-      -- we do not need to drop their initial "parameter" patterns-      -- (this is taken care of by @apply@).-      cls <- mapM (reify . NamedClause x False . (`applyE` pars)) cls-      let cx    = nameConcrete $ qnameName x-          dInfo = mkDefInfo cx noFixity' PublicAccess ConcreteDef (getRange x)-      elims (A.ExtendedLam noExprInfo dInfo x cls) =<< reify rest---- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@-nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)]-nameFirstIfHidden dom (I.Apply (Arg info e) : es) | notVisible info =-  I.Apply (Arg info (Named (Just $ unranged $ fst $ unDom dom) e)) :-  map (fmap unnamed) es-nameFirstIfHidden _ es =-  map (fmap unnamed) es--instance Reify i a => Reify (Named n i) (Named n a) where-  reify = traverse reify-  reifyWhen b = traverse (reifyWhen b)---- | Skip reification of implicit and irrelevant args if option is off.-instance (Reify i a) => Reify (Arg i) (Arg a) where-  reify (Arg info i) = Arg info <$> (flip reifyWhen i =<< condition)-    where condition = (return (argInfoHiding info /= Hidden) `or2M` showImplicitArguments)-              `and2M` (return (argInfoRelevance info /= Irrelevant) `or2M` showIrrelevantArguments)-  reifyWhen b i = traverse (reifyWhen b) i---data NamedClause = NamedClause QName Bool I.Clause-  -- ^ Also tracks whether module parameters should be dropped from the patterns.---- The Monoid instance for Data.Map doesn't require that the values are a--- monoid.-newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map.Map k v }--instance (Ord k, Monoid v) => Semigroup (MonoidMap k v) where-  MonoidMap m1 <> MonoidMap m2 = MonoidMap (Map.unionWith mappend m1 m2)--instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where-  mempty = MonoidMap Map.empty-  mappend = (<>)---- | 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 :: ([NamedArg A.Pattern], [A.Pattern]) ->-                  TCM ([NamedArg A.Pattern], [A.Pattern])-stripImplicits (ps, wps) = do          -- v if show-implicit we don't need the names-  ifM showImplicitArguments (return (map (unnamed . namedThing <$>) ps, wps)) $ do-    reportSLn "reify.implicit" 30 $ unlines-      [ "stripping implicits"-      , "  ps   = " ++ show ps-      , "  wps  = " ++ show wps-      ]-    let allps       = ps ++ map defaultNamedArg wps-        sps         = blankDots $ strip allps-        (ps', wps') = splitAt (length sps - length wps) sps-    reportSLn "reify.implicit" 30 $ unlines-      [ "  ps'  = " ++ show ps'-      , "  wps' = " ++ show (map namedArg wps')-      ]-    return (ps', map namedArg wps')-    where-      -- Replace variables in dot patterns by an underscore _ if they are hidden-      -- in the pattern. This is slightly nicer than making the implicts explicit.-      blankDots ps = blank (varsBoundIn ps) ps--      strip ps = stripArgs True ps-        where-          stripArgs _ [] = []-          stripArgs fixedPos (a : as) =-            if canStrip a-            then if   all canStrip $ takeWhile isUnnamedHidden as-                 then stripArgs False as-                 else let a' = fmap ($> A.WildP (Info.PatRange $ getRange a)) a-                      in  stripName fixedPos a' : stripArgs True as-            else stripName fixedPos (stripArg a) : stripArgs True as--          stripName True  = fmap (unnamed . namedThing)-          stripName False = id--          canStrip a = and-            [ notVisible a-            , getOrigin a /= UserWritten-            , varOrDot (namedArg a)-            ]--          isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing && isNothing (isProjP x)--          stripArg a = fmap (fmap stripPat) a--          stripPat p = case p of-            A.VarP _      -> p-            A.ConP i c ps -> A.ConP i c $ stripArgs True ps-            A.ProjP{}     -> p-            A.DefP _ _ _  -> p-            A.DotP _ _ e  -> p-            A.WildP _     -> p-            A.AbsurdP _   -> p-            A.LitP _      -> p-            A.AsP i x p   -> A.AsP i x $ stripPat p-            A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p-            A.RecP i fs   -> A.RecP i $ map (fmap stripPat) fs  -- TODO Andreas: is this right?--          varOrDot A.VarP{}      = True-          varOrDot A.WildP{}     = True-          varOrDot A.DotP{}      = True-          varOrDot (A.ConP cpi _ ps) | patOrigin cpi == ConOSystem-                                 = all varOrDot $ map namedArg ps-          varOrDot _             = False---- | @blank bound x@ replaces all variables in @x@ that are not in @bound@ by---   an underscore @_@. It is used for printing dot patterns: we don't want to---   make implicit variables explicit, so we blank them out in the dot patterns---   instead (this is fine since dot patterns can be inferred anyway).-class BlankVars a where-  blank :: Set Name -> a -> a--instance BlankVars a => BlankVars (Arg a) where-  blank bound = fmap $ blank bound--instance BlankVars a => BlankVars (Named s a) where-  blank bound = fmap $ blank bound--instance BlankVars a => BlankVars [a] where-  blank bound = fmap $ blank bound--instance (BlankVars a, BlankVars b) => BlankVars (a, b) where-  blank bound (x, y) = (blank bound x, blank bound y)--instance (BlankVars a, BlankVars b) => BlankVars (Either a b) where-  blank bound (Left x)  = Left $ blank bound x-  blank bound (Right y) = Right $ blank bound y--instance BlankVars A.NamedDotPattern where-  blank bound = id--instance BlankVars A.Clause where-  blank bound (A.Clause lhs namedDots rhs [] ca) =-    let bound' = varsBoundIn lhs `Set.union` bound-    in  A.Clause (blank bound' lhs)-                 (blank bound' namedDots)-                 (blank bound' rhs) [] ca-  blank bound (A.Clause lhs namedDots rhs (_:_) ca) = __IMPOSSIBLE__--instance BlankVars A.LHS where-  blank bound (A.LHS i core wps) = uncurry (A.LHS i) $ blank bound (core, wps)--instance BlankVars A.LHSCore where-  blank bound (A.LHSHead f ps) = A.LHSHead f $ blank bound ps-  blank bound (A.LHSProj p b ps) = uncurry (A.LHSProj p) $ blank bound (b, ps)--instance BlankVars A.Pattern where-  blank bound p = case p of-    A.VarP _      -> p   -- do not blank pattern vars-    A.ConP c i ps -> A.ConP c i $ blank bound ps-    A.ProjP{}     -> p-    A.DefP i f ps -> A.DefP i f $ blank bound ps-    A.DotP i o e  -> A.DotP i o $ blank bound e-    A.WildP _     -> p-    A.AbsurdP _   -> p-    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--instance BlankVars A.Expr where-  blank bound e = case e of-    A.ScopedExpr i e       -> A.ScopedExpr i $ blank bound e-    A.Var x                -> if x `Set.member` bound then e-                              else A.Underscore emptyMetaInfo-    A.Def _                -> e-    A.Proj{}               -> e-    A.Con _                -> e-    A.Lit _                -> e-    A.QuestionMark{}       -> e-    A.Underscore _         -> e-    A.Dot i e              -> A.Dot i $ blank bound e-    A.App i e1 e2          -> uncurry (A.App i) $ blank bound (e1, e2)-    A.WithApp i e es       -> uncurry (A.WithApp i) $ blank bound (e, es)-    A.Lam i b e            -> let bound' = varsBoundIn b `Set.union` bound-                              in  A.Lam i (blank bound b) (blank bound' e)-    A.AbsurdLam _ _        -> e-    A.ExtendedLam i d f cs -> A.ExtendedLam i d f $ blank bound cs-    A.Pi i tel e           -> let bound' = varsBoundIn tel `Set.union` bound-                              in  uncurry (A.Pi i) $ blank bound' (tel, e)-    A.Fun i a b            -> uncurry (A.Fun i) $ blank bound (a, b)-    A.Set _ _              -> e-    A.Prop _               -> e-    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.QuoteGoal {}         -> __IMPOSSIBLE__-    A.QuoteContext {}      -> __IMPOSSIBLE__-    A.Quote {}             -> __IMPOSSIBLE__-    A.QuoteTerm {}         -> __IMPOSSIBLE__-    A.Unquote {}           -> __IMPOSSIBLE__-    A.Tactic {}            -> __IMPOSSIBLE__-    A.DontCare v           -> A.DontCare $ blank bound v-    A.PatternSyn {}        -> e-    A.Macro {}             -> e--instance BlankVars a => BlankVars (FieldAssignment' a) where-  blank bound = over exprFieldA (blank bound)--instance BlankVars A.ModuleName where-  blank bound = id--instance BlankVars RHS where-  blank bound (RHS e mc)             = RHS (blank bound e) mc-  blank bound AbsurdRHS              = AbsurdRHS-  blank bound (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ-  blank bound (RewriteRHS xes rhs _) = __IMPOSSIBLE__ -- NZ--instance BlankVars A.LamBinding where-  blank bound b@A.DomainFree{} = b-  blank bound (A.DomainFull bs) = A.DomainFull $ blank bound bs--instance BlankVars TypedBindings where-  blank bound (TypedBindings r bs) = TypedBindings r $ blank bound bs--instance BlankVars TypedBinding where-  blank bound (TBind r n e) = TBind r n $ blank bound e-  blank bound (TLet _ _)    = __IMPOSSIBLE__ -- Since the internal syntax has no let bindings left--class Binder a where-  varsBoundIn :: a -> Set Name--instance Binder A.LHS where-  varsBoundIn (A.LHS _ core ps) = varsBoundIn (core, ps)--instance Binder A.LHSCore where-  varsBoundIn (A.LHSHead _ ps)   = varsBoundIn ps-  varsBoundIn (A.LHSProj _ b ps) = varsBoundIn (b, ps)--instance Binder A.Pattern where-  varsBoundIn p = case p of-    A.VarP x             -> if show x == "()" then empty else singleton x-    A.ConP _ _ ps        -> varsBoundIn ps-    A.ProjP{}            -> empty-    A.DefP _ _ ps        -> varsBoundIn ps-    A.WildP{}            -> empty-    A.AsP _ _ p          -> varsBoundIn p-    A.DotP{}             -> empty-    A.AbsurdP{}          -> empty-    A.LitP{}             -> empty-    A.PatternSynP _ _ ps -> varsBoundIn ps-    A.RecP _ fs          -> varsBoundIn fs--instance Binder A.LamBinding where-  varsBoundIn (A.DomainFree _ x) = singleton x-  varsBoundIn (A.DomainFull b)   = varsBoundIn b--instance Binder TypedBindings where-  varsBoundIn (TypedBindings _ b) = varsBoundIn b--instance Binder TypedBinding where-  varsBoundIn (TBind _ xs _) = varsBoundIn xs-  varsBoundIn (TLet _ bs)    = varsBoundIn bs--instance Binder LetBinding where-  varsBoundIn (LetBind _ _ x _ _) = singleton x-  varsBoundIn (LetPatBind _ p _)  = varsBoundIn p-  varsBoundIn LetApply{}          = empty-  varsBoundIn LetOpen{}           = empty-  varsBoundIn LetDeclaredVariable{} = empty--instance Binder a => Binder (FieldAssignment' a) where-  varsBoundIn = varsBoundIn . (^. exprFieldA)--instance Binder a => Binder (Arg a) where-  varsBoundIn = varsBoundIn . unArg--instance Binder a => Binder (Named x a) where-  varsBoundIn = varsBoundIn . namedThing--instance Binder (WithHiding Name) where-  varsBoundIn (WithHiding _ x) = singleton x--instance Binder a => Binder [a] where-  varsBoundIn xs = Set.unions $ map varsBoundIn xs--instance (Binder a, Binder b) => Binder (a, b) where-  varsBoundIn (x, y) = varsBoundIn x `Set.union` varsBoundIn y----- | Assumes that pattern variables have been added to the context already.---   Picks pattern variable names from context.-reifyPatterns :: MonadTCM tcm => [NamedArg I.DeBruijnPattern] -> tcm [NamedArg A.Pattern]-reifyPatterns = mapM $ stripNameFromExplicit <.> traverse (traverse reifyPat)-  where-    stripNameFromExplicit :: NamedArg p -> NamedArg p-    stripNameFromExplicit a-      | getHiding a == NotHidden = fmap (unnamed . namedThing) a-      | otherwise                = a--    reifyPat :: MonadTCM tcm => I.DeBruijnPattern -> tcm A.Pattern-    reifyPat p = do-     liftTCM $ reportSLn "reify.pat" 80 $ "reifying pattern " ++ show p-     case p of-      I.VarP x | isAbsurdPatternName (dbPatVarName x)-               -> return $ A.AbsurdP patNoRange    -- HACK-      I.VarP x -> liftTCM $ A.VarP <$> nameOfBV (dbPatVarIndex x)-      I.DotP v -> do-        t <- liftTCM $ reify v-        return $ A.DotP patNoRange Inserted t-      I.LitP l  -> return $ A.LitP l-      I.ProjP o d     -> return $ A.ProjP patNoRange o $ AmbQ [d]-      I.ConP c cpi ps -> do-        liftTCM $ reportSLn "reify.pat" 60 $ "reifying pattern " ++ show p-        tryRecPFromConP =<< do A.ConP ci (AmbQ [conName c]) <$> reifyPatterns ps-        where-          ci = ConPatInfo origin patNoRange-          origin = fromMaybe ConOCon $ I.conPRecord cpi---- | If the record constructor is generated or the user wrote a record pattern,---   turn constructor pattern into record pattern.---   Otherwise, keep constructor pattern.-tryRecPFromConP :: MonadTCM tcm => A.Pattern -> tcm A.Pattern-tryRecPFromConP p = do-  let fallback = return p-  case p of-    A.ConP ci (AmbQ [c]) ps -> do-        caseMaybeM (liftTCM $ isRecordConstructor c) fallback $ \ (r, def) -> do-          -- If the record constructor is generated or the user wrote a record pattern,-          -- print record pattern.-          -- Otherwise, print constructor pattern.-          if recNamedCon def && patOrigin ci /= ConORec then fallback else do-            fs <- liftTCM $ getRecordFieldNames r-            unless (length fs == length ps) __IMPOSSIBLE__-            return $ A.RecP patNoRange $ zipWith mkFA fs ps-        where-          mkFA ax nap = FieldAssignment (unArg ax) (namedArg nap)-    _ -> __IMPOSSIBLE__--instance Reify (QNamed I.Clause) A.Clause where-  reify (QNamed f cl) = reify (NamedClause f True cl)--instance Reify NamedClause A.Clause where-  reify (NamedClause f toDrop cl) = addContext (clauseTel cl) $ do-    reportSLn "reify.clause" 60 $ "reifying NamedClause"-      ++ "\n  f      = " ++ show f-      ++ "\n  toDrop = " ++ show toDrop-      ++ "\n  cl     = " ++ show cl-    ps  <- reifyPatterns $ namedClausePats cl-    lhs <- liftTCM $ reifyDisplayFormP $ SpineLHS info f ps [] -- LHS info (LHSHead f ps) []-    -- Unless @toDrop@ we have already dropped the module patterns from the clauses-    -- (e.g. for extended lambdas).-    lhs <- if not toDrop then return lhs else do-      nfv <- getDefFreeVars f `catchError` \_ -> return 0-      return $ dropParams nfv lhs-    lhs <- stripImps lhs-    reportSLn "reify.clause" 60 $ "reifying NamedClause, lhs = " ++ show lhs-    rhs <- caseMaybe (clauseBody cl) (return AbsurdRHS) $ \ e -> do-       RHS <$> reify e <*> pure Nothing-    reportSLn "reify.clause" 60 $ "reifying NamedClause, rhs = " ++ show rhs-    let result = A.Clause (spineToLhs lhs) [] rhs [] (I.clauseCatchall cl)-    reportSLn "reify.clause" 60 $ "reified NamedClause, result = " ++ show result-    return result-    where-      perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl-      info = LHSRange noRange--      dropParams n (SpineLHS i f ps wps) = SpineLHS i f (genericDrop n ps) wps-      stripImps (SpineLHS i f ps wps) = do-        (ps, wps) <- stripImplicits (ps, wps)-        return $ SpineLHS i f ps wps--instance Reify Type Expr where-    reifyWhen = reifyWhenE-    reify (I.El _ t) = reify t--instance Reify Sort Expr where-    reifyWhen = reifyWhenE-    reify s = do-      s <- instantiateFull s-      case s of-        I.Type (I.Max [])                -> return $ A.Set noExprInfo 0-        I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set noExprInfo n-        I.Type a -> do-          a <- reify a-          return $ A.App noExprInfo (A.Set noExprInfo 0) (defaultNamedArg a)-        I.Prop       -> return $ A.Prop noExprInfo-        I.Inf       -> A.Var <$> freshName_ ("Setω" :: String)-        I.SizeUniv  -> do-          I.Def sizeU [] <- primSizeUniv-          return $ A.Def sizeU-        I.DLub s1 s2 -> do-          lub <- freshName_ ("dLub" :: String) -- TODO: hack-          (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)-          let app x y = A.App noExprInfo x (defaultNamedArg y)-          return $ A.Var lub `app` e1 `app` e2--instance Reify Level Expr where-  reifyWhen = reifyWhenE-  reify l = reify =<< reallyUnLevelView l--instance (Free i, Reify i a) => Reify (Abs i) (Name, a) where-  reify (NoAbs x v) = (,) <$> freshName_ x <*> reify v-  reify (Abs s v) = do--    -- If the bound variable is free in the body, then the name "_" is-    -- replaced by "z".-    s <- return $ if isUnderscore s && 0 `freeIn` v then "z" else s--    x <- freshName_ s-    e <- addContext' x -- type doesn't matter-         $ reify v-    return (x,e)--instance Reify I.Telescope A.Telescope where-  reify EmptyTel = return []-  reify (ExtendTel arg tel) = do-    Arg info e <- reify arg-    (x,bs)  <- reify tel-    let r = getRange e-    return $ TypedBindings r (Arg info (TBind r [pure x] e)) : bs--instance Reify i a => Reify (Dom i) (Arg a) where-    reify (Dom info i) = Arg info <$> reify i--instance Reify i a => Reify (I.Elim' i) (I.Elim' a) where-  reify = traverse reify-  reifyWhen b = traverse (reifyWhen b)--instance Reify i a => Reify [i] [a] where-  reify = traverse reify-  reifyWhen b = traverse (reifyWhen b)--instance (Reify i1 a1, Reify i2 a2) => Reify (i1,i2) (a1,a2) where-    reify (x,y) = (,) <$> reify x <*> reify y--instance (Reify i1 a1, Reify i2 a2, Reify i3 a3) => Reify (i1,i2,i3) (a1,a2,a3) where-    reify (x,y,z) = (,,) <$> reify x <*> reify y <*> reify z--instance (Reify i1 a1, Reify i2 a2, Reify i3 a3, Reify i4 a4) => Reify (i1,i2,i3,i4) (a1,a2,a3,a4) where+{-# LANGUAGE NondecreasingIndentation   #-}++{-|+    Translating from internal syntax to abstract syntax. Enables nice+    pretty printing of internal syntax.++    TODO++        - numbers on metas+        - fake dependent functions to independent functions+        - meta parameters+        - shadowing+-}+module Agda.Syntax.Translation.InternalToAbstract+  ( Reify(..)+  , MonadReify+  , NamedClause(..)+  , reifyPatterns+  , reifyUnblocked+  , blankNotInScope+  , reifyDisplayFormP+  ) where++import Prelude hiding (null)++import Control.Applicative ( liftA2 )+import Control.Arrow       ( (&&&) )+import Control.Monad       ( filterM, forM )++import qualified Data.List as List+import qualified Data.Map as Map+import Data.Maybe+import Data.Semigroup ( Semigroup, (<>) )+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Traversable (mapM)++import Agda.Syntax.Literal+import Agda.Syntax.Position+import Agda.Syntax.Common+import qualified Agda.Syntax.Concrete.Name as C+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)++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Reduce+import {-# SOURCE #-} Agda.TypeChecking.Records+import Agda.TypeChecking.CompiledClause (CompiledClauses'(Fail))+import Agda.TypeChecking.DisplayForm+import Agda.TypeChecking.Level+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++import Agda.Utils.Either+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible+++-- | Like @reify@ but instantiates blocking metas, useful for reporting.+reifyUnblocked :: Reify i => i -> TCM (ReifiesTo i)+reifyUnblocked t = locallyTCState stInstantiateBlocking (const True) $ reify t+++-- Composition of reified applications ------------------------------------+--UNUSED Liang-Ting 2019-07-16+---- | Drops hidden arguments unless --show-implicit.+--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+nelims e (I.IApply x y r : es) =+  nelims (A.App defaultAppInfo_ e $ defaultArg r) es+nelims e (I.Apply arg : es) = do+  arg <- reify arg  -- This replaces the arg by _ if irrelevant+  dontShowImp <- not <$> showImplicitArguments+  let hd | notVisible arg && dontShowImp = e+         | otherwise                     = A.App defaultAppInfo_ e arg+  nelims hd es+nelims e (I.Proj ProjPrefix d : es)             = nelimsProjPrefix e d es+nelims e (I.Proj o          d : es) | isSelf e  = nelims (A.Proj ProjPrefix $ unambiguous d) es+                                    | 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++-- | If we are referencing the record from inside the record definition, we don't insert an+-- | A.App+isSelf :: Expr -> Bool+isSelf = \case+  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)++-- Omitting information ---------------------------------------------------++noExprInfo :: ExprInfo+noExprInfo = ExprRange noRange++-- 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++-- Reification ------------------------------------------------------------++type MonadReify m =+  ( PureTCM m+  , MonadInteractionPoints m+  , MonadFresh NameId m+  )++class Reify i where+    type ReifiesTo i++    reify :: MonadReify m => i -> m (ReifiesTo i)++    --   @reifyWhen False@ should produce an 'underscore'.+    --   This function serves to reify hidden/irrelevant things.+    reifyWhen :: MonadReify m => Bool -> i -> m (ReifiesTo i)+    reifyWhen _ = reify++instance Reify Bool where+    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++instance Reify Expr where+    type ReifiesTo Expr = Expr++    reifyWhen = reifyWhenE+    reify = return++instance Reify MetaId where+    type ReifiesTo MetaId = Expr++    reifyWhen = reifyWhenE+    reify x = do+      b <- asksTC envPrintMetasBare+      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+      -- source, we turn all unsolved (non-interaction) metas into+      -- interaction points+      isInteractionMeta x >>= \case+        Nothing | b -> do+          ii <- registerInteractionPoint False noRange Nothing+          connectInteractionPoint ii x+          return $ A.QuestionMark mi' ii+        Just ii | b -> underscore+        Nothing     -> underscore+        Just ii     -> return $ A.QuestionMark mi' ii+{-# SPECIALIZE reify :: MetaId -> TCM (ReifiesTo MetaId) #-}++instance Reify DisplayTerm where+  type ReifiesTo DisplayTerm = Expr++  reifyWhen = reifyWhenE+  reify = \case+    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 (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,+--   otherwise, does @fallback@.+reifyDisplayForm :: MonadReify m => QName -> I.Elims -> m A.Expr -> m A.Expr+reifyDisplayForm f es fallback =+  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 ::+     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").+  -> m (QName, A.Patterns) -- ^ New head symbol and new patterns.+reifyDisplayFormP f ps wps = do+  let fallback = return (f, ps ++ wps)+  ifNotM displayFormsEnabled fallback $ {- else -} do+    -- Try to rewrite @f 0 1 2 ... |ps|-1@ to a dt.+    -- Andreas, 2014-06-11  Issue 1177:+    -- I thought we need to add the placeholders for ps to the context,+    -- because otherwise displayForm will not raise the display term+    -- and we will have variable clashes.+    -- But apparently, it has no influence...+    -- Ulf, can you add an explanation?+    md <- -- addContext (replicate (length ps) "x") $+      displayForm f $ zipWith (\ p i -> I.Apply $ p $> I.var i) ps [0..]+    reportSLn "reify.display" 60 $+      "display form of " ++ prettyShow f ++ " " ++ show ps ++ " " ++ show wps ++ ":\n  " ++ show md+    case md of+      Just d  | okDisplayForm d -> do+        -- In the display term @d@, @var i@ should be a placeholder+        -- for the @i@th pattern of @ps@.+        -- Andreas, 2014-06-11:+        -- Are we sure that @d@ did not use @var i@ otherwise?+        (f', ps', wps') <- displayLHS ps d+        reportSDoc "reify.display" 70 $ do+          doc <- prettyA $ SpineLHS empty f' (ps' ++ wps' ++ wps)+          return $ vcat+            [ "rewritten lhs to"+            , "  lhs' = " <+> doc+            ]+        reifyDisplayFormP f' ps' (wps' ++ wps)+      _ -> do+        reportSLn "reify.display" 70 $ "display form absent or not valid as lhs"+        fallback+  where+    -- Andreas, 2015-05-03: Ulf, please comment on what+    -- is the idea behind okDisplayForm.+    -- Ulf, 2016-04-15: okDisplayForm should return True if the display form+    -- can serve as a valid left-hand side. That means checking that it is a+    -- defined name applied to valid lhs eliminators (projections or+    -- applications to constructor patterns).+    okDisplayForm :: DisplayTerm -> Bool+    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 = \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+    okDElim (I.Apply v) = okDisplayTerm $ unArg v+    okDElim I.Proj{}    = True++    okToDropE :: Elim' Term -> Bool+    okToDropE (I.Apply v) = okToDrop v+    okToDropE I.Proj{}    = False+    okToDropE (I.IApply x y r) = False++    okToDrop :: Arg I.Term -> Bool+    okToDrop arg = notVisible arg && case unArg arg of+      I.Var _ []   -> True+      I.DontCare{} -> True  -- no matching on irrelevant things.  __IMPOSSIBLE__ anyway?+      I.Level{}    -> True  -- no matching on levels. __IMPOSSIBLE__ anyway?+      _ -> False++    okArg :: Arg I.Term -> Bool+    okArg = okTerm . unArg++    okElim :: Elim' I.Term -> Bool+    okElim (I.IApply x y r) = okTerm r+    okElim (I.Apply a) = okArg a+    okElim I.Proj{}  = True++    okTerm :: I.Term -> Bool+    okTerm (I.Var _ []) = True+    okTerm (I.Con c ci vs) = all okElim vs+    okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms+    okTerm _            = False++    -- Flatten a dt into (parentName, parentElims, withArgs).+    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) (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') es) = (f, map (fmap DTerm) $ es' ++ es, [])+    flattenWith _ = __IMPOSSIBLE__++    displayLHS+      :: MonadReify m+      => A.Patterns   -- Patterns to substituted into display term.+      -> DisplayTerm  -- Display term.+      -> m (QName, A.Patterns, A.Patterns)  -- New head, patterns, with-patterns.+    displayLHS ps d = do+        let (f, vs, es) = flattenWith d+        ps  <- mapM elimToPat vs+        wps <- mapM (updateNamedArg (A.WithP empty) <.> elimToPat) es+        return (f, ps, wps)+      where+        argToPat :: MonadReify m => Arg DisplayTerm -> m (NamedArg A.Pattern)+        argToPat arg = traverse termToPat arg++        elimToPat :: MonadReify m => I.Elim' DisplayTerm -> m (NamedArg A.Pattern)+        elimToPat (I.IApply _ _ r) = argToPat (Arg defaultArgInfo r)+        elimToPat (I.Apply arg) = argToPat arg+        elimToPat (I.Proj o d)  = return $ defaultNamedArg $ A.ProjP patNoRange o $ unambiguous d++        -- Substitute variables in display term by patterns.+        termToPat :: MonadReify m => DisplayTerm -> m (Named_ A.Pattern)++        -- Main action HERE:+        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) 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 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]+        argsToExpr = mapM (traverse termToExpr)++        -- TODO: restructure this to avoid having to repeat the code for reify+        termToExpr :: MonadReify m => Term -> m A.Expr+        termToExpr v = do+          reportSLn "reify.display" 60 $ "termToExpr " ++ show v+          -- After unSpine, a Proj elimination is __IMPOSSIBLE__!+          case unSpine v of+            I.Con c ci es -> do+              let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es+              apps (A.Con (unambiguous (conName c))) =<< argsToExpr vs+            I.Def f es -> do+              let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es+              apps (A.Def f) =<< argsToExpr vs+            I.Var n es -> do+              let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es+              -- Andreas, 2014-06-11  Issue 1177+              -- due to β-normalization in substitution,+              -- even the pattern variables @n < len@ can be+              -- applied to some args @vs@.+              e <- if n < len+                   then return $ patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n+                   else reify (I.var (n - len))+              apps e =<< argsToExpr vs+            _ -> return underscore++instance Reify Literal where+  type ReifiesTo Literal = Expr++  reifyWhen = reifyWhenE+  reify l = return $ A.Lit empty l; {-# INLINE reify #-}++instance Reify Term where+  type ReifiesTo Term = Expr++  reifyWhen = reifyWhenE+  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)+   mpath  <- getBuiltinName' builtinPath+   mpathp <- getBuiltinName' builtinPathP+   let fallback = return (x,es)+   case (,) <$> mpath <*> mpathp of+     Just (path,pathp) | x == pathp -> do+       let a = case unArg t of+                I.Lam _ (NoAbs _ b)    -> Just b+                I.Lam _ (Abs   _ b)+                  | not $ 0 `freeIn` b -> Just (strengthen impossible b)+                _                      -> Nothing+       case a of+         Just a -> return (path, [I.Apply l, I.Apply (setHiding Hidden $ defaultArg a), I.Apply lhs, I.Apply rhs])+         Nothing -> fallback+     _ -> fallback+reifyPathPConstAsPath x es = return (x,es)++{-# 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++  -- 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,+        Just name <- getGeneralizedFieldName p -> do+      let fakeName = (qnameName p) {nameConcrete = C.simpleName name} -- TODO: infix names!?+      elims (A.Var fakeName) =<< reify es+    I.Var n es -> do+      x <- fromMaybeM (freshName_ $ "@" ++ show n) $ nameOfBV' n+      elims (A.Var x) =<< reify es+    I.Def x es -> do+      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 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+          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+          -- then we have to drop at least the n module parameters+          n <- getDefFreeVars x+          -- the number of parameters is greater (if the data decl has+          -- extra parameters) or equal (if not) to n+          when (n > np) __IMPOSSIBLE__+          let h = A.Con (unambiguous x)+          if null es+            then return h+            else do+              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+              -- with the parameter arguments which can be supplied in abstract syntax+              --+              -- Andreas, 2012-09-17: this does not remove all sources of confusion,+              -- since parameters could have the same name as regular arguments+              -- (see for example the parameter {i} to Data.Star.Star, which is also+              -- the first argument to the cons).+              -- @data Star {i}{I : Set i} ... where cons : {i :  I} ...@+              if np == 0+                then apps h es+                else do+                  -- Get name of first argument from type of constructor.+                  -- Here, we need the reducing version of @telView@+                  -- because target of constructor could be a definition+                  -- expanding into a function type.  See test/succeed/NameFirstIfHidden.agda.+                  TelV tel _ <- telView (defType def)+                  let (pars, rest) = splitAt np $ telToList tel+                  case rest of+                    -- Andreas, 2012-09-18+                    -- If the first regular constructor argument is hidden,+                    -- we keep the parameters to avoid confusion.+                    (Dom {domInfo = info} : _) | notVisible info -> do+                      let us = for (drop n pars) $ \(Dom {domInfo = ai}) ->+                            -- setRelevance Relevant $+                            hideOrKeepInstance $ Arg ai underscore+                      apps h $ us ++ es -- Note: unless --show-implicit, @apps@ will drop @us@.+                    -- otherwise, we drop all parameters+                    _ -> apps h es++--    I.Lam info b | isAbsurdBody b -> return $ A. AbsurdLam noExprInfo $ getHiding info+    I.Lam info b    -> do+      (x,e) <- reify b+      -- #4160: Hacky solution: if --show-implicit, treat all lambdas as user-written. This will+      -- prevent them from being dropped by AbstractToConcrete (where we don't have easy access to+      -- the --show-implicit flag.+      info <- ifM showImplicitArguments (return $ setOrigin UserWritten info) (return info)+      return $ A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ x) e+      -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda+    I.Lit l        -> reify l+    I.Level l      -> reify l+    I.Pi a b       -> case b of+        NoAbs _ 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') = 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 (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 <- lookupLocalMeta x+          (msub1,meta_tel,msub2) <- do+            local_chkpt <- viewTC eCurrentCheckpoint+            (chkpt, tel, msub2) <- enterClosure mv $ \ _ ->+                               (,,) <$> viewTC eCurrentCheckpoint+                                    <*> getContextTelescope+                                    <*> viewTC (eCheckpoints . key local_chkpt)+            (,,) <$> viewTC (eCheckpoints . key chkpt) <*> pure tel <*> pure msub2++          opt_show_ids <- showIdentitySubstitutions+          let+              addNames []    es = map (fmap unnamed) es+              addNames _     [] = []+              addNames xs     (I.Proj{} : _) = __IMPOSSIBLE__+              addNames xs     (I.IApply x y r : es) =+                -- Needs to be I.Apply so it can have an Origin field.+                addNames xs (I.Apply (defaultArg r) : es)+              addNames (x:xs) (I.Apply arg : es) =+                I.Apply (Named (Just x) <$> (setOrigin Substitution arg)) : addNames xs es++              p = mvPermutation mv+              applyPerm p vs = permute (takeP (size vs) p) vs++              names = map (WithOrigin Inserted . unranged) $ p `applyPerm` teleNames meta_tel+              named_es' = addNames names es'++              dropIdentitySubs sub_local2G sub_tel2G =+                 let+                     args_G = applySubst sub_tel2G $ p `applyPerm` (teleArgs meta_tel :: [Arg Term])+                     es_G = sub_local2G `applySubst` es+                     sameVar x (I.Apply y) = isJust xv && xv == deBruijnView (unArg y)+                      where+                       xv = deBruijnView $ unArg x+                     sameVar _ _ = False+                     dropArg = take (size names) $ zipWith sameVar args_G es_G+                     doDrop (b : xs)  (e : es) = (if b then id else (e :)) $ doDrop xs es+                     doDrop []        es = es+                     doDrop _         [] = []+                 in doDrop dropArg $ named_es'++              simpl_named_es' | opt_show_ids                 = named_es'+                              | Just sub_mtel2local <- msub1 = dropIdentitySubs IdS           sub_mtel2local+                              | Just sub_local2mtel <- msub2 = dropIdentitySubs sub_local2mtel IdS+                              | otherwise                    = named_es'++          nelims x' simpl_named_es'++    I.DontCare v -> do+      showIrr <- optShowIrrelevant <$> pragmaOptions+      if | showIrr   -> reifyTerm expandAnonDefs v+         | otherwise -> return underscore+    I.Dummy s [] -> return $ A.Lit empty $ LitString (T.pack s)+    I.Dummy "applyE" es | I.Apply (Arg _ h) : es' <- es -> do+                            h <- reify h+                            es' <- reify es'+                            elims h es'+                        | otherwise -> __IMPOSSIBLE__+    I.Dummy s es -> do+      s <- reify (I.Dummy s [])+      es <- reify es+      elims s es+  where+    -- Andreas, 2012-10-20  expand a copy if not in scope+    -- to improve error messages.+    -- Don't do this if we have just expanded into a display form,+    -- otherwise we loop!+    reifyDef :: MonadReify m => Bool -> QName -> I.Elims -> m Expr+    reifyDef True x es =+      ifM (not . null . inverseScopeLookupName x <$> getScope) (reifyDef' x es) $ do+      r <- reduceDefCopy x es+      case r of+        YesReduction _ v -> do+          reportS "reify.anon" 60+            [ "reduction on defined ident. in anonymous module"+            , "x = " ++ prettyShow x+            , "v = " ++ show v+            ]+          reify v+        NoReduction () -> do+          reportS "reify.anon" 60+            [ "no reduction on defined ident. in anonymous module"+            , "x  = " ++ prettyShow x+            , "es = " ++ show es+            ]+          reifyDef' x es+    reifyDef _ x es = reifyDef' x es++    reifyDef' :: MonadReify m => QName -> I.Elims -> m Expr+    reifyDef' x es = do+      reportSLn "reify.def" 60 $ "reifying call to " ++ prettyShow x+      -- We should drop this many arguments from the local context.+      n <- getDefFreeVars x+      reportSLn "reify.def" 70 $ "freeVars for " ++ prettyShow x ++ " = " ++ show n+      -- If the definition is not (yet) in the signature,+      -- we just do the obvious.+      let fallback _ = elims (A.Def x) =<< reify (drop n es)+      caseEitherM (getConstInfo' x) fallback $ \ defn -> do+      let def = theDef defn++      -- Check if we have an absurd lambda.+      case def of+       Function{ funCompiled = Just Fail{}, funClauses = [cl] }+          | isAbsurdLambdaName x -> do+                  -- get hiding info from last pattern, which should be ()+                  let (ps, p) = fromMaybe __IMPOSSIBLE__ $ initLast $ namedClausePats cl+                  let h = getHiding p+                      n = length ps  -- drop all args before the absurd one+                      absLam = A.AbsurdLam exprNoRange h+                  if | n > length es -> do -- We don't have all arguments before the absurd one!+                        let name (I.VarP _ x) = patVarNameToString $ dbPatVarName x+                            name _            = __IMPOSSIBLE__  -- only variables before absurd pattern+                            vars = map (getArgInfo &&& name . namedArg) $ drop (length es) ps+                            lam (i, s) = do+                              x <- freshName_ s+                              return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg i $ A.mkBinder_ x)+                        foldr ($) absLam <$> mapM lam vars+                      | otherwise -> elims absLam =<< reify (drop n es)++      -- Otherwise (no absurd lambda):+       _ -> do++        -- Andrea(s), 2016-07-06+        -- Extended lambdas are not considered to be projection like,+        -- as they are mutually recursive with their parent.+        -- Thus we do not have to consider padding them.++        -- Check whether we have an extended lambda and display forms are on.+        df <- displayFormsEnabled++        -- #3004: give up if we have to print a pattern lambda inside its own body!+        alreadyPrinting <- viewTC ePrintingPatternLambdas++        extLam <- case def of+          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+              (filter (not . insClause) (defClauses defn)) es++        -- Otherwise (ordinary function call):+          _ -> do+           (pad, nes :: [Elim' (Named_ Term)]) <- case def of++            Function{ funProjection = Right Projection{ projIndex = np } } | np > 0 -> do+              reportSLn "reify.def" 70 $ "  def. is a projection with projIndex = " ++ show np++              -- This is tricky:+              --  * getDefFreeVars x tells us how many arguments+              --    are part of the local context+              --  * some of those arguments might have been dropped+              --    due to projection likeness+              --  * when showImplicits is on we'd like to see the dropped+              --    projection arguments++              TelV tel _ <- telViewUpTo np (defType defn)+              let (as, rest) = splitAt (np - 1) $ telToList tel+                  dom = headWithDefault __IMPOSSIBLE__ rest++              -- These are the dropped projection arguments+              scope <- getScope+              let underscore = A.Underscore $ Info.emptyMetaInfo { metaScope = scope }+              let pad :: [NamedArg Expr]+                  pad = for as $ \ (Dom{domInfo = ai, unDom = (x, _)}) ->+                    Arg ai $ Named (Just $ WithOrigin Inserted $ unranged x) underscore+                      -- TODO #3353 Origin from Dom?++              -- Now pad' ++ es' = drop n (pad ++ es)+              let pad' = drop n pad+                  es'  = drop (max 0 (n - size pad)) es+              -- Andreas, 2012-04-21: get rid of hidden underscores {_} and {{_}}+              -- Keep non-hidden arguments of the padding.+              --+              -- Andreas, 2016-12-20, issue #2348:+              -- Let @padTail@ be the list of arguments of the padding+              -- (*) after the last visible argument of the padding, and+              -- (*) with the same visibility as the first regular argument.+              -- If @padTail@ is not empty, we need to+              -- print the first regular argument with name.+              -- We further have to print all elements of @padTail@+              -- which have the same name and visibility of the+              -- first regular argument.+              showImp <- showImplicitArguments++              -- Get the visible arguments of the padding and the rest+              -- after the last visible argument.+              let (padVisNamed, padRest) = filterAndRest visible pad'++              -- Remove the names from the visible arguments.+              let padVis  = map (fmap $ unnamed . namedThing) padVisNamed++              -- Keep only the rest with the same visibility of @dom@...+              let padTail = filter (sameHiding dom) padRest++              -- ... and even the same name.+              let padSame = filter ((Just (fst $ unDom dom) ==) . bareNameOf) padTail++              return $ if null padTail || not showImp+                then (padVis           , map (fmap unnamed) es')+                else (padVis ++ padSame, nameFirstIfHidden dom es')++            -- If it is not a projection(-like) function, we need no padding.+            _ -> return ([], map (fmap unnamed) $ drop n es)++           reportSDoc "reify.def" 100 $ return $ vcat+             [ "  pad =" <+> pshow pad+             , "  nes =" <+> pshow nes+             ]+           let hd0 | isProperProjection def = A.Proj ProjPrefix $ AmbQ $ singleton x+                   | otherwise = A.Def x+           let hd = List.foldl' (A.App defaultAppInfo_) hd0 pad+           nelims hd =<< reify nes++    -- Andreas, 2016-07-06 Issue #2047++    -- With parameter refinement, the "parameter" patterns of an extended+    -- lambda can now be different from variable patterns.  If we just drop+    -- them (plus the associated arguments to the extended lambda), we produce+    -- something++    -- i) that violates internal invariants.  In particular, the permutation+    -- dbPatPerm from the patterns to the telescope can no longer be+    -- computed.  (And in fact, dropping from the start of the telescope is+    -- just plainly unsound then.)++    -- ii) prints the wrong thing (old fix for #2047)++    -- What we do now, is more sound, although not entirely satisfying:+    -- When the "parameter" patterns of an external lambdas are not variable+    -- patterns, we fall back to printing the internal function created for the+    -- extended lambda, instead trying to construct the nice syntax.++    reifyExtLam+      :: MonadReify m+      => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause]+      -> I.Elims -> m Expr+    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+        , "es    =" <+> fsep (map (prettyPrec 10) es)+        , "def   =" <+> vcat (map pretty cls) ]+      -- As extended lambda clauses live in the top level, we add the whole+      -- section telescope to the number of parameters.+      let (pares, rest) = splitAt npars es+      let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims pares++      -- Since we applying the clauses to the parameters,+      -- we do not need to drop their initial "parameter" patterns+      -- (this is taken care of by @apply@).+      cls <- caseMaybe msys+               (mapM (reify . NamedClause x False . (`apply` pars)) cls)+               (reify . QNamed x . (`apply` pars))+      let cx     = nameConcrete $ qnameName x+          dInfo  = mkDefInfo cx noFixity' PublicAccess ConcreteDef+                     (getRange x)+          erased = case getQuantity ai of+            Quantity0 o -> Erased o+            Quantityω o -> NotErased o+            Quantity1 o -> __IMPOSSIBLE__+          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)]+nameFirstIfHidden dom (I.Apply (Arg info e) : es) | notVisible info =+  I.Apply (Arg info (Named (Just $ WithOrigin Inserted $ unranged $ fst $ unDom dom) e)) :+  map (fmap unnamed) es+nameFirstIfHidden _ es =+  map (fmap unnamed) es++instance Reify i => Reify (Named n i) where+  type ReifiesTo (Named n i) = Named n (ReifiesTo i)++  reify = traverse reify+  reifyWhen b = traverse (reifyWhen b)++-- | Skip reification of implicit and irrelevant args if option is off.+instance Reify i => Reify (Arg i) where+  type ReifiesTo (Arg i) = Arg (ReifiesTo i)++  reify (Arg info i) = Arg info <$> (flip reifyWhen i =<< condition)+    where condition = (return (argInfoHiding info /= Hidden) `or2M` showImplicitArguments)+              `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+--   reify = \case+--     I.IApply x y r -> appl "iapply" <$> reify (defaultArg r :: Arg Term)+--     I.Apply v -> appl "apply" <$> reify v+--     I.Proj f  -> appl "proj"  <$> reify ((defaultArg $ I.Def f []) :: Arg Term)+--     where+--       appl :: String -> Arg Expr -> Expr+--       appl s v = A.App exprInfo (A.Lit empty (LitString s)) $ fmap unnamed v++data NamedClause = NamedClause QName Bool I.Clause+  -- ^ Also tracks whether module parameters should be dropped from the patterns.++-- The Monoid instance for Data.Map doesn't require that the values are a+-- monoid.+newtype MonoidMap k v = MonoidMap { _unMonoidMap :: Map.Map k v }++instance (Ord k, Monoid v) => Semigroup (MonoidMap k v) where+  MonoidMap m1 <> MonoidMap m2 = MonoidMap (Map.unionWith mappend m1 m2)++instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where+  mempty = MonoidMap Map.empty+  mappend = (<>)++-- | Removes argument names.  Preserves names present in the source.+removeNameUnlessUserWritten :: (LensNamed a, LensOrigin (NameOf a)) => a -> a+removeNameUnlessUserWritten a+  | (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+  => 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+      [ "stripping implicits"+      , nest 2 $ "ps   =" <+> pshow ps+      ]+    let ps' = blankDots $ strip ps+    reportSDoc "reify.implicit" 100 $ return $ vcat+      [ nest 2 $ "ps'  =" <+> pshow ps'+      ]+    return ps'+    where+      -- Replace variables in dot patterns by an underscore _ if they are hidden+      -- in the pattern. This is slightly nicer than making the implicts explicit.+      blankDots ps = blank (varsBoundIn $ params ++ ps) ps++      strip ps = stripArgs True ps+        where+          stripArgs _ [] = []+          stripArgs fixedPos (a : as)+            -- A hidden non-UserWritten variable is removed if not needed for+            -- correct position of the following hidden arguments.+            | canStrip a =+                 if   all canStrip $ takeWhile isUnnamedHidden as+                 then stripArgs False as+                 else goWild+            -- Other arguments are kept.+            | otherwise = stripName fixedPos (stripArg a) : stripArgs True as+            where+              a'     = setNamedArg a $ A.WildP $ Info.PatRange $ getRange a+              goWild = stripName fixedPos a' : stripArgs True as++          stripName True  = fmap removeNameUnlessUserWritten+          stripName False = id++          -- TODO: vars appearing in EqualPs shouldn't be stripped.+          canStrip a = and+            [ notVisible a+            , 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++          stripPat = \case+            p@(A.VarP _)        -> p+            A.ConP i c ps       -> A.ConP i c $ stripArgs True ps+            p@A.ProjP{}         -> p+            p@(A.DefP _ _ _)    -> p+            p@(A.DotP _ _e)     -> p+            p@(A.WildP _)       -> p+            p@(A.AbsurdP _)     -> p+            p@(A.LitP _ _)      -> p+            A.AsP i x p         -> A.AsP i x $ stripPat p+            A.PatternSynP _ _ _ -> __IMPOSSIBLE__+            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?++          varOrDot A.VarP{}      = True+          varOrDot A.WildP{}     = True+          varOrDot A.DotP{}      = True+          varOrDot (A.ConP cpi _ ps) | conPatOrigin cpi == ConOSystem+                                 = 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, MonadDebug m, BlankVars a) => a -> m a+blankNotInScope e = do+  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+++-- | @blank bound e@ replaces all variables in expression @e@ that are not in @bound@ by+--   an underscore @_@. It is used for printing dot patterns: we don't want to+--   make implicit variables explicit, so we blank them out in the dot patterns+--   instead (this is fine since dot patterns can be inferred anyway).++class BlankVars a where+  blank :: Set Name -> a -> a++  default blank :: (Functor f, BlankVars b, f b ~ a) => Set Name -> a -> a+  blank = fmap . blank++instance BlankVars a => BlankVars (Arg a)+instance BlankVars a => BlankVars (Named s a)+instance BlankVars a => BlankVars [a]+instance BlankVars a => BlankVars (List1 a)+instance BlankVars a => BlankVars (FieldAssignment' a)+-- instance BlankVars a => BlankVars (A.Pattern' a)         -- see case EqualP !++instance (BlankVars a, BlankVars b) => BlankVars (a, b) where+  blank bound (x, y) = (blank bound x, blank bound y)++instance (BlankVars a, BlankVars b) => BlankVars (Either a b) where+  blank bound (Left x)  = Left $ blank bound x+  blank bound (Right y) = Right $ blank bound y++instance BlankVars A.ProblemEq where+  blank bound = id++instance BlankVars A.Clause where+  blank bound (A.Clause lhs strippedPats rhs wh ca)+    | null wh =+        A.Clause (blank bound' lhs)+                 (blank bound' strippedPats)+                 (blank bound' rhs) noWhereDecls ca+    | otherwise = __IMPOSSIBLE__+    where bound' = varsBoundIn lhs `Set.union` bound++instance BlankVars A.LHS where+  blank bound (A.LHS i core) = A.LHS i $ blank bound core++instance BlankVars A.LHSCore where+  blank bound (A.LHSHead f ps) = A.LHSHead f $ blank bound ps+  blank bound (A.LHSProj p b ps) = uncurry (A.LHSProj p) $ blank bound (b, ps)+  blank bound (A.LHSWith h wps ps) = uncurry (uncurry A.LHSWith) $ blank bound ((h, wps), ps)++instance BlankVars A.Pattern where+  blank bound p = case p of+    A.VarP _      -> p   -- do not blank pattern vars+    A.ConP c i ps -> A.ConP c i $ blank bound ps+    A.ProjP{}     -> p+    A.DefP i f ps -> A.DefP i f $ blank bound ps+    A.DotP i e    -> A.DotP i $ blank bound e+    A.WildP _     -> p+    A.AbsurdP _   -> p+    A.LitP _ _    -> p+    A.AsP i n p   -> A.AsP i n $ blank bound p+    A.PatternSynP _ _ _ -> __IMPOSSIBLE__+    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)++instance BlankVars A.Expr where+  blank bound e = case e of+    A.ScopedExpr i e         -> A.ScopedExpr i $ blank bound e+    A.Var x                  -> if x `Set.member` bound then e+                                else A.Underscore emptyMetaInfo  -- Here is the action!+    A.Def' _ _               -> e+    A.Proj{}                 -> e+    A.Con _                  -> e+    A.Lit _ _                -> e+    A.QuestionMark{}         -> e+    A.Underscore _           -> e+    A.Dot i e                -> A.Dot i $ blank bound e+    A.App i e1 e2            -> uncurry (A.App i) $ blank bound (e1, e2)+    A.WithApp i e es         -> uncurry (A.WithApp i) $ blank bound (e, es)+    A.Lam i b e              -> let bound' = varsBoundIn b `Set.union` bound+                                in  A.Lam i (blank bound b) (blank bound' e)+    A.AbsurdLam _ _          -> e+    A.ExtendedLam i d e f cs -> A.ExtendedLam i d e f $ blank bound cs+    A.Pi i tel e             -> let bound' = varsBoundIn tel `Set.union` bound+                                in  uncurry (A.Pi i) $ blank bound' (tel, e)+    A.Generalized {}         -> __IMPOSSIBLE__+    A.Fun i a b              -> uncurry (A.Fun i) $ blank bound (a, b)+    A.Let _ _ _              -> __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__+    A.DontCare v             -> A.DontCare $ blank bound v+    A.PatternSyn {}          -> e+    A.Macro {}               -> e++instance BlankVars A.ModuleName where+  blank bound = id++instance BlankVars RHS where+  blank bound (RHS e mc)             = RHS (blank bound e) mc+  blank bound AbsurdRHS              = AbsurdRHS+  blank bound (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ+  blank bound (RewriteRHS xes spats rhs _) = __IMPOSSIBLE__ -- NZ++instance BlankVars A.LamBinding where+  blank bound b@A.DomainFree{} = b+  blank bound (A.DomainFull bs) = A.DomainFull $ blank bound bs++instance BlankVars TypedBinding where+  blank bound (TBind r t n e) = TBind r t n $ blank bound e+  blank bound (TLet _ _)    = __IMPOSSIBLE__ -- Since the internal syntax has no let bindings left+++-- | Collect the binders in some abstract syntax lhs.++class Binder a where+  varsBoundIn :: a -> Set Name++  default varsBoundIn :: (Foldable f, Binder b, f b ~ a) => a -> Set Name+  varsBoundIn = foldMap varsBoundIn++instance Binder A.LHS where+  varsBoundIn (A.LHS _ core) = varsBoundIn core++instance Binder A.LHSCore where+  varsBoundIn (A.LHSHead _ ps)     = varsBoundIn ps+  varsBoundIn (A.LHSProj _ b ps)   = varsBoundIn (b, ps)+  varsBoundIn (A.LHSWith h wps ps) = varsBoundIn ((h, wps), ps)++instance Binder A.Pattern where+  varsBoundIn = foldAPattern $ \case+    A.VarP x            -> varsBoundIn x+    A.AsP _ x _         -> empty    -- Not x because of #2414 (?)+    A.ConP _ _ _        -> empty+    A.ProjP{}           -> empty+    A.DefP _ _ _        -> empty+    A.WildP{}           -> empty+    A.DotP{}            -> empty+    A.AbsurdP{}         -> empty+    A.LitP{}            -> empty+    A.PatternSynP _ _ _ -> empty+    A.RecP _ _ _        -> empty+    A.EqualP{}          -> empty+    A.WithP _ _         -> empty++instance Binder a => Binder (A.Binder' a) where+  varsBoundIn (A.Binder p _ n) = varsBoundIn (p, n)++instance Binder A.LamBinding where+  varsBoundIn (A.DomainFree _ x) = varsBoundIn x+  varsBoundIn (A.DomainFull b)   = varsBoundIn b++instance Binder TypedBinding where+  varsBoundIn (TBind _ _ xs _) = varsBoundIn xs+  varsBoundIn (TLet _ bs)      = varsBoundIn bs++instance Binder BindName where+  varsBoundIn x = singleton (unBind x)++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++instance Binder a => Binder (FieldAssignment' a)+instance Binder a => Binder (Arg a)+instance Binder a => Binder (Named x a)+instance Binder a => Binder [a]+instance Binder a => Binder (List1 a)+instance Binder a => Binder (Maybe a)++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]+reifyPatterns = mapM $ (stripNameFromExplicit . stripHidingFromPostfixProj) <.>+                       traverse (traverse reifyPat)+  where+    -- #4399 strip also empty names+    stripNameFromExplicit :: NamedArg p -> NamedArg p+    stripNameFromExplicit a+      | visible a || maybe True (liftA2 (||) null isNoName) (bareNameOf a) =+          fmap (unnamed . namedThing) a+      | otherwise = a++    stripHidingFromPostfixProj :: IsProjP p => NamedArg p -> NamedArg p+    stripHidingFromPostfixProj a = case isProjP a of+      Just (o, _) | o /= ProjPrefix -> setHiding NotHidden a+      _                             -> a++    reifyPat :: MonadReify m => I.DeBruijnPattern -> m A.Pattern+    reifyPat p = do+     reportSDoc "reify.pat" 80 $ return $ "reifying pattern" <+> pretty p+     keepVars <- optKeepPatternVariables <$> pragmaOptions+     case p of+      -- Possibly expanded literal pattern (see #4215)+      p | Just (PatternInfo PatOLit asB) <- patternInfo p -> do+        reduce (I.patternToTerm p) >>= \case+          I.Lit l -> addAsBindings asB $ return $ A.LitP empty l+          _       -> __IMPOSSIBLE__+      I.VarP i x -> addAsBindings (patAsNames i) $ case patOrigin i of+        o@PatODot  -> reifyDotP o $ var $ dbPatVarIndex x+        PatOWild   -> return $ A.WildP patNoRange+        PatOAbsurd -> return $ A.AbsurdP patNoRange+        _          -> reifyVarP x+      I.DotP i v -> addAsBindings (patAsNames i) $ case patOrigin i of+        PatOWild   -> return $ A.WildP patNoRange+        PatOAbsurd -> return $ A.AbsurdP patNoRange+        -- If Agda turned a user variable @x@ into @.x@, print it back as @x@.+        o@(PatOVar x) | I.Var i [] <- v -> do+          x' <- nameOfBV i+          if nameConcrete x == nameConcrete x' then+            return $ A.VarP $ mkBindName x'+          else+            reifyDotP o v+        o -> reifyDotP o v+      I.LitP i l  -> addAsBindings (patAsNames i) $ return $ A.LitP empty l+      I.ProjP o d -> return $ A.ProjP patNoRange o $ unambiguous d+      I.ConP c cpi ps | conPRecord cpi -> addAsBindings (patAsNames $ conPInfo cpi) $+        case patOrigin (conPInfo cpi) of+          PatOWild   -> return $ A.WildP patNoRange+          PatOAbsurd -> return $ A.AbsurdP patNoRange+          PatOVar x | keepVars -> return $ A.VarP $ mkBindName x+          _               -> reifyConP c cpi ps+      I.ConP c cpi ps -> addAsBindings (patAsNames $ conPInfo cpi) $ reifyConP c cpi ps+      I.DefP i f ps  -> addAsBindings (patAsNames i) $ case patOrigin i of+        PatOWild   -> return $ A.WildP patNoRange+        PatOAbsurd -> return $ A.AbsurdP patNoRange+        PatOVar x | keepVars -> return $ A.VarP $ mkBindName x+        _ -> A.DefP patNoRange (unambiguous f) <$> reifyPatterns ps+      I.IApplyP i _ _ x -> addAsBindings (patAsNames i) $ case patOrigin i of+        o@PatODot  -> reifyDotP o $ var $ dbPatVarIndex x+        PatOWild   -> return $ A.WildP patNoRange+        PatOAbsurd -> return $ A.AbsurdP patNoRange+        _          -> reifyVarP x++    reifyVarP :: MonadReify m => DBPatVar -> m A.Pattern+    reifyVarP x = do+      n <- nameOfBV $ dbPatVarIndex x+      let y = dbPatVarName x+      if | y == "_" -> return $ A.VarP $ mkBindName n+           -- Andreas, 2017-09-03: TODO for #2580+           -- Patterns @VarP "()"@ should have been replaced by @AbsurdP@, but the+           -- case splitter still produces them.+         | prettyShow (nameConcrete n) == "()" -> return $ A.VarP (mkBindName n)+           -- Andreas, 2017-09-03, issue #2729+           -- Restore original pattern name.  AbstractToConcrete picks unique names.+         | otherwise -> return $ A.VarP $+             mkBindName n { nameConcrete = C.simpleName y }++    reifyDotP :: MonadReify m => PatOrigin -> Term -> m A.Pattern+    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+              => ConHead -> ConPatternInfo -> [NamedArg DeBruijnPattern]+              -> m A.Pattern+    reifyConP c cpi ps = do+      tryRecPFromConP =<< do A.ConP ci (unambiguous (conName c)) <$> reifyPatterns ps+      where+        ci = ConPatInfo origin patNoRange lazy+        lazy | conPLazy cpi = ConPatLazy+             | otherwise    = ConPatEager+        origin = fromConPatternInfo cpi++    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.+tryRecPFromConP :: MonadReify m => A.Pattern -> m A.Pattern+tryRecPFromConP p = do+  let fallback = return p+  case p of+    A.ConP ci c ps -> do+        reportSLn "reify.pat" 60 $ "tryRecPFromConP " ++ prettyShow c+        caseMaybeM (isRecordConstructor $ headAmbQ c) fallback $ \ (r, def) -> do+          -- 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+            let fs = recordFieldNames def+            unless (length fs == length ps) __IMPOSSIBLE__+            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.+recOrCon :: MonadReify m => QName -> ConOrigin -> [Arg Expr] -> m A.Expr+recOrCon c co es = do+  reportSLn "reify.expr" 60 $ "recOrCon " ++ prettyShow c+  caseMaybeM (isRecordConstructor c) fallback $ \ (r, def) -> do+    -- 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+      let fs = recordFieldNames def+      unless (length fs == length es) __IMPOSSIBLE__+      return $ A.Rec empty empty $ zipWith mkFA fs es+  where+  fallback = apps (A.Con (unambiguous c)) es+  mkFA ax  = Left . FieldAssignment (unDom ax) . unArg++instance Reify (QNamed I.Clause) where+  type ReifiesTo (QNamed I.Clause) = A.Clause++  reify (QNamed f cl) = reify (NamedClause f True cl); {-# INLINE reify #-}++instance Reify NamedClause where+  type ReifiesTo NamedClause = A.Clause++  reify (NamedClause f toDrop cl) = addContext (clauseTel cl) $ do+    reportSDoc "reify.clause" 60 $ return $ vcat+      [ "reifying NamedClause"+      , "  f      =" <+> pretty f+      , "  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 []+    -- Unless @toDrop@ we have already dropped the module patterns from the clauses+    -- (e.g. for extended lambdas). We still get here with toDrop = True and+    -- pattern lambdas when doing make-case, so take care to drop the right+    -- number of parameters.+    (params , lhs) <- if not toDrop then return ([] , lhs) else do+      nfv <- getDefModule f >>= \case+        Left _  -> return 0+        Right m -> size <$> lookupSection m+      return $ splitParams nfv lhs+    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 => 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]++  reify (QNamed f (System tel sys)) = addContext tel $ do+    reportS "reify.system" 40 $ show tel : map show sys+    view <- intervalView'+    unview <- intervalUnview'+    sys <- flip filterM sys $ \ (phi,t) -> 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+      ps <- reifyPatterns $ teleNamedArgs tel+      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]++      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)) #-}++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{..} <- infallibleSortKit+      case s of+        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 $ 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+          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)+          let app x y = A.App defaultAppInfo_ x (defaultNamedArg y)+          return $ A.Var pis `app` e1 `app` e2+        I.FunSort s1 s2 -> do+          funs <- freshName_ ("funSort" :: String) -- TODO: hack+          (e1,e2) <- reify (s1 , s2)+          let app x y = A.App defaultAppInfo_ x (defaultNamedArg y)+          return $ A.Var funs `app` e1 `app` e2+        I.UnivSort s -> do+          univs <- freshName_ ("univSort" :: String) -- TODO: hack+          e <- reify s+          return $ A.App defaultAppInfo_ (A.Var univs) $ defaultNamedArg e+        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++  reifyWhen = reifyWhenE+  reify l   = ifM haveLevels (reify =<< reallyUnLevelView l) $ {-else-} do+    -- Andreas, 2017-09-18, issue #2754+    -- While type checking the level builtins, they are not+    -- 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)++  reify (NoAbs x v) = freshName_ x >>= \name -> (name,) <$> reify v+  reify (Abs s v) = do++    -- If the bound variable is free in the body, then the name "_" is+    -- replaced by "z".+    s <- return $ if isUnderscore s && 0 `freeIn` v then "z" else s++    x <- C.setNotInScope <$> freshName_ s+    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++  reify EmptyTel = return []+  reify (ExtendTel arg tel) = do+    Arg info e <- reify arg+    (x, bs)  <- reify tel+    let r    = getRange e+        name = domName arg+    tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic arg+    let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x+    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)++  reify = traverse reify+  reifyWhen b = traverse (reifyWhen b)++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)++instance (Reify i1, Reify i2) => Reify (i1, i2) where+    type ReifiesTo (i1, i2) = (ReifiesTo i1, ReifiesTo i2)+    reify (x,y) = (,) <$> reify x <*> reify y++instance (Reify i1, Reify i2, Reify i3) => Reify (i1,i2,i3) where+    type ReifiesTo (i1, i2, i3) = (ReifiesTo i1, ReifiesTo i2, ReifiesTo i3)+    reify (x,y,z) = (,,) <$> reify x <*> reify y <*> reify z++instance (Reify i1, Reify i2, Reify i3, Reify i4) => Reify (i1,i2,i3,i4) where+    type ReifiesTo (i1, i2, i3, i4) = (ReifiesTo i1, ReifiesTo i2, ReifiesTo i3, ReifiesTo i4)     reify (x,y,z,w) = (,,,) <$> reify x <*> reify y <*> reify z <*> reify w
src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs view
@@ -1,177 +1,316 @@-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE UndecidableInstances   #-}- {-# OPTIONS_GHC -fwarn-missing-signatures #-}  module Agda.Syntax.Translation.ReflectedToAbstract where -import Control.Applicative-import Control.Monad.Reader+import Control.Arrow        ( (***) )+import Control.Monad        ( foldM )+import Control.Monad.Except ( MonadError )+import Control.Monad.Reader ( MonadReader(..), asks, reader, runReaderT ) -import Data.Traversable as Trav hiding (mapM)+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text -import Agda.Syntax.Fixity import Agda.Syntax.Literal 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'(..)) +import Agda.Interaction.Options (optUseUnicode, UnicodeOrAscii(..)) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.Syntax.Scope.Monad (getCurrentModule) +import Agda.Utils.Impossible import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty import Agda.Utils.Functor+import Agda.Utils.Singleton import Agda.Utils.Size -type Names = [Name]+type Vars = [(Name,R.Type)] -type WithNames a = ReaderT Names TCM a--- Note: we only need the TCM for fresh names+type MonadReflectedToAbstract m =+  ( MonadReader Vars m+  , MonadFresh NameId m+  , MonadError TCErr m+  , MonadTCEnv m+  , ReadTCState m+  , HasOptions m+  , HasBuiltins m+  , HasConstInfo m+  )  -- | Adds a new unique name to the current context.-withName :: String -> (Name -> WithNames a) -> WithNames a-withName s f = do+--   NOTE: See @chooseName@ in @Agda.Syntax.Translation.AbstractToConcrete@ for similar logic.+--   NOTE: See @freshConcreteName@ in @Agda.Syntax.Scope.Monad@ also for similar logic.+withName :: MonadReflectedToAbstract m => String -> (Name -> m a) -> m a+withName s = withVar s R.Unknown++withVar :: MonadReflectedToAbstract m => String -> R.Type -> (Name -> m a) -> m a+withVar s t f = do   name <- freshName_ s-  ctx  <- asks $ map nameConcrete-  let name' = head $ filter (notTaken ctx) $ iterate nextName name-  local (name:) $ f name'+  ctx  <- asks $ map $ nameConcrete . fst+  glyphMode <- optUseUnicode <$> M.pragmaOptions+  let freshNameMode = case glyphMode of+        UnicodeOk -> A.UnicodeSubscript+        AsciiOnly -> A.AsciiCounter+  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 --- | Returns the name of the variable with the given de Bruijn index.-askName :: Int -> WithNames (Maybe Name)-askName i = reader (!!! i)+withNames :: MonadReflectedToAbstract m => [String] -> ([Name] -> m a) -> m a+withNames ss = withVars $ zip ss $ repeat R.Unknown -class ToAbstract r a | r -> a where-  toAbstract :: r -> WithNames a+withVars :: MonadReflectedToAbstract m => [(String, R.Type)] -> ([Name] -> m a) -> m a+withVars ss f = case ss of+  []     -> f []+  ((s,t):ss) -> withVar s t $ \n -> withVars ss $ \ns -> f (n:ns) +-- | Returns the name and type of the variable with the given de Bruijn index.+askVar :: MonadReflectedToAbstract m => Int -> m (Maybe (Name,R.Type))+askVar i = reader (!!! i)++askName :: MonadReflectedToAbstract m => Int -> m (Maybe Name)+askName i = fmap fst <$> askVar i++class ToAbstract r where+  type AbsOfRef r+  toAbstract :: MonadReflectedToAbstract m => r -> m (AbsOfRef r)++  default toAbstract+    :: (Traversable t, ToAbstract s, t s ~ r, t (AbsOfRef s) ~ (AbsOfRef r))+    => MonadReflectedToAbstract m => r -> m (AbsOfRef r)+  toAbstract = traverse toAbstract+ -- | Translate reflected syntax to abstract, using the names from the current typechecking context.-toAbstract_ :: ToAbstract r a => r -> TCM a+toAbstract_ ::+  (ToAbstract r+  , MonadFresh NameId m+  , MonadError TCErr m+  , MonadTCEnv m+  , ReadTCState m+  , HasOptions m+  , HasBuiltins m+  , HasConstInfo m+  ) => r -> m (AbsOfRef r) toAbstract_ = withShowAllArguments . toAbstractWithoutImplicit  -- | Drop implicit arguments unless --show-implicit is on.-toAbstractWithoutImplicit :: ToAbstract r a => r -> TCM a-toAbstractWithoutImplicit x = runReaderT (toAbstract x) =<< getContextNames+toAbstractWithoutImplicit ::+  (ToAbstract r+  , MonadFresh NameId m+  , MonadError TCErr m+  , MonadTCEnv m+  , ReadTCState m+  , HasOptions m+  , HasBuiltins m+  , HasConstInfo m+  ) => r -> m (AbsOfRef r)+toAbstractWithoutImplicit x = do+  xs <- killRange <$> getContextNames'+  let ctx = zip xs $ repeat R.Unknown+  runReaderT (toAbstract x) ctx -instance ToAbstract r a => ToAbstract (Named name r) (Named name a) where-  toAbstract = traverse toAbstract+instance ToAbstract r => ToAbstract (Named name r) where+  type AbsOfRef (Named name r) = Named name (AbsOfRef r) -instance ToAbstract r a => ToAbstract (Arg r) (NamedArg a) where+instance ToAbstract r => ToAbstract (Arg r) where+  type AbsOfRef (Arg r) = NamedArg (AbsOfRef r)   toAbstract (Arg i x) = Arg i <$> toAbstract (unnamed x) -instance ToAbstract [Arg Term] [NamedArg Expr] where-  toAbstract = traverse toAbstract+instance ToAbstract r => ToAbstract [Arg r] where+  type AbsOfRef [Arg r] = [NamedArg (AbsOfRef r)] -instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBindings) where-  toAbstract (Dom i x, name) = do+-- 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, domIsFinite = isfin, unDom = x, domTactic = tac}, name) = do     dom <- toAbstract x-    return $ TypedBindings noRange $ Arg i $ TBind noRange [pure 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) Expr where+instance ToAbstract (A.Expr, Elim) where+  type AbsOfRef (A.Expr, Elim) = A.Expr   toAbstract (f, Apply arg) = do     arg     <- toAbstract arg-    showImp <- lift showImplicitArguments-    return $ if showImp || getHiding arg == NotHidden-             then App (ExprRange noRange) f arg+    showImp <- showImplicitArguments+    return $ if showImp || visible arg+             then A.App (setOrigin Reflected defaultAppInfo_) f arg              else f -instance ToAbstract (Expr, Elims) Expr where+instance ToAbstract (A.Expr, Elims) where+  type AbsOfRef (A.Expr, Elims) = A.Expr   toAbstract (f, elims) = foldM (curry toAbstract) f elims -instance ToAbstract r a => ToAbstract (R.Abs r) (a, Name) where-  toAbstract (Abs s x) = withName s' $ \name -> (,) <$> toAbstract x <*> return name+instance ToAbstract r => ToAbstract (R.Abs r) where+  type AbsOfRef (R.Abs r) = (AbsOfRef r, 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 Expr where-  toAbstract l = return (A.Lit l)+instance ToAbstract Literal where+  type AbsOfRef Literal = A.Expr+  toAbstract l = return $ A.Lit empty l -instance ToAbstract Term Expr where-  toAbstract t = case t of+instance ToAbstract Term where+  type AbsOfRef Term = A.Expr+  toAbstract = \case     R.Var i es -> do-      mname <- askName i-      case mname of-        Nothing -> do-          cxt   <- lift $ getContextTelescope-          names <- asks $ drop (size cxt) . reverse-          lift $ withShowAllArguments' False $ typeError $ DeBruijnIndexOutOfScope i cxt names-        Just name -> toAbstract (A.Var name, es)-    R.Con c es -> toAbstract (A.Con (AmbQ [killRange c]), es)+      name <- mkVarName i+      toAbstract (A.Var name, es)+    R.Con c es -> toAbstract (A.Con (unambiguous $ killRange c), es)     R.Def f es -> do-      af <- lift $ mkDef (killRange f)+      af <- mkDef (killRange f)       toAbstract (af, es)     R.Lam h t  -> do       (e, name) <- toAbstract t       let info  = setHiding h $ setOrigin Reflected defaultArgInfo-      return $ A.Lam exprNoRange (DomainFree info name) e+      return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ name) e     R.ExtLam cs es -> do       name <- freshName_ extendedLambdaName-      m    <- lift $ getCurrentModule+      m    <- getCurrentModule       let qname   = qualify m name           cname   = nameConcrete name           defInfo = mkDefInfo cname noFixity' PublicAccess ConcreteDef noRange-      cs <- toAbstract $ map (QNamed qname) cs-      toAbstract (A.ExtendedLam exprNoRange defInfo qname cs, es)+      cs <- toAbstract $ fmap (QNamed qname) cs+      toAbstract+        (A.ExtendedLam exprNoRange defInfo defaultErased qname cs, es)     R.Pi a b   -> do       (b, name) <- toAbstract b       a         <- toAbstract (a, name)-      return $ A.Pi exprNoRange [a] b+      return $ A.Pi exprNoRange (singleton a) b     R.Sort s   -> toAbstract s     R.Lit l    -> toAbstract l-    R.Meta x es    -> toAbstract (A.Underscore info, es)-      where info = emptyMetaInfo{ metaNumber = Just x }-    R.Unknown      -> return $ Underscore emptyMetaInfo+    R.Meta x es    -> do+      info <- mkMetaInfo+      let info' = info{ metaNumber = Just x }+      toAbstract (A.Underscore info', es)+    R.Unknown      -> A.Underscore <$> mkMetaInfo -mkDef :: QName -> TCM A.Expr-mkDef f =-  ifM (isMacro . theDef <$> getConstInfo f)-      (return $ A.Macro f)-      (return $ A.Def f)+mkMetaInfo :: ReadTCState m => m MetaInfo+mkMetaInfo = do+  scope <- getScope+  return $ emptyMetaInfo { metaScope = scope } -mkSet :: Expr -> Expr-mkSet e = App exprNoRange (A.Set exprNoRange 0) $ defaultNamedArg e+mkDef :: HasConstInfo m => QName -> m A.Expr+mkDef f = getConstInfo f <&> theDef <&> \case -instance ToAbstract Sort Expr where-  toAbstract (SetS x) = mkSet <$> toAbstract x-  toAbstract (LitS x) = return $ A.Set exprNoRange x-  toAbstract UnknownS = return $ mkSet $ Underscore emptyMetaInfo+  Constructor{}+    -> A.Con $ unambiguous f -instance ToAbstract R.Pattern (Names, A.Pattern) where+  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+  names <- asks $ drop (size cxt) . reverse . map fst+  withShowAllArguments' False $ typeError $ DeBruijnIndexOutOfScope i cxt names++mkVarName :: MonadReflectedToAbstract m => Int -> m Name+mkVarName i = fst <$> mkVar i+++instance ToAbstract Sort where+  type AbsOfRef Sort = A.Expr+  toAbstract s = do+    setName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+    propName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp+    infName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSetOmega+    case s of+      SetS x -> mkApp (A.Def setName) <$> toAbstract x+      LitS x -> return $ A.Def' setName $ A.Suffix x+      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) . A.Underscore <$> mkMetaInfo++instance ToAbstract R.Pattern where+  type AbsOfRef R.Pattern = A.Pattern   toAbstract pat = case pat of     R.ConP c args -> do-      (names, args) <- toAbstractPats args-      return (names, A.ConP (ConPatInfo ConOCon patNoRange) (AmbQ [killRange c]) args)-    R.DotP    -> return ([], A.WildP patNoRange)-    R.VarP s | isNoName s -> withName "z" $ \ name -> return ([name], A.VarP name)-        -- Ulf, 2016-08-09: Also bind noNames (#2129). This to make the-        -- behaviour consistent with lambda and pi.-        -- return ([], A.WildP patNoRange)-    R.VarP s  -> withName s $ \ name -> return ([name], A.VarP name)-    R.LitP l  -> return ([], A.LitP l)-    R.AbsurdP -> return ([], A.AbsurdP patNoRange)-    R.ProjP d -> return ([], A.ProjP patNoRange ProjSystem $ AmbQ [killRange d])+      args <- toAbstract args+      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+      return $ A.VarP $ A.mkBindName x+    R.LitP l  -> return $ A.LitP patNoRange l+    R.AbsurdP _i -> return $ A.AbsurdP patNoRange+    R.ProjP d -> return $ A.ProjP patNoRange ProjSystem $ unambiguous $ killRange d -toAbstractPats :: [Arg R.Pattern] -> WithNames (Names, [NamedArg A.Pattern])-toAbstractPats pats = case pats of-    []   -> return ([], [])-    p:ps -> do-      (names,  p)  <- (distributeF . fmap distributeF) <$> toAbstract p-      (namess, ps) <- local (names++) $ toAbstractPats ps-      return (namess++names, p:ps)+instance ToAbstract (QNamed R.Clause) where+  type AbsOfRef (QNamed R.Clause) = A.Clause -instance ToAbstract (QNamed R.Clause) A.Clause where-  toAbstract (QNamed name (R.Clause pats rhs)) = do-    (names, pats) <- toAbstractPats pats-    rhs           <- local (names++) $ toAbstract rhs-    let lhs = spineToLhs $ SpineLHS (LHSRange noRange) name pats []-    return $ A.Clause lhs [] (RHS rhs Nothing) [] False-  toAbstract (QNamed name (R.AbsurdClause pats)) = do-    (_, pats) <- toAbstractPats pats-    let lhs = spineToLhs $ SpineLHS (LHSRange noRange) name pats []-    return $ A.Clause lhs [] AbsurdRHS [] False+  toAbstract (QNamed name (R.Clause tel pats rhs)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do+    checkClauseTelescopeBindings tel pats+    pats <- toAbstract pats+    rhs  <- toAbstract rhs+    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 $ A.SpineLHS empty name pats+    return $ A.Clause lhs [] A.AbsurdRHS A.noWhereDecls empty -instance ToAbstract [QNamed R.Clause] [A.Clause] where+instance ToAbstract [QNamed R.Clause] where+  type AbsOfRef [QNamed R.Clause] = [A.Clause]   toAbstract = traverse toAbstract++instance ToAbstract (List1 (QNamed R.Clause)) where+  type AbsOfRef (List1 (QNamed R.Clause)) = List1 A.Clause+  toAbstract = traverse toAbstract++-- | Check that all variables in the telescope are bound in the left-hand side. Since we check the+--   telescope by attaching type annotations to the pattern variables there needs to be somewhere to+--   put the annotation. Also, since the lhs is where the variables are actually bound, missing a+--   binding for a variable that's used later in the telescope causes unbound variable panic+--   (see #5044).+checkClauseTelescopeBindings :: MonadReflectedToAbstract m => [(Text, Arg R.Type)] -> [Arg R.Pattern] -> m ()+checkClauseTelescopeBindings tel pats =+  case reverse [ x | ((x, _), i) <- zip (reverse tel) [0..], not $ Set.member i bs ] of+    [] -> return ()+    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++    boundVars = Set.unions . map (bound . unArg)+    bound (R.VarP i)    = Set.singleton i+    bound (R.ConP _ ps) = boundVars ps+    bound R.DotP{}      = Set.empty+    bound R.LitP{}      = Set.empty+    bound (R.AbsurdP i) = Set.singleton i+    bound R.ProjP{}     = Set.empty
src/full/Agda/Syntax/Treeless.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wunused-imports #-} +{-# LANGUAGE PatternSynonyms #-}+ -- | The treeless syntax is intended to be used as input for the compiler backends. -- It is more low-level than Internal syntax and is not used for type checking. --@@ -12,25 +14,42 @@     ) where  import Control.Arrow (first, second)+import Control.DeepSeq -import Data.Map (Map)-import Data.Typeable (Typeable)+import Data.Word +import GHC.Generics (Generic)+ import Agda.Syntax.Position import Agda.Syntax.Literal+import Agda.Syntax.Common import Agda.Syntax.Abstract.Name  data Compiled = Compiled   { cTreeless :: TTerm-  , cArgUsage :: [Bool] }-  deriving (Typeable, Show, Eq, Ord)+  , cArgUsage :: Maybe [ArgUsage]+      -- ^ 'Nothing' if treeless usage analysis has not run yet.+  }+  deriving (Show, Eq, Ord, Generic) +-- | Usage status of function arguments in treeless code.+data ArgUsage+  = ArgUsed+  | ArgUnused+  deriving (Show, Eq, Ord, Generic)++-- | The treeless compiler can behave differently depending on the target+--   language evaluation strategy. For instance, more aggressive erasure for+--   lazy targets.+data EvaluationStrategy = LazyEvaluation | EagerEvaluation+  deriving (Eq, Show)+ type Args = [TTerm]  -- 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@@ -39,11 +58,11 @@            | 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.-           | TCase Int CaseType TTerm [TAlt]+           | TCase Int CaseInfo TTerm [TAlt]            -- ^ Case scrutinee (always variable), case type, default value, alternatives            -- First, all TACon alternatives are tried; then all TAGuard alternatives            -- in top to bottom order.@@ -51,9 +70,10 @@            | TUnit -- used for levels right now            | TSort            | TErased+           | TCoerce TTerm  -- ^ Used by the GHC backend            | TError TError            -- ^ A runtime error, something bad has happened.-  deriving (Typeable, Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic)  -- | Compiler-related primitives. This are NOT the same thing as primitives -- in Agda's surface or internal syntax!@@ -66,37 +86,55 @@ -- Q    | QName -- S    | String data TPrim-  = PAdd-  | PSub-  | PMul-  | PQuot-  | PRem+  = PAdd | PAdd64+  | PSub | PSub64+  | PMul | PMul64+  | PQuot | PQuot64+  | PRem  | PRem64   | PGeq-  | PLt-  | PEqI+  | PLt   | PLt64+  | PEqI  | PEq64   | PEqF   | PEqS   | PEqC   | PEqQ   | PIf   | PSeq-  deriving (Typeable, Show, Eq, Ord)+  | PITo64 | P64ToI+  deriving (Show, Eq, Ord, Generic)  isPrimEq :: TPrim -> Bool-isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ]+isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ, PEq64] +-- | Strip leading coercions and indicate whether there were some.+coerceView :: TTerm -> (Bool, TTerm)+coerceView = \case+  TCoerce t -> (True,) $ snd $ coerceView t+  t         -> (False, t)+ mkTApp :: TTerm -> Args -> TTerm mkTApp x           [] = x mkTApp (TApp x as) bs = TApp x (as ++ bs) mkTApp x           as = TApp x as -tAppView :: TTerm -> [TTerm]-tAppView = view-  where-    view t = case t of-      TApp a bs -> view a ++ bs-      _         -> [t]+tAppView :: TTerm -> (TTerm, [TTerm])+tAppView = \case+  TApp a bs -> second (++ bs) $ tAppView a+  t         -> (t, []) +-- | Expose the format @coerce f args@.+--+--   We fuse coercions, even if interleaving with applications.+--   We assume that coercion is powerful enough to satisfy+--   @+--      coerce (coerce f a) b = coerce f a b+--   @+coerceAppView :: TTerm -> ((Bool, TTerm), [TTerm])+coerceAppView = \case+  TCoerce t -> first ((True,) . snd) $ coerceAppView t+  TApp a bs -> second (++ bs) $ coerceAppView a+  t         -> ((False, t), [])+ tLetView :: TTerm -> ([TTerm], TTerm) tLetView (TLet e b) = first (e :) $ tLetView b tLetView e          = ([], e)@@ -114,12 +152,16 @@ mkLet x body = TLet x body  tInt :: Integer -> TTerm-tInt = TLit . LitNat noRange+tInt = TLit . LitNat  intView :: TTerm -> Maybe Integer-intView (TLit (LitNat _ x)) = Just x+intView (TLit (LitNat x)) = Just x intView _ = Nothing +word64View :: TTerm -> Maybe Word64+word64View (TLit (LitWord64 x)) = Just x+word64View _ = Nothing+ tPlusK :: Integer -> TTerm -> TTerm tPlusK 0 n = n tPlusK k n | k < 0 = tOp PSub n (tInt (-k))@@ -139,8 +181,14 @@ negPlusKView _ = Nothing  tOp :: TPrim -> TTerm -> TTerm -> TTerm-tOp op a b = TApp (TPrim op) [a, b]+tOp op a b = TPOp op a b +pattern TPOp :: TPrim -> TTerm -> TTerm -> TTerm+pattern TPOp op a b = TApp (TPrim op) [a, b]++pattern TPFn :: TPrim -> TTerm -> TTerm+pattern TPFn op a = TApp (TPrim op) [a]+ tUnreachable :: TTerm tUnreachable = TError TUnreachable @@ -148,15 +196,23 @@ tIfThenElse c i e = TApp (TPrim PIf) [c, i, e]  data CaseType-  = CTData QName -- case on datatype+  = CTData QName+    -- Case on datatype.   | CTNat   | CTInt   | CTChar   | CTString   | CTFloat   | CTQName-  deriving (Typeable, Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) +data CaseInfo = CaseInfo+  { caseLazy :: Bool+  , caseErased :: Erased+    -- ^ Is this a match on an erased argument?+  , caseType :: CaseType }+  deriving (Show, Eq, Ord, Generic)+ data TAlt   = TACon    { aCon  :: QName, aArity :: Int, aBody :: TTerm }   -- ^ Matches on the given constructor. If the match succeeds,@@ -164,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 (Typeable, Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic)  data TError   = TUnreachable@@ -173,7 +232,11 @@   -- Runtime behaviour of unreachable code is undefined, but preferably   -- the program will exit with an error message. The compiler is free   -- to assume that this code is unreachable and to remove it.-  deriving (Typeable, Show, Eq, Ord)+  | TMeta String+  -- ^ 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 (Show, Eq, Ord, Generic)   class Unreachable a where@@ -191,3 +254,41 @@ instance KillRange Compiled where   killRange c = c -- bogus, but not used anyway ++-- * Utilities for ArgUsage+---------------------------------------------------------------------------++-- | @filterUsed used args@ drops those @args@ which are labelled+-- @ArgUnused@ in list @used@.+--+-- Specification:+--+-- @+--   filterUsed used args = [ a | (a, ArgUsed) <- zip args $ used ++ repeat ArgUsed ]+-- @+--+-- Examples:+--+-- @+--   filterUsed []                 == id+--   filterUsed (repeat ArgUsed)   == id+--   filterUsed (repeat ArgUnused) == const []+-- @+filterUsed :: [ArgUsage] -> [a] -> [a]+filterUsed = curry $ \case+  ([], args) -> args+  (_ , [])   -> []+  (ArgUsed   : used, a : args) -> a : filterUsed used args+  (ArgUnused : used, a : args) ->     filterUsed used args++-- NFData instances+---------------------------------------------------------------------------++instance NFData Compiled+instance NFData ArgUsage+instance NFData TTerm+instance NFData TPrim+instance NFData CaseType+instance NFData CaseInfo+instance NFData TAlt+instance NFData TError
src/full/Agda/Termination/CallGraph.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams             #-}  -- | Call graphs and related concepts, more or less as defined in@@ -27,13 +27,11 @@ import Prelude hiding (null)  import qualified Data.List as List-import Data.Semigroup import Data.Set (Set)  import Agda.Termination.CallMatrix (CallMatrix, CallMatrixAug(..), CMSet(..), CallComb(..)) import qualified Agda.Termination.CallMatrix as CMSet import Agda.Termination.CutOff-import Agda.Termination.SparseMatrix as Matrix  import Agda.Utils.Favorites (Favorites) import qualified Agda.Utils.Favorites as Fav@@ -41,10 +39,10 @@ import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph  import Agda.Utils.Function-import Agda.Utils.Monad+ import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Utils.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Tuple @@ -62,7 +60,7 @@ --   It can be labelled with several call matrices if there --   are several pathes from one function to another. -type Call cinfo = Edge Node Node (CMSet cinfo)+type Call cinfo = Edge Node (CMSet cinfo)  callMatrixSet :: Call cinfo -> CMSet cinfo callMatrixSet = label@@ -83,7 +81,7 @@ -- meta information for different calls can be combined when the calls -- are combined. -newtype CallGraph cinfo = CallGraph { theCallGraph :: Graph Node Node (CMSet cinfo) }+newtype CallGraph cinfo = CallGraph { theCallGraph :: Graph Node (CMSet cinfo) }   deriving (Show)  @@ -101,8 +99,8 @@ -- | Converts a list of calls with associated meta information to a --   call graph. -fromList :: [Call cinfo] -> CallGraph cinfo-fromList = CallGraph . Graph.fromListWith CMSet.union+fromListCG :: [Call cinfo] -> CallGraph cinfo+fromListCG = CallGraph . Graph.fromEdgesWith CMSet.union  -- | 'null' checks whether the call graph is completely disconnected. instance Null (CallGraph cinfo) where@@ -124,6 +122,12 @@   mempty  = empty   mappend = (<>) +instance Singleton (Call cinfo) (CallGraph cinfo) where+  singleton = fromList . singleton++instance Collection (Call cinfo) (CallGraph cinfo) where+  fromList = fromListCG+ -- | Inserts a call into a call graph.  insert :: Node -> Node -> CallMatrix -> cinfo@@ -146,7 +150,7 @@  deriving instance CombineNewOld (CMSet cinfo) -instance (Monoid a, CombineNewOld a, Ord s, Ord t) => CombineNewOld (Graph s t a) where+instance (Monoid a, CombineNewOld a, Ord n) => CombineNewOld (Graph n a) where   combineNewOld new old = Graph.unzip $ Graph.unionWith comb new' old'     where       new' = (,mempty) <$> new@@ -226,4 +230,3 @@ -- --    , "Behaviour: " ++ show (diagonal $ mat $ cm c)  -- TODO -- --    , "Meta info: " ++ show cinfo --     ]-
src/full/Agda/Termination/CallMatrix.hs view
@@ -1,5 +1,5 @@--- {-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams             #-}  module Agda.Termination.CallMatrix where@@ -11,9 +11,6 @@ --   , tests --   ) where -import Data.Semigroup-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)  import Agda.Termination.CutOff import Agda.Termination.Order as Order@@ -22,10 +19,10 @@  import Agda.Utils.Favorites (Favorites) import qualified Agda.Utils.Favorites as Fav-import Agda.Utils.Monad+ import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Utils.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton  ------------------------------------------------------------------------@@ -209,4 +206,4 @@  instance Pretty cinfo => Pretty (CMSet cinfo) where   pretty = vcat . punctuate newLine . map pretty . toList-    where newLine = text "\n"+    where newLine = "\n"
src/full/Agda/Termination/CutOff.hs view
@@ -1,19 +1,33 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Defines 'CutOff' type which is used in "Agda.Interaction.Options". --   This module's purpose is to eliminate the dependency of --   "Agda.TypeChecking.Monad.Base" on the termination checker and --   everything it imports. -module Agda.Termination.CutOff where+module Agda.Termination.CutOff+  ( CutOff(CutOff, DontCutOff)+  , defaultCutOff+  ) where +import Control.DeepSeq+ -- | Cut off structural order comparison at some depth in termination checker?  data CutOff-  = CutOff Int -- ^ @c >= 0@ means: record decrease up to including @c+1@.+  = CutOff !Int -- ^ @c >= 0@ means: record decrease up to including @c+1@.   | DontCutOff-  deriving (Eq, Ord)+  deriving (Eq , Ord)  instance Show CutOff where   show (CutOff k) = show k   show DontCutOff = "∞" --- That's it!+instance NFData CutOff where+  rnf (CutOff _) = ()+  rnf DontCutOff = ()++-- | The default termination depth.++defaultCutOff :: CutOff+defaultCutOff = CutOff 0 -- minimum value
− src/full/Agda/Termination/Inlining.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE CPP #-}---- Author:  Ulf Norell--- Created: 2013-11-09--{-|-  This module defines an inlining transformation on clauses that's run before-  termination checking. The purpose is to improve termination checking of with-  clauses (issue 59). The transformation inlines generated with-functions-  expanding the clauses of the parent function in such a way that termination-  checking the expanded clauses guarantees termination of the original function,-  while allowing more terminating functions to be accepted. It does in no way-  pretend to preserve the semantics of the original function.--  Roughly, the source program--> f ps with as-> {f ps₁i qsi = bi}--  is represented internally as--> f ps = f-aux xs as      where xs   = vars(ps)-> {f-aux ps₂i qsi = bi}   where ps₁i = ps[ps₂i/xs]--  The inlining transformation turns this into--> {f ps = aj} for aj ∈ as-> {f ps₁i qsi = bi}--  The first set of clauses, called 'withExprClauses', ensure that we-  don't forget any recursive calls in @as@.-  The second set of clauses, henceforth called 'inlinedClauses',-  are the surface-level clauses the user sees (and probably reasons about).--  The reason this works is that there is a single call site for each-  with-function.--  Note that the lhss of the inlined clauses are not type-correct,-  neither with the type of @f@ (since there are additional patterns @qsi@)-  nor with the type of @f-aux@ (since there are the surface-level patterns-  @ps₁i@ instead of the actual patterns @ps₂i@).- -}-module Agda.Termination.Inlining-  ( inlineWithClauses-  , isWithFunction-  , expandWithFunctionCall ) where--import Control.Applicative-import Control.Monad.State--import Data.Traversable (traverse)-import Data.List as List--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.DisplayForm-import Agda.TypeChecking.Telescope--import Agda.Utils.List (downFrom)-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Permutation-import Agda.Utils.Size--import Agda.Utils.Impossible-#include "undefined.h"--inlineWithClauses :: QName -> Clause -> TCM [Clause]-inlineWithClauses f cl = inTopContext $ do-  -- Clauses are relative to the empty context, so we operate @inTopContext@.-  let noInline = return [cl]-  -- The de Bruijn indices of @body@ are relative to the @clauseTel cl@.-  body <- traverse instantiate $ clauseBody cl-  case body of-    Just (Def wf els) ->-      caseMaybeM (isWithFunction wf) noInline $ \ f' ->-      if f /= f' then noInline else do-        -- The clause body is a with-function call @wf args@.-        -- @f@ is the function the with-function belongs to.-        let args = fromMaybe __IMPOSSIBLE__ . allApplyElims $ els--        reportSDoc "term.with.inline" 70 $ sep-          [ text "Found with (raw):", nest 2 $ text $ show cl ]-        reportSDoc "term.with.inline" 20 $ sep-          [ text "Found with:", nest 2 $ prettyTCM $ QNamed f cl ]--        t   <- defType <$> getConstInfo wf-        cs1 <- withExprClauses cl t args--        reportSDoc "term.with.inline" 70 $ vcat $-          text "withExprClauses (raw)" : map (nest 2 . text . show) cs1-        reportSDoc "term.with.inline" 20 $ vcat $-          text "withExprClauses" : map (nest 2 . prettyTCM . QNamed f) cs1--        cs2 <- inlinedClauses f cl t wf--        reportSDoc "term.with.inline" 70 $ vcat $-          text "inlinedClauses (raw)" : map (nest 2 . text . show) cs2-        reportSDoc "term.with.inline" 20 $ vcat $-          text "inlinedClauses" : map (nest 2 . prettyTCM . QNamed f) cs2--        return $ cs1 ++ cs2-    _ -> noInline---- | @withExprClauses cl t as@ generates a clause containing a fake---   call to with-expression @a@ for each @a@ in @as@ that is not---   a variable (and thus cannot contain a recursive call).------   Andreas, 2013-11-11: I guess "not a variable" could be generalized---   to "not containing a call to a mutually defined function".------   Note that the @as@ stem from the *unraised* clause body of @cl@---   and thus can be simply 'fmap'ped back there (under all the 'Bind'---   abstractions).------   Precondition: we are 'inTopContext'.-withExprClauses :: Clause -> Type -> Args -> TCM [Clause]-withExprClauses cl t args = {- addContext (clauseTel cl) $ -} loop t args where-  -- Note: for the following code, it does not matter which context we are in.-  -- Restore the @addContext (clauseTel cl)@ if that should become necessary-  -- (like when debug printing @args@ etc).-  loop t []     = return []-  loop t (a:as) =-    case unArg a of-      Var i [] -> rest  -- TODO: smarter criterion when to skip withExprClause-      v        ->-        (cl { clauseBody = Just v-            , clauseType = Just $ defaultArg dom-            } :) <$> rest-    where-      rest = loop (piApply t [a]) as-      dom  = case unEl t of   -- The type is the generated with-function type so we know it-        Pi a _  -> unDom a    -- doesn't contain anything funny-        _       -> __IMPOSSIBLE__---- | @inlinedClauses f cl t wf@ inlines the clauses of with-function @wf@---   of type @t@ into the clause @cl@.  The original function name is @f@.------   Precondition: we are 'inTopContext'.-inlinedClauses :: QName -> Clause -> Type -> QName -> TCM [Clause]-inlinedClauses f cl t wf = do-  -- @wf@ might define a with-function itself, so we first construct-  -- the with-inlined clauses @wcs@ of @wf@ recursively.-  wcs <- concat <$> (mapM (inlineWithClauses wf) =<< defClauses <$> getConstInfo wf)-  reportSDoc "term.with.inline" 30 $ vcat $ text "With-clauses to inline" :-                                       map (nest 2 . prettyTCM . QNamed wf) wcs-  mapM (inline f cl t wf) wcs---- | The actual work horse.---   @inline f pcl t wf wcl@ inlines with-clause @wcl@ of with-function @wf@---   (of type @t@) into parent clause @pcl@ (original function being @f@).-inline :: QName -> Clause -> Type -> QName -> Clause -> TCM Clause-inline f pcl t wf wcl = inTopContext $ addContext (clauseTel wcl) $ do-  -- The tricky part here is to get the variables to line up properly. The-  -- order of the arguments to the with-function is not the same as the order-  -- of the arguments to the parent function. Fortunately we have already-  -- figured out how to turn an application of the with-function into an-  -- application of the parent function in the display form.-  reportSDoc "term.with.inline" 70 $ text "inlining (raw) =" <+> text (show wcl)-  Just disp <- displayForm wf $ clauseElims wcl-  reportSDoc "term.with.inline" 70 $ text "display form (raw) =" <+> text (show disp)-  reportSDoc "term.with.inline" 40 $ text "display form =" <+> prettyTCM disp-  (pats, perm) <- dispToPats disp--  -- Jesper, 2016-07-28: Since the with-clause and the inlined clause both-  -- have the same clause telescope and the clause body is now relative to the-  -- clause telescope, there is no more need to change the clause body.-  return wcl { namedClausePats = numberPatVars __IMPOSSIBLE__ perm pats }-  where-    numVars  = size (clauseTel wcl)--    dispToPats :: DisplayTerm -> TCM ([NamedArg Pattern], Permutation)-    dispToPats (DWithApp (DDef _ es) ws zs) = do-      let es' = es ++ map (Apply . defaultArg) ws ++ map (fmap DTerm) zs-      (ps, (j, ren)) <- (`runStateT` (0, [])) $ mapM (traverse dtermToPat) es'-      let perm = Perm j (map snd $ List.sort ren)-      return (map ePatToPat ps, perm)-    dispToPats t = __IMPOSSIBLE__--    bindVar i = do-      (j, is)  <- get-      let i' = numVars - i - 1-      case lookup i' is of-        Nothing -> True  <$ put (j + 1, (i', j) : is)-        Just{}  -> False <$ put (j + 1, is)--    skip = modify $ \(j, is) -> (j + 1, is)--    ePatToPat :: Elim' Pattern -> NamedArg Pattern-    ePatToPat (Apply p) = fmap unnamed p-    ePatToPat (Proj o d) = defaultNamedArg $ ProjP o d--    dtermToPat :: DisplayTerm -> StateT (Int, [(Int, Int)]) TCM Pattern-    dtermToPat v =-      case v of-        DWithApp{}       -> __IMPOSSIBLE__   -- I believe-        DCon c ci vs     -> ConP c (toConPatternInfo ci) . map (fmap unnamed)-                              <$> mapM (traverse dtermToPat) vs-        DDef d es        -> do-          ifM (return (null es) `and2M` do isJust <$> lift (isProjection d))-            {-then-} (return $ ProjP ProjPrefix d)-            {-else-} (DotP (dtermToTerm v) <$ skip)-        DDot v           -> DotP v <$ skip-        DTerm (Var i []) ->-          ifM (bindVar i) (varP . nameToPatVarName <$> lift (nameOfBV i))-                          (pure $ DotP (Var i []))-        DTerm (Con c ci vs) -> ConP c (toConPatternInfo ci) . map (fmap unnamed) <$>-                              mapM (traverse (dtermToPat . DTerm)) vs-        DTerm v          -> DotP v <$ skip--isWithFunction :: MonadTCM tcm => QName -> tcm (Maybe QName)-isWithFunction x = liftTCM $ do-  def <- getConstInfo x-  return $ case theDef def of-    Function{ funWith = w } -> w-    _                       -> Nothing--expandWithFunctionCall :: QName -> Elims -> TCM Term-expandWithFunctionCall f es = do-  as <- displayFormArities f-  case as of-    [a] | length es >= a -> do-      Just disp <- displayForm f es-      return $ dtermToTerm disp--    -- We might get an underapplied with function application (issue1598), in-    -- which case we have to eta expand. The resulting term is only used for-    -- termination checking, so we don't have to worry about getting hiding-    -- information right.-    -- Andreas, 2016-07-20 let's pray that there no copatterns needed...-    [a] -> do-      let pad = a - length es-          es' = raise pad es ++ map (Apply . defaultArg . var) (downFrom pad)-      Just disp <- displayForm f es'-      let info = setOrigin Inserted defaultArgInfo-      return $ foldr (\_ -> Lam info . Abs "") (dtermToTerm disp) (replicate pad ())-    _ -> __IMPOSSIBLE__
src/full/Agda/Termination/Monad.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | The monad for the termination checker. --@@ -12,59 +10,61 @@ import Prelude hiding (null)  import Control.Applicative hiding (empty)-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.Semigroup (Semigroup)+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Except   ( MonadError(..) )+import Control.Monad.Reader   ( MonadReader(..), ReaderT(..) ) -import Agda.Interaction.Options+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.Syntax.Abstract (IsProjP(..), AllNames)+import Agda.Interaction.Options (optTerminationDepth)+ import Agda.Syntax.Common 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-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty as TCP+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Except ( MonadError(catchError, throwError) )+import Agda.Utils.Benchmark as B import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List   ( hasElem ) import Agda.Utils.Maybe 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 -#include "undefined.h" 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. @@ -78,11 +78,6 @@    { terUseDotPatterns :: Bool     -- ^ Are we mining dot patterns to find evindence of structal descent?-  , terGuardingTypeConstructors :: Bool-    -- ^ Do we assume that record and data type constructors-    --   preserve guardedness?-  , terInlineWithFunctions :: Bool-    -- ^ Do we inline with functions to enhance termination checking of with?   , terSizeSuc :: Maybe QName     -- ^ The name of size successor, if any.   , terSharp   :: Maybe QName@@ -98,14 +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.-  , terTarget  :: Maybe Target+  , terHaveInlinedWith :: Bool+    -- ^ Does the actual clause result from with-inlining?+    --   (If yes, it may be ill-typed.)+  , 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.@@ -115,7 +111,7 @@     -- ^ How many @SIZELT@ relations do we have in the context     --   (= clause telescope).  Used to approximate termination     --   for metas in call args.-  , terPatterns :: MaskedDeBruijnPats+  , terPatterns :: MaskedDeBruijnPatterns     -- ^ The patterns of the clause we are checking.   , terPatternsRaise :: !Int     -- ^ Number of additional binders we have gone under@@ -142,24 +138,19 @@ --   of these values. -- --   Values that do not have a safe default are set to---   @IMPOSSIBLE@.----   Note: Do not write @__IMPOSSIBLE__@ in the haddock comment above---   since it will be expanded by the CPP, leading to a haddock parse error.+--   @__IMPOSSIBLE__@.  defaultTerEnv :: TerEnv defaultTerEnv = TerEnv   { terUseDotPatterns           = False -- must be False initially!-  , terGuardingTypeConstructors = False-  , terInlineWithFunctions      = True   , terSizeSuc                  = Nothing   , terSharp                    = Nothing   , terCutOff                   = defaultCutOff   , terUserNames                = __IMPOSSIBLE__ -- needs to be set!   , terMutual                   = __IMPOSSIBLE__ -- needs to be set!   , terCurrent                  = __IMPOSSIBLE__ -- needs to be set!-  , terTarget                   = Nothing-  , terDelayed                  = NotDelayed+  , terHaveInlinedWith          = False+  , terTarget                   = TargetOther   , terMaskArgs                 = repeat False   -- use all arguments (mask none)   , terMaskResult               = False          -- use result (do not mask)   , _terSizeDepth               = __IMPOSSIBLE__ -- needs to be set!@@ -182,8 +173,35 @@ -- | Termination monad.  newtype TerM a = TerM { terM :: ReaderT TerEnv TCM a }-  deriving (Functor, Applicative, Monad, MonadBench Phase)+  deriving ( Functor+           , Applicative+           , Monad+           , MonadError TCErr+           , MonadStatistics+           , HasOptions+           , HasBuiltins+           , MonadDebug+           , HasConstInfo+           , MonadIO+           , MonadTCEnv+           , MonadTCState+           , MonadTCM+           , ReadTCState+           , MonadReduce+           , MonadAddContext+           , PureTCM+           ) +-- This could be derived automatically, but the derived type family becomes `BenchPhase (ReaderT TerEnv TCM)` which+-- is *fine* but triggers complaints that the "type family application is no smaller than the instance head, why not+-- nuke everything with UndecidableInstances".+instance MonadBench TerM where+  type BenchPhase TerM = Phase+  getBenchmark              = TerM $ B.getBenchmark+  putBenchmark              = TerM . B.putBenchmark+  modifyBenchmark           = TerM . B.modifyBenchmark+  finally (TerM m) (TerM f) = TerM $ (B.finally m f)+ instance MonadTer TerM where   terAsk     = TerM $ ask   terLocal f = TerM . local f . terM@@ -207,56 +225,31 @@   -- The name of sharp (if available).   sharp <- fmap nameOfSharp <$> coinductionKit -  guardingTypeConstructors <--    optGuardingTypeConstructors <$> pragmaOptions--  -- Andreas, 2014-08-28-  -- We do not inline with functions if --without-K.-  inlineWithFunctions <- not . optWithoutK <$> pragmaOptions-   let tenv = defaultTerEnv-        { terGuardingTypeConstructors = guardingTypeConstructors-        , terInlineWithFunctions      = inlineWithFunctions-        , terSizeSuc                  = suc+        { terSizeSuc                  = suc         , terSharp                    = sharp         , terCutOff                   = cutoff         }    runTer tenv cont --- * Termination monad is a 'MonadTCM'.--instance MonadReader TCEnv TerM where-  ask       = TerM $ lift $ ask-  local f m = TerM $ ReaderT $ local f . runReaderT (terM m)--instance MonadState TCState TerM where-  get     = TerM $ lift $ get-  put     = TerM . lift . put--instance MonadIO TerM where-  liftIO = TerM . liftIO+-- -- * Termination monad is a 'MonadTCM'. -instance MonadTCM TerM where-  liftTCM = TerM . lift+-- instance MonadError TCErr TerM where+--   throwError = liftTCM . throwError+--   catchError m handler = TerM $ ReaderT $ \ tenv -> do+--     runTer tenv m `catchError` (\ err -> runTer tenv $ handler err) -instance MonadError TCErr TerM where-  throwError = liftTCM . throwError-  catchError m handler = TerM $ ReaderT $ \ tenv -> do-    runTer tenv m `catchError` (\ err -> runTer tenv $ handler err)+instance Semigroup m => Semigroup (TerM m) where+  (<>) = liftA2 (<>) -instance HasConstInfo TerM where-  getConstInfo       = liftTCM . getConstInfo-  getRewriteRulesFor = liftTCM . getRewriteRulesFor+instance (Semigroup m, Monoid m) => Monoid (TerM m) where+  mempty  = pure mempty+  mappend = (<>)+  mconcat = mconcat <.> sequence  -- * Modifiers and accessors for the termination environment in the monad. -terGetGuardingTypeConstructors :: TerM Bool-terGetGuardingTypeConstructors = terAsks terGuardingTypeConstructors--terGetInlineWithFunctions :: TerM Bool-terGetInlineWithFunctions = terAsks terInlineWithFunctions- terGetUseDotPatterns :: TerM Bool terGetUseDotPatterns = terAsks terUseDotPatterns @@ -281,20 +274,20 @@ 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 } -terGetDelayed :: TerM Delayed-terGetDelayed = terAsks terDelayed+terGetHaveInlinedWith :: TerM Bool+terGetHaveInlinedWith = terAsks terHaveInlinedWith -terSetDelayed :: Delayed -> TerM a -> TerM a-terSetDelayed b = terLocal $ \ e -> e { terDelayed = b }+terSetHaveInlinedWith :: TerM a -> TerM a+terSetHaveInlinedWith = terLocal $ \ e -> e { terHaveInlinedWith = True }  terGetMaskArgs :: TerM [Bool] terGetMaskArgs = terAsks terMaskArgs@@ -308,13 +301,13 @@ terSetMaskResult :: Bool -> TerM a -> TerM a terSetMaskResult b = terLocal $ \ e -> e { terMaskResult = b } -terGetPatterns :: TerM (MaskedDeBruijnPats)+terGetPatterns :: TerM (MaskedDeBruijnPatterns) terGetPatterns = do   n   <- terAsks terPatternsRaise   mps <- terAsks terPatterns-  return $ if n == 0 then mps else map (fmap (fmap (n +))) mps+  return $ if n == 0 then mps else map (fmap (raise n)) mps -terSetPatterns :: MaskedDeBruijnPats -> TerM a -> TerM a+terSetPatterns :: MaskedDeBruijnPatterns -> TerM a -> TerM a terSetPatterns ps = terLocal $ \ e -> e { terPatterns = ps }  terRaise :: TerM a -> TerM a@@ -332,13 +325,9 @@ terUnguarded :: TerM a -> TerM a terUnguarded = terSetGuarded unknown --- | Should the codomain part of a function type preserve guardedness?-terPiGuarded :: TerM a -> TerM a-terPiGuarded m = ifM terGetGuardingTypeConstructors m $ terUnguarded m- -- | Lens for '_terSizeDepth'. -terSizeDepth :: Lens' Int TerEnv+terSizeDepth :: Lens' TerEnv Int terSizeDepth f e = f (_terSizeDepth e) <&> \ i -> e { _terSizeDepth = i }  -- | Lens for 'terUsableVars'.@@ -367,15 +356,18 @@ withUsableVars :: UsableSizeVars a => a -> TerM b -> TerM b withUsableVars pats m = do   vars <- usableSizeVars pats-  reportSLn "term.size" 20 $ "usableSizeVars = " ++ show vars+  reportSLn "term.size" 70 $ "usableSizeVars = " ++ show vars+  reportSDoc "term.size" 20 $ if null vars then "no usuable size vars" else+    "the size variables amoung these variables are usable: " <+>+      sep (map (prettyTCM . var) $ VarSet.toList vars)   terSetUsableVars vars $ m  -- | Set 'terUseSizeLt' when going under constructor @c@. conUseSizeLt :: QName -> TerM a -> TerM a conUseSizeLt c m = do-  caseMaybeM (liftTCM $ isRecordConstructor c)+  ifM (liftTCM $ isEtaOrCoinductiveRecordConstructor c)  -- Non-eta inductive records are the same as datatypes+    (terSetUseSizeLt False m)     (terSetUseSizeLt True m)-    (const $ terSetUseSizeLt False m)  -- | Set 'terUseSizeLt' for arguments following projection @q@. --   We disregard j<i after a non-coinductive projection.@@ -395,7 +387,7 @@ isProjectionButNotCoinductive qn = liftTCM $ do   b <- isProjectionButNotCoinductive' qn   reportSDoc "term.proj" 60 $ do-    text "identifier" <+> prettyTCM qn <+> do+    "identifier" <+> prettyTCM qn <+> do       text $         if b then "is an inductive projection"           else "is either not a projection or coinductive"@@ -408,7 +400,7 @@         else do           mp <- isProjection qn           case mp of-            Just Projection{ projProper = True, projFromType = t }+            Just Projection{ projProper = Just{}, projFromType = t }               -> isInductiveRecord (unArg t)             _ -> return False @@ -428,95 +420,78 @@   if Just q == flat then return True else do     pdef <- getConstInfo q     case isProjection_ (theDef pdef) of-      Just Projection{ projProper = True, projFromType = Arg _ r, projIndex = n } ->+      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-            reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive"+          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 (recRecursive 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.                 -- Now check if type of field mentions mutually recursive symbol.                 -- Get the type of the field by dropping record parameters and record argument.                 let TelV tel core = telView' (defType pdef)-                    tel' = drop n $ telToList tel+                    (pars, tel') = splitAt n $ telToList tel+                    mut = fromMaybe __IMPOSSIBLE__ $ _recMutual rdef                 -- Check if any recursive symbols appear in the record type.                 -- Q (2014-07-01): Should we normalize the type?-                reportSDoc "term.guardedness" 40 $ sep-                  [ text "looking for recursive occurrences in"-                  , prettyTCM (telFromList tel')-                  , text "and"-                  , prettyTCM core+                -- A (2017-01-13): Yes, since we also normalize during positivity check?+                -- See issue #1899.+                reportSDoc "term.guardedness" 40 $ inTopContext $ sep+                  [ "looking for recursive occurrences of"+                  , sep (map prettyTCM mut)+                  , "in"+                  , addContext pars $ prettyTCM (telFromList tel')+                  , "and"+                  , addContext tel $ prettyTCM core                   ]-                names <- anyDefs (r : recMutual rdef) (map (snd . unDom) tel', core)+                when (null mut) __IMPOSSIBLE__+                names <- anyDefs (mut `hasElem`) (map (snd . unDom) tel', core)                 reportSDoc "term.guardedness" 40 $-                  text "found" <+> sep (map prettyTCM names)+                  "found" <+> if null names then "none" else sep (map prettyTCM $ Set.toList names)                 return $ not $ null names       _ -> do         reportSLn "term.guardedness" 40 $ prettyShow q ++ " is not a proper projection"         return False----- * De Bruijn patterns.--type DeBruijnPats = [DeBruijnPat]---- | Patterns with variables as de Bruijn indices.-type DeBruijnPat = DeBruijnPat' Int--data DeBruijnPat' a-  = VarDBP a-    -- ^ De Bruijn Index.-  | ConDBP QName [DeBruijnPat' a]-    -- ^ The name refers to either an ordinary-    --   constructor or the successor function on sized types.-  | LitDBP Literal-    -- ^ Literal.  Also abused to censor part of a pattern.-  | TermDBP Term-    -- ^ Part of dot pattern that cannot be converted into a pattern.-  | ProjDBP ProjOrigin QName-    -- ^ Projection pattern.-  deriving (Functor, Show)--instance IsProjP (DeBruijnPat' a) where-  isProjP (ProjDBP o d) = Just (o, AmbQ [d])-  isProjP _ = Nothing+  where+  -- Andreas, 2018-02-24, issue #2975, example:+  -- @+  -- record R : Set where+  --   coinductive+  --   field force : R -instance PrettyTCM DeBruijnPat where-  prettyTCM (VarDBP i)    = prettyTCM $ var i-  prettyTCM (ConDBP c ps) = parens $ do prettyTCM c <+> hsep (map prettyTCM ps)-  prettyTCM (LitDBP l)    = prettyTCM l-  prettyTCM (TermDBP v)   = parens $ prettyTCM v-  prettyTCM (ProjDBP o d) = text "." TCP.<> prettyTCM d+  --   r : R+  --   force r = r+  -- @+  -- The termination checker expects the positivity checker to have run on the+  -- record declaration R to know whether R is recursive.+  -- However, here, because the awkward processing of record declarations (see #434),+  -- 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.+  notSafeRecRecursive :: RecordData -> Bool+  notSafeRecRecursive = maybe True null . _recMutual+    -- @_recMutual@ should be something (@Just (_:_)@) to be safe --- | How long is the path to the deepest variable?-patternDepth :: DeBruijnPat' a -> Int-patternDepth p =-  case p of-    ConDBP _ ps -> succ $ maximum $ 0 : map patternDepth ps-    VarDBP{}    -> 0-    LitDBP{}    -> 0-    TermDBP{}   -> 0-    ProjDBP{}   -> 0+-- * De Bruijn pattern stuff +-- | How long is the path to the deepest atomic pattern?+patternDepth :: forall a. Pattern' a -> Int+patternDepth = getMaxNat . foldrPattern depth where+  depth :: Pattern' a -> MaxNat -> MaxNat+  depth ConP{} = succ      -- add 1 to the maximum of the depth of the subpatterns+  depth _      = id        -- atomic pattern (leaf) has depth 0  -- | A dummy pattern used to mask a pattern that cannot be used --   for structural descent. -unusedVar :: DeBruijnPat-unusedVar = LitDBP (LitString noRange "term.unused.pat.var")---- | @raiseDBP n ps@ increases each de Bruijn index in @ps@ by @n@.---   Needed when going under a binder during analysis of a term.--raiseDBP :: Int -> DeBruijnPats -> DeBruijnPats-raiseDBP 0 = id-raiseDBP n = map $ fmap (n +)+unusedVar :: DeBruijnPattern+unusedVar = litP (LitString "term.unused.pat.var") --- | Extract variables from 'DeBruijnPat's that could witness a decrease+-- | Extract variables from 'DeBruijnPattern's that could witness a decrease --   via a SIZELT constraint. -- --   These variables must be under an inductive constructor (with no record@@ -526,44 +501,48 @@ class UsableSizeVars a where   usableSizeVars :: a -> TerM VarSet -instance UsableSizeVars DeBruijnPat where-  usableSizeVars p = do-    let none = return mempty-    case p of-      VarDBP i    -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none-      ConDBP c ps -> conUseSizeLt c $ usableSizeVars ps-      LitDBP{}    -> none-      TermDBP{}   -> none-      ProjDBP{}   -> none+instance UsableSizeVars DeBruijnPattern where+  usableSizeVars = foldrPattern $ \case+    VarP _ x   -> const $ ifM terGetUseSizeLt (return $ VarSet.singleton $ dbPatVarIndex x) $+                   {-else-} return mempty+    ConP c _ _ -> conUseSizeLt $ conName c+    LitP{}     -> none+    DotP{}     -> none+    ProjP{}    -> none+    IApplyP{}  -> none+    DefP{} -> none+    where none _ = return mempty -instance UsableSizeVars DeBruijnPats where+instance UsableSizeVars [DeBruijnPattern] where   usableSizeVars ps =     case ps of-      []                 -> return mempty-      (ProjDBP _ q : ps) -> projUseSizeLt q $ usableSizeVars ps-      (p           : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps+      []               -> return mempty+      (ProjP _ q : ps) -> projUseSizeLt q $ usableSizeVars ps+      (p         : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps -instance UsableSizeVars (Masked DeBruijnPat) where-  usableSizeVars (Masked m p) = do-    let none = return mempty-    case p of-      VarDBP i    -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none-      ConDBP c ps -> if m then none else conUseSizeLt c $ usableSizeVars ps-      LitDBP{}    -> none-      TermDBP{}   -> none-      ProjDBP{}   -> none+instance UsableSizeVars (Masked DeBruijnPattern) where+  usableSizeVars (Masked m p) = (`foldrPattern` p) $ \case+    VarP _ x   -> const $ ifM terGetUseSizeLt (return $ VarSet.singleton $ dbPatVarIndex x) $+                   {-else-} return mempty+    ConP c _ _ -> if m then none else conUseSizeLt $ conName c+    LitP{}     -> none+    DotP{}     -> none+    ProjP{}    -> none+    IApplyP{}  -> none+    DefP{}     -> none+    where none _ = return mempty -instance UsableSizeVars MaskedDeBruijnPats where+instance UsableSizeVars MaskedDeBruijnPatterns where   usableSizeVars ps =     case ps of-      []                            -> return mempty-      (Masked _ (ProjDBP _ q) : ps) -> projUseSizeLt q $ usableSizeVars ps-      (p                      : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps+      []                          -> return mempty+      (Masked _ (ProjP _ q) : ps) -> projUseSizeLt q $ usableSizeVars ps+      (p                    : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps  -- * Masked patterns (which are not eligible for structural descent, only for size descent) --   See issue #1023. -type MaskedDeBruijnPats = [Masked DeBruijnPat]+type MaskedDeBruijnPatterns = [Masked DeBruijnPattern]  data Masked a = Masked   { getMask   :: Bool  -- ^ True if thing not eligible for structural descent.@@ -585,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'.@@ -594,33 +577,48 @@ --   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] }-  deriving (Show, Semigroup, Monoid, AllNames)+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-      arrow = P.text "-->"+      cis   = init (callInfos cis0)+      arrow = "-->"  -- * Size depth estimation  -- | 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 ignoreSharing $ 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,4 +1,5 @@-{-# LANGUAGE CPP               #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams    #-}  -- | An Abstract domain of relative sizes, i.e., differences@@ -8,7 +9,7 @@ module Agda.Termination.Order   ( -- * Structural orderings     Order(..), decr-  , increase, decrease+  , increase, decrease, setUsability   , (.*.)   , supremum, infimum   , orderSemiring@@ -27,9 +28,8 @@ import qualified Agda.Termination.Semiring as Semiring  import Agda.Utils.PartialOrd-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty -#include "undefined.h" import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -55,18 +55,29 @@ -- -- TODO: document orders which are call-matrices themselves. data Order-  = Decr {-# UNPACK #-} !Int+  = Decr !Bool {-# UNPACK #-} !Int     -- ^ Decrease of callee argument wrt. caller parameter.+    --+    --   The @Bool@ indicates whether the decrease (if any) is usable.+    --   In any chain, there needs to be one usable decrease.+    --   Unusable decreases come from SIZELT constraints which are+    --   not in inductive pattern match or a coinductive copattern match.+    --   See issue #2331.+    --+    --   UPDATE: Andreas, 2017-07-26:+    --   Feature #2331 is unsound due to size quantification in terms.+    --   While the infrastructure for usable/unusable decrease remains in+    --   place, no unusable decreases are generated by TermCheck.   | Unknown     -- ^ No relation, infinite increase, or increase beyond termination depth.   | Mat {-# UNPACK #-} !(Matrix Int Order)     -- ^ Matrix-shaped order, currently UNUSED.-  deriving (Eq,Ord)+  deriving (Eq, Ord, Show) -instance Show Order where-  show (Decr k) = show (- k)-  show Unknown  = "."-  show (Mat m)  = "Mat " ++ show m+-- instance Show Order where+--   show (Decr u k) = if u then show (- k) else "(" ++ show (-k) ++ ")"+--   show Unknown    = "."+--   show (Mat m)    = "Mat " ++ show m  instance HasZero Order where   zeroElement = Unknown@@ -82,10 +93,15 @@     (Unknown, Unknown) -> POEQ     (Unknown, _      ) -> POLT     (_      , Unknown) -> POGT-    (Decr k , Decr l ) -> comparableOrd k l+    (Decr u k, Decr u' l) -> comparableBool u u' `orPO` comparableOrd k l     -- Matrix-shaped orders are no longer supported     (Mat{}  , _      ) -> __IMPOSSIBLE__     (_      , Mat{}  ) -> __IMPOSSIBLE__+    where+    comparableBool = curry $ \case+      (False, True) -> POLT+      (True, False) -> POGT+      _ -> POEQ  -- | A partial order, aimed at deciding whether a call graph gets --   worse during the completion.@@ -96,10 +112,10 @@ -- | It does not get worse then ``increase''. --   If we are still decreasing, it can get worse: less decreasing. instance NotWorse Order where-  o       `notWorse` Unknown = True            -- we are unboundedly increasing-  Unknown `notWorse` Decr k = k < 0            -- we are increasing-  Decr l  `notWorse` Decr k = k < 0 || l >= k  -- we are increasing or-                                               -- we are decreasing, but more+  o        `notWorse` Unknown  = True            -- we are unboundedly increasing+  Unknown  `notWorse` Decr _ k = k < 0           -- we are increasing+  Decr u l `notWorse` Decr u' k = k < 0   -- we are increasing or+    || l >= k && (u || not u')            -- we are decreasing, but not less, and not less usable   -- Matrix-shaped orders are no longer supported   Mat m   `notWorse` o       = __IMPOSSIBLE__   o       `notWorse` Mat m   = __IMPOSSIBLE__@@ -124,29 +140,35 @@  -- | Raw increase which does not cut off. increase :: Int -> Order -> Order-increase i o = case o of-  Unknown -> Unknown-  Decr k  -> Decr $ k - i-  Mat m   -> Mat $ fmap (increase i) m+increase i = \case+  Unknown  -> Unknown+  Decr u k -> Decr u $ k - i   -- TODO: should we set u to False if k - i < 0 ?+  Mat m    -> Mat $ fmap (increase i) m  -- | Raw decrease which does not cut off. decrease :: Int -> Order -> Order decrease i o = increase (-i) o +setUsability :: Bool -> Order -> Order+setUsability u o = case o of+  Decr _ k -> Decr u k+  Unknown  -> o+  Mat{}    -> o+ -- | Smart constructor for @Decr k :: Order@ which cuts off too big values. -- -- Possible values for @k@: @- ?cutoff '<=' k '<=' ?cutoff + 1@. -decr :: (?cutoff :: CutOff) => Int -> Order-decr k = case ?cutoff of+decr :: (?cutoff :: CutOff) => Bool -> Int -> Order+decr u k = case ?cutoff of   CutOff c | k < -c -> Unknown-           | k > c  -> Decr $ c + 1-  _                 -> Decr k+           | k > c  -> Decr u $ c + 1+  _                 -> Decr u k  -- | Smart constructor for matrix shaped orders, avoiding empty and singleton matrices. orderMat :: Matrix Int Order -> Order orderMat m- | Matrix.isEmpty m        = Decr 0 -- 0x0 Matrix = neutral element+ | Matrix.isEmpty m        = le     -- 0x0 Matrix = neutral element  | Just o <- isSingleton m = o      -- 1x1 Matrix  | otherwise               = Mat m  -- nxn Matrix @@ -156,30 +178,29 @@   CutOff c   -> k >= -c && k <= c + 1  isOrder :: (?cutoff :: CutOff) => Order -> Bool-isOrder (Decr k) = withinCutOff k-isOrder Unknown = True-isOrder (Mat m) = False  -- TODO: extend to matrices--prop_decr :: (?cutoff :: CutOff) => Int -> Bool-prop_decr = isOrder . decr+isOrder (Decr _ k) = withinCutOff k+isOrder Unknown    = True+isOrder (Mat m)    = False  -- TODO: extend to matrices  -- | @le@, @lt@, @decreasing@, @unknown@: for backwards compatibility, and for external use. le :: Order-le = Decr 0+le = Decr False 0 +-- | Usable decrease. lt :: Order-lt = Decr 1+lt = Decr True 1  unknown :: Order unknown = Unknown  nonIncreasing :: Order -> Bool-nonIncreasing (Decr k) = k >= 0-nonIncreasing _        = False+nonIncreasing (Decr _ k) = k >= 0+nonIncreasing _          = False +-- | Decreasing and usable? decreasing :: Order -> Bool-decreasing (Decr k) = k > 0-decreasing _        = False+decreasing (Decr u k) = u && k > 0+decreasing _ = False  -- | Matrix-shaped order is decreasing if any diagonal element is decreasing. isDecr :: Order -> Bool@@ -187,10 +208,10 @@ isDecr o = decreasing o  instance Pretty Order where-  pretty (Decr 0) = text "="-  pretty (Decr k) = text $ show (0 - k)-  pretty Unknown  = text "?"-  pretty (Mat m)  = text "Mat" <+> pretty m+  pretty (Decr u 0) = "="+  pretty (Decr u k) = mparens (not u) $ text $ show (negate k)+  pretty Unknown    = "?"+  pretty (Mat m)    = "Mat" <+> pretty m   -- | Multiplication of 'Order's.@@ -199,17 +220,17 @@ -- I think this funny pattern matching is because overlapping patterns -- are producing a warning and thus an error (strict compilation settings) (.*.) :: (?cutoff :: CutOff) => Order -> Order -> Order-Unknown  .*. _        = Unknown-(Mat m)  .*. Unknown  = Unknown-(Decr k) .*. Unknown  = Unknown-(Decr k) .*. (Decr l) = decr (k + l)-(Decr 0) .*. (Mat m)  = Mat m-(Decr k) .*. (Mat m)  = (Decr k) .*. (collapse m)-(Mat m1) .*. (Mat m2)-  | okM m1 m2         = Mat $ mul orderSemiring m1 m2-  | otherwise         = (collapse m1) .*. (collapse m2)-(Mat m) .*. (Decr 0)  = Mat m-(Mat m) .*. (Decr k)  = (collapse m) .*. (Decr k)+Unknown    .*. _           = Unknown+(Mat m)    .*. Unknown     = Unknown+(Decr _ k) .*. Unknown     = Unknown+(Decr u k) .*. (Decr u' l) = decr (u || u') (k + l)  -- if one is usable, so is the composition+(Decr _ 0) .*. (Mat m)     = Mat m+(Decr u k) .*. (Mat m)     = (Decr u k) .*. (collapse m)+(Mat m1)   .*. (Mat m2)+  | okM m1 m2              = Mat $ mul orderSemiring m1 m2+  | otherwise              = (collapse m1) .*. (collapse m2)+(Mat m)   .*. (Decr _ 0)   = Mat m+(Mat m)   .*. (Decr u k)   = (collapse m) .*. (Decr u k)  -- | collapse @m@ --@@ -234,7 +255,7 @@  -- | Can two matrices be multplied together? okM :: Matrix Int Order -> Matrix Int Order -> Bool-okM m1 m2 = (rows $ size m2) == (cols $ size m1)+okM m1 m2 = rows (size m2) == cols (size m1)  -- | The supremum of a (possibly empty) list of 'Order's. --   More information (i.e., more decrease) is bigger.@@ -247,7 +268,12 @@  maxO :: (?cutoff :: CutOff) => Order -> Order -> Order maxO o1 o2 = case (o1,o2) of-  (Decr k, Decr l) -> Decr (max k l) -- cut off not needed, within borders+    -- NOTE: strictly speaking the maximum does not exists+    -- which is better, an unusable decrease by 2 or a usable decrease by 1?+    -- We give the usable information priority if it is a decrease.+  (Decr False _, Decr True  l) | l > 0 -> o2+  (Decr True  k, Decr False _) | k > 0 -> o1+  (Decr u k, Decr u' l) -> if l > k then o2 else o1   (Unknown, _)     -> o2   (_, Unknown)     -> o1   (Mat m1, Mat m2) -> Mat (Matrix.add maxO m1 m2)@@ -266,7 +292,13 @@ minO o1 o2 = case (o1,o2) of   (Unknown, _)           -> Unknown   (_, Unknown)           -> Unknown-  (Decr k, Decr l)       -> Decr (min k l) -- cut off not needed, within borders+  -- different usability:+  -- We pick the unusable one if it is not a decrease or+  -- decreases not more than the usable one.+  (Decr False k, Decr True  l) -> if k <= 0 || k <= l then o1 else o2+  (Decr True  k, Decr False l) -> if l <= 0 || l <= k then o2 else o1+  -- same usability:+  (Decr u k, Decr _ l) -> Decr u (min k l)   (Mat m1, Mat m2)     | size m1 == size m2 -> Mat $ Matrix.intersectWith minO m1 m2     | otherwise          -> minO (collapse m1) (collapse m2)
src/full/Agda/Termination/RecCheck.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} -{- Checking for recursion:+{- | Checking for recursion:     - We detect truly (co)recursive definitions by computing the      dependency graph and checking for cycles.@@ -12,58 +12,163 @@    This implementation by Andreas. -} + module Agda.Termination.RecCheck-    ( recursive+    ( MutualNames+    , recursive     , anyDefs     )  where -import Control.Applicative-+import Control.Monad (forM)+import Data.Foldable import Data.Graph--import Data.List (nub)+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 -#include "undefined.h" import Agda.Utils.Impossible -recursive :: [QName] -> TCM Bool+-- | 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)++-- | Given a list of formally mutually recursive functions,+--   check for actual recursive calls in the bodies of these functions.+--   Returns the actually recursive functions as strongly connected components.+--+--   As a side effect, update the 'clauseRecursive' field in the+--   clauses belonging to the given functions.+recursive :: Set QName -> TCM [MutualNames] recursive names = do-  graph <- zip names <$> mapM (\ d -> nub <$> recDef names d) names-  reportSLn "rec.graph" 20 $ show graph-  return $ cyclic graph+  let names' = toList names+  -- For each function, get names per clause and total.+  (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 sccs   = stronglyConnComp graph+  let nonRec = mapMaybe (\case AcyclicSCC x -> Just x+                               _            -> Nothing)+                 sccs+  let recs   = mapMaybe (\case CyclicSCC xs -> Just (Set.fromList xs)+                               _            -> Nothing)+                 sccs --- | A graph is cyclic if it has any strongly connected component.-cyclic :: [(QName, [QName])] -> Bool-cyclic g = or [ True | CyclicSCC _ <- stronglyConnComp g' ]-  where g' = map (\ (n, ns) -> ((), n, ns)) g+  reportSLn "rec.graph" 60 $ show graph +  -- Mark all non-recursive functions and their clauses as such.+  mapM_ markNonRecursive nonRec++  -- Mark individual clauses of recursive functions:+  --------------------------------------------------+  -- Map names to clause numbers to sets of mentioned names.+  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?+    let overlap s = any (`Set.member` s) scc+    -- Walk through members of SCC.+    forM_ scc $ \ x -> do+      -- Get the NamesPerClause for the current function x.+      let perClause  = Map.findWithDefault __IMPOSSIBLE__ x clMap+      -- A clause is recursive if its calls overlap with its scc.+      let recClause i = overlap $ IntMap.findWithDefault __IMPOSSIBLE__ i perClause+      markRecursive recClause x++  -- Return recursive SCCs.+  return recs++-- | Mark a function as terminating and all its clauses as non-recursive.+markNonRecursive :: QName -> TCM ()+markNonRecursive q = modifySignature $ updateDefinition q $ updateTheDef $ \case+  def@Function{} -> def+   { 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.+markRecursive+  :: (Int -> Bool)  -- ^ Which clauses are recursive?+  -> QName -> TCM ()+markRecursive f q = modifySignature $ updateDefinition q $ updateTheDef $ \case+  def@Function{} -> def+   { funClauses    = zipWith (\ i cl -> cl { clauseRecursive = Just (f i) }) [0..] $ funClauses def+   }+  def -> def+ -- | @recDef names name@ returns all definitions from @names@---   that are used in the body of @name@.-recDef :: [QName] -> QName -> TCM [QName]-recDef names name = do+--   that are used in the type and body of @name@.+recDef :: (QName -> Bool) -> QName -> TCM (NamesPerClause, Set QName)+recDef include name = do   -- Retrieve definition   def <- getConstInfo name-  case theDef def of-    Function{ funClauses = cls } -> anyDefs names cls-    _ -> return [] +  -- Get names in type+  ns1 <- anyDefs include (defType def)++  -- 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+    [ "recDef " ++ prettyShow name+    , "  names in the type: " ++ prettyShow ns1+    , "  names in the def:  " ++ prettyShow ns2+    ]+  return (perClause, ns1 `mappend` ns2)+ -- | @anysDef names a@ returns all definitions from @names@ --   that are used in @a@.-anyDefs :: GetDefs a => [QName] -> a -> TCM [QName]-anyDefs names a = do+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 x = case mvInstantiation <$> Map.lookup x st of-        Just (InstV _ v) -> Just v    -- TODO: ignoring the lambdas might be bad?-        _                -> 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 d `elem` names then [d] else []+      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@@ -8,7 +10,7 @@   , boolSemiring   ) where -import Data.Monoid+  -- | @HasZero@ is needed for sparse matrices, to tell which is the element --   that does not have to be stored.
src/full/Agda/Termination/SparseMatrix.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ScopedTypeVariables    #-}+{-# OPTIONS_GHC -Wunused-imports #-}  {- | Sparse matrices. @@ -43,35 +42,33 @@   , Diagonal(..)   , toSparseRows   , supSize+  , zipAssocWith     -- * Modifying matrices   , addRow   , addColumn   ) where  import Data.Array-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe-import Data.Monoid -import Data.Foldable (Foldable)+ import qualified Data.Foldable as Fold-import Data.Traversable (Traversable)  import qualified Text.PrettyPrint.Boxes as Boxes  import Agda.Termination.Semiring (HasZero(..), Semiring) import qualified Agda.Termination.Semiring as Semiring -import Agda.Utils.Functor+ import Agda.Utils.List import Agda.Utils.Maybe-import Agda.Utils.Monad+ import Agda.Utils.PartialOrd-import Agda.Utils.Pretty hiding (isEmpty)+import Agda.Syntax.Common.Pretty hiding (isEmpty) import Agda.Utils.Tuple -#include "undefined.h" import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -94,11 +91,12 @@   }   deriving (Eq, Ord, Show, Ix) --- | Convert a 'Size' to a set of bounds suitable for use with---   the matrices in this module.--toBounds :: Num i => Size i -> (MIx i, MIx i)-toBounds sz = (MIx { row = 1, col = 1 }, MIx { row = rows sz, col = cols sz })+-- UNUSED Liang-Ting Chen 2019-07-15+---- | Convert a 'Size' to a set of bounds suitable for use with+----   the matrices in this module.+--+--toBounds :: Num i => Size i -> (MIx i, MIx i)+--toBounds sz = (MIx { row = 1, col = 1 }, MIx { row = rows sz, col = cols sz })  -- | Type of matrices, parameterised on the type of values. --@@ -191,16 +189,17 @@           | i == j         = b    : aux (i + 1) l'           | otherwise      = zero : aux (i + 1) l --- Older implementation without replicate.-blowUpSparseVec' :: (Ord i, Num i, Enum i) => b -> i -> [(i,b)] -> [b]-blowUpSparseVec' zero n l = aux 1 l-  where aux i [] | i > n = []-                 | otherwise = zero : aux (i+1) []-        aux i ((j,b):l) | i <= n && j == i = b : aux (succ i) l-        aux i ((j,b):l) | i <= n && j >= i = zero : aux (succ i) ((j,b):l)-        aux i l = __IMPOSSIBLE__-          -- error $ "blowUpSparseVec (n = " ++ show n ++ ") aux i=" ++ show i ++ " j=" ++ show (fst (head l)) ++ " length l = " ++ show (length l)-+-- UNUSED Liang-Ting Chen 2019-07-15+---- Older implementation without replicate.+--blowUpSparseVec' :: (Ord i, Num i, Enum i) => b -> i -> [(i,b)] -> [b]+--blowUpSparseVec' zero n l = aux 1 l+--  where aux i [] | i > n = []+--                 | otherwise = zero : aux (i+1) []+--        aux i ((j,b):l) | i <= n && j == i = b : aux (succ i) l+--        aux i ((j,b):l) | i <= n && j >= i = zero : aux (succ i) ((j,b):l)+--        aux i l = __IMPOSSIBLE__+--          -- error $ "blowUpSparseVec (n = " ++ show n ++ ") aux i=" ++ show i ++ " j=" ++ show (fst (head l)) ++ " length l = " ++ show (length l)+-- -- | Converts a matrix to a list of row lists. --   @O(size)@ where @size = rows × cols@. @@ -239,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. @@ -351,16 +350,6 @@     | i > j = interAssocWith f l m'     | otherwise = (i, f a b) : interAssocWith f l' m' -interAssocWith2 :: Ord i => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)]-interAssocWith2 f = zipAssocWith (const []) (const []) (const Nothing) (const Nothing) (\ a -> Just . f a)--prop_interAssocWith_correct2 :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_interAssocWith_correct2 xs ys =-  interAssocWith (*) xs ys == interAssocWith2 (*) xs ys-  where-    l  = List.sortBy (compare `on` fst) xs-    l' = List.sortBy (compare `on` fst) ys- -- | @'mul' semiring m1 m2@ multiplies matrices @m1@ and @m2@. --   Uses the operations of the semiring @semiring@ to perform the --   multiplication.@@ -411,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@@ -449,7 +438,7 @@          . Boxes.render          . Boxes.hsep 1 Boxes.right          . map ( Boxes.vcat Boxes.right-               . map ( Boxes.alignHoriz Boxes.right 2+               . map ( Boxes.alignHoriz Boxes.right 4                      . Boxes.text . render . pretty                      )                )
src/full/Agda/Termination/TermCheck.hs view
@@ -1,1328 +1,1503 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImplicitParams             #-}-{-# LANGUAGE NondecreasingIndentation   #-}--{- Checking for Structural recursion-   Authors: Andreas Abel, Nils Anders Danielsson, Ulf Norell,-              Karl Mehltretter and others-   Created: 2007-05-28-   Source : TypeCheck.Rules.Decl- -}--module Agda.Termination.TermCheck-    ( termDecl-    , termMutual-    , Result, DeBruijnPat-    ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import Control.Monad.Reader-import Control.Monad.State--import Data.Foldable (toList)-import Data.List hiding (null)-import qualified Data.List as List-import Data.Monoid-import qualified Data.Set as Set-import Data.Traversable (traverse)--import Agda.Syntax.Abstract (IsProjP(..), AllNames(..))-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern as I-import Agda.Syntax.Internal.Generic-import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Translation.InternalToAbstract ( reifyPatterns )--import Agda.Termination.CutOff-import Agda.Termination.Monad-import Agda.Termination.CallGraph hiding (toList)-import qualified Agda.Termination.CallGraph as CallGraph-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 qualified Agda.Termination.Termination  as Term-import Agda.Termination.RecCheck-import Agda.Termination.Inlining--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce (reduce, normalise, instantiate, instantiateFull)-import Agda.TypeChecking.Records -- (isRecordConstructor, isInductiveRecord)-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.EtaContract-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Records-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.SizedTypes-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Positivity.Occurrence--import qualified Agda.Benchmarking as Benchmark-import Agda.TypeChecking.Monad.Benchmark (billTo, billPureTo)--import Agda.Interaction.Options--import Agda.Utils.Either-import Agda.Utils.Function-import Agda.Utils.Functor (($>), (<.>))-import Agda.Utils.List-import Agda.Utils.Size-import Agda.Utils.Maybe-import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M)-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.Singleton-import qualified Agda.Utils.VarSet as VarSet--#include "undefined.h"-import Agda.Utils.Impossible---- | Call graph with call info for composed calls.--type Calls = CallGraph CallPath---- | The result of termination checking a module.---   Must be a 'Monoid' and have 'Singleton'.--type Result = [TerminationError]---- | Entry point: Termination check a single declaration.------   Precondition: 'envMutualBlock' must be set correctly.--termDecl :: A.Declaration -> TCM Result-termDecl d = inTopContext $ termDecl' d----- | Termination check a single declaration---   (without necessarily ignoring @abstract@).--termDecl' :: A.Declaration -> TCM Result-termDecl' d = case d of-    A.Axiom {}            -> return mempty-    A.Field {}            -> return mempty-    A.Primitive {}        -> return mempty-    A.Mutual _ ds-      | [A.RecSig{}, A.RecDef _ _ _ _ _ _ _ rds] <- unscopeDefs ds-                          -> termDecls rds-    A.Mutual i ds         -> termMutual $ getNames 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-    A.Import {}           -> return mempty-    A.Pragma {}           -> return mempty-    A.Open {}             -> return mempty-    A.PatternSynDef {}    -> return mempty-        -- open and pattern synonym 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.FunDef{}      -> __IMPOSSIBLE__-    A.DataSig{}     -> __IMPOSSIBLE__-    A.DataDef{}     -> __IMPOSSIBLE__-    A.UnquoteDecl{} -> __IMPOSSIBLE__-    A.UnquoteDef{}  -> __IMPOSSIBLE__-  where-    termDecls ds = concat <$> mapM termDecl' ds--    unscopeDefs = concatMap unscopeDef--    unscopeDef (A.ScopedDecl _ ds) = unscopeDefs ds-    unscopeDef d = [d]--    -- 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.Mutual _ 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-    getName _                           = []----- | Entry point: Termination check the current mutual block.--termMutual-  :: [QName]-     -- ^ The function names defined in this block on top-level.-     --   (For error-reporting only.)-  -> TCM Result-termMutual names0 = ifNotM (optTerminationCheck <$> pragmaOptions) (return mempty) $ {-else-}- disableDestructiveUpdate $ do--  -- Get set of mutually defined names from the TCM.-  -- This includes local and auxiliary functions introduced-  -- during type-checking.-  mid <- fromMaybe __IMPOSSIBLE__ <$> asks envMutualBlock-  mutualBlock <- lookupMutualBlock mid-  let allNames = Set.elems $ mutualNames mutualBlock-      names    = if null names0 then allNames else names0-      i        = mutualInfo mutualBlock-      -- Andreas, 2014-03-26-      -- Keeping recursion check after experiments on the standard lib.-      -- Seems still to save 1s.-      -- skip = return False-      -- No need to term-check if the declarations are acyclic!-      skip = not <$> do-        -- Andreas, 2016-10-01 issue #2231-        -- Recursivity checker has to see through abstract definitions!-        ignoreAbstractMode $ do-        billTo [Benchmark.Termination, Benchmark.RecCheck] $ recursive allNames--  -- We set the range to avoid panics when printing error messages.-  setCurrentRange i $ do--  reportSLn "term.mutual" 10 $ "Termination checking " ++ show allNames--  -- NO_TERMINATION_CHECK-  if (Info.mutualTermCheck i `elem` [ NoTerminationCheck, Terminating ]) then do-      reportSLn "term.warn.yes" 2 $ "Skipping termination check for " ++ show names-      forM_ allNames $ \ q -> setTerminates q True -- considered terminating!-      return mempty-  -- NON_TERMINATING-    else if (Info.mutualTermCheck i == NonTerminating) then do-      reportSLn "term.warn.yes" 2 $ "Considering as non-terminating: " ++ show names-      forM_ allNames $ \ q -> setTerminates q False-      return mempty-  -- Trivially terminating (non-recursive)-    else ifM skip (do-      reportSLn "term.warn.yes" 2 $ "Trivially terminating: " ++ show names-      forM_ allNames $ \ q -> setTerminates q True-      return mempty)-   $ {- else -} do--     -- Set the mutual names in the termination environment.-     let setNames e = e-           { terMutual    = allNames-           , terUserNames = names-           }-         runTerm cont = runTerDefault $ do-           cutoff <- terGetCutOff-           reportSLn "term.top" 10 $ "Termination checking " ++ show names ++-             " with cutoff=" ++ show cutoff ++ "..."-           terLocal setNames cont--     -- New check currently only makes a difference for copatterns.-     -- Since it is slow, only invoke it if-     -- any of the definitions uses copatterns.-     res <- ifM (orM $ map usesCopatterns allNames)-         -- 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---- | @termMutual'@ checks all names of the current mutual block,---   henceforth called @allNames@, for termination.------   @allNames@ is taken from 'Internal' syntax, it contains also---   the definitions created by the type checker (e.g., with-functions).--termMutual' :: TerM Result-termMutual' = do--  -- 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--  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  r <- billToTerGraph $ Term.terminates calls1-  r <- 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--  -- @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-      liftTCM $ reportSLn "term.warn.yes" 2 $-        show (names) ++ " does termination check"-      return mempty---- | Smart constructor for 'TerminationError'.---   Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'.-terminationError :: [QName] -> [CallInfo] -> TerminationError-terminationError names calls = TerminationError names' calls-  where names' = names `intersect` toList (allNames calls)---- ASR (08 November 2014). The type of the function could be------ @Either a b -> TerM (Either a b)@.-billToTerGraph :: a -> TerM a-billToTerGraph a = liftTCM $ billPureTo [Benchmark.Termination, Benchmark.Graph] a---- | @reportCalls@ for debug printing.------   Replays the call graph completion for debugging.--reportCalls :: String -> Calls -> TerM ()-reportCalls no calls = do-  cutoff <- terGetCutOff-  let ?cutoff = cutoff--  -- We work in TCM exclusively.-  liftTCM $ do--    reportS "term.lex" 20 $ unlines-      [ "Calls (" ++ no ++ "dot patterns): " ++ show calls-      ]--    -- Print the whole completion phase.-    verboseS "term.matrices" 40 $ do-      let header s = unlines-            [ replicate n '='-            , replicate k '=' ++ s ++ replicate k' '='-            , replicate n '='-            ]-            where n  = 70-                  r  = n - length s-                  k  = r `div` 2-                  k' = r - k-      let report s cs = reportSDoc "term.matrices" 40 $ vcat-            [ text   $ header s-            , nest 2 $ pretty cs-            ]-          cs0     = calls-          step cs = do-            let (new, cs') = completionStep cs0 cs-            report " New call matrices " new-            return $ if null new then Left () else Right cs'-      report " Initial call matrices " cs0-      trampolineM step cs0--    -- Print the result of completion.-    let calls' = CallGraph.complete calls-        idems = filter idempotent $ endos $ CallGraph.toList calls'-    -- TODO-    -- reportSDoc "term.behaviours" 20 $ vcat-    --   [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):"-    --   , nest 2 $ return $ Term.prettyBehaviour calls'-    --   ]-    reportSDoc "term.matrices" 30 $ vcat-      [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n"-      , nest 2 $ vcat $ punctuate (text "\n") $ map pretty idems-      ]-    -- reportSDoc "term.matrices" 30 $ vcat-    --   [ text $ "Other call matrices (" ++ no ++ "dot patterns):"-    --   , nest 2 $ pretty $ CallGraph.fromList others-    --   ]-    return ()---- | @termFunction name@ checks @name@ for termination.--termFunction :: QName -> TerM Result-termFunction name = 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--  -- Retrieve the target type of the function to check.--  target <- liftTCM $ do typeEndsInDef =<< typeOfConst name-  reportTarget target-  terSetTarget target $ do--    -- Collect the recursive calls in the block which (transitively)-    -- involve @name@,-    -- taking the target of @name@ into account for computing guardedness.--    let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do-          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-            -- Mark those functions as processed and add the calls to the result.-            let done'  = done `mappend` todo-                calls' = new  `mappend` calls-            -- Compute the new todo list:-                todo' = CallGraph.targetNodes new Set.\\ done'-            -- 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--    names <- terGetUserNames-    case r of-      Left calls -> return $ singleton $ terminationError ([name] `intersect` names) calls-      Right () -> do-        liftTCM $ reportSLn "term.warn.yes" 2 $-          show name ++ " does termination check"-        return mempty-   where-     reportTarget r = liftTCM $-       reportSLn "term.target" 20 $ "  target type " ++-         caseMaybe r "not recognized" (\ q ->-           "ends in " ++ show q)---- | To process the target type.-typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName)-typeEndsInDef t = liftTCM $ do-  TelV _ core <- telView t-  case ignoreSharing $ unEl core of-    Def d vs -> return $ Just d-    _        -> return Nothing---- | Termination check a definition by pattern matching.------   TODO: Refactor!---   As this function may be called twice,---   once disregarding dot patterns,---   the second time regarding dot patterns,---   it is better if we separated bare call extraction---   from computing the change in structural order.---   Only the latter depends on the choice whether we---   consider dot patterns or not.-termDef :: QName -> TerM Calls-termDef name = terSetCurrent name $ inConcreteOrAbstractMode name $ \ def -> do--  -- Retrieve definition-  let t = defType def--  liftTCM $ reportSDoc "term.def.fun" 5 $-    sep [ text "termination checking body of" <+> prettyTCM name-        , nest 2 $ text ":" <+> prettyTCM t-        ]--  -- If --without-K, we disregard all arguments (and result)-  -- which are not of data or record type.--  withoutKEnabled <- liftTCM $ optWithoutK <$> pragmaOptions-  applyWhen withoutKEnabled (setMasks t) $ do--    -- If the result should be disregarded, set all calls to unguarded.-    applyWhenM terGetMaskResult terUnguarded $ do--      case theDef def of-        Function{ funClauses = cls, funDelayed = delayed } ->-          terSetDelayed delayed $ forM' cls $ termClause--        _ -> return empty---- | Mask arguments and result for termination checking---   according to type of function.---   Only arguments of types ending in data/record or Size are counted in.-setMasks :: Type -> TerM a -> TerM a-setMasks t cont = do-  (ds, d) <- liftTCM $ do-    TelV tel core <- telView t-    -- Check argument types-    ds <- forM (telToList tel) $ \ t -> do-      TelV _ t <- telView $ snd $ unDom t-      d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)-      when d $-        reportSDoc "term.mask" 20 $ do-          text "argument type "-            <+> prettyTCM t-            <+> text " is not data or record type, ignoring structural descent for --without-K"-      return d-    -- Check result types-    d  <- 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--{- Termination check clauses:--   For instance--   f x (cons y nil) = g x y--   Clause-     [VarP "x", ConP "List.cons" [VarP "y", ConP "List.nil" []]]-     Bind (Abs { absName = "x"-               , absBody = Bind (Abs { absName = "y"-                                     , absBody = Def "g" [ Var 1 []-                                                         , Var 0 []]})})--   Outline:-   - create "De Bruijn pattern"-   - collect recursive calls-   - going under a binder, lift de Bruijn pattern-   - compare arguments of recursive call to pattern---}---- | Is the current target type among the given ones?--targetElem :: [Target] -> TerM Bool-targetElem ds = maybe False (`elem` ds) <$> terGetTarget--{---- | 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.--termToDBP :: Term -> TerM DeBruijnPat-termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do-    suc <- terGetSizeSuc-    let-      loop :: Term -> TCM DeBruijnPat-      loop t = do-        t <- constructorForm t-        case ignoreSharing t of-          -- Constructors.-          Con c ci args -> ConDBP (conName c) <$> mapM (loop . unArg) args-          Def s [Apply arg] | Just s == suc-                      -> ConDBP s . (:[]) <$> loop (unArg arg)-          DontCare t  -> __IMPOSSIBLE__  -- removed by stripAllProjections-          -- Leaves.-          Var i []    -> return $ VarDBP i-          Lit l       -> return $ LitDBP l-          t           -> return $ TermDBP t-    liftTCM $ loop =<< stripAllProjections =<< normalise t----- | Masks coconstructor patterns in a deBruijn pattern.-stripCoConstructors :: DeBruijnPat -> TerM DeBruijnPat-stripCoConstructors p = do-  case p of-    ConDBP c args -> do-      ind <- ifM ((Just c ==) <$> terGetSizeSuc) (return Inductive) {- else -}-               (liftTCM $ whatInduction c)-      case ind of-        Inductive   -> ConDBP c <$> mapM stripCoConstructors args-        CoInductive -> return unusedVar-    -- The remaining (atomic) patterns cannot contain coconstructors, obviously.-    VarDBP{}  -> return p-    LitDBP{}  -> return p-    TermDBP{} -> return p  -- Can contain coconstructors, but they do not count here.-    ProjDBP{} -> return p---- | Masks all non-data/record type patterns if --without-K.---   See issue #1023.-maskNonDataArgs :: [DeBruijnPat] -> TerM [Masked DeBruijnPat]-maskNonDataArgs ps = zipWith mask ps <$> terGetMaskArgs-  where-    mask p@ProjDBP{} _ = Masked False p-    mask p           d = Masked d     p---- | Convert patterns to the format used by the termination checker---   TODO: refactor termination checking to use regular patterns-convertPatterns :: [DeBruijnPattern] -> TerM [DeBruijnPat]-convertPatterns ps = mapM build ps-  where-    build :: DeBruijnPattern -> TerM DeBruijnPat-    build (VarP x)        = return $ VarDBP $ dbPatVarIndex x-    build (ConP con _ ps) = ConDBP (conName con) <$> mapM (build . namedArg) ps-    build (DotP t)        = termToDBP t-    build (LitP l)        = return $ LitDBP l-    build (ProjP o d)     = return $ ProjDBP o d---- | Extract recursive calls from one clause.-termClause :: Clause -> TerM Calls-termClause clause = do-  ifNotM (terGetInlineWithFunctions) (termClause' clause) $ {- else -} do-    name <- terGetCurrent-    ifM (isJust <$> do isWithFunction name) (return mempty) $-      mapM' termClause' =<< do liftTCM $ inlineWithClauses name clause--termClause' :: Clause -> TerM Calls-termClause' clause = do-  cl <- introHiddenLambdas clause-  let tel      = clauseTel cl-      argPats' = namedClausePats cl-      body     = clauseBody cl-  liftTCM $ reportSDoc "term.check.clause" 25 $ vcat-    [ text "termClause"-    , nest 2 $ text "tel      =" <+> prettyTCM tel-    , nest 2 $ text "argPats' =" <+> do-      addContext tel $ do-       aps <- reifyPatterns argPats'-       fsep $ map prettyA aps-    ]-  addContext tel $ do-    dbpats <- convertPatterns $ map namedArg argPats'-    case body of-      Nothing -> return empty-      Just v -> do-        dbpats <- mapM stripCoConstructors dbpats-        mdbpats <- maskNonDataArgs dbpats-        terSetPatterns mdbpats $ do-          terSetSizeDepth tel $ do-            reportBody v-            extract v--  where-    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")-                <+> prettyTCM f-            , nest 2 $ text "lhs:" <+> hsep (map prettyTCM pats)-            , nest 2 $ text "rhs:" <+> prettyTCM v-            ]---- | Rewrite a clause @f ps =tel= \ {xs} -> v@ to @f ps {xs} =(tel {xs})= v@.---   The pupose is to move hidden size quantifications---   to the lhs such that the termination checker can make use of them.---   See, e.g., test/succeed/SizedTypesExtendedLambda.agda.-introHiddenLambdas :: MonadTCM tcm => Clause -> tcm Clause-introHiddenLambdas clause = liftTCM $ do-  case clause of-    Clause range ctel ps body        Nothing  catchall -> return clause--    Clause range ctel ps Nothing     (Just t) catchall -> return clause-    Clause range ctel ps (Just body) (Just t) catchall -> do-      case removeHiddenLambdas body of-        -- nobody or no hidden lambdas-        ([], _) -> return clause-        -- hidden lambdas-        (axs, body') -> do-          -- n = number of hidden lambdas-          let n = length axs-          -- take n abstractions from rhs type-          TelV ttel t' <- telViewUpTo n $ unArg t-          when (size ttel < n) __IMPOSSIBLE__-          -- join with lhs telescope-          let ctel' = telFromList $ telToList ctel ++ telToList ttel-              ps'   = raise n ps ++ zipWith toPat (downFrom $ size axs) axs-          return $ Clause range ctel' ps' (Just body') (Just (t $> t')) catchall-  where-    toPat i (Arg info x) = Arg info $ namedDBVarP i x--    removeHiddenLambdas :: Term -> ([Arg ArgName], Term)-    removeHiddenLambdas v =-      case ignoreSharing v of-        Lam info b | getHiding info == Hidden ->-          let (xs, b') = removeHiddenLambdas $ unAbs b-          in  (Arg info (absName b) : xs, b')-        _ -> ([], v)---- | Extract recursive calls from expressions.-class ExtractCalls a where-  extract :: a -> TerM Calls--instance ExtractCalls a => ExtractCalls (Abs a) where-  extract (NoAbs _ a) = extract a-  extract (Abs x a)   = addContext x $ terRaise $ extract a--instance ExtractCalls a => ExtractCalls (Arg a) where-  extract = extract . unArg--instance ExtractCalls a => ExtractCalls (Dom a) where-  extract = extract . unDom--instance ExtractCalls a => ExtractCalls (Elim' a) where-  extract Proj{}    = return empty-  extract (Apply a) = extract $ unArg a--instance ExtractCalls a => ExtractCalls [a] where-  extract = mapM' extract--instance (ExtractCalls a, ExtractCalls b) => ExtractCalls (a,b) where-  extract (a, b) = CallGraph.union <$> extract a <*> extract b---- | Sorts can contain arbitrary terms of type @Level@,---   so look for recursive calls also in sorts.---   Ideally, 'Sort' would not be its own datatype but just---   a subgrammar of 'Term', then we would not need this boilerplate.--instance ExtractCalls Sort where-  extract s = do-    liftTCM $ do-      reportSDoc "term.sort" 20 $-        text "extracting calls from sort" <+> prettyTCM s-      reportSDoc "term.sort" 50 $-        text ("s = " ++ show s)-    case s of-      Prop       -> return empty-      Inf        -> return empty-      SizeUniv   -> return empty-      Type t     -> terUnguarded $ extract t  -- no guarded levels-      DLub s1 s2 -> extract (s1, s2)---- | Extract recursive calls from a type.--instance ExtractCalls Type where-  extract (El s t) = extract (s, t)---- | Extract recursive calls from a constructor application.--constructor-  :: QName-    -- ^ Constructor name.-  -> Induction-    -- ^ Should the constructor be treated as inductive or coinductive?-  -> [(Arg Term, Bool)]-    -- ^ All the arguments,-    --   and for every argument a boolean which is 'True' iff the-    --   argument should be viewed as preserving guardedness.-  -> TerM Calls-constructor c ind args = do-  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  mapM' loopArg args-  where-    loopArg (arg, preserves) = terModifyGuarded g' $ extract arg where-      g' = case (preserves, ind) of-             (True,  Inductive)   -> id-             (True,  CoInductive) -> (Order.lt .*.)-             (False, _)           -> const Order.unknown----- | Handle guardedness preserving type constructor.--guardPresTyCon :: QName -> Elims -> (QName -> Elims -> TerM Calls) -> TerM Calls-guardPresTyCon g es cont = do-  ifNotM (terGetGuardingTypeConstructors) (cont g es) $ {- else -} do--    def <- liftTCM $ getConstInfo g-    let occs = defArgOccurrences def-        preserves = (StrictPos <=)-        -- Data or record type constructor.-        con = constructor g Inductive $   -- guardedness preserving-                zip (argsFromElims es)-                    (map preserves occs ++ repeat False)--    case theDef def of-      Datatype{} -> con-      Record{}   -> con-      _          -> cont g es----- | Extract calls from with function application.--withFunction :: QName -> Elims -> TerM Calls-withFunction g es = do-  v <- liftTCM $ -- billTo [Benchmark.Termination, Benchmark.With] $  -- 0ms-         expandWithFunctionCall g es-  liftTCM $ reportSDoc "term.with.call" 30 $-    text "termination checking expanded with-function call:" <+> prettyTCM v-  extract v---- | Handles function applications @g es@.--function :: QName -> Elims -> TerM Calls-function g es = ifM (terGetInlineWithFunctions `and2M` do isJust <$> isWithFunction g) (withFunction g es)-  $ {-else, no with function-} do--    f       <- terGetCurrent-    names   <- terGetMutual-    guarded <- terGetGuarded--    let gArgs = Def g es-    liftTCM $ reportSDoc "term.function" 30 $-      text "termination checking function call " <+> prettyTCM gArgs--    -- First, look for calls in the arguments of the call gArgs.--    -- We have to reduce constructors in case they're reexported.-    -- Andreas, Issue 1530: constructors have to be reduced deep inside terms,-    -- thus, we need to use traverseTermM.  Sharing is handled by traverseTermM,-    -- so no ignoreSharing needed here.-    let reduceCon = traverseTermM $ \ t -> case t of-           Con c ci vs -> (`apply` vs) <$> reduce (Con c ci [])  -- make sure we don't reduce the arguments-           _ -> return t--    -- Reduce constructors only when this call is actually a recursive one.-    -- es <- liftTCM $ billTo [Benchmark.Termination, Benchmark.Reduce] $ forM es $-    --         etaContract <=< traverse reduceCon <=< instantiateFull--    -- If the function is a projection but not for a coinductive record,-    -- then preserve guardedness for its principal argument.-    isProj <- isProjectionButNotCoinductive g-    let unguards = repeat Order.unknown-    let guards = applyWhen isProj (guarded :) unguards-    -- Collect calls in the arguments of this call.-    let args = map unArg $ argsFromElims es-    calls <- forM' (zip guards args) $ \ (guard, a) -> do-      terSetGuarded guard $ extract a--    -- Then, consider call gArgs itself.--    liftTCM $ reportSDoc "term.found.call" 20 $-      sep [ text "found call from" <+> prettyTCM f-          , nest 2 $ text "to" <+> prettyTCM g-          ]--    -- insert this call into the call list-    case List.elemIndex 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-       Just gInd -> do-         delayed <- terGetDelayed-         pats    <- terGetPatterns-         -- 2014-03-25 Andreas, the costs seem small, benchmark turned off.-         es <- liftTCM $ -- billTo [Benchmark.Termination, Benchmark.Reduce] $-           forM es $-              etaContract <=< traverse reduceCon <=< instantiateFull--         -- Compute the call matrix.--         -- Andreas, 2014-03-26 only 6% of termination time for library test-         -- 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-         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--         -- Andreas, 2013-04-26 FORBIDDINGLY expensive!-         -- This PrettyTCM QName cost 50% of the termination time for std-lib!!-         -- gPretty <-liftTCM $ billTo [Benchmark.Termination, Benchmark.Level] $-         --   render <$> prettyTCM g--         -- Andreas, 2013-05-19 as pointed out by Andrea Vezzosi,-         -- printing the call eagerly is forbiddingly expensive.-         -- So we build a closure such that we can print the call-         -- whenever we really need to.-         -- This saves 30s (12%) on the std-lib!-         -- Andreas, 2015-01-21 Issue 1410: Go to the module where g is defined-         -- otherwise its free variables with be prepended to the call-         -- in the error message.-         doc <- liftTCM $ withCurrentModule (qnameModule g) $ buildClosure gArgs--         let src  = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names-             tgt  = gInd-             cm   = makeCM ncols nrows matrix'-             info = CallPath [CallInfo-                      { callInfoTarget = g-                      , callInfoRange  = getRange g-                      , callInfoCall   = doc-                      }]-         liftTCM $ reportSDoc "term.kept.call" 5 $ vcat-           [ text "kept call from" <+> text (show f) <+> hsep (map prettyTCM pats)-           , nest 2 $ text "to" <+> text (show g) <+>-                       hsep (map (parens . prettyTCM) args)-           , nest 2 $ text "call matrix (with guardedness): "-           , nest 2 $ pretty cm-           ]-         return $ CallGraph.insert src tgt cm info calls---- | Extract recursive calls from a term.--instance ExtractCalls Term where-  extract t = do-    liftTCM $ reportSDoc "term.check.term" 50 $ do-      text "looking for calls in" <+> prettyTCM t--    -- Instantiate top-level MetaVar.-    t <- liftTCM $ instantiate t-    case ignoreSharing t of--      -- Constructed value.-      Con ConHead{conName = c} _ args -> do--        -- A constructor preserves the guardedness of all its arguments.-        let argsg = zip args $ repeat True--        -- If we encounter a coinductive record constructor-        -- in a type mutual with the current target-        -- then we count it as guarding.-        ind <- ifM ((Just c ==) <$> terGetSharp) (return CoInductive) $ do-          r <- liftTCM $ isRecordConstructor c-          case r of-            Nothing       -> return Inductive-            Just (q, def) -> (\ b -> if b then CoInductive else Inductive) <$>-              andM [ return $ recRecursive def-                   , return $ recInduction def == Just CoInductive-                   , targetElem (q : recMutual def)-                   ]-        constructor c ind argsg--      -- Function, data, or record type.-      Def g es -> guardPresTyCon g es function--      -- Abstraction. Preserves guardedness.-      Lam h b -> extract b--      -- Neutral term. Destroys guardedness.-      Var i es -> terUnguarded $ extract es--      -- Dependent function space.-      Pi a (Abs x b) -> CallGraph.union <$> (terUnguarded $ extract a) <*> do-         a <- maskSizeLt a  -- OR: just do not add a to the context!-         terPiGuarded $ addContext (x, a) $ terRaise $ extract b--      -- Non-dependent function space.-      Pi a (NoAbs _ b) -> CallGraph.union-         <$> terUnguarded (extract a)-         <*> terPiGuarded (extract b)--      -- Literal.-      Lit l -> return empty--      -- Sort.-      Sort s -> extract s--      -- Unsolved metas are not considered termination problems, there-      -- will be a warning for them anyway.-      MetaV x args -> return empty--      -- Erased and not-yet-erased proof.-      DontCare t -> extract t--      -- Level.-      Level l -> -- billTo [Benchmark.Termination, Benchmark.Level] $ do-        -- Andreas, 2014-03-26 Benchmark discontinued, < 0.3% spent on levels.-        extract l--      Shared{} -> __IMPOSSIBLE__---- | Extract recursive calls from level expressions.--deriving instance ExtractCalls Level--instance ExtractCalls PlusLevel where-  extract (ClosedLevel n) = return $ mempty-  extract (Plus n l)      = extract l--instance ExtractCalls LevelAtom where-  extract (MetaLevel x es)   = extract es-  extract (BlockedLevel x t) = extract t-  extract (NeutralLevel _ t) = extract t-  extract (UnreducedLevel t) = extract t---- | Rewrite type @tel -> Size< u@ to @tel -> Size@.-maskSizeLt :: MonadTCM tcm => Dom Type -> tcm (Dom Type)-maskSizeLt dom@(Dom info a) = liftTCM $ do-  (msize, msizelt) <- getBuiltinSize-  case (msize, msizelt) of-    (_ , Nothing) -> return dom-    (Nothing, _)  -> __IMPOSSIBLE__-    (Just size, Just sizelt) -> do-      TelV tel c <- telView a-      case ignoreSharingType a of-        El s (Def d [v]) | d == sizelt -> return $ Dom info $-          abstract tel $ El s $ Def size []-        _ -> return dom--{- | @compareArgs es@--     Compare the list of de Bruijn patterns (=parameters) @pats@-     with a list of arguments @es@ and create a call maxtrix-     with |es| rows and |pats| columns.--     The guardedness is the number of projection patterns in @pats@-     minus the number of projections in @es@.- -}-compareArgs :: (Integral n) => [Elim] -> TerM (n, n, [[Order]])-compareArgs es = do-  pats <- terGetPatterns-  -- apats <- annotatePatsWithUseSizeLt pats-  -- reportSDoc "term.compare" 20 $-  --   text "annotated patterns = " <+> sep (map prettyTCM apats)-  -- matrix <- forM es $ \ e -> forM apats $ \ (b, p) -> terSetUseSizeLt b $ compareElim e p-  matrix <- withUsableVars pats $ forM es $ \ e -> forM pats $ \ p -> compareElim e p--  -- Count the number of coinductive projection(pattern)s in caller and callee.-  -- Only recursive coinductive projections are eligible (Issue 1209).-  projsCaller <- genericLength <$> do-    filterM (isCoinductiveProjection True) $ mapMaybe (fmap (head . unAmbQ . snd) . isProjP . getMasked) pats-  projsCallee <- genericLength <$> do-    filterM (isCoinductiveProjection True) $ mapMaybe (fmap snd . isProjElim) es-  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  let guardedness = decr $ projsCaller - projsCallee-  liftTCM $ reportSDoc "term.guardedness" 30 $ sep-    [ text "compareArgs:"-    , nest 2 $ text $ "projsCaller = " ++ show projsCaller-    , nest 2 $ text $ "projsCallee = " ++ show projsCallee-    , nest 2 $ text $ "guardedness of call: " ++ show guardedness-    ]-  return $ addGuardedness guardedness (size es) (size pats) matrix---- | Traverse patterns from left to right.---   When we come to a projection pattern,---   switch usage of SIZELT constraints:---   on, if coinductive,---   off, if inductive.------   UNUSED-annotatePatsWithUseSizeLt :: [DeBruijnPat] -> TerM [(Bool,DeBruijnPat)]-annotatePatsWithUseSizeLt = loop where-  loop [] = return []-  loop (p@(ProjDBP _ q) : pats) = ((False,p) :) <$> do projUseSizeLt q $ loop pats-  loop (p : pats) = (\ b ps -> (b,p) : ps) <$> terGetUseSizeLt <*> loop pats----- | @compareElim e dbpat@--compareElim :: Elim -> Masked DeBruijnPat -> TerM Order-compareElim e p = do-  liftTCM $ do-    reportSDoc "term.compare" 30 $ sep-      [ text "compareElim"-      , nest 2 $ text "e = " <+> prettyTCM e-      , nest 2 $ text "p = " <+> prettyTCM p-      ]-    reportSDoc "term.compare" 50 $ sep-      [ nest 2 $ text $ "e = " ++ show e-      , nest 2 $ text $ "p = " ++ show p-      ]-  case (e, getMasked p) of-    (Proj _ d, ProjDBP _ d')       -> do-      d  <- liftTCM $ getOriginalProjection d-      d' <- liftTCM $ getOriginalProjection d'-      compareProj d d'-    (Proj{}, _         )           -> return Order.unknown-    (Apply{}, ProjDBP{})           -> return Order.unknown-    (Apply arg, _)                 -> compareTerm (unArg arg) p---- | In dependent records, the types of later fields may depend on the---   values of earlier fields.  Thus when defining an inhabitant of a---   dependent record type such as Σ by copattern matching,---   a recursive call eliminated by an earlier projection (proj₁) might---   occur in the definition at a later projection (proj₂).---   Thus, earlier projections are considered "smaller" when---   comparing copattern spines.  This is an ok approximation---   of the actual dependency order.---   See issues 906, 942.-compareProj :: MonadTCM tcm => QName -> QName -> tcm Order-compareProj d d'-  | d == d' = return Order.le-  | otherwise = liftTCM $ do-      -- different projections-      mr  <- getRecordOfField d-      mr' <- getRecordOfField d'-      case (mr, mr') of-        (Just r, Just r') | r == r' -> do-          -- of same record-          def <- theDef <$> getConstInfo r-          case def of-            Record{ recFields = fs } -> do-              fs <- return $ map unArg fs-              case (find (d==) fs, find (d'==) fs) of-                (Just i, Just i')-                  -- earlier field is smaller-                  | i < i'    -> return Order.lt-                  | i == i'   -> do-                     __IMPOSSIBLE__-                  | otherwise -> return Order.unknown-                _ -> __IMPOSSIBLE__-            _ -> __IMPOSSIBLE__-        _ -> return Order.unknown---- | 'makeCM' turns the result of 'compareArgs' into a proper call matrix-makeCM :: Int -> Int -> [[Order]] -> CallMatrix-makeCM ncols nrows matrix = CallMatrix $-  Matrix.fromLists (Matrix.Size nrows ncols) matrix--{- To turn off guardedness, restore this code.--- | 'addGuardedness' does nothing.-addGuardedness :: Integral n => Order -> n -> n -> [[Order]] -> (n, n, [[Order]])-addGuardedness g nrows ncols m = (nrows, ncols, m)--}---- | 'addGuardedness' adds guardedness flag in the upper left corner (0,0).-addGuardedness :: Integral n => Order -> n -> n -> [[Order]] -> (n, n, [[Order]])-addGuardedness o nrows ncols m =-  (nrows + 1, ncols + 1,-   (o : genericReplicate ncols Order.unknown) : map (Order.unknown :) m)---- | Compose something with the upper-left corner of a call matrix-composeGuardedness :: (?cutoff :: CutOff) => Order -> [[Order]] -> [[Order]]-composeGuardedness o ((corner : row) : rows) = ((o .*. corner) : row) : rows-composeGuardedness _ _ = __IMPOSSIBLE__---- | Stripping off a record constructor is not counted as decrease, in---   contrast to a data constructor.---   A record constructor increases/decreases by 0, a data constructor by 1.-offsetFromConstructor :: MonadTCM tcm => QName -> tcm Int-offsetFromConstructor c = maybe 1 (const 0) <$> do-  liftTCM $ isRecordConstructor c---- | Compute the proper subpatterns of a 'DeBruijnPat'.-subPatterns :: DeBruijnPat -> [DeBruijnPat]-subPatterns p = case p of-  ConDBP c ps -> ps ++ concatMap subPatterns ps-  VarDBP _    -> []-  LitDBP _    -> []-  TermDBP _   -> []-  ProjDBP{}   -> []--compareTerm :: Term -> Masked DeBruijnPat -> TerM Order-compareTerm t p = do---   reportSDoc "term.compare" 25 $---     text " comparing term " <+> prettyTCM t <+>---     text " to pattern " <+> prettyTCM p-  t <- liftTCM $ stripAllProjections t-  o <- compareTerm' t p-  liftTCM $ reportSDoc "term.compare" 25 $-    text " comparing term " <+> prettyTCM t <+>-    text " to pattern " <+> prettyTCM p <+>-    text (" results in " ++ show o)-  return o-{--compareTerm t p = Order.supremum $ compareTerm' t p : map cmp (subPatterns p)-  where-    cmp p' = (Order..*.) Order.lt (compareTerm' t p')--}----- | Remove all non-coinductive projections from an algebraic term---   (not going under binders).---   Also, remove 'DontCare's.-class StripAllProjections a where-  stripAllProjections :: a -> TCM a--instance StripAllProjections a => StripAllProjections (Arg a) where-  stripAllProjections = traverse stripAllProjections-  -- stripAllProjections (Arg info a) = Arg info <$> stripAllProjections a--{- DOES NOT WORK, since s.th. special is needed for Elims-instance StripAllProjections a => StripAllProjections [a] where-  stripAllProjections = traverse stripAllProjections--instance StripAllProjections a => StripAllProjections (Elim' a) where--}--instance StripAllProjections Elims where-  stripAllProjections es =-    case es of-      []             -> return []-      (Apply a : es) -> do-        (:) <$> (Apply <$> stripAllProjections a) <*> stripAllProjections es-      (Proj o p  : es) -> do-        isP <- isProjectionButNotCoinductive p-        applyUnless isP (Proj o p :) <$> stripAllProjections es--instance StripAllProjections Args where-  stripAllProjections = mapM stripAllProjections--instance StripAllProjections Term where-  stripAllProjections t = do-    case ignoreSharing t of-      Var i es   -> Var i <$> stripAllProjections es-      Con c ci ts -> Con c ci <$> stripAllProjections ts-      Def d es   -> Def d <$> stripAllProjections es-      DontCare t -> stripAllProjections t-      _ -> return t---- | @compareTerm' t dbpat@------   Precondition: top meta variable resolved--compareTerm' :: Term -> Masked DeBruijnPat -> TerM Order-compareTerm' v mp@(Masked m p) = do-  suc  <- terGetSizeSuc-  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  v <- return $ ignoreSharing v-  case (v, p) of--    -- Andreas, 2013-11-20 do not drop projections,-    -- in any case not coinductive ones!:-    (Var i es, _) | Just{} <- allApplyElims es ->-      compareVar i mp--    (DontCare t, _) ->-      compareTerm' t mp--    -- Andreas, 2014-09-22, issue 1281:-    -- For metas, termination checking should be optimistic.-    -- If there is any instance of the meta making termination-    -- checking succeed, then we should not fail.-    -- Thus, we assume the meta will be instantiated with the-    -- deepest variable in @p@.-    -- For sized types, the depth is maximally-    -- the number of SIZELT hypotheses one can have in a context.-    (MetaV{}, p) -> Order.decr . max (if m then 0 else patternDepth p) . pred <$>-       terAsks _terSizeDepth--    -- Successor on both sides cancel each other.-    -- We ignore the mask for sizes.-    (Def s [Apply t], ConDBP s' [p]) | s == s' && Just s == suc ->-      compareTerm' (unArg t) (notMasked p)--    -- Register also size increase.-    (Def s [Apply t], p) | Just s == suc ->-      -- Andreas, 2012-10-19 do not cut off here-      increase 1 <$> compareTerm' (unArg t) mp--    -- In all cases that do not concern sizes,-    -- we cannot continue if pattern is masked.--    _ | m -> return Order.unknown--    (Lit l, LitDBP l')-      | l == l'     -> return Order.le-      | otherwise   -> return Order.unknown--    (Lit l, _) -> do-      v <- liftTCM $ constructorForm v-      case ignoreSharing v of-        Lit{}       -> return Order.unknown-        v           -> compareTerm' v mp--    -- Andreas, 2011-04-19 give subterm priority over matrix order--    (Con{}, ConDBP c ps) | any (isSubTerm v) ps ->-      decrease <$> offsetFromConstructor c <*> return Order.le--    (Con c ci ts, ConDBP c' ps) | conName c == c'->-      compareConArgs ts ps--    (Con c ci [], _) -> return Order.le--    -- new case for counting constructors / projections-    -- register also increase-    (Con c ci ts, _) -> do-      increase <$> offsetFromConstructor (conName c)-               <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) mp) ts)--    (t, p) -> return $ subTerm t p---- | @subTerm@ computes a size difference (Order)-subTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPat -> Order-subTerm t p = if equal t p then Order.le else properSubTerm t p-  where-    equal (Shared p) dbp = equal (derefPtr p) dbp-    equal (Con c ci ts) (ConDBP c' ps) =-      and $ (conName c == c')-          : (length ts == length ps)-          : zipWith equal (map unArg ts) ps-    equal (Var i []) (VarDBP i') = i == i'-    equal (Lit l)    (LitDBP l') = l == l'-    -- Terms.-    -- Checking for identity here is very fragile.-    -- However, we cannot do much more, as we are not allowed to normalize t.-    -- (It might diverge, and we are just in the process of termination checking.)-    equal t         (TermDBP t') = t == t'-    equal _ _ = False--    properSubTerm t (ConDBP _ ps) = decrease 1 $ supremum $ map (subTerm t) ps-    properSubTerm _ _ = Order.unknown--isSubTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPat -> Bool-isSubTerm t p = nonIncreasing $ subTerm t p--compareConArgs :: Args -> [DeBruijnPat] -> TerM Order-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 (head ps))-    (_,_) -> foldl (Order..*.) Order.le <$>-               zipWithM compareTerm' (map unArg ts) (map notMasked ps)-       -- corresponds to taking the size, not the height-       -- allows examples like (x, y) < (Succ x, y)-{- version which does an "order matrix"-   -- Andreas, 2013-02-18 disabled because it is unclear-   -- how to scale idempotency test to matrix-shaped orders (need thinking/researcH)-   -- Trigges issue 787.-        (_,_) -> do -- build "call matrix"-          m <- mapM (\t -> mapM (compareTerm' suc (unArg t)) ps) ts-          let m2 = makeCM (genericLength ps) (genericLength ts) m-          return $ Order.orderMat (Order.mat m2)--}-{- version which takes height---    if null ts then Order.Le---               else Order.infimum (zipWith compareTerm' (map unArg ts) ps)--}--compareVar :: Nat -> Masked DeBruijnPat -> TerM Order-compareVar i (Masked m p) = do-  suc    <- terGetSizeSuc-  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  let no = return Order.unknown-  case p of-    ProjDBP{}   -> no-    LitDBP{}    -> no-    TermDBP{}   -> no-    VarDBP j    -> compareVarVar i (Masked m j)-    ConDBP s [p] | Just s == suc -> decrease 1 <$> compareVar i (notMasked p)-    ConDBP c ps -> if m then no else do-      decrease <$> offsetFromConstructor c-               <*> (Order.supremum <$> mapM (compareVar i . notMasked) ps)---- | Compare two variables.------   The first variable comes from a term, the second from a pattern.-compareVarVar :: Nat -> Masked Nat -> TerM Order-compareVarVar i (Masked m j)-  | i == j    = if not m then return Order.le else liftTCM $-      -- If j is a size, we ignore the mask.-      ifM (isJust <$> do isSizeType =<< reduce =<< typeOfBV j)-        {- then -} (return Order.le)-        {- else -} (return Order.unknown)-  | otherwise = ifNotM ((i `VarSet.member`) <$> terGetUsableVars) (return Order.unknown) $ {- else -} do-      res <- isBounded i-      case res of-        BoundedNo  -> return Order.unknown-        BoundedLt v -> decrease 1 <$> compareTerm' v (Masked  m (VarDBP j))++{-# LANGUAGE ImplicitParams             #-}+{-# LANGUAGE NondecreasingIndentation   #-}++{- Checking for Structural recursion+   Authors: Andreas Abel, Nils Anders Danielsson, Ulf Norell,+              Karl Mehltretter and others+   Created: 2007-05-28+   Source : TypeCheck.Rules.Decl+ -}++module Agda.Termination.TermCheck+    ( termDecl+    , termMutual+    , Result+    ) where++import Prelude hiding ( null )++import Control.Applicative  ( liftA2 )+import Control.Monad        ( (<=<), filterM, forM, forM_, zipWithM )++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+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.Pattern as I+import Agda.Syntax.Internal.Generic+import qualified Agda.Syntax.Info as Info+import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))++import Agda.Termination.CutOff+import Agda.Termination.Monad+import Agda.Termination.CallGraph hiding (toList)+import qualified Agda.Termination.CallGraph as CallGraph+import Agda.Termination.CallMatrix hiding (toList)+import Agda.Termination.Order     as Order+import qualified Agda.Termination.SparseMatrix as Matrix+import Agda.Termination.Termination (Terminates(..), GuardednessHelps(..), endos, idempotent)+import qualified Agda.Termination.Termination  as Term+import Agda.Termination.RecCheck++import Agda.TypeChecking.Datatypes+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+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import qualified Agda.Benchmarking as Benchmark+import Agda.TypeChecking.Monad.Benchmark (billTo, billPureTo)++import Agda.Interaction.Options++import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M)+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.Singleton+import Agda.Utils.Size+import qualified Agda.Utils.SmallSet as SmallSet+import qualified Agda.Utils.VarSet as VarSet++import Agda.Utils.Impossible++-- | Call graph with call info for composed calls.++type Calls = CallGraph CallPath++-- | The result of termination checking a module.+--   Must be a 'Monoid' and have 'Singleton'.++type Result = [TerminationError]++-- | Entry point: Termination check a single declaration.+--+--   Precondition: 'envMutualBlock' must be set correctly.++termDecl :: A.Declaration -> TCM Result+termDecl d = inTopContext $ termDecl' d+++-- | Termination check a single declaration+--   (without necessarily ignoring @abstract@).++termDecl' :: A.Declaration -> TCM Result+termDecl' = \case+    A.Axiom {}            -> return mempty+    A.Field {}            -> return mempty+    A.Primitive {}        -> return mempty+    A.Mutual i ds         -> termMutual $ getNames 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+    A.Import {}           -> return mempty+    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 _ 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 cs)   = [x]+    getName (A.RecDef _ x _ _ _ _ ds)   = x : getNames ds+    getName (A.Mutual _ 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+    getName _                           = []+++-- | Entry point: Termination check the current mutual block.++termMutual+  :: [QName]+     -- ^ The function names defined in this block on top-level.+     --   (For error-reporting only.)+  -> TCM Result+termMutual names0 = ifNotM (optTerminationCheck <$> pragmaOptions) (return mempty) $ {-else-}+ inTopContext $ do++  -- Get set of mutually defined names from the TCM.+  -- This includes local and auxiliary functions introduced+  -- during type-checking.+  mid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envMutualBlock+  mutualBlock <- lookupMutualBlock mid+  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.+  setCurrentRange i $ do++  -- The following debug statement is part of a test case for Issue+  -- #3590.+  reportSLn "term.mutual.id" 40 $+    "Termination checking mutual block " ++ prettyShow mid+  reportSLn "term.mutual" 10 $ "Termination checking " ++ prettyShow allNames++  -- NO_TERMINATION_CHECK+  if (Info.mutualTerminationCheck i `elem` [ NoTerminationCheck, Terminating ]) then do+      reportSLn "term.warn.yes" 10 $ "Skipping termination check for " ++ prettyShow names+      forM_ allNames $ \ q -> setTerminates q True -- considered terminating!+      return mempty+  -- NON_TERMINATING+  else if (Info.mutualTerminationCheck i == NonTerminating) then do+      reportSLn "term.warn.yes" 10 $ "Considering as non-terminating: " ++ prettyShow names+      forM_ allNames $ \ q -> setTerminates q False+      return mempty+  else do+    sccs <- do+      -- Andreas, 2016-10-01 issue #2231+      -- Recursivity checker has to see through abstract definitions!+      ignoreAbstractMode $ do+        billTo [Benchmark.Termination, Benchmark.RecCheck] $ recursive allNames+      -- -- Andreas, 2017-03-24, use positivity info to skip non-recursive functions+      -- skip = ignoreAbstractMode $ forallM allNames $ \ x -> do+      --   null <$> getMutual x+      -- PROBLEMS with test/Succeed/AbstractCoinduction.agda++    -- Trivially terminating (non-recursive)?+    when (null sccs) $+      reportSLn "term.warn.yes" 10 $ "Trivially terminating: " ++ prettyShow names++    -- Actual termination checking needed: go through SCCs.+    concat <$> do+     forM sccs $ \ allNames -> do++     -- Set the mutual names in the termination environment.+     let namesSCC = Set.filter (`Set.member` allNames) names+     let setNames e = e+           { terMutual    = allNames+           , terUserNames = namesSCC+           }+         runTerm cont = runTerDefault $ do+           cutoff <- terGetCutOff+           reportSLn "term.top" 10 $ "Termination checking " ++ prettyShow namesSCC +++             " with cutoff=" ++ show cutoff ++ "..."+           terLocal setNames cont++     -- 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 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')++-- | 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.+--+--   @allNames@ is taken from 'Internal' syntax, it contains also+--   the definitions created by the type checker (e.g., with-functions).++termMutual' :: TerM Result+termMutual' = do++  -- collect all recursive calls in the block+  allNames <- terGetMutual+  let collect :: TerM Calls+      collect = forM' allNames termDef++  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++    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 :: Set QName -> CallPath -> GuardednessHelps -> TerminationError+terminationError names calls guardednessHelps = TerminationError names' calls' guardednessHelps+  where+  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++-- | @reportCalls@ for debug printing.+--+--   Replays the call graph completion for debugging.++reportCalls :: String -> Calls -> TerM ()+reportCalls no calls = do+  cutoff <- terGetCutOff+  let ?cutoff = cutoff++  -- We work in TCM exclusively.+  liftTCM $ do++    reportS "term.lex" 20+      [ "Calls (" ++ no ++ "dot patterns): " ++ prettyShow calls+      ]++    -- Print the whole completion phase.+    verboseS "term.matrices" 40 $ do+      let header s = unlines+            [ replicate n '='+            , replicate k '=' ++ s ++ replicate k' '='+            , replicate n '='+            ]+            where n  = 70+                  r  = n - length s+                  k  = r `div` 2+                  k' = r - k+      let report s cs = reportSDoc "term.matrices" 40 $ vcat+            [ text   $ header s+            , nest 2 $ pretty cs+            ]+          cs0     = calls+          step cs = do+            let (new, cs') = completionStep cs0 cs+            report " New call matrices " new+            return $ if null new then Left () else Right cs'+      report " Initial call matrices " cs0+      trampolineM step cs0++    -- Print the result of completion.+    let calls' = CallGraph.complete calls+        idems = filter idempotent $ endos $ CallGraph.toList calls'+    -- TODO+    -- reportSDoc "term.behaviours" 20 $ vcat+    --   [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):"+    --   , nest 2 $ return $ Term.prettyBehaviour calls'+    --   ]+    reportSDoc "term.matrices" 30 $ vcat+      [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n"+      , nest 2 $ vcat $ punctuate "\n" $ map pretty idems+      ]+    -- reportSDoc "term.matrices" 30 $ vcat+    --   [ text $ "Other call matrices (" ++ no ++ "dot patterns):"+    --   , nest 2 $ pretty $ CallGraph.fromList others+    --   ]+    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 = 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__ $ 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 <- 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++    -- Collect the recursive calls in the block which (transitively)+    -- involve @name@,+    -- taking the target of @name@ into account for computing guardedness.++    let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do+          if null todo then return $ Left calls else do+            -- Extract calls originating from indices in @todo@.+            new <- forM' todo $ \ 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+            -- Compute the new todo list:+                todo' = CallGraph.targetNodes new Set.\\ done'+            -- Jump the trampoline.+            return $ Right (todo', done', calls')++    r <- withOrWithoutDotPatterns (== index) collect++    names <- terGetUserNames+    case r of++      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 :: 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)+typeEndsInDef t = liftTCM $ do+  TelV _ core <- telViewPath t+  case unEl core of+    Def d vs -> return $ Just d+    _        -> return Nothing++-- | Termination check a definition by pattern matching.+--+--   TODO: Refactor!+--   As this function may be called twice,+--   once disregarding dot patterns,+--   the second time regarding dot patterns,+--   it is better if we separated bare call extraction+--   from computing the change in structural order.+--   Only the latter depends on the choice whether we+--   consider dot patterns or not.+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++  liftTCM $ reportSDoc "term.def.fun" 5 $+    sep [ "termination checking type of" <+> prettyTCM name+        , nest 2 $ ":" <+> prettyTCM t+        ]++  termType t `mappend` do++  liftTCM $ reportSDoc "term.def.fun" 5 $+    sep [ "termination checking body of" <+> prettyTCM name+        , nest 2 $ ":" <+> prettyTCM t+        ]++  -- If --without-K, we disregard all arguments (and result)+  -- which are not of data or record type.++  withoutKEnabled <- liftTCM withoutKOption+  applyWhen withoutKEnabled (setMasks t) $ do++    -- If the result should be disregarded, set all calls to unguarded.+    applyWhenM terGetMaskResult terUnguarded $ do++      case theDef def of+        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++-- | 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.+--   @@+--      f = A1+--      f x1 = A2+--      f x1 x2 = A3+--      ...+--      f x1 ... xn = B+--   @@++termType :: Type -> TerM Calls+termType = return mempty+-- termType = loop 0  -- Andreas, 2019-04-10 deactivate for backwards-compatibility in 2.6.0 #1556+  where+  loop n t = do+    ps <- mkPats n+    reportSDoc "term.type" 60 $ vcat+      [ text $ "termType " ++ show n ++ " with " ++ show (length ps) ++ " patterns"+      , nest 2 $ "looking at type " <+> prettyTCM t+      ]+    tel <- getContextTelescope  -- Andreas, 2018-11-15, issue #3394, forgotten initialization of terSizeDepth+    terSetPatterns ps $ terSetSizeDepth tel $ do+      ifNotPiType t {-then-} extract {-else-} $ \ dom absB -> do+        extract dom `mappend` underAbstractionAbs dom absB (loop $! n + 1)++  -- create n variable patterns+  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.+--   Only arguments of types ending in data/record or Size are counted in.+setMasks :: Type -> TerM a -> TerM a+setMasks t cont = do+  (ds, d) <- liftTCM $ do+    TelV tel core <- telViewPath t+    -- Check argument types+    ds <- checkArgumentTypes tel+    -- Check result types+    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 :: [QName] -> TerM Bool+targetElem ds = terGetTarget <&> \case+  TargetDef d  -> d `elem` ds+  TargetRecord -> False+  TargetOther  -> False+++-- | Convert a term (from a dot pattern) to a DeBruijn pattern.+--+--   The term is first normalized and stripped of all non-coinductive projections.++termToDBP :: Term -> TerM DeBruijnPattern+termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do+  termToPattern =<< do liftTCM $ stripAllProjections =<< normalise t++-- | Convert a term (from a dot pattern) to a pattern for the purposes of the termination checker.+--+--   @SIZESUC@ is treated as a constructor.++class TermToPattern a b where+  termToPattern :: a -> TerM b++  default termToPattern :: (TermToPattern a' b', Traversable f, a ~ f a', b ~ f b') => a -> TerM b+  termToPattern = traverse termToPattern++instance TermToPattern a b => TermToPattern [a] [b] where+instance TermToPattern a b => TermToPattern (Arg a) (Arg b) where+instance TermToPattern a b => TermToPattern (Named c a) (Named c b) where++-- OVERLAPPING+-- instance TermToPattern a b => TermToPattern a (Named c b) where+--   termToPattern t = unnamed <$> termToPattern t++instance TermToPattern Term DeBruijnPattern where+  termToPattern t = liftTCM (constructorForm t) >>= \case+    -- Constructors.+    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 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           -> 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.+maskNonDataArgs :: [DeBruijnPattern] -> TerM [Masked DeBruijnPattern]+maskNonDataArgs ps = zipWith mask ps <$> terGetMaskArgs+  where+    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+termClause clause = do+  Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body } <- etaExpandClause clause+  liftTCM $ reportSDoc "term.check.clause" 25 $ vcat+    [ "termClause"+    , nest 2 $ "tel =" <+> prettyTCM tel+    , nest 2 $ "ps  =" <+> do addContext tel $ prettyTCMPatternList ps+    ]+  forM' body $ \ v -> addContext tel $ do+    -- TODO: combine the following two traversals, avoid full normalisation.+    -- Parse dot patterns as patterns as far as possible.+    ps <- postTraversePatternM parseDotP ps+    -- Blank out coconstructors.+    ps <- preTraversePatternM stripCoCon ps+    -- Mask non-data arguments.+    mdbpats <- maskNonDataArgs $ map namedArg ps+    terSetPatterns mdbpats $ do+      terSetSizeDepth tel $ do+        reportBody v+        extract v++  where+    parseDotP = \case+      DotP o t -> termToDBP t+      p        -> 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+      pats    <- terGetPatterns+      liftTCM $ reportSDoc "term.check.clause" 6 $ do+        sep [ text ("termination checking clause of")+                <+> prettyTCM f+            , nest 2 $ "lhs:" <+> sep (map prettyTCM pats)+            , nest 2 $ "rhs:" <+> prettyTCM v+            ]+++-- | Extract recursive calls from expressions.+class ExtractCalls a where+  extract :: a -> TerM Calls++instance ExtractCalls a => ExtractCalls (Abs a) where+  extract (NoAbs _ a) = extract a+  extract (Abs x a)   = addContext x $ terRaise $ extract a++instance ExtractCalls a => ExtractCalls (Arg a) where+  extract = extract . unArg++instance ExtractCalls a => ExtractCalls (Dom a) where+  extract = extract . unDom++instance ExtractCalls a => ExtractCalls (Elim' a) where+  extract Proj{}    = return empty+  extract (Apply a) = extract $ unArg a+  extract (IApply x y a) = extract (x,(y,a)) -- TODO Andrea: conservative++instance ExtractCalls a => ExtractCalls [a] where+  extract = mapM' extract++instance (ExtractCalls a, ExtractCalls b) => ExtractCalls (a,b) where+  extract (a, b) = CallGraph.union <$> extract a <*> extract b++instance (ExtractCalls a, ExtractCalls b, ExtractCalls c) => ExtractCalls (a,b,c) where+  extract (a, b, c) = extract (a, (b, c))++-- | Sorts can contain arbitrary terms of type @Level@,+--   so look for recursive calls also in sorts.+--   Ideally, 'Sort' would not be its own datatype but just+--   a subgrammar of 'Term', then we would not need this boilerplate.++instance ExtractCalls Sort where+  extract s = do+    liftTCM $ do+      reportSDoc "term.sort" 20 $+        "extracting calls from sort" <+> prettyTCM s+      reportSDoc "term.sort" 50 $+        text ("s = " ++ show s)+    case s of+      Inf _ _    -> return empty+      SizeUniv   -> return empty+      LockUniv   -> return empty+      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+      MetaS x es -> return empty+      DefS d es  -> return empty+      DummyS{}   -> return empty++-- | Extract recursive calls from a type.++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+  :: QName+    -- ^ Constructor name.+  -> Induction+    -- ^ Should the constructor be treated as inductive or coinductive?+  -> [(Arg Term, Bool)]+    -- ^ All the arguments,+    --   and for every argument a boolean which is 'True' iff the+    --   argument should be viewed as preserving guardedness.+  -> TerM Calls+constructor c ind args = do+  cutoff <- terGetCutOff+  let ?cutoff = cutoff+  forM' args $ \ (arg, preserves) -> do+    let g' = case (preserves, ind) of+             (True,  Inductive)   -> id+             (True,  CoInductive) -> (Order.lt .*.)+             (False, _)           -> const Order.unknown+    terModifyGuarded g' $ extract arg++-- | Handles function applications @g es@.++function :: QName -> Elims -> TerM Calls+function g es0 = do++    f       <- terGetCurrent+    names   <- terGetMutual+    guarded <- terGetGuarded++    -- let gArgs = Def g es0+    liftTCM $ reportSDoc "term.function" 30 $+      "termination checking function call " <+> prettyTCM (Def g es0)++    -- First, look for calls in the arguments of the call gArgs.++    -- If the function is a projection but not for a coinductive record,+    -- then preserve guardedness for its principal argument.+    isProj <- isProjectionButNotCoinductive g+    let unguards = repeat Order.unknown+    let guards = applyWhen isProj (guarded :) unguards+    -- Collect calls in the arguments of this call.+    let args = map unArg $ argsFromElims es0+    calls <- forM' (zip guards args) $ \ (guard, a) -> do+      terSetGuarded guard $ extract a++    -- Then, consider call gArgs itself.++    liftTCM $ reportSDoc "term.found.call" 20 $+      sep [ "found call from" <+> prettyTCM f+          , nest 2 $ "to" <+> prettyTCM g+          ]++    -- insert this call into the call list+    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/record+       Just gInd -> do+         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.+         -- Andreas, 2017-06-20 issue #2613:+         -- We still need to reduce constructors, even when with-inlining happened.+         es <- -- ifM terGetHaveInlinedWith (return es0) {-else-} $+           liftTCM $ forM es0 $+             -- 2017-09-09, re issue #2732+             -- The eta-contraction that was here does not seem necessary to make structural order+             -- comparison not having to worry about eta.+             -- Maybe we thought an eta redex could come from a meta instantiation.+             -- However, eta-contraction is already performed by instantiateFull.+             -- See test/Succeed/Issue2732-termination.agda.+             traverse reduceCon <=< instantiateFull++           -- 2017-05-16, issue #2403: Argument normalization is too expensive,+           -- even if we only expand non-recursive functions.+           -- Argument normalization TURNED OFF.+           -- liftTCM $ billTo [Benchmark.Termination, Benchmark.Reduce] $ do+           --  -- Andreas, 2017-01-13, issue #2403, normalize arguments for the structural ordering.+           --  -- Andreas, 2017-03-25, issue #2495, restrict this to non-recursive functions+           --  -- otherwise, the termination checking may run forever.+           --  reportSLn "term.reduce" 90 $ "normalizing call arguments"+           --  modifyAllowedReductions (List.\\ [UnconfirmedReductions,RecursiveReductions]) $+           --    forM es0 $ \ e -> do+           --      reportSDoc "term.reduce" 95 $ "normalizing " <+> prettyTCM e+           --      etaContract =<< normalise e++         -- Compute the call matrix.++         -- Andreas, 2014-03-26 only 6% of termination time for library test+         -- spent on call matrix generation+         (nrows, ncols, matrix) <- billTo [Benchmark.Termination, Benchmark.Compare] $+           compareArgs es++         -- 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 guarded'+         let matrix' = composeGuardedness guarded' matrix++         -- Andreas, 2013-04-26 FORBIDDINGLY expensive!+         -- This PrettyTCM QName cost 50% of the termination time for std-lib!!+         -- gPretty <-liftTCM $ billTo [Benchmark.Termination, Benchmark.Level] $+         --   render <$> prettyTCM g++         -- Andreas, 2013-05-19 as pointed out by Andrea Vezzosi,+         -- printing the call eagerly is forbiddingly expensive.+         -- So we build a closure such that we can print the call+         -- whenever we really need to.+         -- This saves 30s (12%) on the std-lib!+         -- Andreas, 2015-01-21 Issue 1410: Go to the module where g is defined+         -- otherwise its free variables with be prepended to the call+         -- in the error message.+         doc <- liftTCM $ withCurrentModule (qnameModule g) $ buildClosure $+           Def g $ List.dropWhileEnd ((Inserted ==) . getOrigin) es0+           -- Andreas, 2018-07-22, issue #3136+           -- Dropping only inserted arguments at the end, since+           -- dropping arguments in the middle might make the printer crash.+           -- Def g $ filter ((/= Inserted) . getOrigin) es0+           -- Andreas, 2017-01-05, issue #2376+           -- Remove arguments inserted by etaExpandClause.++         let src  = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex f names+             tgt  = gInd+             cm   = makeCM ncols nrows matrix'+             info = CallPath $ singleton $+                    CallInfo+                      { callInfoTarget = g+                      , callInfoCall   = doc+                      }+         verboseS "term.kept.call" 5 $ do+           pats <- terGetPatterns+           reportSDoc "term.kept.call" 5 $ vcat+             [ "kept call from" <+> text (prettyShow f) <+> hsep (map prettyTCM pats)+             , nest 2 $ "to" <+> text (prettyShow g) <+>+                         hsep (map (parens . prettyTCM) args)+             , nest 2 $ "call matrix (with guardedness): "+             , nest 2 $ pretty cm+             ]+         return $ CallGraph.insert src tgt cm info calls++  where+    -- We have to reduce constructors in case they're reexported.+    -- Andreas, Issue 1530: constructors have to be reduced deep inside terms,+    -- thus, we need to use traverseTermM.+    reduceCon :: Term -> TCM Term+    reduceCon = traverseTermM $ \case+      Con c ci vs -> (`applyE` vs) <$> reduce (Con c ci [])  -- make sure we don't reduce the arguments+      t -> return t+++-- | Try to get rid of a function call targeting the current SCC+--   using a non-recursive clause.+--+--   This can help copattern definitions of dependent records.+tryReduceNonRecursiveClause+  :: QName                 -- ^ Function+  -> Elims                 -- ^ Arguments+  -> (Term -> TerM Calls)  -- ^ Continue here if we managed to reduce.+  -> TerM Calls            -- ^ Otherwise, continue here.+  -> TerM Calls+tryReduceNonRecursiveClause g es continue fallback = do+  -- Andreas, 2020-02-06, re: issue #906+  let v0 = Def g es+  reportSDoc "term.reduce" 40 $ "Trying to reduce away call: " <+> prettyTCM v0++  -- First, make sure the function is in the current SCC.+  ifM (notElem g <$> terGetMutual) fallback {-else-} $ do+  reportSLn "term.reduce" 40 $ "This call is in the current SCC!"++  -- 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) $+    localTC (\e -> e { envTermCheckReducing = True }) $+    runReduceM $ appDefE' g v0 cls [] (map notReduced es)+  case r of+    NoReduction{}    -> fallback+    YesReduction _ v -> do+      reportSDoc "term.reduce" 30 $ vcat+        [ "Termination checker: Successfully reduced away call:"+        , nest 2 $ prettyTCM v0+        ]+      verboseS "term.reduce" 5 $ tick "termination-checker-reduced-nonrecursive-call"+      continue v++-- | Extract recursive calls from a term.++instance ExtractCalls Term where+  extract t = do+    reportSDoc "term.check.term" 50 $ do+      "looking for calls in" <+> prettyTCM t++    -- Instantiate top-level MetaVar.+    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.+        -- 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    -- 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+          -- 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+            -- 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++      -- Function, data, or record type.+      Def g es -> tryReduceNonRecursiveClause g es extract $ function g es++      -- Abstraction. Preserves guardedness.+      Lam h b -> extract b++      -- Neutral term. Destroys guardedness.+      Var i es -> terUnguarded $ extract es++      -- Dependent function space.+      Pi a (Abs x b) ->+        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.+      Pi a (NoAbs _ b) ->+        CallGraph.union <$> extract a <*> extract b++      -- Literal.+      Lit l -> return empty++      -- Sort.+      Sort s -> extract s++      -- Unsolved metas are not considered termination problems, there+      -- will be a warning for them anyway.+      MetaV x args -> return empty++      -- Erased and not-yet-erased proof.+      DontCare t -> extract t++      -- Level.+      Level l -> -- billTo [Benchmark.Termination, Benchmark.Level] $ do+        -- Andreas, 2014-03-26 Benchmark discontinued, < 0.3% spent on levels.+        extract l++      -- Dummy.+      Dummy{} -> return empty++-- | Extract recursive calls from level expressions.++instance ExtractCalls Level where+  extract (Max n as) = extract as++instance ExtractCalls PlusLevel where+  extract (Plus n l) = extract l++-- | Rewrite type @tel -> Size< u@ to @tel -> Size@.+maskSizeLt :: MonadTCM tcm => Dom Type -> tcm (Dom Type)+maskSizeLt !dom = liftTCM $ do+  let a = unDom dom+  (msize, msizelt) <- getBuiltinSize+  case (msize, msizelt) of+    (_ , Nothing) -> return dom+    (Nothing, _)  -> __IMPOSSIBLE__+    (Just size, Just sizelt) -> do+      TelV tel c <- telView a+      case a of+        El s (Def d [v]) | d == sizelt -> return $+          abstract tel (El s $ Def size []) <$ dom+        _ -> return dom++{- | @compareArgs es@++     Compare the list of de Bruijn patterns (=parameters) @pats@+     with a list of arguments @es@ and create a call maxtrix+     with |es| rows and |pats| columns.++     The guardedness is the number of projection patterns in @pats@+     minus the number of projections in @es@.+ -}+compareArgs :: [Elim] -> TerM (Int, Int, [[Order]])+compareArgs es = do+  pats <- terGetPatterns+  liftTCM $ reportSDoc "term.compareArgs" 90 $ vcat+    [ text $ "comparing " ++ show (length es) ++ " args to " ++ show (length pats) ++ " patterns"+    ]+  -- apats <- annotatePatsWithUseSizeLt pats+  -- reportSDoc "term.compare" 20 $+  --   "annotated patterns = " <+> sep (map prettyTCM apats)+  -- matrix <- forM es $ \ e -> forM apats $ \ (b, p) -> terSetUseSizeLt b $ compareElim e p+  matrix <- withUsableVars pats $ forM es $ \ e -> forM pats $ \ p -> compareElim e p++  -- Count the number of coinductive projection(pattern)s in caller and callee.+  -- Only recursive coinductive projections are eligible (Issue 1209).+  projsCaller <- length <$> do+    filterM (isCoinductiveProjection True) $ mapMaybe (fmap (headAmbQ . snd) . isProjP . getMasked) pats+  projsCallee <- length <$> do+    filterM (isCoinductiveProjection True) $ mapMaybe (fmap snd . isProjElim) es+  cutoff <- terGetCutOff+  let ?cutoff = cutoff+  let guardedness = decr True $ projsCaller - projsCallee+  liftTCM $ reportSDoc "term.guardedness" 30 $ sep+    [ "compareArgs:"+    , nest 2 $ text $ "projsCaller = " ++ prettyShow projsCaller+    , nest 2 $ text $ "projsCallee = " ++ prettyShow projsCallee+    , nest 2 $ text $ "guardedness of call: " ++ prettyShow guardedness+    ]+  return $ addGuardedness guardedness (size es, size pats, matrix)++-- | Traverse patterns from left to right.+--   When we come to a projection pattern,+--   switch usage of SIZELT constraints:+--   on, if coinductive,+--   off, if inductive.+--+--   UNUSED+--annotatePatsWithUseSizeLt :: [DeBruijnPattern] -> TerM [(Bool,DeBruijnPattern)]+--annotatePatsWithUseSizeLt = loop where+--  loop [] = return []+--  loop (p@(ProjP _ q) : pats) = ((False,p) :) <$> do projUseSizeLt q $ loop pats+--  loop (p : pats) = (\ b ps -> (b,p) : ps) <$> terGetUseSizeLt <*> loop pats+++-- | @compareElim e dbpat@++compareElim :: Elim -> Masked DeBruijnPattern -> TerM Order+compareElim e p = do+  liftTCM $ do+    reportSDoc "term.compare" 30 $ sep+      [ "compareElim"+      , nest 2 $ "e = " <> prettyTCM e+      , nest 2 $ "p = " <> prettyTCM p+      ]+    reportSDoc "term.compare" 50 $ sep+      [ nest 2 $ text $ "e = " ++ show e+      , nest 2 $ text $ "p = " ++ show p+      ]+  case (e, getMasked p) of+    (Proj _ d, ProjP _ d') -> do+      d  <- getOriginalProjection d+      d' <- getOriginalProjection d'+      o  <- compareProj d d'+      reportSDoc "term.compare" 30 $ sep+        [ text $ "comparing callee projection " ++ prettyShow d+        , text $ "against caller projection " ++ prettyShow d'+        , text $ "yields order " ++ prettyShow o+        ]+      return o+    (Proj{}, _)            -> return Order.unknown+    (Apply{}, ProjP{})     -> return Order.unknown+    (Apply arg, _)         -> compareTerm (unArg arg) p+    -- TODO Andrea: making sense?+    (IApply{}, ProjP{})  -> return Order.unknown+    (IApply _ _ arg, _)    -> compareTerm arg p++-- | In dependent records, the types of later fields may depend on the+--   values of earlier fields.  Thus when defining an inhabitant of a+--   dependent record type such as Σ by copattern matching,+--   a recursive call eliminated by an earlier projection (proj₁) might+--   occur in the definition at a later projection (proj₂).+--   Thus, earlier projections are considered "smaller" when+--   comparing copattern spines.  This is an ok approximation+--   of the actual dependency order.+--   See issues 906, 942.+compareProj :: MonadTCM tcm => QName -> QName -> tcm Order+compareProj d d'+  | d == d' = return Order.le+  | otherwise = liftTCM $ do+      -- different projections+      mr  <- getRecordOfField d+      mr' <- getRecordOfField d'+      case (mr, mr') of+        (Just r, Just r') | r == r' -> do+          -- of same record+          def <- theDef <$> getConstInfo r+          case def of+            Record{ recFields = fs } -> do+              fs <- return $ map unDom fs+              case (List.find (d ==) fs, List.find (d' ==) fs) of+                (Just i, Just i')+                  -- earlier field is smaller+                  | i < i'    -> return Order.lt+                  | i == i'   -> do+                     __IMPOSSIBLE__+                  | otherwise -> return Order.unknown+                _ -> __IMPOSSIBLE__+            _ -> __IMPOSSIBLE__+        _ -> return Order.unknown++-- | 'makeCM' turns the result of 'compareArgs' into a proper call matrix+makeCM :: Int -> Int -> [[Order]] -> CallMatrix+makeCM ncols nrows matrix = CallMatrix $+  Matrix.fromLists (Matrix.Size nrows ncols) matrix++-- | 'addGuardedness' adds guardedness flag in the upper left corner+-- (0,0).+addGuardedness :: Order -> (Int, Int, [[Order]]) -> (Int, Int, [[Order]])+addGuardedness o (nrows, ncols, m) =+  (nrows + 1, ncols + 1,+   (o : replicate ncols Order.unknown) : map (Order.unknown :) m)++-- | Compose something with the upper-left corner of a call matrix+composeGuardedness :: (?cutoff :: CutOff) => Order -> [[Order]] -> [[Order]]+composeGuardedness o ((corner : row) : rows) = ((o .*. corner) : row) : rows+composeGuardedness _ _ = __IMPOSSIBLE__++-- | Stripping off a record constructor is not counted as decrease, in+--   contrast to a data constructor.+--   A record constructor increases/decreases by 0, a data constructor by 1.+offsetFromConstructor :: HasConstInfo tcm => QName -> tcm Int+offsetFromConstructor c =+  ifM (isEtaOrCoinductiveRecordConstructor c) (return 0) (return 1)++--UNUSED Liang-Ting 2019-07-16+---- | Compute the proper subpatterns of a 'DeBruijnPattern'.+--subPatterns :: DeBruijnPattern -> [DeBruijnPattern]+--subPatterns = foldPattern $ \case+--  ConP _ _ ps -> map namedArg ps+--  DefP _ _ ps -> map namedArg ps -- TODO check semantics+--  VarP _ _    -> mempty+--  LitP _      -> mempty+--  DotP _ _    -> mempty+--  ProjP _ _   -> mempty+--  IApplyP{}   -> mempty+++compareTerm :: Term -> Masked DeBruijnPattern -> TerM Order+compareTerm t p = do+--   reportSDoc "term.compare" 25 $+--     " comparing term " <+> prettyTCM t <+>+--     " to pattern " <+> prettyTCM p+  t <- liftTCM $ stripAllProjections t+  o <- compareTerm' t p+  liftTCM $ reportSDoc "term.compare" 25 $+    " comparing term " <+> prettyTCM t <+>+    " to pattern " <+> prettyTCM p <+>+    text (" results in " ++ prettyShow o)+  return o+++-- | Remove all non-coinductive projections from an algebraic term+--   (not going under binders).+--   Also, remove 'DontCare's.+--+class StripAllProjections a where+  stripAllProjections :: a -> TCM a++instance StripAllProjections a => StripAllProjections (Arg a) where+  stripAllProjections = traverse stripAllProjections++instance StripAllProjections Elims where+  stripAllProjections es =+    case es of+      []             -> return []+      (Apply a : es) -> do+        (:) <$> (Apply <$> stripAllProjections a) <*> stripAllProjections es+      (IApply x y a : es) -> do+        -- TODO Andrea: are we doind extra work?+        (:) <$> (IApply <$> stripAllProjections x+                        <*> stripAllProjections y+                        <*> stripAllProjections a)+            <*> stripAllProjections es+      (Proj o p  : es) -> do+        isP <- isProjectionButNotCoinductive p+        applyUnless isP (Proj o p :) <$> stripAllProjections es++instance StripAllProjections Args where+  stripAllProjections = mapM stripAllProjections++instance StripAllProjections Term where+  stripAllProjections t = do+    case t of+      Var i es   -> Var i <$> stripAllProjections es+      Con c ci ts -> do+        -- Andreas, 2019-02-23, re #2613.  This is apparently not necessary:+        -- c <- fromRightM (\ err -> return c) $ getConForm (conName c)+        Con c ci <$> stripAllProjections ts+      Def d es   -> Def d <$> stripAllProjections es+      DontCare t -> stripAllProjections t+      _ -> return t++-- | Normalize outermost constructor name in a pattern.++reduceConPattern :: DeBruijnPattern -> TCM DeBruijnPattern+reduceConPattern = \case+  ConP c i ps -> fromRightM (\ err -> return c) (getConForm (conName c)) <&> \ c' ->+    ConP c' i ps+  p -> return p++-- | @compareTerm' t dbpat@++compareTerm' :: Term -> Masked DeBruijnPattern -> TerM Order+compareTerm' v mp@(Masked m p) = do+  suc  <- terGetSizeSuc+  cutoff <- terGetCutOff+  let ?cutoff = cutoff+  v <- liftTCM (instantiate v)+  p <- liftTCM $ reduceConPattern p+  case (v, p) of++    -- Andreas, 2013-11-20 do not drop projections,+    -- in any case not coinductive ones!:+    (Var i es, _) | Just{} <- allApplyElims es ->+      compareVar i mp++    (DontCare t, _) ->+      compareTerm' t mp++    -- Andreas, 2014-09-22, issue 1281:+    -- For metas, termination checking should be optimistic.+    -- If there is any instance of the meta making termination+    -- checking succeed, then we should not fail.+    -- Thus, we assume the meta will be instantiated with the+    -- deepest variable in @p@.+    -- For sized types, the depth is maximally+    -- the number of SIZELT hypotheses one can have in a context.+    (MetaV{}, p) -> Order.decr True . max (if m then 0 else patternDepth p) . pred <$>+       terAsks _terSizeDepth++    -- Successor on both sides cancel each other.+    -- We ignore the mask for sizes.+    (Def s [Apply t], ConP s' _ [p]) | s == conName s' && Just s == suc ->+      compareTerm' (unArg t) (notMasked $ namedArg p)++    -- Register also size increase.+    (Def s [Apply t], p) | Just s == suc ->+      -- Andreas, 2012-10-19 do not cut off here+      increase 1 <$> compareTerm' (unArg t) mp++    -- In all cases that do not concern sizes,+    -- we cannot continue if pattern is masked.++    _ | m -> return Order.unknown++    (Lit l, LitP _ l')+      | l == l'     -> return Order.le+      | otherwise   -> return Order.unknown++    (Lit l, _) -> do+      v <- liftTCM $ constructorForm v+      case v of+        Lit{}       -> return Order.unknown+        v           -> compareTerm' v mp++    -- Andreas, 2011-04-19 give subterm priority over matrix order++    (Con{}, ConP c _ ps) | any (isSubTerm v . namedArg) ps ->+      decr True <$> offsetFromConstructor (conName c)++    (Con c _ es, ConP c' _ ps) | conName c == conName c'->+      let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es in+      compareConArgs ts ps++    (Con _ _ [], _) -> return Order.le++    -- new case for counting constructors / projections+    -- register also increase+    (Con c _ es, _) -> do+      let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+      increase <$> offsetFromConstructor (conName c)+               <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) mp) ts)++    (t, p) -> return $ subTerm t p++-- | @subTerm@ computes a size difference (Order)+subTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPattern -> Order+subTerm t p = if equal t p then Order.le else properSubTerm t p+  where+    equal (Con c _ es) (ConP c' _ ps) =+      let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es in+      and $ (conName c == conName c')+          : (length ts == length ps)+          : zipWith (\ t p -> equal (unArg t) (namedArg p)) ts ps+    equal (Var i []) (VarP _ x) = i == dbPatVarIndex x+    equal (Lit l)    (LitP _ l') = l == l'+    -- Terms.+    -- Checking for identity here is very fragile.+    -- However, we cannot do much more, as we are not allowed to normalize t.+    -- (It might diverge, and we are just in the process of termination checking.)+    equal t         (DotP _ t') = t == t'+    equal _ _ = False++    properSubTerm t (ConP _ _ ps) =+      setUsability True $ decrease 1 $ supremum $ map (subTerm t . namedArg) ps+    properSubTerm _ _ = Order.unknown++isSubTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPattern -> Bool+isSubTerm t p = nonIncreasing $ subTerm t p++compareConArgs :: Args -> [NamedArg DeBruijnPattern] -> TerM Order+compareConArgs ts ps = do+  cutoff <- terGetCutOff+  let ?cutoff = cutoff+  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)+{- version which does an "order matrix"+   -- Andreas, 2013-02-18 disabled because it is unclear+   -- how to scale idempotency test to matrix-shaped orders (need thinking/researcH)+   -- Trigges issue 787.+        (_,_) -> do -- build "call matrix"+          m <- mapM (\t -> mapM (compareTerm' suc (unArg t)) ps) ts+          let m2 = makeCM (length ps) (length ts) m+          return $ Order.orderMat (Order.mat m2)+-}+{- version which takes height+--    if null ts then Order.Le+--               else Order.infimum (zipWith compareTerm' (map unArg ts) ps)+-}++compareVar :: Nat -> Masked DeBruijnPattern -> TerM Order+compareVar i (Masked m p) = do+  suc    <- terGetSizeSuc+  cutoff <- terGetCutOff+  let ?cutoff = cutoff+  let no = return Order.unknown+  case p of+    ProjP{}   -> no+    IApplyP _ _ _ x  -> compareVarVar i (Masked m x)+    LitP{}    -> no+    DotP{}   -> no+    VarP _ x  -> compareVarVar i (Masked m x)++    ConP s _ [p] | Just (conName s) == suc ->+      setUsability True . decrease 1 <$> compareVar i (notMasked $ namedArg p)++    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+      decrease <$> offsetFromConstructor c+               <*> (Order.supremum <$> mapM (compareVar i . notMasked . namedArg) ps)+      -- This should be fine for c == hcomp++-- | Compare two variables.+--+--   The first variable comes from a term, the second from a pattern.+compareVarVar :: Nat -> Masked DBPatVar -> TerM Order+compareVarVar i (Masked m x@(DBPatVar _ j))+  | i == j = if not m then return Order.le else liftTCM $+      -- If j is a size, we ignore the mask.+      ifM (isJust <$> do isSizeType =<< reduce =<< typeOfBV j)+        {- then -} (return Order.le)+        {- else -} (return Order.unknown)+  | otherwise = do+      -- record usability of variable+      u <- (i `VarSet.member`) <$> terGetUsableVars+      -- Andreas, 2017-07-26, issue #2331.+      -- The usability logic is refuted by bounded size quantification in terms.+      -- Thus, it is switched off (the infrastructure remains in place for now).+      if not u then return Order.unknown else do+      -- Only if usable:+      res <- isBounded i+      case res of+        BoundedNo  -> return Order.unknown+        BoundedLt v -> setUsability u . decrease 1 <$> compareTerm' v (Masked m $ varP x)
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,28 +30,30 @@ import Agda.Termination.Order import Agda.Termination.SparseMatrix -import Agda.Utils.Either-import Agda.Utils.List-import Agda.Utils.Maybe+import Agda.Utils.Boolean+import Agda.Utils.Null+import Agda.Utils.Three -import Data.Monoid+-- | 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) --- | TODO: This comment seems to be partly out of date.------ @'terminates' cs@ checks if the functions represented by @cs@+-- | 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.+++-- | @'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.@@ -51,28 +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 (headMaybe offending) (Right ()) $ Left . augCallInfo-  where-    -- Every idempotent call must have decrease, otherwise it offends us.-    offending = filter (not . hasDecrease) $ filter idempotent calls--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).@@ -82,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,72 +1,132 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Functions for abstracting terms over other terms.+ module Agda.TypeChecking.Abstract where -import Control.Applicative+import Prelude hiding ( null )+ import Control.Monad-import Control.Monad.State-import Data.Function-import Data.Traversable+import Control.Monad.Except +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) import Agda.TypeChecking.Substitute import Agda.TypeChecking.CheckInternal import Agda.TypeChecking.Conversion import Agda.TypeChecking.Constraints 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)-import Agda.Utils.Size-import Agda.Utils.Except-import qualified Agda.Utils.HashMap as HMap+import Agda.Utils.List ( splitExactlyAt, dropEnd )+import Agda.Utils.Null  import Agda.Utils.Impossible-#include "undefined.h" -typeOf :: Type -> Type-typeOf = sort . getSort+-- | @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 --- | @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+  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 v a b[v] = (w : a) -> b[w]@-piAbstractTerm :: Term -> Type -> Type -> TCM Type-piAbstractTerm v a b = do-  fun <- mkPi (defaultDom ("w", a)) <$> abstractType a v b+-- | @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 empty a v b   reportSDoc "tc.abstract" 50 $-    sep [ text "piAbstract" <+> sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM a ]-        , nest 2 $ text "from" <+> prettyTCM b-        , nest 2 $ text "-->" <+> prettyTCM fun ]+    sep [ "piAbstract" <+> sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ]+        , nest 2 $ "from" <+> prettyTCM b+        , nest 2 $ "-->" <+> prettyTCM fun ]+  reportSDoc "tc.abstract" 70 $+    sep [ "piAbstract" <+> sep [ (text . show) v <+> ":", nest 2 $ (text . show) a ]+        , nest 2 $ "from" <+> (text . show) b+        , nest 2 $ "-->" <+> (text . show) fun ]   return fun  -- | @piAbstract (v, a) b[v] = (w : a) -> b[w]@ -----   For @rewrite@, it does something special:+--   For the inspect idiom, it does something special:+--   @piAbstract (v, a) b[v] = (w : a) {w' : Eq a w v} -> b[w] --+--   For @rewrite@, it does something special: --   @piAbstract (prf, Eq a v v') b[v,prf] = (w : a) (w' : Eq a w v') -> b[w,w']@ -piAbstract :: (Term, EqualityView) -> Type -> TCM Type-piAbstract (v, OtherType a) b = piAbstractTerm v a b-piAbstract (prf, eqt@(EqualityType s _ _ a v _)) b = do-  let prfTy = equalityUnview eqt-      vTy   = El s (unArg a)-  b <- abstractType prfTy prf b-  b <- addContext ("w", defaultDom prfTy) $ abstractType (raise 1 vTy) (unArg $ raise 1 v) b-  return . funType vTy . funType eqTy' . swap01 $ b+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 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 3 $ telToList eqTel)+    let eq = Def eqName $ map Apply+                 $ map (setHiding Hidden) tel+                 -- we write `v ≡ w` because this equality is typically used to+                 -- get `v` to unfold to whatever pattern was used to refine `w`+                 -- 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`.+                 ++ [ 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+    return $ El sort eq++  pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a))+       $ mkPi (setHiding NotHidden        $ defaultDom ("eq", eq))+       $ b+piAbstract (Arg info (prf, EqualityViewType eqt@(EqualityTypeData r _ _ _ (Arg _ a) v _))) b = do+  s <- sortOf a+  let prfTy :: Type+      prfTy = equalityUnview eqt+      vTy   = El s a+  -- 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) $+         -- 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 a = mkPi $ defaultDom ("w", a)+    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@. class IsPrefixOf a where   isPrefixOf :: a -> a -> Maybe Elims@@ -74,79 +134,91 @@ instance IsPrefixOf Elims where   isPrefixOf us vs = do     (vs1, vs2) <- splitExactlyAt (length us) vs-    guard $ us == vs1+    guard $ equalSy us vs1     return vs2  instance IsPrefixOf Args where   isPrefixOf us vs = do     (vs1, vs2) <- splitExactlyAt (length us) vs-    guard $ us == vs1+    guard $ equalSy us vs1     return $ map Apply vs2  instance IsPrefixOf Term where   isPrefixOf u v =-    case (ignoreSharing u, ignoreSharing v) of+    case (u, v) of       (Var   i us, Var   j vs) | i == j  -> us `isPrefixOf` vs       (Def   f us, Def   g vs) | f == g  -> us `isPrefixOf` vs       (Con c _ us, Con d _ vs) | c == d  -> us `isPrefixOf` vs       (MetaV x us, MetaV y vs) | x == y  -> us `isPrefixOf` vs-      (u, v) -> guard (u == v) >> return []+      (u, v) -> guard (equalSy u v) >> return []  -- Type-based abstraction. Needed if u is a constructor application (#745). abstractTerm :: Type -> Term -> Type -> Term -> TCM Term abstractTerm a u@Con{} b v = do   reportSDoc "tc.abstract" 50 $-    sep [ text "Abstracting"-        , nest 2 $ sep [ prettyTCM u <+> text ":", nest 2 $ prettyTCM a ]-        , text "over"-        , nest 2 $ sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM b ] ]+    sep [ "Abstracting"+        , nest 2 $ sep [ prettyTCM u <+> ":", nest 2 $ prettyTCM a ]+        , "over"+        , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM b ] ]+  reportSDoc "tc.abstract" 70 $+    sep [ "Abstracting"+        , nest 2 $ sep [ (text . show) u <+> ":", nest 2 $ (text . show) a ]+        , "over"+        , nest 2 $ sep [ (text . show) v <+> ":", nest 2 $ (text . show) b ] ] -  hole <- qualify <$> currentModule <*> freshName_ "hole"-  noMutualBlock $ addConstant hole $ defaultDefn defaultArgInfo hole a Axiom+  hole <- qualify <$> currentModule <*> freshName_ ("hole" :: String)+  noMutualBlock $ addConstant' hole defaultArgInfo a defaultAxiom    args <- map Apply <$> getContextArgs   let n = length args    let abstr b v = do-        m <- size <$> getContext+        m <- getContextSize         let (a', u') = raise (m - n) (a, u)-        case isPrefixOf u' v of+        case u' `isPrefixOf` v of           Nothing -> return v           Just es -> do -- Check that the types match.-            s <- get-            do  disableDestructiveUpdate (noConstraints $ equalType a' b)-                put s+            s <- getTC+            do  noConstraints $ equalType a' b+                putTC s                 return $ Def hole (raise (m - n) args ++ es)               `catchError` \ _ -> do                 reportSDoc "tc.abstract.ill-typed" 50 $-                  sep [ text "Skipping ill-typed abstraction"-                      , nest 2 $ sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM b ] ]+                  sep [ "Skipping ill-typed abstraction"+                      , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM b ] ]                 return v -  v <- catchError_ (checkInternal' (defaultAction { preAction = abstr }) v b) $ \ err -> do-        reportSDoc "impossible" 10 $-          vcat [ text "Type error in term to abstract"-               , nest 2 $ (prettyTCM =<< getContextTelescope) <+> text "⊢"-               , nest 2 $ sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM b ]-               , nest 2 $ prettyTCM err ]-        __IMPOSSIBLE__-  reportSDoc "tc.abstract" 50 $ sep [ text "Resulting abstraction", nest 2 $ prettyTCM v ]+  -- #2763: This can fail if the user is with-abstracting incorrectly (for+  -- instance, abstracting over a first component of a sigma without also+  -- abstracting the second component). In this case we skip abstraction+  -- altogether and let the type check of the final with-function type produce+  -- the error message.+  res <- catchError_ (checkInternal' (defaultAction { preAction = abstr }) v CmpLeq b) $ \ err -> do+        reportSDoc "tc.abstract.ill-typed" 40 $+          "Skipping typed abstraction over ill-typed term" <?> (prettyTCM v <?> (":" <+> prettyTCM b))+        return v+  reportSDoc "tc.abstract" 50 $ "Resulting abstraction" <?> prettyTCM res   modifySignature $ updateDefinitions $ HMap.delete hole-  return $ absTerm (Def hole args) v+  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@@ -156,61 +228,155 @@       Sort s      -> Sort $ absT s       MetaV m vs  -> MetaV m $ absT vs       DontCare mv -> DontCare $ absT mv-      Shared p    -> Shared $ absT p+      Dummy s es   -> Dummy s $ absT es       where-        absT x = absTerm u x--instance AbsTerm a => AbsTerm (Ptr a) where-  absTerm u = fmap (absTerm u)+        absT :: AbsTerm b => b -> b+        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 s = case s of-    Type n     -> Type $ absS n-    Prop       -> Prop-    Inf        -> Inf+  absTerm j u = \case+    Univ u n   -> Univ u $ absS n+    s@Inf{}    -> s     SizeUniv   -> SizeUniv-    DLub s1 s2 -> DLub (absS s1) (absS s2)-    where absS x = absTerm u x+    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+    MetaS x es -> MetaS x $ absS es+    DefS d es  -> DefS d $ absS es+    s@DummyS{} -> s+    where+      absS :: AbsTerm b => b -> b+      absS x = absTerm j u x  instance AbsTerm Level where-  absTerm u (Max as) = Max $ absTerm u as+  absTerm j u (Max n as) = Max n $ absTerm j u as  instance AbsTerm PlusLevel where-  absTerm u l@ClosedLevel{} = l-  absTerm u (Plus n l) = Plus n $ absTerm u l--instance AbsTerm LevelAtom where-  absTerm u l = case l of-    MetaLevel m vs   -> MetaLevel m    $ absTerm u vs-    NeutralLevel r v -> NeutralLevel r $ absTerm u v-    BlockedLevel _ v -> UnreducedLevel $ absTerm u v -- abstracting might remove the blockage-    UnreducedLevel v -> UnreducedLevel $ absTerm u v+  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 (Subst Term 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+instance (TermSubst a, AbsTerm a) => AbsTerm (Abs a) where+  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 :: (Subst Term a) => a -> a+swap01 :: TermSubst a => a -> a swap01 = applySubst $ var 1 :# liftS 1 (raiseS 1)+++-- ** Equality of terms for the sake of with-abstraction.++-- The following could be parameterized by a record of flags+-- what parts of the syntax tree should be ignored.+-- For now, there is a fixed strategy.++class EqualSy a where+  equalSy :: a -> a -> Bool++instance EqualSy a => EqualSy [a] where+  equalSy us vs = and $ (length us == length vs) : zipWith equalSy us vs++instance EqualSy Term where+  equalSy = curry $ \case+    (Var i   vs, Var i'   vs') -> i == i' && equalSy vs vs'+    (Con c _ es, Con c' _ es') -> c == c' && equalSy es es'+    (Def   f es, Def   f' es') -> f == f' && equalSy es es'+    (MetaV x es, MetaV x' es') -> x == x' && equalSy es es'+    (Lit   l   , Lit   l'    ) -> l == l'+    (Lam   ai b, Lam   ai' b') -> equalSy ai ai' && equalSy b b'+    (Level l   , Level l'    ) -> equalSy l l'+    (Sort  s   , Sort  s'    ) -> equalSy s s'+    (Pi    a b , Pi    a' b' ) -> equalSy a a' && equalSy b b'+    (DontCare _, DontCare _  ) -> True+       -- Irrelevant things are syntactically equal.+    (Dummy{}   , _           ) -> __IMPOSSIBLE__+    (_         , Dummy{}     ) -> __IMPOSSIBLE__+    _ -> False++instance EqualSy Level where+  equalSy (Max n vs) (Max n' vs') = n == n' && equalSy vs vs'++instance EqualSy PlusLevel where+  equalSy (Plus n v) (Plus n' v') = n == n' && equalSy v v'++instance EqualSy Sort where+  equalSy = curry $ \case+    (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'+    (MetaS x es, MetaS x' es') -> x == x' && equalSy es es'+    (DefS  d es, DefS  d' es') -> d == d' && equalSy es es'+    (DummyS{}  , _           ) -> __IMPOSSIBLE__+    (_         , DummyS{}    ) -> __IMPOSSIBLE__+    _ -> False++-- | Ignores sorts.+instance EqualSy Type where+  equalSy = equalSy `on` unEl++instance EqualSy a => EqualSy (Elim' a) where+  equalSy = curry $ \case+    (Proj _ f, Proj _ f') -> f == f'+    (Apply a, Apply a') -> equalSy a a'+    (IApply u v r, IApply u' v' r') ->+           equalSy u u'+        && equalSy v v'+        && equalSy r r'+    _ -> False++-- | Ignores 'absName'.+instance (Subst a, EqualSy a) => EqualSy (Abs a) where+  equalSy = curry $ \case+    (NoAbs _x b, NoAbs _x' b') -> equalSy b b' -- no need to raise if both are NoAbs+    (a         , a'          ) -> equalSy (absBody a) (absBody a')++-- | Ignore origin and free variables.+instance EqualSy ArgInfo where+  equalSy (ArgInfo h m _o _fv a) (ArgInfo h' m' _o' _fv' a') =+    h == h' && m == m' && a == a'++-- | Ignore the tactic.+instance EqualSy a => EqualSy (Dom a) where+  equalSy d@(Dom ai x f _tac a) d'@(Dom ai' x' f' _tac' a') = and+    [ x == x'+    , f == f'+    , equalSy ai ai'+    , equalSy a a'+    ]++-- | Ignores irrelevant arguments and modality.+--   (And, of course, origin and free variables).+instance EqualSy a => EqualSy (Arg a) where+  equalSy (Arg (ArgInfo h m _o _fv a) v) (Arg (ArgInfo h' m' _o' _fv' a') v') =+    h == h' && (isIrrelevant m || isIrrelevant m' || equalSy v v')+    -- Andreas, 2017-10-04, issue #2775,+    -- ignore irrelevant arguments during with-abstraction.+    -- 2019-07-05, issue #3889, don't ignore quantity during caching+    -- this is why we let equalSy replace (==).
src/full/Agda/TypeChecking/CheckInternal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- Initially authored by Andreas, 2013-10-22. @@ -9,317 +9,370 @@ --   have to be reduced since they break bidirectionality.  module Agda.TypeChecking.CheckInternal-  ( checkType-  , checkInternal-  , checkInternal'-  , defaultAction, Action(..)-  , infer+  ( MonadCheckInternal+  , checkType, infer, inferSpine+  , CheckInternal(..)+  , Action(..), defaultAction, eraseUnusedAction   ) where -import Control.Arrow ((&&&), (***), first, second)-import Control.Applicative 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)+import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty-import Agda.TypeChecking.ProjectionLike (elimView)-import Agda.TypeChecking.Records (getDefType)-import Agda.TypeChecking.Reduce+import Agda.TypeChecking.ProjectionLike (elimView, ProjEliminator(..))+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.Monad+import Agda.Utils.Maybe import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible --- -- | Entry point for e.g. checking WithFunctionType.--- checkType :: Type -> TCM ()--- checkType t = -- dontAssignMetas $ ignoreSorts $---   checkInternal (unEl t) (sort Inf)+import Agda.Interaction.Options +-- * Bidirectional rechecker++type MonadCheckInternal m = MonadConversion m++{-# SPECIALIZE checkType :: Type -> TCM () #-} -- | Entry point for e.g. checking WithFunctionType.-checkType :: Type -> TCM ()-checkType t = void $ checkType' t+checkType :: (MonadCheckInternal m) => Type -> m ()+checkType t = catchConstraint (CheckType t) $ inferInternal t --- | 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' :: Type -> TCM Sort-checkType' t = do-  reportSDoc "tc.check.internal" 20 $ sep-    [ text "checking internal type "-    , prettyTCM t-    ]-  v <- elimView True $ unEl t -- bring projection-like funs in post-fix form-  case ignoreSharing v of-    Pi a b -> do-      s1 <- checkType' $ unDom a-      s2 <- (b $>) <$> do-        addContext (absName b, a) $ do-          checkType' $ absBody b-      return $ dLub s1 s2-    Sort s -> do-      _ <- checkSort defaultAction s-      return $ sSuc 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-    Shared{}   -> __IMPOSSIBLE__+-- | 'checkInternal' traverses the whole 'Term', and we can use this+--   traversal to modify the term.+data Action m = Action+  { preAction  :: Type -> Term -> m Term+    -- ^ Called on each subterm before the checker runs.+  , postAction :: Type -> Term -> m Term+    -- ^ Called on each subterm after the type checking.+  , modalityAction :: Modality -> Modality -> Modality+    -- ^ Called for each @ArgInfo@.+    --   The first 'Modality' is from the type,+    --   the second from the term.+  , elimViewAction :: Term -> m Term+    -- ^ Called for bringing projection-like funs in post-fix form+  } -checkTypeSpine :: Type -> Term -> Elims -> TCM Sort-checkTypeSpine a self es = shouldBeSort =<< do snd <$> inferSpine a self es+-- | The default action is to not change the 'Term' at all.+defaultAction :: PureTCM m => Action m+--(MonadReduce m, MonadTCEnv m, HasConstInfo m) => Action m+defaultAction = Action+  { preAction       = \ _ -> return+  , postAction      = \ _ -> return+  , modalityAction  = \ _ -> id+  , elimViewAction  = elimView EvenLone+  } -data Action = Action { preAction  :: Type -> Term -> TCM Term-                     , postAction :: Type -> Term -> TCM Term }+eraseUnusedAction :: Action TCM+eraseUnusedAction = defaultAction { postAction = eraseUnused }+  where+    eraseUnused :: Type -> Term -> TCM Term+    eraseUnused t = \case+      Def f es -> do+        pols <- getPolarity f+        return $ Def f $ eraseIfNonvariant pols es+      v        -> return v -defaultAction :: Action-defaultAction = Action (\ _ v -> return v) (\ _ v -> return v)+    eraseIfNonvariant :: [Polarity] -> Elims -> Elims+    eraseIfNonvariant []                  es             = es+    eraseIfNonvariant pols                []             = []+    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 :: Term -> Type -> TCM ()-checkInternal v t = void $ checkInternal' defaultAction v t+class CheckInternal a where+  checkInternal' :: (MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a -checkInternal' :: Action -> Term -> Type -> TCM Term-checkInternal' action v t = do-  reportSDoc "tc.check.internal" 20 $ sep-    [ text "checking internal "-    , nest 2 $ sep [ prettyTCM v <+> text ":"-                   , nest 2 $ prettyTCM t ] ]-  -- Bring projection-like funs in post-fix form,-  -- even lone ones (True).-  v <- elimView True =<< preAction action t v-  postAction action t =<< case ignoreSharing v of-    Var i es   -> do-      a <- typeOfBV i-      checkSpine action a (Var i []) es t-    Def f es   -> do  -- f is not projection(-like)!-      a <- defType <$> getConstInfo f-      checkSpine action a (Def f []) es t-    MetaV x es -> do -- we assume meta instantiations to be well-typed-      a <- metaType x-      checkSpine action a (MetaV x []) es t-    Con c ci vs -> do-      -- we need to fully apply the constructor to make getConType work-      TelV tel t <- telView t-      addContext tel $ do-        let failure = typeError $ DoesNotConstructAnElementOf (conName c) t-            vs'     = raise (size tel) vs ++ teleArgs tel-        a <- maybe failure return =<< getConType c t-        Con c ci vs2 <- checkArgs action a (Con c ci []) vs' t-                 -- Strip away the extra arguments-        return $ applySubst (strengthenS __IMPOSSIBLE__ (size tel))-               $ Con c ci (take (length vs) vs2)-    Lit l      -> Lit l <$ ((`subtype` t) =<< litType l)-    Lam ai vb  -> do-      (a, b) <- shouldBePi t-      checkArgInfo ai $ domInfo a-      addContext (suggest vb b, a) $ do-        Lam ai . Abs (absName vb) <$> checkInternal' action (absBody vb) (absBody b)-    Pi a b     -> do-      s <- shouldBeSort t-      when (s == SizeUniv) $ typeError $ FunctionTypeInSizeUniv v-      let st  = sort s-          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) (sort sa)-      -- TODO: checkPTS sa sb s-      goInside $ Pi a . mkRng <$> checkInternal' action (unEl $ unAbs b) (sort sb)-    Sort s     -> do-      s <- checkSort action s  -- this ensures @s /= Inf@-      Sort s <$ ((sSuc s `leqSort`) =<< shouldBeSort t)-    Level l    -> do-      l <- checkLevel action l-      Level l <$ ((`subtype` t) =<< levelType)-    DontCare v -> DontCare <$> checkInternal' action v t-    Shared{}   -> __IMPOSSIBLE__+  checkInternal :: (MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()+  checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t -checkSpine :: Action -> Type -> Term -> Elims -> Type -> TCM Term-checkSpine action a self es t = do-  reportSDoc "tc.check.internal" 20 $ sep-    [ text "checking spine "-    , nest 2 $ sep [ parens (sep [ prettyTCM self <+> text ":"-                                 , nest 2 $ prettyTCM a ])-                   , nest 4 $ prettyTCM es <+> text ":"-                   , nest 2 $ prettyTCM t ] ]-  ((v, v'), t') <- inferSpine' action a self self es-  v' <$ coerceSize subtype v t' t+  inferInternal' :: (MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a+  inferInternal' act v = checkInternal' act v CmpEq () -checkArgs :: Action -> Type -> Term -> Args -> Type -> TCM Term-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 () --- | @checkArgInfo actual expected@.-checkArgInfo :: ArgInfo -> ArgInfo -> TCM ()-checkArgInfo ai ai' = do-  checkHiding    (getHiding ai)     (getHiding ai')-  checkRelevance (getRelevance ai)  (getRelevance ai')+{-# 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 () #-} -checkHiding    :: Hiding -> Hiding -> TCM ()-checkHiding    h h' = unless (h == h') $ typeError $ HidingMismatch h h'+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') -checkRelevance :: Relevance -> Relevance -> TCM ()-checkRelevance r0 r0' = unless (r == r') $ typeError $ RelevanceMismatch r r'-  where-    r  = canon r0-    r' = canon r0'-    canon Forced{}  = Relevant-    canon UnusedArg = Relevant-    canon r         = r+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 --- | Infer type of a neutral term.-infer :: Term -> TCM Type-infer v = do-  case ignoreSharing v 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-    MetaV x es -> do -- we assume meta instantiations to be well-typed-      a <- metaType x-      snd <$> inferSpine a (MetaV x []) es-    Shared{} -> __IMPOSSIBLE__-    _ -> __IMPOSSIBLE__+    -- 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 ] ] --- | Infer ordinary function application.-inferDef :: QName -> Elims -> TCM Type-inferDef f es = do-  a <- defType <$> getConstInfo f-  snd <$> inferSpine a (Def f []) es+    -- 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 --- | Infer possibly projection-like function application-inferDef' :: QName -> Arg Term -> Elims -> TCM Type-inferDef' f a es = do-  isProj <- isProjection f-  case isProj of-    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)+        -- 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) --- | @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 :: Type -> Term -> Elims -> TCM (Term, Type)-inferSpine a v es = first fst <$> inferSpine' defaultAction a v v es+        unless (usablePolarity d) $+          typeError $ VariableIsOfUnusablePolarity n (getModalPolarity d) --- | 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' :: Action -> Type -> Term -> Term -> Elims -> TCM ((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-    [ text "inferSpine': "-    , text "type t = " <+> prettyTCM t-    , text "self  = " <+> prettyTCM self-    , text "self' = " <+> prettyTCM self'-    , text "eliminated by e = " <+> prettyTCM e-    ]-  case e of-    Apply (Arg ai v) -> do-      (a, b) <- shouldBePi t-      checkArgInfo ai $ domInfo a-      v' <- checkInternal' action v $ 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+        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 --- | Type should either be a record type of a type eligible for---   the principal argument of projection-like functions.-shouldBeProjectible :: Type -> QName -> TCM Type--- shouldBeProjectible t f = maybe failure return =<< projectionType t f-shouldBeProjectible t f = maybe failure return =<< getDefType f =<< reduce t-  where failure = typeError $ ShouldBeRecordType t-    -- TODO: more accurate error that makes sense also for proj.-like funs.+-- | @checkArgInfo actual expected@.+--+--   The @expected@ 'ArgInfo' comes from the type.+--   The @actual@ 'ArgInfo' comes from the term and can be updated+--   by an action.+checkArgInfo :: (MonadCheckInternal m) => Action m -> ArgInfo -> ArgInfo -> m ArgInfo+checkArgInfo action ai ai' = do+  checkHiding    (getHiding ai)     (getHiding ai')+  mod <- checkModality action (getModality ai)  (getModality ai')+  return $ setModality mod ai -shouldBePi :: Type -> TCM (Dom Type, Abs Type)-shouldBePi t = ifPiType t (\ a b -> return (a, b)) $ const $ typeError $ ShouldBePi t+checkHiding :: (MonadCheckInternal m) => Hiding -> Hiding -> m ()+checkHiding h h' = unless (sameHiding h h') $ typeError $ HidingMismatch h h' --- | Result is in reduced form.-shouldBeSort :: Type -> TCM Sort-shouldBeSort t = ifIsSort t return (typeError $ ShouldBeASort t)+-- | @checkRelevance action term type@.+--+--   The @term@ 'Relevance' can be updated by the @action@.+checkModality :: (MonadCheckInternal m) => Action m -> Modality -> Modality -> m Modality+checkModality action mod mod' = do+  let (r,r') = (getRelevance mod, getRelevance mod')+      (q,q') = (getQuantity  mod, getQuantity  mod')+  unless (sameModality mod mod') $ typeError $ if+    | not (sameRelevance r r') -> RelevanceMismatch r r'+    | not (sameQuantity q q')  -> QuantityMismatch  q q'+    | otherwise -> __IMPOSSIBLE__ -- add more cases when adding new modalities+  return $ modalityAction action mod' mod  -- Argument order for actions: @type@ @term@ -ifIsSort :: Type -> (Sort -> TCM a) -> TCM a -> TCM a-ifIsSort t yes no = do-  t <- reduce t-  case ignoreSharing $ unEl t of-    Sort s -> yes s-    _      -> no+{-# SPECIALIZE infer :: Term -> TCM Type #-}+-- | Infer type of a neutral term.+infer :: (MonadCheckInternal m) => Term -> m Type+infer u = do+  reportSDoc "tc.check.internal" 20 $ "CheckInternal.infer" <+> prettyTCM u+  case u of+    Var i es -> do+      a <- typeOfBV i+      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+      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+      ] --- | Check if sort is well-formed.-checkSort :: Action -> Sort -> TCM Sort-checkSort action s =-  case s of-    Type l   -> Type <$> checkLevel action l-    Prop     -> __IMPOSSIBLE__-      -- the dummy Prop should not be part of a term we check-    Inf      -> typeError $ SetOmegaNotValidType-      -- we cannot have Setω on the lhs of the colon-    SizeUniv -> typeError $ InvalidTypeSort s-    DLub a b -> do-      a <- checkSort action a-      addContext (absName b, defaultDom (sort a) :: Dom Type) $ do-        DLub a . Abs (absName b) <$> checkSort action (absBody b)+instance CheckInternal Elims where+  checkInternal' action es cmp (t , hd) = snd <$> inferSpine action t hd es --- | Check if level is well-formed.-checkLevel :: Action -> Level -> TCM Level-checkLevel action (Max ls) = Max <$> mapM checkPlusLevel ls+{-# 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-    checkPlusLevel l@ClosedLevel{} = return l-    checkPlusLevel (Plus k l)      = Plus k <$> checkLevelAtom l+  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 -    checkLevelAtom l = do-      lvl <- levelType-      UnreducedLevel <$> case l of-        MetaLevel x es   -> checkInternal' action (MetaV x es) lvl-        BlockedLevel _ v -> checkInternal' action v lvl-        NeutralLevel _ v -> checkInternal' action v lvl-        UnreducedLevel v -> checkInternal' action v lvl+{-# 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' --- | Type of a term or sort meta.-metaType :: MetaId -> TCM Type-metaType x = jMetaType . mvJudgement <$> lookupMeta x+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' <- inferInternal' action s1+      a' <- checkInternal' action a CmpLeq $ sort s1'+      let dom' = dom $> a'+      s2' <- mapAbstraction (El s1' <$> dom') (inferInternal' action) s2+      return $ PiSort dom' s1' s2'+    FunSort s1 s2 -> do+      s1' <- inferInternal' action s1+      s2' <- inferInternal' action s2+      return $ FunSort s1' s2'+    UnivSort s -> UnivSort <$> inferInternal' action s+    MetaS x es -> do -- we assume sort meta instantiations to be well-formed+      a <- metaType x+      MetaS x <$> checkInternal' action es cmp (a , Sort . MetaS x)+    DefS d es -> do+      a <- defType <$> getConstInfo d+      DefS d <$> checkInternal' action es cmp (a , Sort . DefS d)+    DummyS s -> __IMPOSSIBLE_VERBOSE__ s --- | Universe subsumption and type equality (subtyping for sizes, resp.).-subtype :: Type -> Type -> TCM ()-subtype t1 t2 = do-  ifIsSort t1 (\ s1 -> (s1 `leqSort`) =<< shouldBeSort t2) $-    leqType t1 t2+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'+      checkInternal' action l CmpLeq lvl
src/full/Agda/TypeChecking/CheckInternal.hs-boot view
@@ -1,8 +1,50 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE KindSignatures #-}+ module Agda.TypeChecking.CheckInternal where +import Control.Monad.Except++import qualified Data.Kind as Hs+ import Agda.Syntax.Internal-import Agda.TypeChecking.Monad.Base (TCM)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Warnings -checkType :: Type -> TCM ()-checkInternal :: Term -> Type -> TCM ()-infer :: Term -> TCM Type+type MonadCheckInternal m =+  ( PureTCM m+  , MonadConstraint m+  , MonadMetaSolver m+  , MonadError TCErr m+  , MonadWarning m+  , MonadStatistics m+  , MonadFresh ProblemId m+  , MonadFresh Int m+  )++data Action (m :: Hs.Type -> Hs.Type)++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 ()+infer :: (MonadCheckInternal m) => Term -> m Type
src/full/Agda/TypeChecking/CompiledClause.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Case trees. --@@ -11,26 +10,27 @@  import Prelude hiding (null) +import Control.DeepSeq+ import qualified Data.Map as Map import Data.Map (Map)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Any(..))-import Data.Typeable (Typeable)-import Data.Foldable (Foldable, foldMap)-import Data.Traversable (Traversable)+import Data.Semigroup hiding (Arg(..)) +import GHC.Generics (Generic)+ import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Generic import Agda.Syntax.Literal import Agda.Syntax.Position  import Agda.Utils.Null-import Agda.Utils.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty -#include "undefined.h" import Agda.Utils.Impossible  data WithArity c = WithArity { arity :: Int, content :: c }-  deriving (Typeable, Functor, Foldable, Traversable)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Branches in a case tree. @@ -41,110 +41,148 @@   , conBranches    :: Map QName (WithArity c)     -- ^ Map from constructor (or projection) names to their arity     --   and the case subtree.  (Projections have arity 0.)+  , etaBranch      :: Maybe (ConHead, WithArity c)+    -- ^ Eta-expand with the given (eta record) constructor. If this is+    --   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.+  , lazyMatch :: Bool+    -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit+    --   branches and no catch-all.   }-  deriving (Typeable, Functor, Foldable, Traversable)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Case tree with bodies. -data CompiledClauses-  = Case (Arg Int) (Case CompiledClauses)+data CompiledClauses' a+  = Case (Arg Int) (Case (CompiledClauses' a))     -- ^ @Case n bs@ stands for a match on the @n@-th argument     -- (counting from zero) with @bs@ as the case branches.     -- If the @n@-th argument is a projection, we have only 'conBranches'     -- with arity 0.-  | Done [Arg ArgName] Term+  | Done [Arg ArgName] a     -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding     --   and name suggestions for the free variables. This is needed to build     --   lambdas on the right hand side for partial applications which can     --   still reduce.-  | Fail-    -- ^ Absurd case.-  deriving (Typeable)+  | 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 (Functor, Traversable, Foldable, Show, Generic) +type CompiledClauses = CompiledClauses' Term+ litCase :: Literal -> c -> Case c-litCase l x = Branches False Map.empty (Map.singleton l x) Nothing+litCase l x = Branches False Map.empty Nothing (Map.singleton l x) Nothing (Just False) False -conCase :: QName -> WithArity c -> Case c-conCase c x = Branches False (Map.singleton c x) Map.empty Nothing+conCase :: QName -> Bool -> WithArity c -> Case c+conCase c b x = Branches False (Map.singleton c x) Nothing Map.empty Nothing (Just b) False +etaCase :: ConHead -> WithArity c -> Case c+etaCase c x = Branches False Map.empty (Just (c, x)) Map.empty Nothing (Just False) True+ projCase :: QName -> c -> Case c-projCase c x = Branches True (Map.singleton c $ WithArity 0 x) Map.empty Nothing+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 Map.empty (Just x)+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.+checkLazyMatch :: Case c -> Case c+checkLazyMatch b = b { lazyMatch = lazyMatch b && requirements }+  where+    requirements = and+      [ 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 -instance Monoid c => Semigroup (WithArity c) where+-- | Check whether a case tree has any projection patterns+hasProjectionPatterns :: CompiledClauses -> Bool+hasProjectionPatterns = getAny . loop+  where+  loop cc = case cc of+    Fail{}    -> mempty+    Done{}    -> mempty+    Case _ br -> Any (projPatterns br) <> foldMap loop br++instance Semigroup c => Semigroup (WithArity c) where   WithArity n1 c1 <> WithArity n2 c2-    | n1 == n2  = WithArity n1 $ mappend c1 c2+    | n1 == n2  = WithArity n1 (c1 <> c2)     | otherwise = __IMPOSSIBLE__   -- arity must match! -instance Monoid c => Monoid (WithArity c) where-  mempty = WithArity __IMPOSSIBLE__ mempty+instance (Semigroup c, Monoid c) => Monoid (WithArity c) where+  mempty  = WithArity __IMPOSSIBLE__ mempty   mappend = (<>) -instance Monoid m => Semigroup (Case m) where-  Branches cop  cs  ls  m <> Branches cop' cs' ls' m' =+instance Semigroup m => Semigroup (Case m) where+  Branches cop cs eta ls m b lazy <> Branches cop' cs' eta' ls' m' b' lazy' = checkLazyMatch $     Branches (cop || cop') -- for @projCase <> mempty@-             (Map.unionWith mappend cs cs')-             (Map.unionWith mappend ls ls')-             (mappend m m')+             (Map.unionWith (<>) cs cs')+             (unionEta eta eta')+             (Map.unionWith (<>) ls ls')+             (m <> m')+             (combine b b')+             (lazy && lazy')+   where+     combine Nothing  b'        = b+     combine b        Nothing   = b+     combine (Just b) (Just b') = Just $ b && b' -instance Monoid m => Monoid (Case m) where-  mempty = empty+     unionEta Nothing b = b+     unionEta b Nothing = b+     unionEta Just{} Just{} = __IMPOSSIBLE__++instance (Semigroup m, Monoid m) => Monoid (Case m) where+  mempty  = empty   mappend = (<>)  instance Null (Case m) where-  empty = Branches False Map.empty Map.empty Nothing-  null (Branches _cop cs ls mcatch) = null cs && null ls && null mcatch+  empty = Branches False Map.empty Nothing Map.empty Nothing Nothing True+  null (Branches _cop cs eta ls mcatch _b _lazy) = null cs && null eta && null ls && null mcatch  -- * Pretty instances. -instance Pretty a => Show (Case a) where-  show = show . pretty--instance Show CompiledClauses where-  show = show . pretty- instance Pretty a => Pretty (WithArity a) where   pretty = pretty . content  instance Pretty a => Pretty (Case a) where-  prettyPrec p (Branches _cop cs ls m) =-    mparens (p > 0) $ vcat $-      prettyMap cs ++ prettyMap ls ++ prC m+  prettyPrec p (Branches _cop cs eta ls m b lazy) =+    mparens (p > 0) $ prLazy lazy <+> vcat (prettyMap_ cs ++ prEta eta ++ prettyMap_ ls ++ prC m)     where+      prLazy True  = "~"+      prLazy False = empty       prC Nothing = []-      prC (Just x) = [text "_ ->" <+> pretty x]+      prC (Just x) = ["_ ->" <+> pretty x]+      prEta Nothing = []+      prEta (Just (c, cc)) = [("eta" <+> pretty c <+> "->") <?> pretty cc] -prettyMap :: (Show k, Pretty v) => Map k v -> [Doc]-prettyMap m = [ sep [ text (show x ++ " ->")-                    , nest 2 $ pretty v ]-              | (x, v) <- Map.toList m ]+prettyMap_ :: (Pretty k, Pretty v) => Map k v -> [Doc]+prettyMap_ = map prettyAssign . Map.toList  instance Pretty CompiledClauses where-  pretty (Done hs t) = text ("done" ++ show hs) <+> pretty t-  pretty Fail        = text "fail"+  pretty (Done hs t) = ("done" <> pretty hs) <?> pretty t+  pretty Fail{}      = "fail"   pretty (Case n bs) | projPatterns bs =-    sep [ text "record"+    sep [ "record"         , nest 2 $ pretty bs         ]   pretty (Case n bs) =-    sep [ text ("case " ++ show n ++ " of")-        , nest 2 $ pretty bs-        ]+    text ("case " ++ prettyShow n ++ " of") <?> pretty bs  -- * KillRange instances. @@ -152,12 +190,34 @@   killRange = fmap killRange  instance KillRange c => KillRange (Case c) where-  killRange (Branches cop con lit all) = Branches cop+  killRange (Branches cop con eta lit all b lazy) = Branches cop     (killRangeMap con)+    (killRange eta)     (killRangeMap lit)     (killRange all)+    b lazy  instance KillRange CompiledClauses where-  killRange (Case i br) = killRange2 Case i br-  killRange (Done xs v) = killRange2 Done xs v-  killRange Fail        = Fail+  killRange (Case i br) = killRangeN Case i br+  killRange (Done xs v) = killRangeN Done xs v+  killRange (Fail xs)   = killRangeN Fail xs++-- * TermLike instances++instance TermLike a => TermLike (WithArity a) where+  traverseTermM = traverse . traverseTermM+  foldTerm      = foldMap . foldTerm++instance TermLike a => TermLike (Case a) where+  traverseTermM = traverse . traverseTermM+  foldTerm      = foldMap . foldTerm++instance TermLike a => TermLike (CompiledClauses' a) where+  traverseTermM = traverse . traverseTermM+  foldTerm      = foldMap . foldTerm++-- NFData instances++instance NFData c => NFData (WithArity c)+instance NFData a => NFData (Case a)+instance NFData a => NFData (CompiledClauses' a)
src/full/Agda/TypeChecking/CompiledClause/Compile.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE CPP           #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.CompiledClause.Compile where  import Prelude hiding (null) +import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Identity+ import Data.Maybe-import Data.Monoid+import Data.List (partition) import qualified Data.Map as Map-import Data.List (nubBy)-import Data.Function -import Debug.Trace- import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern@@ -21,18 +21,35 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.RecordPatterns import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Pretty (prettyTCM, nest, sep, text)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Free.Precompute+import Agda.TypeChecking.Reduce  import Agda.Utils.Functor import Agda.Utils.Maybe-import Agda.Utils.Null import Agda.Utils.List-import Agda.Utils.Pretty (Pretty(..), prettyShow)-import qualified Agda.Utils.Pretty as P+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Size+import Agda.Utils.Update -#include "undefined.h" import Agda.Utils.Impossible +data RunRecordPatternTranslation = RunRecordPatternTranslation | DontRunRecordPatternTranslation+  deriving (Eq)++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 q+                | otherwise                             = return++  translate $ caseMaybe mSplitTree (compile cs) $ \splitTree ->+    compileWithSplitTree splitTree cs+ -- | Process function clauses into case tree. --   This involves: --   1. Coverage checking, generating a split tree.@@ -42,37 +59,48 @@ --   Phases 1. and 2. are skipped if @Nothing@. compileClauses ::   Maybe (QName, Type) -- ^ Translate record patterns and coverage check with given type?-  -> [Clause] -> TCM CompiledClauses+  -> [Clause]+  -> TCM (Maybe SplitTree, Bool, CompiledClauses)+     -- ^ The 'Bool' indicates whether we turned a record expression into a copattern match. compileClauses mt cs = do   -- Construct clauses with pattern variables bound in left-to-right order.   -- Discard de Bruijn indices in patterns.-  cs <- normaliseProjP cs-  let unBruijn cs = [ Cl (map (fmap (fmap dbPatVarName . namedThing)) $ namedClausePats c)-                         (compiledClauseBody c) | c <- cs ]-  shared <- sharedFun   case mt of-    Nothing -> return $ compile shared $ unBruijn cs+    Nothing -> (Nothing,False,) . compile . map unBruijn <$> normaliseProjP cs     Just (q, t)  -> do       splitTree <- coverageCheck q t cs +      reportSDoc "tc.cc.tree" 20 $ vcat+        [ "split tree of " <+> prettyTCM q <+> " from coverage check "+        , return $ P.pretty splitTree+        ]+       -- The coverage checker might have added some clauses (#2288)!-      cs <- normaliseProjP =<< defClauses <$> getConstInfo q-      let cls = unBruijn cs+      -- Throw away the unreachable clauses (#2723).+      let notUnreachable = (Just True /=) . clauseUnreachable+      cs <- normaliseProjP =<< instantiateFull =<< filter notUnreachable . defClauses <$> getConstInfo q +      let cls = map unBruijn cs+       reportSDoc "tc.cc" 30 $ sep $ do-        (text "clauses patterns  before compilation") : do+        ("clauses patterns of " <+> prettyTCM q <+> " before compilation") : do           map (prettyTCM . map unArg . clPats) cls-      reportSDoc "tc.cc" 50 $ do-        sep [ text "clauses before compilation"-            , (nest 2 . text . show) cs-            ]-      let cc = compileWithSplitTree shared splitTree 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 q cc+       reportSDoc "tc.cc" 12 $ sep-        [ text "compiled clauses (still containing record splits)"-        , nest 2 $ text (show cc)+        [ "compiled clauses of " <+> prettyTCM q+        , nest 2 $ return $ P.pretty cc         ]-      cc <- translateCompiledClauses cc-      return cc+      return (Just splitTree, becameCopatternLHS, fmap precomputeFreeVars_ cc)  -- | Stripped-down version of 'Agda.Syntax.Internal.Clause' --   used in clause compiler.@@ -82,100 +110,138 @@   , clBody :: Maybe Term   } deriving (Show) -instance Pretty Cl where-  pretty (Cl ps b) = P.prettyList ps P.<+> P.text "->" P.<+> maybe (P.text "_|_") pretty b+instance P.Pretty Cl where+  pretty (Cl ps b) = P.prettyList ps P.<+> "->" P.<+> maybe "_|_" P.pretty b  type Cls = [Cl] -compileWithSplitTree :: (Term -> Term) -> SplitTree -> Cls -> CompiledClauses-compileWithSplitTree shared t cs = case t of-  SplitAt i ts -> Case i $ compiles ts $ splitOn (length ts == 1) (unArg i) cs+-- | Strip down a clause. Don't forget to apply the substitution to the dot+--   patterns!+unBruijn :: Clause -> Cl+unBruijn c = Cl (applySubst sub $ (map . fmap) (fmap dbPatVarName . namedThing) $ namedClausePats c)+                (applySubst sub $ clauseBody c)+  where+    sub = renamingR $ fromMaybe __IMPOSSIBLE__ (clausePerm c)++compileWithSplitTree :: SplitTree -> Cls -> CompiledClauses+compileWithSplitTree t cs = case t of+  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 shared cs+  SplittingDone n -> compile cs     -- after end of split tree, continue with left-to-right strategy-   where-    compiles :: SplitTrees -> Case Cls -> Case CompiledClauses-    compiles ts br@Branches{ projPatterns = cop-                           , conBranches = cons-                           , litBranches = lits-                           , catchAllBranch = catchAll }-      = Branches-          { projPatterns   = cop-          , conBranches    = updCons cons-          , litBranches    = compile shared <$> lits-          , catchAllBranch = compile shared <$> catchAll+    compiles :: LazySplit -> SplitTrees -> Case Cls -> Case CompiledClauses+    compiles lz ts br@Branches{ projPatterns = cop+                              , conBranches = cons+                              , etaBranch   = Nothing+                              , litBranches = lits+                              , fallThrough = fT+                              , catchallBranch = catchall+                              , lazyMatch = lazy }+      = br{ conBranches    = updCons cons+          , etaBranch      = Nothing+          , litBranches    = updLits lits+          , fallThrough    = fT+          , catchallBranch = updCatchall catchall+          , lazyMatch      = lazy || lz == LazySplit           }       where         updCons = Map.mapWithKey $ \ c cl ->-         caseMaybe (lookup c ts) (compile shared) (compileWithSplitTree shared) <$> cl+         caseMaybe (lookup (SplitCon c) ts) compile compileWithSplitTree <$> cl          -- When the split tree is finished, we continue with @compile@.+        updLits = Map.mapWithKey $ \ l cl ->+          caseMaybe (lookup (SplitLit l) ts) compile compileWithSplitTree cl+        updCatchall = fmap $ caseMaybe (lookup SplitCatchall ts) compile compileWithSplitTree+    compiles _ _ Branches{etaBranch = Just{}} = __IMPOSSIBLE__  -- we haven't inserted eta matches yet -compile :: (Term -> Term) -> Cls -> CompiledClauses-compile shared cs = case nextSplit cs of-  Just (isRecP, n)-> Case n $ fmap (compile shared) $ splitOn isRecP (unArg n) cs+compile :: Cls -> CompiledClauses+compile [] = Fail []+compile cs = case nextSplit cs of+  Just (isRecP, n) -> Case n $ compile <$> splitOn isRecP (unArg n) cs   Nothing -> case clBody c of     -- It's possible to get more than one clause here due to     -- catch-all expansion.-    Just t  -> Done (map (fmap name) $ clPats c) (shared t)-    Nothing -> Fail+    Just t  -> Done (map (fmap name) $ clPats c) t+    Nothing -> Fail (map (fmap name) $ clPats c)   where     -- If there are more than one clauses, take the first one.     c = headWithDefault __IMPOSSIBLE__ cs-    name (VarP x) = x-    name (DotP _) = underscore+    name (VarP _ x) = x+    name (DotP _ _) = underscore     name ConP{}  = __IMPOSSIBLE__+    name DefP{}  = __IMPOSSIBLE__     name LitP{}  = __IMPOSSIBLE__     name ProjP{} = __IMPOSSIBLE__+    name (IApplyP _ _ _ x) = x  -- | Get the index of the next argument we need to split on.---   This the number of the first pattern that does a match in the first clause.+--   This the number of the first pattern that does a (non-lazy) match in the first clause.+--   Or the first lazy match where all clauses agree on the constructor, if there are no+--   non-lazy matches. nextSplit :: Cls -> Maybe (Bool, Arg Int)-nextSplit []            = __IMPOSSIBLE__-nextSplit (Cl ps _ : _) = headMaybe $ catMaybes $-  zipWith (\ (Arg ai p) n -> (, Arg ai n) <$> properSplit p) ps [0..]+nextSplit []             = __IMPOSSIBLE__+nextSplit (Cl ps _ : cs) = findSplit nonLazy ps <|> findSplit allAgree ps+  where+    nonLazy _ (ConP _ cpi _) = not $ conPLazy cpi+    nonLazy _ _              = True +    findSplit okPat ps = listToMaybe (catMaybes $+      zipWith (\ (Arg ai p) n -> (, Arg ai n) <$> properSplit p <* guard (okPat n p)) ps [0..])++    allAgree i (ConP c _ _) = all ((== Just (conName c)) . getCon . map unArg . drop i . clPats) cs+    allAgree _ _            = False++    getCon (ConP c _ _ : _) = Just $ conName c+    getCon _                = Nothing+ -- | Is is not a variable pattern?---   And if yes, is it a record pattern?+--   And if yes, is it a record pattern and/or a fallThrough one? properSplit :: Pattern' a -> Maybe Bool-properSplit (ConP _ cpi _) = Just $ isJust $ conPRecord cpi-properSplit LitP{}  = Just False-properSplit ProjP{} = Just False-properSplit VarP{}  = Nothing-properSplit DotP{}  = Nothing+properSplit (ConP _ cpi _) = Just ((conPRecord cpi && patOrigin (conPInfo cpi) == PatORec) || conPFallThrough cpi)+properSplit DefP{}    = Just False+properSplit LitP{}    = Just False+properSplit ProjP{}   = Just False+properSplit IApplyP{} = Nothing+properSplit VarP{}    = Nothing+properSplit DotP{}    = Nothing  -- | Is this a variable pattern? -- --   Maintain invariant: @isVar = isNothing . properSplit@! isVar :: Pattern' a -> Bool-isVar VarP{}  = True-isVar DotP{}  = True-isVar ConP{}  = False-isVar LitP{}  = False-isVar ProjP{} = False+isVar IApplyP{} = True+isVar VarP{}    = True+isVar DotP{}    = True+isVar ConP{}    = False+isVar DefP{}    = False+isVar LitP{}    = False+isVar ProjP{}   = False  -- | @splitOn single n cs@ will force expansion of catch-alls --   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   ProjP _ d   -> projCase d $ Cl (ps0 ++ ps1) b-  ConP c _ qs -> conCase (conName c) $ WithArity (length qs) $-                   Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b-  LitP l      -> litCase l $ Cl (ps0 ++ ps1) b+  IApplyP{}   -> fallback+  ConP c i qs -> (conCase (conName c) (conPFallThrough i) $ WithArity (length qs) $+                   Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b) { lazyMatch = conPLazy i }+  DefP o q qs -> (conCase q False $ WithArity (length qs) $+                   Cl (ps0 ++ map (fmap namedThing) qs ++ ps1) b) { lazyMatch = False }+  LitP _ l    -> litCase l $ Cl (ps0 ++ ps1) b   VarP{}      -> fallback   DotP{}      -> fallback   where     (ps0, rest) = splitAt n ps-    mp          = unArg <$> headMaybe rest+    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. --@@ -229,56 +295,111 @@ --       false -> b --     false -> a -- @-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+--+-- Example from issue #3628:+-- @+--   f i j k (i = i0)(k = i1) = base+--   f i j k (j = i1)         = base+-- @+-- case tree:+-- @+--   f i j k o = case i of+--     i0 -> case k of+--             i1 -> base+--             _  -> case j of+--                     i1 -> base+--     _  -> case j of+--             i1 -> base+-- @+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 c+    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.-    expansions = nubBy ((==) `on` (classify . unArg . snd))+    expansions = nubOn (classify . unArg . snd)                . mapMaybe (notVarNth . clPats)                $ cs-    notVarNth ps = caseMaybe (headMaybe ps2) Nothing $ \ p ->-      if isVar (unArg p) then Nothing else Just (ps1, p)-      where (ps1, ps2) = splitAt n ps+    notVarNth+      :: [Arg Pattern]+      -> Maybe ([Arg Pattern]  -- First @n@ patterns.+               , Arg Pattern)  -- @n+1@st pattern, not a variable+    notVarNth ps = do+      let (ps1, ps2) = splitAt n ps+      p <- listToMaybe ps2+      guard $ not $ isVar $ unArg p+      return (ps1, p)      expand cl (qs, q) =       case unArg q of         ConP c mt qs' -> Cl (ps0 ++ [q $> ConP c mt conPArgs] ++ ps1)-                            (substBody n' m (Con c ci conArgs) b)+                            (substBody n' m (Con c ci (map Apply conArgs)) b)           where             ci       = fromConPatternInfo mt             m        = length qs'             -- replace all direct subpatterns of q by _-            conPArgs = map (fmap ($> VarP "_")) qs'+            -- TODO Andrea: might need these to sometimes be IApply?+            conPArgs = map (fmap ($> varP "_")) qs'             conArgs  = zipWith (\ q' i -> q' $> var i) qs' $ downFrom m-        LitP l -> Cl (ps0 ++ [q $> LitP l] ++ ps1) (substBody n' 0 (Lit l) b)+        LitP i l -> Cl (ps0 ++ [q $> LitP i l] ++ ps1) (substBody n' 0 (Lit l) b)+        DefP o d qs' -> Cl (ps0 ++ [q $> DefP o d conPArgs] ++ ps1)+                            (substBody n' m (Def d (map Apply conArgs)) b)+          where+            m        = length qs'+            -- replace all direct subpatterns of q by _+            conPArgs = map (fmap ($> varP "_")) qs'+            conArgs  = zipWith (\ q' i -> q' $> var i) qs' $ downFrom m         _ -> __IMPOSSIBLE__       where         -- Andreas, 2016-09-19 issue #2168@@ -288,12 +409,7 @@         -- The following pattern match cannot fail (by construction of @ps@).         (ps0, _:ps1) = splitAt n ps -        n' = countVars ps1-        countVars = sum . map (count . unArg)-        count VarP{}        = 1-        count (ConP _ _ ps) = countVars $ map (fmap namedThing) ps-        count DotP{}        = 1   -- dot patterns are treated as variables in the clauses-        count _             = 0+        n' = countPatternVars ps1  -- | Make sure (by eta-expansion) that clause has arity at least @n@ --   where @n@ is also the length of the provided list.@@ -306,8 +422,10 @@   ais  = drop k ais0   -- m = Number of arguments to add   m    = n - k-  ps'  = for ais $ \ ai -> Arg ai $ VarP "_"+  ps'  = for ais $ \ ai -> Arg ai $ varP "_"   args = zipWith (\ i ai -> Arg ai $ var i) (downFrom m) ais -substBody :: (Subst t a) => Int -> Int -> t -> a -> a+substBody :: Subst a => Int -> Int -> SubstArg a -> a -> a substBody n m v = applySubst $ liftS n $ v :# raiseS m++instance PrecomputeFreeVars a => PrecomputeFreeVars (CompiledClauses' a) where
src/full/Agda/TypeChecking/CompiledClause/Compile.hs-boot view
@@ -1,7 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.CompiledClause.Compile where  import Agda.Syntax.Internal import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad.Base -compileClauses :: Maybe (QName, Type) -> [Clause] -> TCM CompiledClauses+compileClauses :: Maybe (QName, Type) -> [Clause] -> TCM (Maybe SplitTree, Bool, CompiledClauses)
src/full/Agda/TypeChecking/CompiledClause/Match.hs view
@@ -1,27 +1,24 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.CompiledClause.Match where -import Control.Applicative-import Control.Monad.Reader (asks)--import Data.List import qualified Data.Map as Map +import Agda.Interaction.Options (optRewriting)+ import Agda.Syntax.Internal import Agda.Syntax.Common  import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad hiding (reportSDoc, reportSLn)-import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Monad hiding (constructorForm) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad as RedM import Agda.TypeChecking.Substitute  import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Syntax.Common.Pretty (prettyShow) -#include "undefined.h" import Agda.Utils.Impossible  matchCompiled :: CompiledClauses -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Args) Term)@@ -29,7 +26,7 @@   r <- matchCompiledE c $ map (fmap Apply) args   case r of     YesReduction simpl v -> return $ YesReduction simpl v-    NoReduction bes      -> return $ NoReduction $ fmap (map argFromElim) bes+    NoReduction bes      -> return $ NoReduction $ fmap (map (fromMaybe __IMPOSSIBLE__ . isApplyElim)) bes  -- | @matchCompiledE c es@ takes a function given by case tree @c@ and --   and a spine @es@ and tries to apply the function to @es@.@@ -66,16 +63,14 @@ match' :: Stack -> ReduceM (Reduced (Blocked Elims) Term) match' ((c, es, patch) : stack) = do   let no blocking es = return $ NoReduction $ blocking $ patch $ map ignoreReduced es-      yes t          = flip YesReduction t <$> asks envSimplification+      yes t          = flip YesReduction t <$> asksTC envSimplification    do -    shared <- sharedFun-     case c of        -- impossible case-      Fail -> no (NotBlocked AbsurdMatch) es+      Fail{} -> no (NotBlocked AbsurdMatch) es        -- done matching       Done xs t@@ -89,15 +84,28 @@           m              = length es           -- at least the first @n@ elims must be @Apply@s, so we can           -- turn them into a subsitution-          toSubst        = parallelS . reverse . map (unArg . argFromElim . ignoreReduced)-          -- Andreas, 2013-05-21 why introduce sharing only here,-          -- and not in underapplied case also?-          (es0, es1)     = splitAt n $ map (fmap $ fmap shared) es+          toSubst        = parallelS . reverse . map (unArg . fromMaybe __IMPOSSIBLE__ . isApplyElim . ignoreReduced)+          (es0, es1)     = splitAt n es           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 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+            where+              fs = conFields c+              patchEta es = patch (es0 ++ [e] ++ es1)+                where (es0, es') = splitAt n es+                      (_, es1)   = splitAt (length fs) es'+          _ -> __IMPOSSIBLE__+       -- splitting on the @n@th elimination       Case (Arg _ n) bs -> do-        case genericSplitAt n es of+        case splitAt n es of           -- if the @n@th elimination is not supplied, no match           (_, []) -> no (NotBlocked Underapplied) es           -- if the @n@th elimination is @e0@@@ -111,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@@ -119,12 +127,13 @@                     Just cc -> (cc, es0 ++ es1, patchLit) : stack                 -- If our argument (or its constructor form) is @Con c ci vs@                 -- we push @conFrame c vs@ onto the stack.-                conFrame c ci vs stack =-                  case Map.lookup (conName c) (conBranches bs) of+                conFrame c ci vs stack = conFrame' (conName c) (Con c ci) vs stack+                conFrame' q f vs stack =+                  case Map.lookup q (conBranches bs) of                     Nothing -> stack                     Just cc -> ( content cc-                               , es0 ++ map (MaybeRed NotReduced . Apply) vs ++ es1-                               , patchCon c ci (length vs)+                               , es0 ++ map (MaybeRed NotReduced) vs ++ es1+                               , patchCon f (length vs)                                ) : stack                 -- If our argument is @Proj p@, we push @projFrame p@ onto the stack.                 projFrame p stack =@@ -137,41 +146,63 @@                   where (es0, es1) = splitAt n es                 -- In case we matched constructor @c@ with @m@ arguments,                 -- contract these @m@ arguments @vs@ to @Con c ci vs@.-                patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)+--                patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)+                patchCon f m es = patch (es0 ++ [f vs <$ e] ++ es2)                   where (es0, rest) = splitAt n es                         (es1, es2)  = splitAt m rest-                        vs          = map argFromElim es1+                        vs          = es1+            -- zo <- do+            --    mi <- getBuiltinName' builtinIZero+            --    mo <- getBuiltinName' builtinIOne+            --    return $ Set.fromList $ catMaybes [mi,mo] -            -- Now do the matching on the @n@ths argument:-            id $-             case fmap ignoreSharing <$> eb of-              Blocked x _            -> no (Blocked x) es'-              NotBlocked _ (Apply (Arg info (MetaV x _))) -> no (Blocked x) es'+            fallThrough <- return $ Just True == fallThrough bs && isJust (catchallBranch bs) +            let+              isCon b =+                case ignoreBlocking b of+                 Apply a | c@Con{} <- unArg a -> Just c+                 _                            -> Nothing+            -- Now do the matching on the @n@ths argument:+            case eb of               -- In case of a literal, try also its constructor form               NotBlocked _ (Apply (Arg info v@(Lit l))) -> performedSimplification $ do                 cv <- constructorForm v-                let cFrame stack = case ignoreSharing cv of+                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+               -- In case of a constructor, push the conFrame-              NotBlocked _ (Apply (Arg info (Con c ci vs))) -> performedSimplification $-                match' $ conFrame c ci vs $ catchAllFrame $ stack+              b | Just (Con c ci vs) <- isCon b -> performedSimplification $+                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++              Blocked x _            -> no (Blocked x) es'+               -- Otherwise, we are stuck.  If we were stuck before,               -- we keep the old reason, otherwise we give reason StuckOn here.               NotBlocked blocked e -> no (NotBlocked $ stuckOn e blocked) es' + -- If we reach the empty stack, then pattern matching was incomplete match' [] = {- new line here since __IMPOSSIBLE__ does not like the ' in match' -}-  caseMaybeM (asks envAppDef) __IMPOSSIBLE__ $ \ f -> do-    traceSLn "impossible" 10-      ("Incomplete pattern matching when applying " ++ show f)-      __IMPOSSIBLE__+  caseMaybeM (asksTC envAppDef) __IMPOSSIBLE__ $ \ f -> do+    pds <- getPartialDefs+    if f `elem` pds+    then return (NoReduction $ NotBlocked (MissingClauses f) [])+    else do+      ifM (optRewriting <$> pragmaOptions)+      {-then-} (return (NoReduction $ NotBlocked ReallyNotBlocked [])) -- See #5396+      {-else-} $ traceSLn "impossible" 10+        ("Incomplete pattern matching when applying " ++ prettyShow f)+        __IMPOSSIBLE__
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,118 +1,189 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Constraints where  import Prelude hiding (null) -import Control.Applicative hiding (empty)--import Control.Monad-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Maybe+import Control.Monad.Except ( MonadError ) -import Data.List as List hiding (null)+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.Free import Agda.TypeChecking.Monad import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute import Agda.TypeChecking.LevelConstraints import Agda.TypeChecking.SizedTypes+import Agda.TypeChecking.Sort+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 import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Empty+import {-# SOURCE #-} Agda.TypeChecking.Lock+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal ( checkType ) -import Agda.Utils.Except ( MonadError(throwError) )-import Agda.Utils.Functor+import Agda.Utils.CallStack ( withCurrentCallStack )+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.Lens-import Agda.Utils.Size-import qualified Agda.Utils.VarSet as VarSet+import Agda.Utils.Null ()+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Singleton -#include "undefined.h" import Agda.Utils.Impossible --- | Catches pattern violation errors and adds a constraint.----catchConstraint :: Constraint -> TCM () -> TCM ()-catchConstraint c v = liftTCM $-   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{} -> addConstraint c-       _            -> throwError err+instance MonadConstraint TCM where+  addConstraint             = addConstraintTCM+  addAwakeConstraint        = addAwakeConstraint'+  solveConstraint           = solveConstraintTCM+  solveSomeAwakeConstraints = solveSomeAwakeConstraintsTCM+  wakeConstraints           = wakeConstraintsTCM+  stealConstraints          = stealConstraintsTCM+  modifyAwakeConstraints    = modifyTC . mapAwakeConstraints+  modifySleepingConstraints = modifyTC . mapSleepingConstraints -addConstraint :: Constraint -> TCM ()-addConstraint c = do-    pids <- asks envActiveProblems-    reportSDoc "tc.constr.add" 20 $ hsep-      [ text "adding constraint"-      , text (show pids)-      , prettyTCM c ]-    -- Need to reduce to reveal possibly blocking metas-    c <- reduce =<< instantiateFull c-    c' <- simpl c-    if (c /= c')-      then do-        reportSDoc "tc.constr.add" 20 $ text "  simplified:" <+> prettyTCM c'-        solveConstraint_ c'-      else addConstraint' c'-    -- the added constraint can cause IFS constraints to be solved (but only-    -- the constraints which aren’t blocked on an uninstantiated meta)-    unless (isIFSConstraint c) $-       wakeConstraints (isWakeableIFSConstraint . clValue . theConstraint)+addConstraintTCM :: Blocker -> Constraint -> TCM ()+addConstraintTCM unblock c = do+      pids <- asksTC envActiveProblems+      reportSDoc "tc.constr.add" 20 $ hsep+        [ "adding constraint"+        , 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+          reportSDoc "tc.constr.add" 20 $ "  simplified:" <+> prettyList (map prettyTCM cs)+          mapM_ solveConstraint_ cs+      -- The added constraint can cause instance constraints to be solved,+      -- but only the constraints which aren’t blocked on an uninstantiated meta.+      unless (isInstanceConstraint c) $+         wakeConstraints' isWakeableInstanceConstraint+    where+      isWakeableInstanceConstraint :: ProblemConstraint -> WakeUp+      isWakeableInstanceConstraint c =+        case clValue $ theConstraint c of+          FindInstance{}+            | constraintUnblocker c == alwaysUnblock -> WakeUp+          _ -> DontWakeUp Nothing++      isLvl LevelCmp{} = True+      isLvl _          = False++      -- Try to simplify a level constraint+      simpl :: Constraint -> TCM (Maybe [Constraint])+      simpl c+        | isLvl c = do+          -- Get all level constraints.+          lvlcs <- instantiateFull =<< do+            List.filter (isLvl . clValue) . map theConstraint <$> getAllConstraints+          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 $ fmap clValue lvlcs+        | otherwise = return Nothing++wakeConstraintsTCM :: (ProblemConstraint-> WakeUp) -> TCM ()+wakeConstraintsTCM wake = do+  c <- useR stSleepingConstraints+  let (wakeup, sleepin) = partitionEithers $ map checkWakeUp c+  reportSLn "tc.constr.wake" 50 $+    "waking up         " ++ show (List.map (Set.toList . constraintProblems) wakeup) ++ "\n" +++    "  still sleeping: " ++ show (List.map (Set.toList . constraintProblems) sleepin)+  modifySleepingConstraints $ const sleepin+  modifyAwakeConstraints (++ wakeup)   where-    isWakeableIFSConstraint :: Constraint -> TCM Bool-    isWakeableIFSConstraint (FindInScope _ b _) = caseMaybe b (return True) (\m -> isInstantiatedMeta m)-    isWakeableIFSConstraint _ = return False+    checkWakeUp c = case wake c of+      WakeUp              -> Left c+      DontWakeUp Nothing  -> Right c+      DontWakeUp (Just u) -> Right c{ constraintUnblocker = u } -    isIFSConstraint :: Constraint -> Bool-    isIFSConstraint FindInScope{} = True-    isIFSConstraint _             = False+-- | Add all constraints belonging to the given problem to the current problem(s).+stealConstraintsTCM :: ProblemId -> TCM ()+stealConstraintsTCM pid = do+  current <- asksTC envActiveProblems+  reportSLn "tc.constr.steal" 50 $ "problem " ++ show (Set.toList current) ++ " is stealing problem " ++ show pid ++ "'s constraints!"+  -- Add current to any constraint in pid.+  let rename pc@(PConstr pids u c) | Set.member pid pids = PConstr (Set.union current pids) u c+                                   | otherwise           = pc+  -- We should never steal from an active problem.+  whenM (Set.member pid <$> asksTC envActiveProblems) __IMPOSSIBLE__+  modifyAwakeConstraints    $ List.map rename+  modifySleepingConstraints $ List.map rename -    isLvl LevelCmp{} = True-    isLvl _          = False -    -- Try to simplify a level constraint-    simpl :: Constraint -> TCM Constraint-    simpl c = if not $ isLvl c then return c else do-      n <- genericLength <$> getContext-      cs <- map theConstraint <$> getAllConstraints-      lvls <- instantiateFull $ List.filter (isLvl . clValue) cs-      when (not $ null lvls) $ do-        reportSDoc "tc.constr.lvl" 40 $ text "simplifying level constraint" <+> prettyTCM c-                                        $$ nest 2 (hang (text "using") 2 (prettyTCM lvls))-      let c' = simplifyLevelConstraint c $ map clValue lvls-      reportSDoc "tc.constr.lvl" 40 $-        if c' /= c then text "simplified to" <+> prettyTCM c'-                   else text "no simplification"-      return c'+{-# 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+-- constrain the solution space further.+-- It can well do so, by solving metas.+noConstraints+  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+  => m a -> m a+noConstraints = noConstraints' False --- | Don't allow the argument to produce any constraints.-noConstraints :: TCM a -> TCM a-noConstraints problem = liftTCM $ do+-- | 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-  w <- warning_ (UnsolvedConstraints cs)-  unless (null cs) $ typeError $ 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+--   the solution space, i.e., not add any information about meta-variables.+nonConstraining ::+  ( HasOptions m+  , MonadConstraint m+  , MonadDebug m+  , MonadError TCErr m+  , MonadFresh ProblemId m+  , MonadTCEnv m+  , MonadWarning m+  ) => m a -> m a+nonConstraining = dontAssignMetas . noConstraints++{-# SPECIALIZE newProblem :: TCM a -> TCM (ProblemId, a) #-} -- | Create a fresh problem for the given action.-newProblem :: TCM a -> TCM (ProblemId, a)+newProblem+  :: (MonadFresh ProblemId m, MonadConstraint m)+  => m a -> m (ProblemId, a) newProblem action = do   pid <- fresh   -- Don't get distracted by other constraints while working on the problem@@ -121,7 +192,10 @@   solveAwakeConstraints   return (pid, x) -newProblem_ :: TCM () -> TCM ProblemId+{-# SPECIALIZE newProblem_ :: TCM a -> TCM ProblemId #-}+newProblem_+  :: (MonadFresh ProblemId m, MonadConstraint m)+  => m a -> m ProblemId newProblem_ action = fst <$> newProblem action  ifNoConstraints :: TCM a -> (a -> TCM b) -> (ProblemId -> a -> TCM b) -> TCM b@@ -134,11 +208,10 @@  -- | @guardConstraint c blocker@ tries to solve @blocker@ first. --   If successful without constraints, it moves on to solve @c@, otherwise it---   adds a @Guarded c cs@ constraint---   to the @blocker@-generated constraints @cs@.+--   adds a @c@ to the constraint pool, blocked by the problem generated by @blocker@. guardConstraint :: Constraint -> TCM () -> TCM () guardConstraint c blocker =-  ifNoConstraints_ blocker (solveConstraint_ c) (addConstraint . Guarded c)+  ifNoConstraints_ blocker (solveConstraint c) (\ pid -> addConstraint (unblockOnProblem pid) c)  whenConstraints :: TCM () -> TCM () -> TCM () whenConstraints action handler =@@ -146,69 +219,71 @@     stealConstraints pid     handler +{-# 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 (return . const True) -- (mentionsMeta x) -- TODO: needs fixing to cope with shared updates+  wakeConstraints' (wakeIfBlockedOnMeta x . constraintUnblocker)   solveAwakeConstraints --- | Wake up all constraints.+-- | Wake up all constraints not blocked on a problem. wakeupConstraints_ :: TCM () wakeupConstraints_ = do-  wakeConstraints (return . const True)+  wakeConstraints' (wakeup . constraintUnblocker)   solveAwakeConstraints--solveAwakeConstraints :: TCM ()-solveAwakeConstraints = solveAwakeConstraints' False+  where+    wakeup u | Set.null $ allBlockingProblems u = WakeUp+             | otherwise                        = DontWakeUp Nothing -solveAwakeConstraints' :: Bool -> TCM ()-solveAwakeConstraints' force = do-    verboseS "profile.constraints" 10 $ liftTCM $ tickMax "max-open-constraints" . genericLength =<< getAllConstraints+-- | 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+    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      -- already contain all their dependencies.-     locally eActiveProblems (const []) solve+     locallyTC eActiveProblems (const Set.empty) solve   where     solve = do-      reportSDoc "tc.constr.solve" 10 $ hsep [ text "Solving awake constraints."+      reportSDoc "tc.constr.solve" 10 $ hsep [ "Solving awake constraints."                                              , text . show . length =<< getAwakeConstraints-                                             , text "remaining." ]-      whenJustM takeAwakeConstraint $ \ c -> do+                                             , "remaining." ]+      whenJustM (takeAwakeConstraint' solveThis) $ \ c -> do         withConstraint solveConstraint c         solve -solveConstraint :: Constraint -> TCM ()-solveConstraint c = do-    verboseS "profile.constraints" 10 $ liftTCM $ tick "attempted-constraints"+solveConstraintTCM :: Constraint -> TCM ()+solveConstraintTCM c = do+    whenProfile Profile.Constraints $ liftTCM $ tick "attempted-constraints"     verboseBracket "tc.constr.solve" 20 "solving constraint" $ do-      pids <- asks envActiveProblems-      reportSDoc "tc.constr.solve" 20 $ text (show pids) <+> prettyTCM c+      pids <- asksTC envActiveProblems+      reportSDoc "tc.constr.solve.constr" 20 $ text (show $ Set.toList pids) <+> prettyTCM c       solveConstraint_ c  solveConstraint_ :: Constraint -> TCM ()-solveConstraint_ (ValueCmp cmp a u v)       = compareTerm cmp a u v-solveConstraint_ (ElimCmp cmp a e u v)      = compareElims cmp a e u v-solveConstraint_ (TypeCmp cmp a b)          = compareType cmp a b-solveConstraint_ (TelCmp a b cmp tela telb) = compareTel a b cmp tela telb+solveConstraint_ (ValueCmp cmp a u v)       = compareAs cmp a u v+solveConstraint_ (ValueCmpOnFace cmp p a u v) = compareTermOnFace cmp p a u v+solveConstraint_ (ElimCmp cmp fs a e u v)   = compareElims cmp fs a e u v solveConstraint_ (SortCmp cmp s1 s2)        = compareSort cmp s1 s2 solveConstraint_ (LevelCmp cmp a b)         = compareLevel cmp a b-solveConstraint_ c0@(Guarded c pid)         = do-  ifM (isProblemSolved pid) (solveConstraint_ c)-                            (addConstraint c0)-solveConstraint_ (IsEmpty r t)              = isEmptyType r t+solveConstraint_ (IsEmpty r t)              = ensureEmptyType r t solveConstraint_ (CheckSizeLtSat t)         = checkSizeLtSat t-solveConstraint_ (UnBlock m)                =-  ifM (isFrozen m) (addConstraint $ UnBlock m) $ do-    inst <- mvInstantiation <$> lookupMeta m-    reportSDoc "tc.constr.unblock" 15 $ text ("unblocking a metavar yields the constraint: " ++ show inst)+solveConstraint_ (UnquoteTactic tac hole goal) = unquoteTactic tac hole goal+solveConstraint_ (UnBlock m)                =   -- alwaysUnblock since these have their own unblocking logic (for now)+  ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (do+        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 <- 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 $           text ("blocked const " ++ prettyShow m ++ " :=") <+> prettyTCM t         assignTerm m [] t-      PostponedTypeCheckingProblem cl unblock -> enterClosure cl $ \prob -> do-        ifNotM unblock (addConstraint $ UnBlock m) $ do+      PostponedTypeCheckingProblem cl -> enterClosure cl $ \prob -> do           tel <- getContextTelescope           v   <- liftTCM $ checkTypeCheckingProblem prob           assignTerm m (telToArgs tel) v@@ -217,24 +292,69 @@       --       -- already solved metavariables: should only happen for size       -- metas (not sure why it does, Andreas?)-      InstV{} -> return ()-      -- Open (whatever that means)-      Open -> __IMPOSSIBLE__-      OpenIFS -> __IMPOSSIBLE__-solveConstraint_ (FindInScope m b cands)      = findInScope m cands+      -- Andreas, 2017-07-11:+      -- I think this is because the size solver instantiates+      -- some metas with infinity but does not clean up the UnBlock constraints.+      -- See also issue #2637.+      -- 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__+      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 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 cc ms mod t) = usableAtModality' ms cc mod t  checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term-checkTypeCheckingProblem p = case p of-  CheckExpr e t                  -> checkExpr e t-  CheckArgs eh r args t0 t1 k    -> checkArguments' eh r args t0 t1 k-  CheckLambda args body target   -> checkPostponedLambda args body target-  UnquoteTactic tac hole t       -> unquoteTactic tac hole t $ return hole+checkTypeCheckingProblem = \case+  CheckExpr cmp e t              -> checkExpr' cmp e t+  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-  awake    <- use stAwakeConstraints-  sleeping <- use stSleepingConstraints-  reportSDoc "" 0 $ vcat-    [ text "Current constraints"-    , nest 2 $ vcat [ text "awake " <+> vcat (map prettyTCM awake)-                    , text "asleep" <+> vcat (map prettyTCM sleeping) ] ]+  awake    <- useTC stAwakeConstraints+  sleeping <- useTC stSleepingConstraints+  reportSDoc "tc.constr" 50 $ vcat+    [ "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,12 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Constraints where ++import Control.Monad.Except (MonadError)++import Agda.Syntax.Internal (ProblemId) import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Constraints (MonadConstraint)+import Agda.TypeChecking.Warnings (MonadWarning) -addConstraint          :: Constraint -> TCM ()-catchConstraint        :: Constraint -> TCM () -> TCM ()-solveConstraint        :: Constraint -> TCM ()-solveAwakeConstraints' :: Bool -> TCM ()-noConstraints          :: TCM a -> TCM a+instance MonadConstraint TCM where++noConstraints          :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+                       => m a -> m a ifNoConstraints_       :: TCM () -> TCM a -> (ProblemId -> TCM a) -> TCM a+ifNoConstraints        :: TCM a -> (a -> TCM b) -> (ProblemId -> a -> TCM b) -> TCM b guardConstraint        :: Constraint -> TCM () -> TCM () debugConstraints       :: TCM ()
src/full/Agda/TypeChecking/Conversion.hs view
@@ -1,1349 +1,2265 @@-{-# LANGUAGE CPP               #-}--module Agda.TypeChecking.Conversion where--import Control.Applicative-import Control.Monad-import Control.Monad.Reader-import Control.Monad.State--import Data.List hiding (sort)-import qualified Data.List as List-import Data.Traversable hiding (mapM, sequence)--import Agda.Syntax.Abstract.Views (isSet)-import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Translation.InternalToAbstract (reify)--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.CompiledClause (CompiledClauses(Fail))-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..))-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import qualified Agda.TypeChecking.SyntacticEquality as SynEq-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Constraints-import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (infer)-import Agda.TypeChecking.Errors-import Agda.TypeChecking.Free-import Agda.TypeChecking.Datatypes (getConType)-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.ProjectionLike (elimView)--import Agda.Interaction.Options--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.Functor-import Agda.Utils.Monad-import Agda.Utils.Maybe-import Agda.Utils.Size-import Agda.Utils.Tuple-import Agda.Utils.Lens--#include "undefined.h"-import Agda.Utils.Impossible---- | Try whether a computation runs without errors or new constraints---   (may create new metas, though).---   Restores state upon failure.-tryConversion :: TCM () -> TCM 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' :: TCM a -> TCM (Maybe a)-tryConversion' m = tryMaybe $ disableDestructiveUpdate $ 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--equalTerm :: Type -> Term -> Term -> TCM ()-equalTerm = compareTerm CmpEq--equalAtom :: Type -> Term -> Term -> TCM ()-equalAtom = compareAtom CmpEq--equalType :: Type -> Type -> TCM ()-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 <$> asks envRelevance) (return ()) $ typeError err---- | Type directed equality on values.----compareTerm :: Comparison -> Type -> Term -> Term -> TCM ()-  -- If one term is a meta, try to instantiate right away. This avoids unnecessary unfolding.-  -- Andreas, 2012-02-14: This is UNSOUND for subtyping!-compareTerm cmp a u v = do-  reportSDoc "tc.conv.term" 10 $ sep-    [ text "compareTerm"-    , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v-    , nest 2 $ text ":" <+> prettyTCM a-    ]-  -- Check pointer equality first.-  let checkPointerEquality def | not $ null $ List.intersect (pointerChain u) (pointerChain v) = do-        verboseS "profile.sharing" 10 $ tick "pointer equality"-        return ()-      checkPointerEquality def = def-  checkPointerEquality $ do-    -- Check syntactic equality. This actually saves us quite a bit of work.-    ((u, v), equal) <- runReduceM $ 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-    unifyPointers cmp 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-        [ text "compareTerm (not syntactically equal)"-        , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v-        , nest 2 $ text ":" <+> 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 = compareTerm' cmp a u v-          unlessSubtyping cont =-              if cmp == CmpEq then cont else do-                -- Andreas, 2014-04-12 do not short cut if type is blocked.-                ifBlockedType 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 (ignoreSharing u, ignoreSharing v) of-        (MetaV x us, MetaV y vs)-          | x /= y    -> unlessSubtyping $ solve1 `orelse` solve2 `orelse` compareTerm' cmp a u v-          | 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-        _               -> fallback-  where-    assign dir x es v = do-      -- Andreas, 2013-10-19 can only solve if no projections-      reportSDoc "tc.conv.term.shortcut" 20 $ sep-        [ text "attempting shortcut"-        , nest 2 $ prettyTCM (MetaV x es) <+> text ":=" <+> prettyTCM v-        ]-      ifM (isInstantiatedMeta x) patternViolation {-else-} $ do-        assignE dir x es v $ compareTermDir dir a-      _ <- instantiate u-      -- () <- seq u' $ return ()-      reportSLn "tc.conv.term.shortcut" 50 $-        "shortcut successful\n  result: " ++ show u-    -- Should be ok with catchError_ but catchError is much safer since we don't-    -- rethrow errors.-    orelse m h = catchError m (\_ -> h)--unifyPointers :: Comparison -> Term -> Term -> TCM () -> TCM ()-unifyPointers _ _ _ action = action--- unifyPointers cmp _ _ action | cmp /= CmpEq = action--- unifyPointers _ u v action = do---   reportSLn "tc.ptr.unify" 50 $ "Maybe unifying pointers\n  u = " ++ show u ++ "\n  v = " ++ show v---   old <- use stDirty---   stDirty .= False---   action---   reportSLn "tc.ptr.unify" 50 $ "Finished comparison\n  u = " ++ show u ++ "\n  v = " ++ show v---   (u, v) <- instantiate (u, v)---   reportSLn "tc.ptr.unify" 50 $ "After instantiation\n  u = " ++ show u ++ "\n  v = " ++ show v---   dirty <- use stDirty---   stDirty .= old---   if dirty then verboseS "profile.sharing" 20 (tick "unifyPtr: dirty")---            else do---             verboseS "profile.sharing" 20 (tick "unifyPtr: clean")---             reportSLn "tc.ptr.unify" 80 $ "Unifying\n  u = " ++ show u ++ "\n  v = " ++ show v---             forceEqualTerms u v---             reportSLn "tc.ptr.unify" 80 $ "After unification\n  u = " ++ show u ++ "\n  v = " ++ show v---- | Try to assign meta.  If meta is projected, try to eta-expand---   and run conversion check again.-assignE :: CompareDirection -> MetaId -> Elims -> Term -> (Term -> Term -> TCM ()) -> TCM ()-assignE dir x es v comp = assignWrapper dir x es v $ do-  case allApplyElims es of-    Just vs -> assignV dir x vs v-    Nothing -> do-      reportSDoc "tc.conv.assign" 30 $ sep-        [ text "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-            [ text "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  -- nothing happened, give up--compareTermDir :: CompareDirection -> Type -> Term -> Term -> TCM ()-compareTermDir dir a = dirToCmp (`compareTerm'` a) dir--compareTerm' :: Comparison -> Type -> Term -> Term -> TCM ()-compareTerm' cmp a m n =-  verboseBracket "tc.conv.term" 20 "compareTerm" $ do-  a' <- reduce a-  catchConstraint (ValueCmp cmp a' m n) $ do-    reportSDoc "tc.conv.term" 30 $ fsep-      [ text "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, text ":", prettyTCM a' ]-    proofIrr <- proofIrrelevance-    isSize   <- isJust <$> isSizeType a'-    s        <- reduce $ getSort a'-    mlvl     <- tryMaybe primLevel-    reportSDoc "tc.conv.level" 60 $ nest 2 $ sep-      [ text $ "a'   = " ++ show a'-      , text $ "mlvl = " ++ show mlvl-      , text $ "(Just (ignoreSharing $ unEl a') == mlvl) = " ++ show (Just (ignoreSharing $ unEl a') == mlvl)-      ]-    case s of-      Prop | proofIrr -> return ()-      _    | isSize   -> compareSizes cmp m n-      _               -> case ignoreSharing $ unEl a' of-        a | Just a == mlvl -> do-          a <- levelView m-          b <- levelView n-          equalLevel a b--- OLD:        Pi dom _  -> equalFun (dom, a') m n-        a@Pi{}    -> equalFun 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 = isNeutral' . fmap ignoreSharing-                  isMeta    = isMeta'    . fmap ignoreSharing-                  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' (NotBlocked _ MetaV{}) = True-                  isMeta' _                      = False--              reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> text "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 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-                    isSing <- isSingletonRecordModuloRelevance r ps-                    case isSing of-                      Right True -> return ()-                      -- do not eta-expand if comparing two neutrals-                      _ -> compareAtom cmp 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 $ sort Prop) (Con c ConOSystem []) m' n'--            else compareAtom cmp a' m n-        _ -> compareAtom cmp a' m n-  where-    -- equality at function type (accounts for eta)-    equalFun :: Term -> Term -> Term -> TCM ()-    equalFun (Shared p) m n = equalFun (derefPtr p) m n-    equalFun (Pi dom@(Dom info _) b) m n = do-        name <- freshName_ $ suggest (absName b) "x"-        addContext (name, dom) $ compareTerm cmp (absBody b) m' n'-      where-        (m',n') = raise 1 (m,n) `apply` [Arg info $ var 0]-    equalFun _ _ _ = __IMPOSSIBLE__---- | @compareTel t1 t2 cmp tel1 tel1@ checks whether pointwise---   @tel1 \`cmp\` tel2@ and complains that @t2 \`cmp\` t1@ failed if---   not.-compareTel :: Type -> Type ->-  Comparison -> Telescope -> Telescope -> TCM ()-compareTel t1 t2 cmp tel1 tel2 =-  verboseBracket "tc.conv.tel" 20 "compareTel" $-  catchConstraint (TelCmp t1 t2 cmp tel1 tel2) $ case (tel1, tel2) of-    (EmptyTel, EmptyTel) -> return ()-    (EmptyTel, _)        -> bad-    (_, EmptyTel)        -> bad-    (ExtendTel dom1@(Dom i1 a1) tel1, ExtendTel dom2@(Dom i2 a2) tel2) -> do-      compareDom cmp dom1 dom2 tel1 tel2 bad bad $-        compareTel t1 t2 cmp (absBody tel1) (absBody tel2)--{- OLD, before 2013-05-15-          let checkDom = escapeContext 1 $ compareType cmp a1 a2-              c = TelCmp t1 t2 cmp (absBody tel1) (absBody tel2)--          addContext (name, dom1) $-            if dependent-            then guardConstraint c checkDom-            else checkDom >> solveConstraint_ c--}-  where-    -- Andreas, 2011-05-10 better report message about types-    bad = typeError $ UnequalTypes cmp t2 t1-      -- switch t2 and t1 because of contravariance!------ | Raise 'UnequalTerms' if there is no hope that by---   meta solving and subsequent eta-contraction these---   terms could become equal.---   Precondition: the terms are in reduced form---   (with no top-level pointer) and---   failed to be equal in the 'compareAtom' check.------   By eta-contraction, a lambda or a record constructor term---   can become anything.-etaInequal :: Comparison -> Type -> Term -> Term -> TCM ()-etaInequal cmp t m n = do-  let inequal  = typeError $ UnequalTerms cmp m n t-      dontKnow = do-        reportSDoc "tc.conv.inequal" 20 $ hsep-          [ text "etaInequal: postponing "-          , prettyTCM m-          , text " != "-          , prettyTCM n-          ]-        patternViolation-  -- if type is not blocked, then we would have tried eta already-  flip (ifBlockedType t) (\ _ -> inequal) $ \ _ _ -> do-    -- type is blocked-    case (m, n) of-      (Con{}, _) -> dontKnow-      (_, Con{}) -> dontKnow-      (Lam{}, _) -> dontKnow-      (_, Lam{}) -> dontKnow-      _          -> inequal--compareAtomDir :: CompareDirection -> Type -> Term -> Term -> TCM ()-compareAtomDir dir a = dirToCmp (`compareAtom` a) dir---- | Syntax directed equality on atomic values----compareAtom :: Comparison -> Type -> Term -> Term -> TCM ()-compareAtom cmp t m n =-  verboseBracket "tc.conv.atom" 20 "compareAtom" $-  -- if a PatternErr is thrown, rebuild constraint!-  catchConstraint (ValueCmp cmp t m n) $ do-    reportSDoc "tc.conv.atom" 50 $-      text "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp-                                  , prettyTCM n-                                  , text ":" <+> prettyTCM t ]-    -- Andreas: what happens if I cut out the eta expansion here?-    -- Answer: Triggers issue 245, does not resolve 348-    (mb',nb') <- ifM (asks envCompareBlocked) ((notBlocked -*- notBlocked) <$> reduce (m,n)) $ do-      mb' <- etaExpandBlocked =<< reduceB m-      nb' <- etaExpandBlocked =<< reduceB n-      return (mb', nb')--    -- constructorForm changes literal to constructors-    -- only needed if the other side is not a literal-    (mb'', nb'') <- case (ignoreSharing $ ignoreBlocking mb', ignoreSharing $ ignoreBlocking nb') of-      (Lit _, Lit _) -> return (mb', nb')-      _ -> (,) <$> traverse constructorForm mb'-               <*> traverse constructorForm nb'--    mb <- traverse unLevel mb''-    nb <- traverse unLevel nb''--    let m = ignoreBlocking mb-        n = ignoreBlocking nb--        postpone = addConstraint $ ValueCmp cmp t m n--        checkSyntacticEquality = do-          n <- normalise n    -- is this what we want?-          m <- normalise m-          if m == n-              then return ()  -- Check syntactic equality for blocked terms-              else postpone--        dir = fromCmp cmp-        rid = flipCmp dir     -- The reverse direction.  Bad name, I know.--        assign dir x es v = assignE dir x es v $ compareAtomDir dir t--    unifyPointers cmp (ignoreBlocking mb') (ignoreBlocking nb') $ do    -- this needs to go after eta expansion to avoid creating infinite terms--      reportSDoc "tc.conv.atom" 30 $-        text "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp-                                    , prettyTCM nb-                                    , text ":" <+> prettyTCM t ]-      case (ignoreSharing <$> mb, ignoreSharing <$> nb) of-        -- equate two metas x and y.  if y is the younger meta,-        -- try first y := x and then x := y-        (NotBlocked _ (MetaV x xArgs), NotBlocked _ (MetaV y yArgs))-            | x == y ->-              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    -> postpone-                    PrunedSomething  -> postpone-                    -- OLD CODE: if killedAll then return () else checkSyntacticEquality-                -- not all relevant arguments are variables-                Nothing -> checkSyntacticEquality -- Check syntactic equality on meta-variables-                                -- (same as for blocked terms)-            | otherwise -> do-                [p1, p2] <- mapM getMetaPriority [x,y]-                -- instantiate later meta variables first-                let (solve1, solve2)-                      | (p1,x) > (p2,y) = (l,r)-                      | otherwise       = (r,l)-                      where l = assign dir x xArgs n-                            r = assign rid y yArgs m--                    try m h = m `catchError_` \err -> case err of-                      PatternErr{} -> h-                      _            -> throwError err--                -- First try the one with the highest priority. If that doesn't-                -- work, try the low priority one.-                try solve1 solve2--        -- one side a meta, the other an unblocked term-        (NotBlocked _ (MetaV x es), _) -> assign dir x es n-        (_, NotBlocked _ (MetaV x es)) -> assign rid x es m-        (Blocked{}, Blocked{})  -> checkSyntacticEquality-        (Blocked{}, _)    -> useInjectivity cmp t m n-        (_,Blocked{})     -> useInjectivity cmp t m n-        _ -> 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 (ignoreSharing m, ignoreSharing n) of-            (Pi{}, Pi{}) -> equalFun m n--            (Sort s1, Sort Inf) -> return ()-            (Sort s1, Sort s2) -> compareSort CmpEq 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'-            (Def f [], Def f' []) | f == f' -> return ()-            (Def f es, Def f' es') | f == f' -> do-                def <- getConstInfo f-                -- To compute the type @a@ of a projection-like @f@,-                -- we have to infer the type of its first argument.-                a <- if projectionArgs (theDef def) <= 0 then return $ defType def else do-                  -- Find an 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 $-                    text "inferring type of internal arg: " <+> prettyTCM arg-                  targ <- infer $ unArg arg-                  reportSDoc "tc.conv.infer" 30 $-                    text "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.-                  fromMaybeM patternViolation $ getDefType f =<< reduce targ-                -- The polarity vector of projection-like functions-                -- does not include the parameters.-                pol <- getPolarity' cmp f-                compareElims pol a (Def f []) es es'-            (Def f es, Def f' es') ->-              unlessM (bothAbsurd f f') $ do-                trySizeUniv cmp t m n f es f' es'-            (Con x ci xArgs, Con y _ yArgs)-                | x == y -> do-                    -- Get the type of the constructor instantiated to the datatype parameters.-                    a' <- conType x t-                    -- Constructors are covariant in their arguments-                    -- (see test/succeed/CovariantConstructors).-                    compareArgs (repeat $ polFromCmp cmp) a' (Con x ci []) xArgs yArgs-            _ -> etaInequal cmp t m n -- fixes issue 856 (unsound conversion error)-    where-        -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked-        conType c t = ifBlockedType t (\ _ _ -> patternViolation) $ \ t -> do-          let impossible = do-                reportSDoc "impossible" 10 $-                  text "expected data/record type, found " <+> prettyTCM t-                reportSLn "impossible" 70 $ "  raw = " ++ show 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-          maybe impossible return =<< getConType c t-        equalFun t1 t2 = case (ignoreSharing t1, ignoreSharing 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-                [ text "t1 =" <+> prettyTCM t1-                , text "t2 =" <+> prettyTCM t2 ]-              compareDom cmp dom2 dom1 b1 b2 errH errR $-                compareType cmp (absBody b1) (absBody b2)-            where-            errH = typeError $ UnequalHiding t1 t2-            errR = typeError $ UnequalRelevance cmp t1 t2--{- OLD, before 2013-05-15-                let checkDom = escapeContext 1 $ compareType cmp a2 a1-                    conCoDom = TypeCmp cmp (absBody b1) (absBody b2)-                -- We only need to require a1 == a2 if t2 is a dependent function type.-                -- If it's non-dependent it doesn't matter what we add to the context.-                name <- freshName_ (suggest b1 b2)-                addContext (name, dom1) $-                  if isBinderUsed b2 -- dependent function type?-                  then guardConstraint conCoDom checkDom-                  else checkDom >> solveConstraint_ conCoDom--}-          _ -> __IMPOSSIBLE__---- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@.-compareDom :: 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.-  -> TCM ()     -- ^ Continuation if mismatch in 'Hiding'.-  -> TCM ()     -- ^ Continuation if mismatch in 'Relevance'.-  -> TCM ()     -- ^ Continuation if comparison is successful.-  -> TCM ()-compareDom cmp dom1@(Dom i1 a1) dom2@(Dom i2 a2) b1 b2 errH errR cont-  | getHiding dom1 /= getHiding dom2 = errH-  -- Andreas 2010-09-21 compare r1 and r2, but ignore forcing annotations!-  | not $ compareRelevance cmp (ignoreForced $ getRelevance dom1)-                               (ignoreForced $ getRelevance dom2) = errR-  | otherwise = do-      let r = max (getRelevance dom1) (getRelevance dom2)-              -- take "most irrelevant"-          dependent = (r /= Irrelevant) && isBinderUsed b2-      pid <- newProblem_ $ compareType cmp a1 a2-      dom <- if dependent-             then Dom i1 <$> 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.-      name <- freshName_ $ suggest b1 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 = (<=)---- | @compareElims pols a v els1 els2@ performs type-directed equality on eliminator spines.---   @t@ is the type of the head @v@.-compareElims :: [Polarity] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()-compareElims pols0 a v els01 els02 = catchConstraint (ElimCmp pols0 a v els01 els02) $ do-  let v1 = applyE v els01-      v2 = applyE v els02-      failure = typeError $ UnequalTerms CmpEq v1 v2 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 $ text "compareElims" $$ do-     nest 2 $ vcat-      [ text "a     =" <+> prettyTCM a-      , text "pols0 (truncated to 10) =" <+> sep (map prettyTCM $ take 10 pols0)-      , text "v     =" <+> prettyTCM v-      , text "els01 =" <+> prettyTCM els01-      , text "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-    (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)-    (Apply arg1 : els1, Apply arg2 : els2) ->-      verboseBracket "tc.conv.elim" 20 "compare Apply" $ do-      reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat-        [ text "a    =" <+> prettyTCM a-        , text "v    =" <+> prettyTCM v-        , text "arg1 =" <+> prettyTCM arg1-        , text "arg2 =" <+> prettyTCM arg2-        ]-      reportSDoc "tc.conv.elim" 50 $ nest 2 $ vcat-        [ text "v    =" <+> text (show v)-        , text "arg1 =" <+> text (show arg1)-        , text "arg2 =" <+> text (show arg2)-        , text ""-        ]-      let (pol, pols) = nextPolarity pols0-      ifBlockedType a (\ m t -> patternViolation) $ \ a -> do-        case ignoreSharing . unEl $ a of-          (Pi (Dom info b) codom) -> do-            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-                r = getRelevance info---- NEW, Andreas, 2013-05-15--            -- compare arg1 and arg2-            pid <- newProblem_ $ applyRelevanceToContext r $-                case r of-                  Forced{}   -> return ()-                  r | irrelevantOrUnused r ->-                                compareIrrelevant b (unArg arg1) (unArg arg2)-                  _          -> compareWithPol pol (flip compareTerm b)-                                  (unArg arg1) (unArg arg2)-            -- if comparison got stuck and function type is dependent, block arg-            arg <- if dependent-                   then (arg1 $>) <$> blockTermOnProblem b (unArg arg1) pid-                   else return arg1-            -- continue, possibly with blocked instantiation-            compareElims pols (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2-            -- any left over constraints of arg are associatd to the comparison-            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.--}--{- OLD, before 2013-05-15--            let checkArg = applyRelevanceToContext r $-                               case r of-                  Forced     -> return ()-                  r | irrelevantOrUnused r ->-                                compareIrrelevant b (unArg arg1) (unArg arg2)-                  _          -> compareWithPol pol (flip compareTerm b)-                                  (unArg arg1) (unArg arg2)--                theRest = ElimCmp pols (piApply a [arg1]) (apply v [arg1]) els1 els2--            if dependent-              then guardConstraint theRest checkArg-              else checkArg >> solveConstraint_ theRest--}--          a -> do-            reportSDoc "impossible" 10 $-              text "unexpected type when comparing apply eliminations " <+> prettyTCM a-            reportSLn "impossible" 50 $ "raw type: " ++ show a-            patternViolation-            -- 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 . GenericError . show =<< prettyTCM f <+> text "/=" <+> prettyTCM f'-      | otherwise -> ifBlockedType a (\ m t -> patternViolation) $ \ a -> do-        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 " ++ show f-              , text   "applied to value " <+> prettyTCM v-              , text   "of unexpected type " <+> prettyTCM a-              ]-            patternViolation----- | "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 :: Type -> Term -> Term -> TCM ()-{- 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 v w = do-  reportSDoc "tc.conv.irr" 20 $ vcat-    [ text "compareIrrelevant"-    , nest 2 $ text "v =" <+> prettyTCM v-    , nest 2 $ text "w =" <+> prettyTCM w-    ]-  reportSDoc "tc.conv.irr" 50 $ vcat-    [ nest 2 $ text $ "v = " ++ show v-    , nest 2 $ text $ "w = " ++ show w-    ]-  try v w $ try w v $ return ()-  where-    try (Shared p) w fallback = try (derefPtr p) w fallback-    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 $ text $ "inst = " ++ show inst-        ]-      if not (irrelevantOrUnused 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 $ compareIrrelevant t) `catchError` \ _ -> fallback-        -- the value of irrelevant or unused meta does not matter-    try v w fallback = fallback--compareWithPol :: Polarity -> (Comparison -> a -> a -> TCM ()) -> a -> a -> TCM ()-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 :: [Polarity] -> Type -> Term -> Args -> Args -> TCM ()-compareArgs pol a v args1 args2 =-  compareElims pol a v (map Apply args1) (map Apply args2)-------------------------------------------------------------------------------- * Types-------------------------------------------------------------------------------- | Equality on Types-compareType :: Comparison -> Type -> Type -> TCM ()-compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) =-    verboseBracket "tc.conv.type" 20 "compareType" $-    catchConstraint (TypeCmp cmp ty1 ty2) $ do-        reportSDoc "tc.conv.type" 50 $ vcat-          [ text "compareType" <+> sep [ prettyTCM ty1 <+> prettyTCM cmp-                                       , prettyTCM ty2 ]-          , hsep [ text "   sorts:", prettyTCM s1, text " and ", prettyTCM s2 ]-          ]--- Andreas, 2011-4-27 should not compare sorts, but currently this is needed--- for solving sort and level metas-        compareSort CmpEq s1 s2 `catchError` \err -> case err of-          TypeError _ e -> do-            reportSDoc "tc.conv.type" 30 $ vcat-              [ text "sort comparison failed"-              , nest 2 $ vcat-                [ text "s1 =" <+> prettyTCM s1-                , text "s2 =" <+> prettyTCM s2-                ]-              ]-            case clValue e of-              -- Issue 659: Better error message-              SetOmegaNotValidType -> typeError $ UnequalBecauseOfUniverseConflict cmp a1 a2-              _ -> do-                -- This error will probably be more informative-                compareTerm cmp (sort s1) a1 a2-                -- Throw the original error if the above doesn't-                -- give an error (for instance, due to pending-                -- constraints).-                -- Or just ignore it... We run into this with irrelevant levels-                -- which may show up in sort constraints, causing them to fail.-                -- In any case it's not safe to ignore the error, for instance-                -- a1 might be Set and a2 a meta of type Set, in which case we-                -- really need the sort comparison to fail, instead of silently-                -- instantiating the meta.-                -- Andreas, 2013-10-31 Maybe the error went away-                -- when we compared the types.  So we try the sort comparison-                -- again, this time not catching the error.  (see Issue 930)-                -- throwError err-                compareSort CmpEq s1 s2-          _             -> throwError err-        compareTerm cmp (sort s1) a1 a2-        return ()--leqType :: Type -> Type -> TCM ()-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 :: Term -> Type -> Type -> TCM Term-coerce v t1 t2 = blockTerm t2 $ do-  verboseS "tc.conv.coerce" 10 $ do-    (a1,a2) <- reify (t1,t2)-    let dbglvl = if isSet a1 && isSet a2 then 50 else 10-    reportSDoc "tc.conv.coerce" dbglvl $-      text "coerce" <+> vcat-        [ text "term      v  =" <+> prettyTCM v-        , text "from type t1 =" <+> prettyTCM a1-        , text "to type   t2 =" <+> prettyTCM a2-        ]-  -- v <$ do workOnTypes $ leqType t1 t2-  -- take off hidden/instance domains from t1 and t2-  TelV tel1 b1 <- telViewUpTo' (-1) ((NotHidden /=) . getHiding) t1-  TelV tel2 b2 <- telViewUpTo' (-1) ((NotHidden /=) . getHiding) 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-    ifBlockedType b2 (\ _ _ -> fallback) $ \ _ -> do-      (args, t1') <- implicitArgs n (NotHidden /=) t1-      coerceSize leqType (v `apply` args) t1' t2-  where-    fallback = coerceSize leqType 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 :: (Type -> Type -> TCM ()) -> Term -> Type -> Type -> TCM Term-coerceSize leqType v t1 t2 = workOnTypes $ do-    let fallback = v <$ leqType t1 t2-        done = caseMaybeM (isSizeType t1) fallback $ \ b1 -> return v-    -- 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 t2) fallback $ \ b2 -> do-      -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).-      ifM (tryConversion $ dontAssignMetas $ leqType t1 t2) (return v) $ {- else -} do-        -- A (most probably weaker) alternative is to just check syn.eq.-        -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do-        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 :: Comparison -> Level -> Level -> TCM ()-compareLevel CmpLeq u v = leqLevel u v-compareLevel CmpEq  u v = equalLevel u v--compareSort :: Comparison -> Sort -> Sort -> TCM ()-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 :: Sort -> Sort -> TCM ()-leqSort s1 s2 = catchConstraint (SortCmp CmpLeq s1 s2) $ do-  (s1,s2) <- reduce (s1,s2)-  let postpone = addConstraint (SortCmp CmpLeq s1 s2)-      no       = typeError $ NotLeqSort s1 s2-      yes      = return ()-  reportSDoc "tc.conv.sort" 30 $-    sep [ text "leqSort"-        , nest 2 $ fsep [ prettyTCM s1 <+> text "=<"-                        , prettyTCM s2 ]-        ]-  case (s1, s2) of--      (_       , Inf     ) -> yes--      (SizeUniv, _       ) -> equalSort s1 s2-      (_       , SizeUniv) -> equalSort s1 s2--      (Type a  , Type b  ) -> leqLevel a b--      (Prop    , Prop    ) -> yes-      (Prop    , Type _  ) -> yes-      (Type _  , Prop    ) -> no--      -- (SizeUniv, SizeUniv) -> yes-      -- (SizeUniv, _       ) -> no-      -- (_       , SizeUniv) -> no--      (Inf     , _       ) -> equalSort s1 s2-      (DLub{}  , _       ) -> postpone-      (_       , DLub{}  ) -> postpone--leqLevel :: Level -> Level -> TCM ()-leqLevel a b = liftTCM $ do-  reportSDoc "tc.conv.nat" 30 $-    text "compareLevel" <+>-      sep [ prettyTCM a <+> text "=<"-          , prettyTCM b ]-  -- Andreas, 2015-12-28 Issue 1757-  -- We normalize both sides to make the syntactic equality check (==) stronger.-  -- See case for `same term` below.-  a <- normalise a-  b <- normalise b-  leqView a b-  where-    -- Andreas, 2016-09-28-    -- If we have to postpone a constraint, then its simplified form!-    leqView a@(Max as) b@(Max bs) = catchConstraint (LevelCmp CmpLeq a b) $ do-      reportSDoc "tc.conv.nat" 30 $-        text "compareLevelView" <+>-          sep [ text (show a) <+> text "=<"-              , text (show b) ]-      wrap $ case (as, bs) of--        -- same term-        _ | as == bs -> ok--        -- 0 ≤ any-        ([], _) -> ok--        -- as ≤ 0-        (as, [])              -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]-        (as, [ClosedLevel 0]) -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]-           -- Andreas, 2016-09-28, @[ClosedLevel 0]@ is possible if we come from case-           -- "reduce constants" where we run @subtr@ on both sides.-           -- See test/Succeed/LevelMetaLeqZero.agda.--        -- as ≤ [b]-        (as@(_:_:_), [b]) -> sequence_ [ leqView (Max [a]) (Max [b]) | a <- as ]--        -- reduce constants-        (as, bs) | minN > 0 -> leqView (Max $ map (subtr minN) as) (Max $ map (subtr minN) bs)-          where-            ns = map constant as-            ms = map constant bs-            minN = minimum (ns ++ ms)--        -- remove subsumed-        -- Andreas, 2014-04-07: This is ok if we do not go back to equalLevel-        (as, bs)-          | not $ null subsumed -> leqView (Max $ as \\ subsumed) (Max bs)-          where-            subsumed = [ a | a@(Plus m l) <- as, n <- findN l, m <= n ]-            -- @findN a@ finds the unique(?) term @Plus n a@ in @bs@, if any.-            -- Andreas, 2014-04-07 Why must there be a unique term?-            findN a = case [ n | Plus n b <- bs, b == a ] of-                        [n] -> [n]-                        _   -> []--        -- Andreas, 2012-10-02 raise error on unsolvable constraint-        ([ClosedLevel n], [ClosedLevel m]) -> if n <= m then ok else notok--        -- closed ≤ bs-        ([ClosedLevel n], bs)-          | n <= maximum (map constant bs) -> ok--        -- as ≤ neutral-        (as, bs)-          | neutralB && maxA > maxB -> notok-          | neutralB && any (\a -> neutral a && not (isInB a)) as -> notok-          | neutralB && neutralA -> maybeok $ all (\a -> constant a <= findN a) as-          where-            maxA = maximum $ map constant as-            maxB = maximum $ map constant bs-            neutralA = all neutral as-            neutralB = all neutral bs-            isInB a = elem (unneutral a) $ map unneutral bs-            findN a = case [ n | b@(Plus n _) <- bs, unneutral b == unneutral a ] of-                        [n] -> n-                        _   -> __IMPOSSIBLE__--        -- 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-        _ -> postpone-      where-        ok       = return ()-        notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)-        postpone = patternViolation--        wrap m = catchError m $ \e ->-          case e of-            TypeError{} -> notok-            _           -> throwError e--        maybeok True = ok-        maybeok False = notok--        neutral (Plus _ NeutralLevel{}) = True-        neutral _                       = False--        meta (Plus _ MetaLevel{}) = True-        meta _                    = False--        unneutral (Plus _ (NeutralLevel _ v)) = v-        unneutral _ = __IMPOSSIBLE__--        constant (ClosedLevel n) = n-        constant (Plus n _)      = n--        subtr m (ClosedLevel n) = ClosedLevel (n - m)-        subtr m (Plus n l)      = Plus (n - m) l----     choice []     = patternViolation---     choice (m:ms) = noConstraints m `catchError` \_ -> choice ms---       case e of---         PatternErr{} -> choice ms---         _            -> throwError e--equalLevel :: Level -> Level -> TCM ()-equalLevel a b = do-  -- Andreas, 2013-10-31 Use normalization to make syntactic equality stronger-  (a, b) <- normalise (a, b)-  equalLevel' a b---- | Precondition: levels are 'normalise'd.-equalLevel' :: Level -> Level -> TCM ()-equalLevel' a b = do-  reportSLn "tc.conv.level" 50 $ "equalLevel (" ++ show a ++ ") (" ++ show b ++ ")"-  liftTCM $ catchConstraint (LevelCmp CmpEq a b) $-    check a b-  where-    check a@(Max as) b@(Max bs) = do-      -- Jesper, 2014-02-02 remove terms that certainly do not contribute-      -- to the maximum-      as <- return $ [ a | a <- as, not $ a `isStrictlySubsumedBy` bs ]-      bs <- return $ [ b | b <- bs, not $ b `isStrictlySubsumedBy` as ]-      -- 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-      as <- return $ List.sort $ closed0 as-      bs <- return $ List.sort $ closed0 bs-      reportSDoc "tc.conv.level" 40 $-        sep [ text "equalLevel"-            , vcat [ nest 2 $ sep [ prettyTCM a <+> text "=="-                                  , prettyTCM b-                                  ]-                   , text "reduced"-                   , nest 2 $ sep [ prettyTCM (Max as) <+> text "=="-                                  , prettyTCM (Max bs)-                                  ]-                   ]-            ]-      reportSDoc "tc.conv.level" 50 $-        sep [ text "equalLevel"-            , vcat [ nest 2 $ sep [ text (show (Max as)) <+> text "=="-                                  , text (show (Max bs))-                                  ]-                   ]-            ]-      case (as, bs) of-        _ | as == bs -> ok-          | any isBlocked (as ++ bs) -> do-              lvl <- levelType-              liftTCM $ useInjectivity CmpEq lvl (Level a) (Level b)--        -- closed == closed-        ([ClosedLevel n], [ClosedLevel m])-          | n == m    -> ok-          | otherwise -> notok--        -- closed == neutral-        ([ClosedLevel{}], _) | any isNeutral bs -> notok-        (_, [ClosedLevel{}]) | any isNeutral as -> notok--        -- 0 == any-        ([ClosedLevel 0], bs@(_:_:_)) -> sequence_ [ equalLevel' (Max []) (Max [b]) | b <- bs ]-        (as@(_:_:_), [ClosedLevel 0]) -> sequence_ [ equalLevel' (Max [a]) (Max []) | a <- as ]-        -- Andreas, 2014-04-07 Why should the following be ok?-        --   X (suc a)  could be different from  X (suc (suc a))-        -- -- Same meta-        -- ([Plus n (MetaLevel x _)], [Plus m (MetaLevel y _)])-        --   | n == m && x == y -> ok--        -- meta == any-        ([Plus n (MetaLevel x as)], _)-          | any (isThisMeta x) bs -> postpone-        (_, [Plus n (MetaLevel x bs)])-          | any (isThisMeta x) as -> postpone-        ([Plus n (MetaLevel x as')], [Plus m (MetaLevel y bs')])-            -- lexicographic comparison intended!-          | (n, y) < (m, x)            -> meta n x as' bs-          | otherwise                  -> meta m y bs' as-        ([Plus n (MetaLevel x as')],_) -> meta n x as' bs-        (_,[Plus m (MetaLevel y bs')]) -> meta m y bs' as--        -- any other metas-        -- Andreas, 2013-10-31: There could be metas in neutral levels (see Issue 930).-        -- Should not we postpone there as well?  Yes!-        _ | any hasMeta (as ++ bs) -> postpone--        -- neutral/closed == neutral/closed-        _ | all isNeutralOrClosed (as ++ bs) -> do-          reportSLn "tc.conv.level" 60 $ "equalLevel: all are neutral or closed"-          if length as == length bs-            then zipWithM_ (\a b -> [a] =!= [b]) as bs-            else notok--        -- more cases?-        _ -> postpone--      where-        a === b   = unlessM typeInType $ do-            lvl <- levelType-            equalAtom lvl a b-        as =!= bs = levelTm (Max as) === levelTm (Max bs)--        ok       = return ()-        notok    = unlessM typeInType notOk-        notOk    = typeError $ UnequalSorts (Type a) (Type b)-        postpone = do-          reportSLn "tc.conv.level" 30 $ "postponing: " ++ show a ++ " == " ++ show b-          patternViolation--        closed0 [] = [ClosedLevel 0]-        closed0 as = as--        -- perform assignment (Plus n (MetaLevel x as)) := bs-        meta n x as bs = do-          reportSLn "tc.meta.level" 30 $ "Assigning meta level"-          reportSLn "tc.meta.level" 50 $ "meta " ++ show as ++ " " ++ show bs-          bs' <- mapM (subtr n) bs-          assignE DirEq x as (levelTm (Max bs')) (===) -- fallback: check equality as atoms--        -- Make sure to give a sensible error message-        wrap m = m `catchError` \err ->-          case err of-            TypeError{} -> notok-            _           -> throwError err--        subtr n (ClosedLevel m)-          | m >= n    = return $ ClosedLevel (m - n)-          | otherwise = ifM typeInType (return $ ClosedLevel 0) $ notOk-        subtr n (Plus m a)-          | m >= n    = return $ Plus (m - n) a-        subtr _ (Plus _ BlockedLevel{}) = postpone-        subtr _ (Plus _ MetaLevel{})    = postpone-        subtr _ (Plus _ NeutralLevel{}) = postpone-        subtr _ (Plus _ UnreducedLevel{}) = __IMPOSSIBLE__--        isNeutral (Plus _ NeutralLevel{}) = True-        isNeutral _                       = False--        isClosed ClosedLevel{} = True-        isClosed _             = False--        isNeutralOrClosed l = isClosed l || isNeutral l--        isBlocked (Plus _ BlockedLevel{}) = True-        isBlocked _                       = False--        hasMeta ClosedLevel{}               = False-        hasMeta (Plus _ MetaLevel{})        = True-        hasMeta (Plus _ (BlockedLevel _ v)) = not $ null $ allMetas v-        hasMeta (Plus _ (NeutralLevel _ v)) = not $ null $ allMetas v-        hasMeta (Plus _ (UnreducedLevel v)) = not $ null $ allMetas v--        isThisMeta x (Plus _ (MetaLevel y _)) = x == y-        isThisMeta _ _                      = False--        constant (ClosedLevel n) = n-        constant (Plus n _)      = n--        (ClosedLevel m) `isStrictlySubsumedBy` [] = m == 0-        (ClosedLevel m) `isStrictlySubsumedBy` ys = m < maximum (map constant ys)-        (Plus m x)      `isStrictlySubsumedBy` ys = not $ null $-          [ n | Plus n y <- ys, x == y, m < n ]----- | Check that the first sort equal to the second.-equalSort :: Sort -> Sort -> TCM ()-equalSort s1 s2 = do-    catchConstraint (SortCmp CmpEq s1 s2) $ do-        (s1,s2) <- reduce (s1,s2)-        let postpone = addConstraint (SortCmp CmpEq s1 s2)-            yes      = return ()-            no       = unlessM typeInType $ typeError $ UnequalSorts s1 s2--            -- Test whether a level is infinity.-            isInf ClosedLevel{}   = no-            isInf (Plus _ l) = case l of-              MetaLevel x es -> assignE DirEq x es (Sort Inf) $ equalAtom topSort-                -- Andreas, 2015-02-14-                -- This seems to be a hack, as a level meta is instantiated-                -- by a sort.-              NeutralLevel _ v -> case ignoreSharing v of-                Sort Inf -> yes-                _        -> no-              _ -> no--            -- Equate a level with SizeUniv.-            eqSizeUniv l0 = case l0 of-              Plus 0 l -> case l of-                MetaLevel x es -> assignE DirEq x es (Sort SizeUniv) $ equalAtom topSort-                NeutralLevel _ v -> case ignoreSharing v of-                  Sort SizeUniv -> yes-                  _ -> no-                _ -> no-              _ -> no--        reportSDoc "tc.conv.sort" 30 $ sep-          [ text "equalSort"-          , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> text "=="-                                 , prettyTCM s2 ]-                 , nest 2 $ fsep [ text (show s1) <+> text "=="-                                 , text (show s2) ]-                 ]-          ]--        case (s1, s2) of--            (Type a  , Type b  ) -> equalLevel a b--            (SizeUniv, SizeUniv) -> yes-            (SizeUniv, Type (Max as@(_:_))) -> mapM_ eqSizeUniv as-            (Type (Max as@(_:_)), SizeUniv) -> mapM_ eqSizeUniv as-            (SizeUniv, _       ) -> no-            (_       , SizeUniv) -> no--            (Prop    , Prop    ) -> yes-            (Type _  , Prop    ) -> no-            (Prop    , Type _  ) -> no--            (Inf     , Inf     )             -> yes-            (Inf     , Type (Max as@(_:_)))  -> mapM_ isInf as-            (Type (Max as@(_:_)), Inf)       -> mapM_ isInf as-            -- Andreas, 2014-06-27:-            -- @Type (Max [])@ (which is Set0) falls through to error.-            (Inf     , _       )             -> no-            (_       , Inf     )             -> no--            -- Andreas, 2014-06-27:  Why are there special cases for Set0?-            -- Andreas, 2015-02-14:  Probably because s ⊔ s' = Set0-            -- entailed that both s and s' are Set0.-            -- This is no longer true if  SizeUniv ⊔ s = s--            -- (DLub s1 s2, s0@(Type (Max []))) -> do-            --   equalSort s1 s0-            --   underAbstraction_ s2 $ \s2 -> equalSort s2 s0-            -- (s0@(Type (Max [])), DLub s1 s2) -> do-            --   equalSort s0 s1-            --   underAbstraction_ s2 $ \s2 -> equalSort s0 s2--            (DLub{}  , _       )             -> postpone-            (_       , DLub{}  )             -> postpone-------------------------------------------------------------------------------- * Definitions------------------------------------------------------------------------------bothAbsurd :: QName -> QName -> TCM Bool-bothAbsurd f f'-  | isAbsurdLambdaName f, isAbsurdLambdaName f' = do-      def  <- getConstInfo f-      def' <- getConstInfo f'-      case (theDef def, theDef def') of-        (Function{ funCompiled = Just Fail},-         Function{ funCompiled = Just Fail}) -> return True+{-# 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)++---------------------------------------------------------------------------+-- * Definitions+---------------------------------------------------------------------------++bothAbsurd :: MonadConversion m => QName -> QName -> m Bool+bothAbsurd f f'+  | isAbsurdLambdaName f, isAbsurdLambdaName f' = do+      -- Double check we are really dealing with absurd lambdas:+      -- Their functions should not have bodies.+      def  <- getConstInfo f+      def' <- getConstInfo f'+      case (theDef def, theDef def') of+        (Function{ funClauses = [Clause{ clauseBody = Nothing }] },+         Function{ funClauses = [Clause{ clauseBody = Nothing }] }) -> return True         _ -> return False   | otherwise = return False
src/full/Agda/TypeChecking/Conversion.hs-boot view
@@ -1,18 +1,38 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Conversion where +import Control.Monad.Except ( MonadError )+ import Agda.Syntax.Internal import Agda.TypeChecking.Monad+import Agda.TypeChecking.Warnings -compareTerm  :: Comparison -> Type -> Term -> Term -> TCM ()-compareAtom  :: Comparison -> Type -> Term -> Term -> TCM ()-compareArgs  :: [Polarity] -> Type -> Term -> Args -> Args -> TCM ()-compareElims :: [Polarity] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()-compareType  :: Comparison -> Type -> Type -> TCM ()-compareTel   :: Type -> Type -> Comparison -> Telescope -> Telescope -> TCM ()-compareSort  :: Comparison -> Sort -> Sort -> TCM ()-compareLevel :: Comparison -> Level -> Level -> TCM ()-equalTerm    :: Type -> Term -> Term -> TCM ()-equalType    :: Type -> Type -> TCM ()-equalSort    :: Sort -> Sort -> TCM ()-leqType      :: Type -> Type -> TCM ()+type MonadConversion m =+  ( PureTCM m+  , MonadConstraint m+  , MonadMetaSolver m+  , MonadError TCErr m+  , MonadWarning m+  , MonadStatistics m+  , MonadFresh ProblemId m+  , MonadFresh Int m+  )++compareTerm  :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()+compareAs    :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()+compareAtom  :: MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareArgs  :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()+compareElims :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()+compareType  :: MonadConversion m => Comparison -> Type -> Type -> m ()+compareSort  :: MonadConversion m => Comparison -> Sort -> Sort -> m ()+compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()+equalTerm    :: MonadConversion m => Type -> Term -> Term -> m ()+equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()+equalType    :: MonadConversion m => Type -> Type -> m ()+equalSort    :: MonadConversion m => Sort -> Sort -> m ()+equalLevel   :: MonadConversion m => Level -> Level -> m ()+leqType      :: MonadConversion m => Type -> Type -> m ()+leqLevel     :: MonadConversion m => Level -> Level -> m ()+leqSort      :: MonadConversion m => Sort -> Sort -> m ()
+ src/full/Agda/TypeChecking/Conversion/Pure.hs view
@@ -0,0 +1,192 @@++module Agda.TypeChecking.Conversion.Pure where++import Control.Monad.Except+import Control.Monad.State++import Data.String++import Agda.Syntax.Common+import Agda.Syntax.Internal++import {-# SOURCE #-} Agda.TypeChecking.Conversion+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce (isBlocked)+import Agda.TypeChecking.Warnings++import Agda.Utils.Maybe+import Agda.Utils.Null++import Agda.Utils.Impossible++data FreshThings = FreshThings+  { freshInt       :: Int+  , freshProblemId :: ProblemId+  , freshNameId    :: NameId+  }++newtype PureConversionT m a = PureConversionT+  { 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)+  => PureConversionT m a -> m (Maybe a)+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+  case result of+    Left (PatternErr block)+     | 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++deriving instance MonadFail       m => MonadFail       (PureConversionT m)+deriving instance HasBuiltins     m => HasBuiltins     (PureConversionT m)+deriving instance HasConstInfo    m => HasConstInfo    (PureConversionT m)+deriving instance HasOptions      m => HasOptions      (PureConversionT m)+deriving instance MonadTCEnv      m => MonadTCEnv      (PureConversionT m)+deriving instance ReadTCState     m => ReadTCState     (PureConversionT m)+deriving instance MonadReduce     m => MonadReduce     (PureConversionT m)+deriving instance MonadAddContext m => MonadAddContext (PureConversionT m)+deriving instance MonadDebug      m => MonadDebug      (PureConversionT m)++instance (Monad m, Semigroup a) => Semigroup (PureConversionT m a) where+  d1 <> d2 = (<>) <$> d1 <*> d2++instance (IsString a, Monad m) => IsString (PureConversionT m a) where+  fromString s = return (fromString s)++instance Monad m => Null (PureConversionT m Doc) where+  empty = return empty+  null = __IMPOSSIBLE__++instance Monad m => MonadBlock (PureConversionT m) where+  patternViolation = throwError . PatternErr+  catchPatternErr handle m = m `catchError` \case+    PatternErr b -> handle b+    err          -> throwError err+++instance PureTCM m => MonadConstraint (PureConversionT m) where+  addConstraint u _ = patternViolation u+  addAwakeConstraint u _ = patternViolation u+  solveConstraint c = patternViolation alwaysUnblock  -- TODO: does this happen?+  solveSomeAwakeConstraints _ _ = return ()+  wakeConstraints _ = return ()+  stealConstraints _ = return ()+  modifyAwakeConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen?+  modifySleepingConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen?++instance PureTCM m => MonadMetaSolver (PureConversionT m) where+  newMeta' _ _ _ _ _ _ = patternViolation alwaysUnblock  -- TODO: does this happen?+  assignV _ m _ v _ = do+    bv <- isBlocked v+    let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta m+    patternViolation blocker+  assignTerm' m _ v = do+    bv <- isBlocked v+    let blocker = caseMaybe bv id unblockOnEither $ unblockOnMeta m+    patternViolation blocker+  etaExpandMeta _ _ = return ()+  updateMetaVar _ _ = patternViolation alwaysUnblock  -- TODO: does this happen?+  speculateMetas fallback m = m >>= \case+    KeepMetas     -> return ()+    RollBackMetas -> fallback++instance PureTCM m => MonadInteractionPoints (PureConversionT m) where+  freshInteractionId = patternViolation alwaysUnblock  -- TODO: does this happen?+  modifyInteractionPoints _ = patternViolation alwaysUnblock  -- TODO: does this happen?++-- This is a bogus instance that promptly forgets all concrete names,+-- but we don't really care+instance ReadTCState m => MonadStConcreteNames (PureConversionT m) where+  runStConcreteNames m = do+    concNames <- useR stConcreteNames+    fst <$> runStateT m concNames++instance PureTCM m => MonadWarning (PureConversionT m) where+  addWarning _enabled w = case classifyWarning (tcWarning w) of+    ErrorWarnings -> patternViolation neverUnblock+    AllWarnings   -> return ()++instance ReadTCState m => MonadStatistics (PureConversionT m) where+  modifyCounter _ _ = return ()++instance Monad m => MonadFresh ProblemId (PureConversionT m) where+  fresh = do+    i <- gets freshProblemId+    modify $ \f -> f { freshProblemId = i + 1 }+    return i++instance Monad m => MonadFresh NameId (PureConversionT m) where+  fresh = do+    i <- gets freshNameId+    modify $ \f -> f { freshNameId = succ i }+    return i++instance Monad m => MonadFresh Int (PureConversionT m) where+  fresh = do+    i <- gets freshInt+    modify $ \f -> f { freshInt = i + 1 }+    return i
src/full/Agda/TypeChecking/Coverage.hs view
@@ -1,854 +1,1549 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE NondecreasingIndentation #-}--{-| Coverage checking, case splitting, and splitting for refine tactics.-- -}--module Agda.TypeChecking.Coverage-  ( SplitClause(..), clauseToSplitClause, fixTarget-  , Covering(..), splitClauses-  , coverageCheck-  , isCovered-  , splitClauseWithAbsurd-  , splitLast-  , splitResult-  , normaliseProjP-  ) where--import Prelude hiding (null)--import Control.Monad-import Control.Monad.Trans ( lift )--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative hiding (empty)-#endif--import Data.List hiding (null)-import Data.Monoid (Any(..))-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--import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Exception--import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)-import Agda.TypeChecking.Rules.LHS.Unify--import Agda.TypeChecking.Coverage.Match-import Agda.TypeChecking.Coverage.SplitTree--import Agda.TypeChecking.Datatypes (getConForm)-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Records-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.MetaVars--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.Size-import Agda.Utils.Tuple-import Agda.Utils.Lens--#include "undefined.h"-import Agda.Utils.Impossible--data SplitClause = SClause-  { scTel    :: Telescope-    -- ^ Type of variables in @scPats@.-  , scPats   :: [NamedArg DeBruijnPattern]-    -- ^ The patterns leading to the currently considered branch of-    --   the split tree.-  , scSubst  :: PatternSubstitution-    -- ^ 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.-  , scModuleParameterSub :: ModuleParamDict-    -- ^ We need to keep track of the module parameter substitutions for the-    -- clause for the purpose of inferring missing instance clauses.-  , scTarget :: Maybe (Arg Type)-    -- ^ The type of the rhs, living in context 'scTel'.-    --   This invariant is broken before calls to 'fixTarget';-    --   there, 'scTarget' lives in the old context.-    --   'fixTarget' moves 'scTarget' to the new context 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 :: [(QName, SplitClause)]-      -- ^ Covering clauses, indexed by constructor 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   = namedClausePats cl-  , scSubst  = idS  -- Andreas, 2014-07-15  TODO: Is this ok?-  , scModuleParameterSub = Map.empty-  , scTarget = clauseType cl-  }--type CoverM = ExceptionT SplitError TCM---- | Top-level function for checking pattern coverage.-coverageCheck :: QName -> Type -> [Clause] -> TCM SplitTree-coverageCheck f t cs = do-  TelV gamma a <- telView t-  let -- n             = arity-      -- xs            = variable patterns fitting lgamma-      n            = size gamma-      xs           =  map (setOrigin Inserted) $ teleNamedArgs gamma-      -- The initial module parameter substitutions need to be weakened by the-      -- number of arguments that aren't module parameters.-  fv           <- getDefFreeVars f-  moduleParams <- raise (n - fv) <$> use stModuleParameters-      -- construct the initial split clause-  let sc = SClause gamma xs idS moduleParams $ Just $ defaultArg a--  reportSDoc "tc.cover.top" 10 $ do-    let prCl cl = addContext (clauseTel cl) $-                  prettyTCMPatternList $ namedClausePats cl-    vcat-      [ text $ "Coverage checking " ++ show f ++ " with patterns:"-      , nest 2 $ vcat $ map prCl cs-      ]--  -- used = actually used clauses for cover-  -- pss  = uncovered cases-  (splitTree, used, pss) <- cover f cs sc-  reportSDoc "tc.cover.splittree" 10 $ vcat-    [ text "generated split tree for" <+> prettyTCM f-    , text $ show splitTree-    ]-  -- report an error if there are uncovered cases-  unless (null pss) $-      setCurrentRange cs $-        typeError $ CoverageFailure f pss-  -- is = indices of unreachable clauses-  let is = Set.toList $ Set.difference (Set.fromList [0..genericLength cs - 1]) used-  -- report an error if there are unreachable clauses-  unless (null is) $ do-      let unreached = map (cs !!) is-      setCurrentRange unreached $-        typeError $ UnreachableClauses f $ map namedClausePats unreached-  return splitTree---- | Top-level function for eliminating redundant clauses in the interactive---   case splitter-isCovered :: QName -> [Clause] -> SplitClause -> TCM Bool-isCovered f cs sc = do-  (_, _, missing) <- cover f cs sc-  return $ null missing---- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@.---   checks that the list of clauses @cs@ covers the given split clause.---   Returns the @splitTree@, the @used@ clauses, and missing cases @pss@.-cover :: QName -> [Clause] -> SplitClause ->-         TCM (SplitTree, Set Nat, [[NamedArg DeBruijnPattern]])-cover f cs sc@(SClause tel ps _ _ target) = do-  reportSDoc "tc.cover.cover" 10 $ vcat-    [ text "checking coverage of pattern:"-    , nest 2 $ text "tel  =" <+> prettyTCM tel-    , nest 2 $ text "ps   =" <+> do addContext tel $ prettyTCMPatternList ps-    ]-  exactSplitEnabled <- optExactSplit <$> pragmaOptions-  cs' <- normaliseProjP cs-  case match cs' ps of-    Yes (i,(mps,ls0))-     | not exactSplitEnabled || (clauseCatchall (cs !! i) || all isTrivialPattern mps)-     -> do-      reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i-      -- Check if any earlier clauses could match with appropriate literals-      let lsis = mapMaybe (\(j,c) -> (,j) <$> matchLits c ps) $ zip [0..i-1] cs-      reportSLn "tc.cover.cover"  10 $ "literal matches: " ++ show lsis-      -- Andreas, 2016-10-08, issue #2243 (#708)-      -- If we have several literal matches with the same literals-      -- only take the first matching clause of these.-      let is = Map.elems $ Map.fromListWith min $ (ls0,i) : lsis-      return (SplittingDone (size tel), Set.fromList is, [])--     | otherwise -> do-         reportSDoc "tc.cover.cover" 10 $ vcat-           [ text $ "pattern covered by clause " ++ show i ++ " but case splitting was not exact. remaining mpats: "-           , nest 2 $ vcat $ map (text . show) mps-           ]-         setCurrentRange (cs !! i) $-           typeError $ CoverageNoExactSplit f (cs !! i)--    No        ->  do-      reportSLn "tc.cover" 20 $ "pattern is not covered"-      case fmap getHiding target of-        Just h | h == Instance -> do-          -- Ulf, 2016-10-31: For now we only infer instance clauses. It would-          -- make sense to do it also for hidden, but since the value of a-          -- hidden clause is expected to be forced by later clauses, it's too-          -- late to add it now. If it was inferrable we would have gotten a-          -- type error before getting to this point.-          inferMissingClause f sc-          return (SplittingDone (size tel), Set.empty, [])-        _ -> return (SplittingDone (size tel), Set.empty, [ps])--    -- We need to split!-    -- If all clauses have an unsplit copattern, we try that first.-    Block res bs -> tryIf (getAny res) splitRes $ do-      let done = return (SplittingDone (size tel), Set.empty, [ps])-      if null bs then done else do-      -- Otherwise, if there are variables to split, we try them-      -- in the order determined by a split strategy.-      reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++ show bs-      -- xs is a non-empty lists of blocking variables-      -- try splitting on one of them-      xs <- splitStrategy bs tel-      r <- altM1 (split Inductive sc) xs-      case r of-        Left err  -> case err of-          CantSplit c tel us vs   -> typeError $ CoverageCantSplitOn c tel us vs-          NotADatatype a          -> enterClosure a $ typeError . CoverageCantSplitType-          IrrelevantDatatype a    -> enterClosure a $ typeError . CoverageCantSplitIrrelevantType-          CoinductiveDatatype a   -> enterClosure a $ typeError . CoverageCantSplitType-{- UNUSED-          NoRecordConstructor a   -> typeError $ CoverageCantSplitType a- -}-          GenericSplitError s     -> fail $ "failed to split: " ++ s-        -- If we get the empty covering, we have reached an impossible case-        -- and are done.-        Right (Covering n []) ->-          return (SplittingDone (size tel), Set.empty, [])-        Right (Covering n scs) -> do-          (trees, useds, psss) <- unzip3 <$> mapM (cover f cs) (map snd scs)-          -- Jesper, 2016-03-10  We need to remember which variables were-          -- eta-expanded by the unifier in order to generate a correct split-          -- tree (see Issue 1872).-          reportSDoc "tc.cover.split.eta" 60 $ vcat-            [ text "etaRecordSplits"-            , nest 2 $ vcat-              [ text "n   = " <+> text (show n)-              , text "scs = " <+> prettyTCM scs-              , text "ps  = " <+> text (show ps)-              ]-            ]-          let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees-              tree   = SplitAt n trees'-          return (tree, Set.unions useds, concat psss)--  where-    tryIf :: Monad m => Bool -> m (Maybe a) -> m a -> m a-    tryIf True  me m = fromMaybeM m me-    tryIf False me m = m--    -- Try to split result-    splitRes :: TCM (Maybe (SplitTree, Set Nat, [[NamedArg DeBruijnPattern]]))-    splitRes = do-      reportSLn "tc.cover" 20 $ "blocked by projection pattern"-      -- forM is a monadic map over a Maybe here-      mcov <- splitResult f sc-      Trav.forM mcov $ \ (Covering n scs) -> do-        -- If result splitting was successful, continue coverage checking.-        (projs, (trees, useds, psss)) <- mapSnd unzip3 . unzip <$> do-          mapM (traverseF $ cover f cs <=< (snd <.> fixTarget)) scs-          -- OR:-          -- forM scs $ \ (proj, sc') -> (proj,) <$> do-          --   cover f cs =<< do-          --     snd <$> fixTarget sc'-        let tree = SplitAt n $ zip projs trees-        return (tree, Set.unions useds, concat psss)--    gatherEtaSplits :: Int -> SplitClause-                    -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]-    gatherEtaSplits n sc []-       | n >= 0    = __IMPOSSIBLE__ -- we should have encountered the main-                                    -- split by now already-       | otherwise = []-    gatherEtaSplits n sc (p:ps) = case namedArg p of-      VarP x-       | n == 0    -> case p' of -- this is the main split-           VarP  _      -> __IMPOSSIBLE__-           DotP  _      -> __IMPOSSIBLE__-           ConP  _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps-           LitP  _      -> __IMPOSSIBLE__-           ProjP{}      -> __IMPOSSIBLE__-       | otherwise ->-           updateNamedArg (\ _ -> p') p : gatherEtaSplits (n-1) sc ps-        where p' = lookupS (scSubst sc) $ dbPatVarIndex x-      DotP  _      -> p : gatherEtaSplits (n-1) sc ps -- count dot patterns-      ConP  _ _ qs -> gatherEtaSplits n sc (qs ++ ps)-      LitP  _      -> gatherEtaSplits n sc ps-      ProjP{}      -> gatherEtaSplits n sc ps--    addEtaSplits :: Int -> [NamedArg DeBruijnPattern] -> 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-      ConP c cpi qs -> SplitAt (p $> k) [(conName c , addEtaSplits k (qs ++ ps) t)]-      LitP  _       -> __IMPOSSIBLE__-      ProjP{}       -> __IMPOSSIBLE__--    etaRecordSplits :: Int -> [NamedArg DeBruijnPattern] -> (QName,SplitClause)-                    -> SplitTree -> (QName,SplitTree)-    etaRecordSplits n ps (q , sc) t =-      (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)--inferMissingClause :: QName -> SplitClause -> TCM ()-inferMissingClause f (SClause tel ps _ mpsub (Just t)) = setCurrentRange f $ do-  reportSDoc "tc.cover.infer" 20 $ addContext tel $ text "Trying to infer right-hand side of type" <+> prettyTCM t-  cl <- addContext tel $ withModuleParameters mpsub $ do-    (x, rhs) <- case getHiding t of-                  Instance  -> newIFSMeta "" (unArg t)-                  Hidden    -> __IMPOSSIBLE__-                  NotHidden -> __IMPOSSIBLE__-    return $ Clause { clauseRange     = noRange-                    , clauseTel       = tel-                    , namedClausePats = ps-                    , clauseBody      = Just rhs-                    , clauseType      = Just t-                    , clauseCatchall  = False }-  addClauses f [cl]-inferMissingClause _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__--splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars-splitStrategy bs tel = return $ updateLast clearBlockingVarCons xs-  -- Make sure we do not insists on precomputed coverage when-  -- we make our last try to split.-  -- Otherwise, we will not get a nice error message.-  where-    xs       = bs-{- KEEP!---  Andreas, 2012-10-13---  The following split strategy which prefers all-constructor columns---  fails on test/fail/CoverStrategy-    xs       = ys ++ zs-    (ys, zs) = partition allConstructors bs-    allConstructors :: BlockingVar -> Bool-    allConstructors = isJust . snd--}---- | Check that a type is a non-irrelevant datatype or a record with--- named constructor. Unless the 'Induction' argument is 'CoInductive'--- the data type must be inductive.-isDatatype :: (MonadTCM tcm, MonadException SplitError tcm) =>-              Induction -> Dom Type ->-              tcm (QName, [Arg Term], [Arg Term], [QName])-isDatatype ind at = do-  let t       = unDom at-      throw f = throwException . f =<< do liftTCM $ buildClosure t-  t' <- liftTCM $ reduce t-  case ignoreSharing $ unEl t' of-    Def d es -> do-      let ~(Just args) = allApplyElims es-      def <- liftTCM $ theDef <$> getConstInfo d-      splitOnIrrelevantDataAllowed <- liftTCM $ optExperimentalIrrelevance <$> pragmaOptions-      case def of-        Datatype{dataPars = np, dataCons = cs, dataInduction = i}-          | i == CoInductive && ind /= CoInductive ->-              throw CoinductiveDatatype-          -- Andreas, 2011-10-03 allow some splitting on irrelevant data (if only one constr. matches)-          | isIrrelevant at && not splitOnIrrelevantDataAllowed ->-              throw IrrelevantDatatype-          | otherwise -> do-              let (ps, is) = genericSplitAt np args-              return (d, ps, is, cs)-        Record{recPars = np, recConHead = con, recInduction = i}-          | i == Just CoInductive && ind /= CoInductive ->-              throw CoinductiveDatatype-          | otherwise ->-              return (d, args, [], [conName con])-        _ -> throw NotADatatype-    _ -> throw NotADatatype---- | Update the target type, add more patterns to split clause---   if target becomes a function type.---   Returns the domains of the function type (if any).-fixTarget :: SplitClause -> TCM (Telescope, SplitClause)-fixTarget sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scModuleParameterSub = mpsub, scTarget = target } =-  caseMaybe target (return (empty, sc)) $ \ a -> do-    reportSDoc "tc.cover.target" 20 $ sep-      [ text "split clause telescope: " <+> prettyTCM sctel-      , text "old patterns          : " <+> do-          addContext sctel $ prettyTCMPatternList ps-      ]-    reportSDoc "tc.cover.target" 60 $ sep-      [ text "substitution          : " <+> text (show sigma)-      ]-    reportSDoc "tc.cover.target" 30 $ sep-      [ text "target type before substitution (variables may be wrong): " <+> do-          addContext sctel $ prettyTCM a-      ]-    TelV tel b <- telView $ applyPatSubst sigma $ unArg a-    reportSDoc "tc.cover.target" 15 $ sep-      [ text "target type telescope (after substitution): " <+> do-          addContext sctel $ prettyTCM tel-      , text "target type core      (after substitution): " <+> do-          addContext sctel $ addContext tel $ prettyTCM b-      ]-    let n         = size tel-        -- Andreas, 2016-10-04 issue #2236-        -- Need to set origin to "Inserted" to avoid printing of hidden patterns.-        xs        = map (setOrigin Inserted) $ teleNamedArgs tel-        -- Compute new split clause-        sctel'    = telFromList $ telToList (raise n sctel) ++ telToList tel-        -- Dot patterns in @ps@ need to be raised!  (Issue 1298)-        ps'       = applySubst (raiseS n) ps ++ xs-        newTarget = Just $ a $> b-        sc'       = SClause-          { scTel    = sctel'-          , scPats   = ps'-          , scSubst  = wkS n $ sigma -- Should be wkS instead of liftS since-                                     -- variables are only added to new tel.-          , scModuleParameterSub = applySubst (raiseS n) mpsub-          , scTarget = newTarget-          }-    -- Separate debug printing to find cause of crash (Issue 1374)-    reportSDoc "tc.cover.target" 30 $ sep-      [ text "new split clause telescope   : " <+> prettyTCM sctel'-      ]-    reportSDoc "tc.cover.target" 30 $ sep-      [ text "new split clause patterns    : " <+> do-          addContext sctel' $ prettyTCMPatternList ps'-      ]-    reportSDoc "tc.cover.target" 60 $ sep-      [ text "new split clause substitution: " <+> text (show $ scSubst sc')-      ]-    reportSDoc "tc.cover.target" 30 $ sep-      [ text "new split clause target      : " <+> do-          addContext sctel' $ prettyTCM $ fromJust newTarget-      ]-    reportSDoc "tc.cover.target" 20 $ sep-      [ text "new split clause"-      , prettyTCM sc'-      ]-    return $ if n == 0 then (empty, sc { scTarget = newTarget }) else (tel, sc')---- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps mpsub con@------   @---      delta1   Telescope before split point---      n        Name of pattern variable at split point---      delta2   Telescope after split point---      d        Name of datatype to split at---      pars     Data type parameters---      ixs      Data type indices---      hix      Index of split variable---      tel      Telescope for patterns ps---      ps       Patterns before doing the split---      mpsub    Current module parameter substitutions---      con      Constructor to fit into hole---   @---   @dtype == d pars ixs@-computeNeighbourhood-  :: Telescope                    -- ^ Telescope before split point.-  -> PatVarName                   -- ^ Name of pattern variable at split point.-  -> Telescope                    -- ^ Telescope after split point.-  -> QName                        -- ^ Name of datatype to split at.-  -> Args                         -- ^ Data type parameters.-  -> Args                         -- ^ Data type indices.-  -> Nat                          -- ^ Index of split variable.-  -> Telescope                    -- ^ Telescope for the patterns.-  -> [NamedArg DeBruijnPattern]   -- ^ Patterns before doing the split.-  -> ModuleParamDict              -- ^ Current module parameter substitution.-  -> QName                        -- ^ Constructor to fit into hole.-  -> CoverM (Maybe SplitClause)   -- ^ New split clause if successful.-computeNeighbourhood delta1 n delta2 d pars ixs hix tel ps mpsub c = do--  -- Get the type of the datatype-  dtype <- liftTCM $ (`piApply` pars) . defType <$> getConstInfo d--  -- Get the real constructor name-  con <- liftTCM $ getConForm c-  con <- return $ con { conName = c }  -- What if we restore the current name?-                                       -- Andreas, 2013-11-29 changes nothing!-{--  con <- conSrcCon . theDef <$> getConstInfo con-  Con con ci [] <- liftTCM $ ignoreSharing <$> (constructorForm =<< normalise (Con con ci []))--}--  -- Get the type of the constructor-  ctype <- liftTCM $ defType <$> getConInfo con--  -- Lookup the type of the constructor at the given parameters-  (gamma0, cixs) <- do-    TelV gamma0 (El _ d) <- liftTCM $ telView (ctype `piApply` pars)-    let Def _ es = ignoreSharing d-        Just cixs = allApplyElims es-    return (gamma0, cixs)--  -- Andreas, 2012-02-25 preserve name suggestion for recursive arguments-  -- of constructor--  let preserve (x, t@(El _ (Def d' _))) | d == d' = (n, t)-      preserve (x, (El s (Shared p))) = preserve (x, El s $ derefPtr p)-      preserve p = p-      gammal = map (fmap preserve) . telToList $ gamma0-      gamma  = telFromList gammal-      delta1Gamma = delta1 `abstract` gamma--  debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix--  -- All variables are flexible-  let flex = allFlexVars delta1Gamma--  -- Unify constructor target and given type (in Δ₁Γ)-  let conIxs   = drop (size pars) cixs-      givenIxs = raise (size gamma) ixs--  r <- unifyIndices-         delta1Gamma-         flex-         (raise (size gamma) dtype)-         conIxs-         givenIxs--  case r of-    NoUnify {} -> debugNoUnify $> Nothing--    DontKnow{} -> do-      debugCantSplit-      throwException $ CantSplit (conName con) (delta1 `abstract` gamma) conIxs givenIxs-    Unifies (delta1',rho0,_) -> do-      debugSubst "rho0" rho0--      -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ-      let (rho1,rho2) = splitS (size gamma) rho0--      -- Andreas, 2015-05-01  I guess it is fine to use @noConPatternInfo@-      -- as the result of splitting is never used further down the pipeline.-      -- After splitting, Agda reloads the file.-      let conp    = ConP con noConPatternInfo $ applySubst rho2 $-                      map (setOrigin Inserted) $ tele2NamedArgs gamma0 gamma-          -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names--      -- Compute final context and substitution-      let rho3    = consS conp rho1            -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)-          delta2' = applyPatSubst rho3 delta2  -- Δ₂' = Δ₂ρ₃-          delta'  = delta1' `abstract` delta2' -- Δ'  = Δ₁'Δ₂'-          rho     = liftS (size delta2) rho3   -- Δ' ⊢ ρ : Δ₁(x:D)Δ₂--      debugTel "delta'" delta'-      debugSubst "rho" rho-      addContext tel $ debugPs ps--      -- Apply the substitution-      let ps' = applySubst rho ps-      addContext delta' $ debugPlugged ps'--      let mpsub' = applySubst (fromPatternSubstitution rho) mpsub--      return $ Just $ SClause delta' ps' rho mpsub' Nothing -- target fixed later--  where-    debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix =-      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ vcat-        [ text "computeNeighbourhood"-        , nest 2 $ vcat-          [ text "context=" <+> (inTopContext . prettyTCM =<< getContextTelescope)-          , text "con    =" <+> prettyTCM con-          , text "ctype  =" <+> prettyTCM ctype-          , text "ps     =" <+> do addContext tel $ prettyTCMPatternList ps-          , text "d      =" <+> prettyTCM d-          , text "pars   =" <+> prettyList (map prettyTCM pars)-          , text "ixs    =" <+> addContext delta1 (prettyList (map prettyTCM ixs))-          , text "cixs   =" <+> do addContext gamma $ prettyList (map prettyTCM cixs)-          , text "delta1 =" <+> prettyTCM delta1-          , text "delta2 =" <+> prettyTCM delta2-          , text "gamma  =" <+> prettyTCM gamma-          , text "hix    =" <+> text (show hix)-          ]-        ]--    debugNoUnify =-      liftTCM $ reportSLn "tc.cover.split.con" 20 "  Constructor impossible!"--    debugCantSplit =-      liftTCM $ reportSLn "tc.cover.split.con" 20 "  Bad split!"--    debugSubst s sub =-      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat-        [ text (s ++ " =") <+> prettyTCM sub-        ]--    debugTel s tel =-      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat-        [ text (s ++ " =") <+> prettyTCM tel-        ]--    debugPs ps =-      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat-        [ text "ps     =" <+> prettyTCMPatternList ps-        ]--    debugPlugged ps' =-      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat-        [ text "ps'    =" <+> do prettyTCMPatternList ps'-        ]---- | Entry point from @Interaction.MakeCase@.-splitClauseWithAbsurd :: SplitClause -> Nat -> TCM (Either SplitError (Either SplitClause Covering))-splitClauseWithAbsurd c x = split' Inductive False c (BlockingVar x Nothing)-  -- Andreas, 2016-05-03, issue 1950:-  -- Do not introduce trailing pattern vars after split,-  -- because this does not work for with-clauses.---- | Entry point from @TypeChecking.Empty@ and @Interaction.BasicOps@.---   @splitLast CoInductive@ is used in the @refine@ tactics.--splitLast :: Induction -> Telescope -> [NamedArg DeBruijnPattern] -> TCM (Either SplitError Covering)-splitLast ind tel ps = split ind sc (BlockingVar 0 Nothing)-  where sc = SClause tel ps empty empty Nothing---- | @split ind splitClause x = return res@---   splits @splitClause@ at pattern var @x@ (de Bruijn index).------   Possible results @res@ are:------   1. @Left err@:---      Splitting failed.------   2. @Right covering@:---      A covering set of split clauses, one for each valid constructor.---      This could be the empty set (denoting an absurd clause).--split :: Induction-         -- ^ Coinductive constructors are allowed if this argument is-         -- 'CoInductive'.-      -> SplitClause-      -> BlockingVar-      -> TCM (Either SplitError Covering)-split ind sc x = fmap blendInAbsurdClause <$> split' ind True sc x-  where-    n = lookupPatternVar sc $ blockingVarNo x-    blendInAbsurdClause :: Either SplitClause Covering -> Covering-    blendInAbsurdClause = fromRight (const $ Covering n [])---- | Convert a de Bruijn index relative to the clause telescope to a de Bruijn---   level. The result should be the argument position (counted from left,---   starting with 0) to split at (dot patterns included!).-lookupPatternVar :: SplitClause -> Int -> Arg Nat-lookupPatternVar SClause{ scTel = tel, scPats = pats } x = arg $>-    if n < 0 then __IMPOSSIBLE__ else n-  where n = if k < 0-            then __IMPOSSIBLE__-            else fromMaybe __IMPOSSIBLE__ $ permPicks perm !!! k-        perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm pats-        k = size tel - x - 1-        arg = telVars (size tel) tel !! k---- | @split' ind splitClause x = return res@---   splits @splitClause@ at pattern var @x@ (de Bruijn index).------   Possible results @res@ are:------   1. @Left err@:---      Splitting failed.------   2. @Right (Left splitClause')@:---      Absurd clause (type of @x@ has 0 valid constructors).------   3. @Right (Right covering)@:---      A covering set of split clauses, one for each valid constructor.--split' :: Induction-          -- ^ Coinductive constructors are allowed if this argument is-          -- 'CoInductive'.-       -> Bool-          -- ^ If 'True', introduce new trailing variable patterns via-          --   'fixTarget'.-       -> SplitClause-       -> BlockingVar-       -> TCM (Either SplitError (Either SplitClause Covering))-split' ind fixtarget sc@(SClause tel ps _ mpsub target) (BlockingVar x mcons) = liftTCM $ runExceptionT $ do--  debugInit tel x ps mpsub--  -- Split the telescope at the variable-  -- t = type of the variable,  Δ₁ ⊢ t-  (n, t, delta1, delta2) <- do-    let (tel1, Dom info (n, t) : tel2) = genericSplitAt (size tel - x - 1) $ telToList tel-    return (n, Dom info t, telFromList tel1, telFromList tel2)--  -- 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-  (d, pars, ixs, cons) <- inContextOfT $ isDatatype ind t--  -- Compute the neighbourhoods for the constructors-  ns <- catMaybes <$> do-    forM cons $ \ con ->-      fmap (con,) <$> do-        msc <- computeNeighbourhood delta1 n delta2 d pars ixs x tel ps mpsub con-        if not fixtarget then return msc else do-        Trav.forM msc $ \ sc -> lift $ snd <$> fixTarget sc{ scTarget = target }--  case ns of-    []  -> do-      let ps' = (fmap . fmap . fmap . fmap)-                  (\(DBPatVar name y) -> if (x==y)-                                         then DBPatVar absurdPatternName y-                                         else DBPatVar name y)-                  ps-      return $ Left $ SClause-               { scTel  = telFromList $ telToList delta1 ++-                                        [fmap ((,) "()") t] ++ -- add name "()"-                                        telToList delta2-               , scPats = ps-               , scSubst = idS -- not used anyway-               , scModuleParameterSub = __IMPOSSIBLE__ -- not used-               , scTarget = Nothing -- not used-               }--    -- Andreas, 2011-10-03-    -- if more than one constructor matches, we cannot be irrelevant-    -- (this piece of code is unreachable if --experimental-irrelevance is off)-    (_ : _ : _) | unusableRelevance (getRelevance t) ->-      throwException . IrrelevantDatatype =<< do liftTCM $ buildClosure (unDom t)--  -- Andreas, 2012-10-10 fail if precomputed constructor set does not cover-  -- all the data type constructors--    _ | Just pcons' <- mcons,-        let pcons = map conName pcons',-        let cons = (map fst ns),-        let diff = Set.fromList cons Set.\\ Set.fromList pcons,-        not (Set.null diff) -> do-          liftTCM $ reportSDoc "tc.cover.precomputed" 10 $ vcat-            [ hsep $ text "pcons =" : map prettyTCM pcons-            , hsep $ text "cons  =" : map prettyTCM cons-            ]-          throwException (GenericSplitError "precomputed set of constructors does not cover all cases")--    _  -> return $ Right $ Covering (lookupPatternVar sc x) ns--  where-    inContextOfT :: MonadTCM tcm => tcm a -> tcm a-    inContextOfT = addContext tel . escapeContext (x + 1)--    inContextOfDelta2 :: MonadTCM tcm => tcm a -> tcm a-    inContextOfDelta2 = addContext tel . escapeContext x--    -- Debug printing-    debugInit tel x ps mpsub = liftTCM $ do-      reportSDoc "tc.cover.top" 10 $ vcat-        [ text "TypeChecking.Coverage.split': split"-        , nest 2 $ vcat-          [ text "tel     =" <+> prettyTCM tel-          , text "x       =" <+> text (show x)-          , text "ps      =" <+> do addContext tel $ prettyTCMPatternList ps-          , text "mpsub   =" <+> prettyTCM mpsub-          ]-        ]--    debugHoleAndType delta1 delta2 s ps t =-      liftTCM $ reportSDoc "tc.cover.top" 10 $ nest 2 $ vcat $-        [ text "p      =" <+> text (patVarNameToString s)-        , text "ps    =" <+> text (show ps)-        , text "delta1 =" <+> prettyTCM delta1-        , text "delta2 =" <+> inContextOfDelta2 (prettyTCM delta2)-        , text "t      =" <+> inContextOfT (prettyTCM t)-        ]---- | @splitResult f sc = return res@------   If the target type of @sc@ is a record type, a covering set of---   split clauses is returned (@sc@ extended by all valid projection patterns),---   otherwise @res == Nothing@.---   Note that the empty set of split clauses is returned if the record has no fields.-splitResult :: QName -> SplitClause -> TCM (Maybe Covering)-splitResult f sc@(SClause tel ps _ _ target) = do-  reportSDoc "tc.cover.split" 10 $ vcat-    [ text "splitting result:"-    , nest 2 $ text "f      =" <+> text (show f)-    , nest 2 $ text "target =" <+> (addContext tel $ maybe empty prettyTCM target)-    ]-  -- if we want to split projections, but have no target type, we give up-  let done = return Nothing-  caseMaybe target done $ \ t -> do-    isR <- addContext tel $ isRecordType $ unArg t-    case isR of-      Just (_r, vs, Record{ recFields = fs }) -> do-        reportSDoc "tc.cover" 20 $ sep-          [ text $ "we are of record type _r = " ++ show _r-          , text   "applied to parameters vs = " <+> (addContext tel $ prettyTCM vs)-          , text $ "and have fields       fs = " ++ show fs-          ]-        let es = patternsToElims ps-        -- Note: module parameters are part of ps-        let self  = defaultArg $ Def f [] `applyE` es-            pargs = vs ++ [self]-        reportSDoc "tc.cover" 20 $ sep-          [ text   "we are              self = " <+> (addContext tel $ prettyTCM $ unArg self)-          ]-        let n = defaultArg $ permRange $ fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps-            -- Andreas & James, 2013-11-19 includes the dot patterns!-            -- See test/succeed/CopatternsAndDotPatterns.agda for a case with dot patterns-            -- and copatterns which fails for @n = size tel@ with a broken case tree.--        -- Andreas, 2016-07-22 read the style of projections from the user's lips-        projOrigin <- ifM (optPostfixProjections <$> pragmaOptions) (return ProjPostfix) (return ProjPrefix)-        Just . Covering n <$> do-          forM fs $ \ proj -> do-            -- compute the new target-            dType <- defType <$> do getConstInfo $ unArg proj -- WRONG: typeOfConst $ unArg proj-            let -- type of projection instantiated at self-                target' = Just $ proj $> dType `piApply` pargs      -- Always visible (#2287)-                projArg = fmap (Named Nothing . ProjP projOrigin) $ setHiding NotHidden proj-                sc' = sc { scPats   = scPats sc ++ [projArg]-                         , scSubst  = idS-                         , scTarget = target'-                         }-            return (unArg proj, sc')-      _ -> done---- * Boring instances---- | For debugging only.-instance PrettyTCM SplitClause where-  prettyTCM (SClause tel pats sigma mpsub target) = sep-    [ text "SplitClause"-    , nest 2 $ vcat-      [ text "tel          =" <+> prettyTCM tel-      , text "pats         =" <+> sep (map (prettyTCM . namedArg) pats)-      , text "subst        =" <+> (text . show) sigma-      , text "mpsub        =" <+> prettyTCM mpsub-      , text "target       =" <+> do-          caseMaybe target empty $ \ t -> do-            addContext tel $ prettyTCM t-      -- Triggers crash (see Issue 1374).-      -- , text "subst target = " <+> do+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeApplications #-}++{-| Coverage checking, case splitting, and splitting for refine tactics.++ -}++module Agda.TypeChecking.Coverage+  ( SplitClause(..), clauseToSplitClause, insertTrailingArgs+  , Covering(..), splitClauses+  , coverageCheck+  , isCovered+  , splitClauseWithAbsurd+  , splitLast+  , splitResult+  , normaliseProjP+  ) where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++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 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.Pattern+import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))++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.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)+import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records+import Agda.TypeChecking.Sort+import Agda.TypeChecking.Telescope+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.Singleton+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible++type CoverM = ExceptT SplitError TCM++-- | Top-level function for checking pattern coverage.+--+--   Effects:+--+--   - Marks unreachable clauses as such in the signature.+--+--   - Adds missing instances clauses to the signature.+--+coverageCheck+  :: QName     -- ^ Name @f@ of definition.+  -> Type      -- ^ Absolute type (including the full parameter telescope).+  -> [Clause]  -- ^ Clauses of @f@.  These are the very clauses of @f@ in the signature.+  -> TCM SplitTree+coverageCheck f t cs = do+  reportSLn "tc.cover.top" 30 $ "entering coverageCheck for " ++ prettyShow f+  reportSDoc "tc.cover.top" 75 $ "  of type (raw): " <+> (text . prettyShow) t+  reportSDoc "tc.cover.top" 45 $ "  of type: " <+> prettyTCM t+  TelV gamma a <- telViewUpTo (-1) t+  reportSLn "tc.cover.top" 30 $ "coverageCheck: computed telView"++  let -- n             = arity+      -- xs            = variable patterns fitting lgamma+      n            = size gamma+      xs           =  map (setOrigin Inserted) $ teleNamedArgs gamma++  reportSLn "tc.cover.top" 30 $ "coverageCheck: getDefFreeVars"++      -- The initial module parameter substitutions need to be weakened by the+      -- number of arguments that aren't module parameters.+  fv           <- getDefFreeVars f++  reportSLn "tc.cover.top" 30 $ "coverageCheck: getting checkpoints"++  -- TODO: does this make sense? Why are we weakening by n - fv?+  checkpoints <- applySubst (raiseS (n - fv)) <$> viewTC eCheckpoints++      -- construct the initial split clause+  let sc = SClause gamma xs idS checkpoints $ Just $ defaultDom a++  reportSDoc "tc.cover.top" 10 $ do+    let prCl cl = addContext (clauseTel cl) $+                  prettyTCMPatternList $ namedClausePats cl+    vcat+      [ text $ "Coverage checking " ++ prettyShow f ++ " with patterns:"+      , nest 2 $ vcat $ map prCl cs+      ]++  -- used = actually used clauses for cover+  -- pss  = non-covered cases+  CoverResult splitTree used pss qss noex <- cover f cs sc++  -- Andreas, 2018-11-12, issue #378:+  -- 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 $ IntSet.filter (< length cs) noex++  reportSDoc "tc.cover.top" 10 $ vcat+    [ "cover computed!"+    , text $ "used clauses: " ++ show used+    , text $ "non-exact clauses: " ++ show (IntSet.toList noex)+    ]+  reportSDoc "tc.cover.splittree" 10 $ vcat+    [ "generated split tree for" <+> prettyTCM f+    , text $ prettyShow splitTree+    ]+  reportSDoc "tc.cover.covering" 10 $ vcat+    [ text $ "covering patterns for " ++ prettyShow f+    , nest 2 $ vcat $ map (\ cl -> addContext (clauseTel cl) $ prettyTCMPatternList $ namedClausePats cl) qss+    ]++  -- Storing the covering clauses so that checkIApplyConfluence_ can+  -- find them later.+  -- Andreas, 2019-03-27, only needed when --cubical+  -- 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 <- 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+      -- Now, @l@ is the first type in @tel@ (counting from 0=leftmost)+      -- which is empty.  Turn it into a de Bruijn index @i@.+      let i = size tel - 1 - l+      -- Build a substitution mapping this pattern variable to the absurd pattern.+      let sub = inplaceS i $ absurdP i+        -- 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    = 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"+            , nest 2 $ prettyTCM $ QNamed f cl+            ]+      reportSDoc "tc.cover.missing" 80 $ inTopContext $ vcat+        [ "l   = " <+> pretty l+        , "i   = " <+> pretty i+        , "cl  = " <+> pretty (QNamed f cl)+        ]+      addClauses f [cl]+      return False++  -- report a warning if there are uncovered cases,+  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.+  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.+  List1.unlessNull (filter ((Just True ==) . clauseUnreachable) cs1) \ unreached -> do+    -- Warn about unreachable clauses.+    let ranges = fmap clauseFullRange unreached+    setCurrentRange ranges $ warning $ UnreachableClauses f ranges++  -- 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+  -- 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+--   case splitter+isCovered :: QName -> [Clause] -> SplitClause -> TCM Bool+isCovered f cs sc = do+  reportSDoc "tc.cover.isCovered" 20 $ vcat+    [ "isCovered"+    , nest 2 $ vcat $+      [ "f  = " <+> prettyTCM f+      , "cs = " <+> vcat (map (nest 2 . prettyTCM . NamedClause f True) cs)+      , "sc = " <+> prettyTCM sc+      ]+    ]+  -- Jesper, 2019-10: introduce trailing arguments (see #3828)+  (_ , sc') <- insertTrailingArgs True sc+  CoverResult { coverMissingClauses = missing } <- cover f cs sc'+  return $ null missing+ -- Andreas, 2019-08-08 and 2020-02-11+ -- If there is an error (e.g. unification error), don't report it+ -- to the user.  Rather, assume the clause is not already covered.+ `catchError` \ _ -> return False++-- | @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, @missing@ cases, the @covering@ clauses,+--   and the non-exact clauses @noex@.+--+--   Effect: adds missing instance clauses for @f@ to signature.+--+cover :: QName -> [Clause] -> SplitClause ->+         TCM CoverResult+cover f cs sc@(SClause tel ps _ _ target) = updateRelevance $ do+  reportSDoc "tc.cover.cover" 10 $ inTopContext $ vcat+    [ "checking coverage of pattern:"+    , nest 2 $ prettyTCM sc+    , 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+      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 = if exact then empty else singleton i+        }++    No        ->  do+      reportSLn "tc.cover" 20 $ "pattern is not covered"+      let infer dom = isInstance dom || isJust (domTactic dom)+      if maybe False infer target+        then do+          -- Ulf, 2016-10-31: For now we only infer instance clauses. It would+          -- make sense to do it also for hidden, but since the value of a+          -- hidden clause is expected to be forced by later clauses, it's too+          -- late to add it now. If it was inferrable we would have gotten a+          -- type error before getting to this point.+          -- Ulf, 2019-11-21: Also @tactic clauses.+          cl <- inferMissingClause f sc+          return $ CoverResult (SplittingDone (size tel)) empty [] [cl] empty+        else do+          let ps' = fromSplitPatterns ps+          return $ CoverResult (SplittingDone (size tel)) empty [(tel, ps')] [] empty++    -- We need to split!+    -- If all clauses have an unsplit copattern, we try that first.+    Block res bs -> trySplitRes res (null bs) splitError $ do+      when (null bs) __IMPOSSIBLE__+      -- Otherwise, if there are variables to split, we try them+      -- in the order determined by a split strategy.+      reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++ prettyShow bs+      -- xs is a non-empty lists of blocking variables+      -- try splitting on one of them+      xs <- splitStrategy bs tel+      -- Andreas, 2017-10-08, issue #2594+      -- First, try to find split order for complete coverage.+      -- If this fails, try to at least carry out the splitting to the end.+      continue xs NoAllowPartialCover $ \ _err -> do+        continue xs YesAllowPartialCover $ \ err -> do+          splitError err+  where+    -- Andreas, 2019-08-07, issue #3966+    -- When we get a SplitError, tighten the error Range to the clauses+    -- that are still candidates for covering the SplitClause.+    splitError :: SplitError -> TCM a+    splitError = withRangeOfCandidateClauses . typeError . SplitError++    -- This repeats the matching, but since we are crashing anyway,+    -- the extra work just to compute a better Range does not matter.+    withRangeOfCandidateClauses :: TCM a -> TCM a+    withRangeOfCandidateClauses cont = do+      cands <- mapMaybe (uncurry notNo) . zip cs <$> mapM (matchClause ps) cs+      setCurrentRange cands cont+      where+        notNo :: Clause -> Match a -> Maybe Clause+        notNo c = \case+          Yes{}   -> Just c+          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 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 $ "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+        reportSDoc "tc.cover.applyCl" 40 $ "ps[s]  =" <+> pretty (s `applySubst` ps)++        -- If a matching clause has fewer patterns than the split+        -- clause we ought to copy over the extra ones.+        -- e.g. if the user wrote:+        --+        --   bar : Bool -> Bool+        --   bar false = false+        --   bar = \ _ -> true+        --+        -- then for the second clause the @extra@ patterns will be @[true]@.++        let extra = drop (length ps) $ fromSplitPatterns sps+            n_extra = length extra++        reportSDoc "tc.cover.applyCl" 40 $ "extra  =" <+> pretty extra++        -- When we add the extra patterns we also update the type+        -- and the body of the clause.++        mtv <- (traverse . traverse) (telViewUpToPath n_extra) $ clauseType cl+        let ty = (fmap . fmap) ((parallelS (reverse $ map namedArg extra) `composeS` liftS n_extra s `applyPatSubst`) . theCore) mtv++        reportSDoc "tc.cover.applyCl" 40 $ "new ty =" <+> pretty ty++        return $+             Clause { clauseLHSRange  = clauseLHSRange cl+                    , clauseFullRange = clauseFullRange cl+                    , clauseTel       = tel+                    , namedClausePats = (s `applySubst` ps) ++ extra+                    , clauseBody      = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl+                    , clauseType      = ty+                    , clauseCatchall    = clauseCatchall cl+                    , clauseRecursive   = clauseRecursive cl+                    , clauseUnreachable = clauseUnreachable cl+                    , clauseEllipsis    = clauseEllipsis cl+                    , clauseWhereModule = clauseWhereModule cl+                    }+      where+      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 =+      -- Don't do anything if there is no target type info.+      caseMaybe target cont $ \ b -> do+        -- TODO (2018-10-16): if proofs get erased in the compiler, also wake erased vars!+        let m = getModality b+        applyModalityToContext m cont++    continue+      :: [BlockingVar]+      -> AllowPartialCover+      -> (SplitError -> TCM CoverResult)+      -> TCM CoverResult+    continue xs allowPartialCover handle = do+      r <- altM1 (\ x -> fmap (,x) <$> split Inductive allowPartialCover sc x) xs+      case r of+        Left err -> handle err+        -- If we get the empty covering, we have reached an impossible case+        -- and are done.+        Right (Covering n [], _) ->+         do+          -- 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+          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 $ \ (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+              qsss  = map coverPatterns       results+              noex  = map coverNoExactClauses results+          -- Jesper, 2016-03-10  We need to remember which variables were+          -- eta-expanded by the unifier in order to generate a correct split+          -- tree (see Issue 1872).+          reportSDoc "tc.cover.split.eta" 60 $ vcat+            [ "etaRecordSplits"+            , nest 2 $ vcat+              [ "n   = " <+> text (show n)+              , "scs = " <+> prettyTCM scs+              , "ps  = " <+> prettyTCMPatternList (fromSplitPatterns ps)+              ]+            ]+          let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees+              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+    trySplitRes+      :: BlockedOnResult                  -- Are we blocked on the result?+      -> Bool                             -- Is this the last thing we try?+      -> (SplitError -> TCM CoverResult)  -- Handler for 'SplitError'+      -> TCM CoverResult                  -- Continuation+      -> TCM CoverResult+    -- not blocked on result: try regular splits+    trySplitRes NotBlockedOnResult finalSplit splitError cont+      | finalSplit = __IMPOSSIBLE__ -- there must be *some* reason we are blocked+      | otherwise  = cont+    -- blocked on arguments that are not yet introduced:++    -- we must split on a variable so that the target type becomes a pi type+    trySplitRes (BlockedOnApply IsApply) finalSplit splitError cont = do+      -- Andreas, 2021-12-31, issue #5712.+      -- If there is a tactic to solve the clause, we might not have inserted+      -- trailing args (due to #5358).  Now we force it!+      (tel, sc') <- insertTrailingArgs True sc+      if null tel then+        if finalSplit then __IMPOSSIBLE__ -- already ruled out by lhs checker+        else cont+      else cover f cs sc'++    -- ...or it was an IApply pattern, so we might just need to introduce the variable now.+    trySplitRes (BlockedOnApply IsIApply) finalSplit splitError cont+       = do+         caseMaybeM (splitResultPath f sc) fallback $ (cover f cs . snd) <=< insertTrailingArgs False+      where+        fallback | finalSplit = __IMPOSSIBLE__ -- already ruled out by lhs checker?+                 | otherwise  = cont++    -- blocked on result but there are catchalls:+    -- try regular splits if there are any, or else throw an error,+    -- this is nicer than continuing and reporting unreachable clauses+    -- (see issue #2833)+    trySplitRes (BlockedOnProj True) finalSplit splitError cont+      | finalSplit = splitError CosplitCatchall+      | otherwise  = cont+    -- all clauses have an unsplit copattern: try to split+    trySplitRes (BlockedOnProj False) finalSplit splitError cont = do+      reportSLn "tc.cover" 20 $ "blocked by projection pattern"+      -- forM is a monadic map over a Maybe here+      mcov <- splitResultRecord f sc+      case mcov of+        Left err+          | finalSplit -> splitError err+          | otherwise  -> cont+        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)) (map (\(t,(sc,i)) -> (t,sc)) scs)+            -- OR:+            -- forM scs $ \ (proj, sc') -> (proj,) <$> do+            --   cover f cs =<< do+            --     snd <$> fixTarget sc'+          let trees = map coverSplitTree results+              useds = map coverUsedClauses results+              psss  = map coverMissingClauses results+              qsss  = map coverPatterns results+              noex  = map coverNoExactClauses results+              tree  = SplitAt n StrictSplit $ zip projs trees   -- TODO: Lazy?+          return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex)++    gatherEtaSplits :: Int -> SplitClause+                    -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]+    gatherEtaSplits n sc []+       | n >= 0    = __IMPOSSIBLE__ -- we should have encountered the main+                                    -- split by now already+       | otherwise = []+    gatherEtaSplits n sc (p:ps) = case namedArg p of+      VarP _ x+       | n == 0    -> case p' of -- this is the main split+           VarP  _ _    -> p : gatherEtaSplits (-1) sc ps+           DotP  _ _    -> __IMPOSSIBLE__+           ConP  _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps+           LitP{}       -> gatherEtaSplits (-1) sc ps+           ProjP{}      -> __IMPOSSIBLE__+           IApplyP{}    -> __IMPOSSIBLE__+           DefP  _ _ qs -> qs ++ gatherEtaSplits (-1) sc ps -- __IMPOSSIBLE__ -- Andrea: maybe?+       | otherwise ->+           updateNamedArg (\ _ -> p') p : gatherEtaSplits (n-1) sc ps+        where p' = lookupS (scSubst sc) $ splitPatVarIndex x+      IApplyP{}   ->+           updateNamedArg (applySubst (scSubst sc)) p : gatherEtaSplits (n-1) sc ps+      DotP  _ _    -> p : gatherEtaSplits (n-1) sc ps -- count dot patterns+      ConP  _ _ qs -> gatherEtaSplits n sc (qs ++ ps)+      DefP  _ _ qs -> gatherEtaSplits n sc (qs ++ ps)+      LitP{}       -> gatherEtaSplits n sc ps+      ProjP{}      -> gatherEtaSplits n sc ps++    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+      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++    etaRecordSplits :: Int -> [NamedArg SplitPattern] -> (SplitTag,SplitClause)+                    -> SplitTree -> (SplitTag,SplitTree)+    etaRecordSplits n ps (q , sc) t =+      (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)+++-- | Append a instance clause to the clauses of a function.+inferMissingClause+  :: QName+       -- ^ Function name.+  -> SplitClause+       -- ^ Clause to add.  Clause hiding (in 'clauseType') must be 'Instance'.+   -> TCM Clause+inferMissingClause f (SClause tel ps _ cps (Just t)) = setCurrentRange f $ do+  reportSDoc "tc.cover.infer" 20 $ addContext tel $ "Trying to infer right-hand side of type" <+> prettyTCM t+  rhs <-+    addContext tel+    $ locallyTC eCheckpoints (const cps)+    $ checkpoint IdS    -- introduce a fresh checkpoint+    $ case getHiding t of+        _ | Just tac <- domTactic t -> do+          reportSDoc "tc.cover.infer" 40 $ vcat+            [ "@tactic rhs"+            , nest 2 $ "target =" <+> pretty t ]+          (_, v) <- newValueMeta DontRunMetaOccursCheck CmpLeq (unDom t)+          v <$ unquoteTactic tac v (unDom t)+        Instance{} -> snd <$> newInstanceMeta "" (unDom t)+        Hidden     -> __IMPOSSIBLE__+        NotHidden  -> __IMPOSSIBLE__+  let cl = Clause { clauseLHSRange  = noRange+                  , clauseFullRange = noRange+                  , clauseTel       = tel+                  , namedClausePats = fromSplitPatterns ps+                  , clauseBody      = Just rhs+                  , clauseType      = Just (argFromDom t)+                  , clauseCatchall    = empty+                  , clauseRecursive   = Nothing     -- could be recursive+                  , clauseUnreachable = Just False  -- missing, thus, not unreachable+                  , clauseEllipsis    = NoEllipsis+                  , clauseWhereModule = Nothing+                  }+  addClauses f [cl]  -- Important: add at the end.+  return cl+inferMissingClause _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__++splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars+splitStrategy bs tel = return $ updateLast setBlockingVarOverlap xs+  -- Make sure we do not insists on precomputed coverage when+  -- we make our last try to split.+  -- Otherwise, we will not get a nice error message.+  where+    xs             = strict ++ lazy+    (lazy, strict) = List.partition blockingVarLazy bs+{- KEEP!+--  Andreas, 2012-10-13+--  The following split strategy which prefers all-constructor columns+--  fails on test/fail/CoverStrategy+    xs       = ys ++ zs+    (ys, zs) = partition allConstructors bs+    allConstructors :: BlockingVar -> Bool+    allConstructors = isJust . snd+-}+++-- | Check that a type is a non-irrelevant datatype or a record with+-- named constructor. Unless the 'Induction' argument is 'CoInductive'+-- the data type must be inductive.+isDatatype :: (MonadTCM tcm, MonadError SplitError tcm) =>+              Induction -> Dom Type ->+              tcm (DataOrRecord, QName, Sort, Args, Args, [QName], Bool)+isDatatype ind at = do+  let t       = unDom at+      throw f = throwError . f =<< do liftTCM $ buildClosure t+  t' <- liftTCM $ reduce t+  mInterval <- liftTCM $ getBuiltinName' builtinInterval+  mIsOne <- liftTCM $ getBuiltinName' builtinIsOne+  case unEl t' of+    Def d [] | Just d == mInterval -> throw NotADatatype+    Def d [Apply phi] | Just d == mIsOne -> do+                xs <- liftTCM $ decomposeInterval =<< reduce (unArg phi)+                if null xs+                   then return $ (IsData, d, mkSSet 0, [phi], [], [], False)+                   else throw NotADatatype+    Def d es -> do+      let ~(Just args) = allApplyElims es+      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, 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 -> 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++-- | Update the target type of the split clause after a case split.+fixTargetType+  :: Quantity  -- ^ The quantity of the thing that is split.+  -> SplitTag -> SplitClause -> Dom Type -> TCM SplitClause+fixTargetType q tag sc@SClause{ scTel = sctel, scSubst = sigma } target = do+    reportSDoc "tc.cover.target" 20 $ sep+      [ "split clause telescope: " <+> prettyTCM sctel+      ]+    reportSDoc "tc.cover.target" 60 $ sep+      [ "substitution          : " <+> prettyTCM sigma+      ]+    reportSDoc "tc.cover.target" 60 $ sep+      [ "target type before substitution:" <+> pretty target+      , "             after substitution:" <+> pretty (applySplitPSubst sigma target)+      ]++    -- We update the target quantity to 0 for erased constructors, but+    -- not if the match is made in an erased position, or if the+    -- original constructor definition is not erased.+    updQuant <- do+      let erased = case q of+            Quantity0{} -> True+            Quantity1{} -> __IMPOSSIBLE__+            Quantityω{} -> False+      if erased then return id else case tag of+        SplitCon c -> do+          q <- getQuantity <$> getOriginalConstInfo c+          case q of+            Quantity0{} -> return $ mapQuantity (composeQuantity q)+            Quantity1{} -> return id+            Quantityω{} -> return id+        SplitLit{} -> return id+        SplitCatchall{} -> return id++    return $ sc { scTarget = Just $ updQuant $ applySplitPSubst sigma target }+++-- | Add more patterns to split clause if the target type is a function type.+--   Returns the domains of the function type (if any).+insertTrailingArgs+  :: Bool         -- ^ Force insertion even when there is a 'domTactic'?+  -> SplitClause+  -> TCM (Telescope, SplitClause)+insertTrailingArgs force sc@SClause{ scTel = sctel, scPats = ps, scSubst = sigma, scCheckpoints = cps, scTarget = target } = do+  let fallback = return (empty, sc)+  caseMaybe target fallback $ \ a -> do+    if isJust (domTactic a) && not force then fallback else do+    (TelV tel b) <- addContext sctel $ telViewUpTo (-1) $ unDom a+    reportSDoc "tc.cover.target" 15 $ sep+      [ "target type telescope: " <+> do+          addContext sctel $ prettyTCM tel+      , "target type core     : " <+> do+          addContext sctel $ addContext tel $ prettyTCM b+      ]+    let n         = size tel+        -- Andreas, 2016-10-04 issue #2236+        -- Need to set origin to "Inserted" to avoid printing of hidden patterns.+        xs        = map (mapArgInfo hiddenInserted) $ teleNamedArgs tel+        -- Compute new split clause+        sctel'    = telFromList $ telToList (raise n sctel) ++ telToList tel+        -- Dot patterns in @ps@ need to be raised!  (Issue 1298)+        ps'       = applySubst (raiseS n) ps ++ xs+        newTarget = Just $ (if not (null tel) then a{ domTactic = Nothing } else a) $> b+        sc'       = SClause+          { scTel    = sctel'+          , scPats   = ps'+          , scSubst  = wkS n $ sigma -- Should be wkS instead of liftS since+                                     -- variables are only added to new tel.+          , scCheckpoints        = applySubst (raiseS n) cps+          , scTarget = newTarget+          }+    -- Separate debug printing to find cause of crash (Issue 1374)+    reportSDoc "tc.cover.target" 30 $ sep+      [ "new split clause telescope   : " <+> prettyTCM sctel'+      ]+    reportSDoc "tc.cover.target" 30 $ sep+      [ "new split clause patterns    : " <+> do+          addContext sctel' $ prettyTCMPatternList $ fromSplitPatterns ps'+      ]+    reportSDoc "tc.cover.target" 60 $ sep+      [ "new split clause substitution: " <+> prettyTCM (scSubst sc')+      ]+    reportSDoc "tc.cover.target" 30 $ sep+      [ "new split clause target      : " <+> do+          addContext sctel' $ prettyTCM $ fromJust newTarget+      ]+    reportSDoc "tc.cover.target" 20 $ sep+      [ "new split clause"+      , prettyTCM sc'+      ]+    return $ if n == 0 then (empty, sc { scTarget = newTarget }) else (tel, sc')++-- Andreas, 2017-01-18, issue #819, set visible arguments to UserWritten.+-- Otherwise, they will be printed as _.+hiddenInserted :: ArgInfo -> ArgInfo+hiddenInserted ai+  | 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.+  -> QName                        -- ^ Name of datatype to split at.+  -> Args                         -- ^ Data type parameters.+  -> Args                         -- ^ Data type indices.+  -> Nat                          -- ^ Index of split variable.+  -> Telescope                    -- ^ Telescope for the patterns.+  -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.+  -> Map CheckpointId Substitution -- ^ Current checkpoints+  -- -> 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 dlvl'+    dterm = Def d [] `apply` (pars ++ ixs)+  -- Δ1 ⊢ gamma+  TelV gamma _ <- lift $ telView (theHCompT `piApply` [setHiding Hidden $ defaultArg $ dlvl , defaultArg $ dterm])+  case (delta1 `abstract` gamma,IdS) of+    (delta1',rho0) -> do+--      debugSubst "rho0" rho0++      -- 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) $ -- 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?+      -- Compute final context and substitution+      let rho3    = consS defp rho1            -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)+          delta2' = applySplitPSubst rho3 delta2  -- Δ₂' = Δ₂ρ₃+          delta'  = delta1' `abstract` delta2' -- Δ'  = Δ₁'Δ₂'+          rho     = liftS (size delta2) rho3   -- Δ' ⊢ ρ : Δ₁(x:D)Δ₂++      -- debugTel "delta'" delta'+      -- debugSubst "rho" rho+      -- debugPs tel ps++      -- Apply the substitution+      let ps' = applySubst rho ps+      -- debugPlugged delta' ps'++      let cps' = applySplitPSubst rho cps++      return $ Just . (SplitCon hCompName,) $ SClause delta' ps' rho cps' Nothing -- target fixed later+++-- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps con@+--+--   @+--      delta1   Telescope before split point+--      n        Name of pattern variable at split point+--      delta2   Telescope after split point+--      d        Name of datatype to split at+--      pars     Data type parameters+--      ixs      Data type indices+--      hix      Index of split variable+--      tel      Telescope for patterns ps+--      ps       Patterns before doing the split+--      cps      Current module parameter checkpoints+--      con      Constructor to fit into hole+--   @+--   @dtype == d pars ixs@+computeNeighbourhood+  :: Telescope                    -- ^ Telescope before split point.+  -> PatVarName                   -- ^ Name of pattern variable at split point.+  -> Telescope                    -- ^ Telescope after split point.+  -> QName                        -- ^ Name of datatype to split at.+  -> Args                         -- ^ Data type parameters.+  -> Args                         -- ^ Data type indices.+  -> Nat                          -- ^ Index of split variable.+  -> Telescope                    -- ^ Telescope for the patterns.+  -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.+  -> Map CheckpointId Substitution -- ^ Current checkpoints+  -> QName                        -- ^ Constructor to fit into hole.+  -> 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+  dtype <- liftTCM $ (`piApply` pars) . defType <$> getConstInfo d++  -- Get the real constructor name+  con <- liftTCM $ fromRight __IMPOSSIBLE__ <$> getConForm c+  con <- return $ con { conName = c }  -- What if we restore the current name?+                                       -- Andreas, 2013-11-29 changes nothing!++  -- Get the type of the constructor+  ctype <- liftTCM $ defType <$> getConInfo con++  -- Lookup the type of the constructor at the given parameters+  (gamma0, cixs, boundary) <- do+    (TelV gamma0 (El _ d), boundary) <- liftTCM $ addContext delta1 $+      telViewPathBoundary (ctype `piApply` pars)+    let Def _ es = d+        Just cixs = allApplyElims es+    return (gamma0, cixs, boundary)++  let (_, Dom{domInfo = info} : _) = splitAt (size tel - hix - 1) (telToList tel)++  -- Andreas, 2012-02-25 preserve name suggestion for recursive arguments+  -- of constructor++  let preserve (x, t@(El _ (Def d' _))) | d == d' = (n, t)+      preserve (x, t) = (x, t)+      gamma  = (fmap . mapModality) (composeModality (getModality info)) $ telFromList . map (fmap preserve) . telToList $ gamma0+      delta1Gamma = delta1 `abstract` gamma++  debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix++  cforced <- defForced <$> getConstInfo c+      -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced+      -- variables.+  let forced = replicate (size delta1) NotForced ++ cforced+      flex   = allFlexVars forced delta1Gamma -- All variables are flexible++  -- Unify constructor target and given type (in Δ₁Γ)+  let conIxs   = drop (size pars) cixs+      givenIxs = raise (size gamma) ixs++  -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope+  -- TODO: should we propagate the modality in general?+  -- See also LHS checking.+  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)++  let withKIfStrict = applyWhen (isStrictDataSort dsort) $ locallyTC eSplitOnStrict $ const True++  -- 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+++  case r of+    NoUnify {} -> debugNoUnify $> Nothing++    UnifyBlocked block -> stuck (Just block) []++    UnifyStuck errs -> stuck Nothing errs++    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++      -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ+      let (rho1,rho2) = splitS (size gamma) $ rho0'++      -- Andreas, 2015-05-01  I guess it is fine to use no @conPType@+      -- as the result of splitting is never used further down the pipeline.+      -- After splitting, Agda reloads the file.+      -- 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 . 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+      let rho3    = consS conp rho1            -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)+          delta2' = applySplitPSubst rho3 delta2  -- Δ₂' = Δ₂ρ₃+          delta'  = delta1' `abstract` delta2' -- Δ'  = Δ₁'Δ₂'+          rho     = liftS (size delta2) rho3   -- Δ' ⊢ ρ : Δ₁(x:D)Δ₂++      debugTel "delta'" delta'+      debugSubst "rho" rho+      debugPs tel ps++      -- Apply the substitution+      let ps' = applySubst rho ps+      debugPlugged delta' ps'++      let cps'  = applySplitPSubst rho cps++      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"+        , nest 2 $ vcat+          [ "context=" <+> (inTopContext . prettyTCM =<< getContextTelescope)+          , "con    =" <+> prettyTCM con+          , "ctype  =" <+> prettyTCM ctype+          , "ps     =" <+> do inTopContext $ addContext tel $ prettyTCMPatternList $ fromSplitPatterns ps+          , "d      =" <+> prettyTCM d+          , "pars   =" <+> do prettyList $ map prettyTCM pars+          , "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 n $ prettyTCM delta2+          , "gamma  =" <+> do inTopContext $ addContext delta1 $ prettyTCM gamma+          , "tel  =" <+> do inTopContext $ prettyTCM tel+          , "hix    =" <+> text (show hix)+          ]+        ]+      reportSDoc "tc.cover.split.con" 70 $ vcat+        [ "computeNeighbourhood"+        , nest 2 $ vcat+          [ "context=" <+> (inTopContext . (text . show) =<< getContextTelescope)+          , "con    =" <+> (text . show) con+          , "ctype  =" <+> (text . show) ctype+          , "ps     =" <+> (text . show) ps+          , "d      =" <+> (text . show) d+          , "pars   =" <+> (text . show) pars+          , "ixs    =" <+> (text . show) ixs+          , "cixs   =" <+> (text . show) cixs+          , "delta1 =" <+> (text . show) delta1+          , "delta2 =" <+> (text . show) delta2+          , "gamma  =" <+> (text . show) gamma+          , "hix    =" <+> text (show hix)+          ]+        ]++    debugNoUnify =+      liftTCM $ reportSLn "tc.cover.split.con" 20 "  Constructor impossible!"++    debugCantSplit =+      liftTCM $ reportSLn "tc.cover.split.con" 20 "  Bad split!"++    debugSubst s sub =+      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat+        [ text (s ++ " =") <+> prettyTCM sub+        ]++    debugTel s tel =+      liftTCM $ reportSDoc "tc.cover.split.con" 20 $ nest 2 $ vcat+        [ text (s ++ " =") <+> prettyTCM tel+        ]++    debugPs tel ps =+      liftTCM $ reportSDoc "tc.cover.split.con" 20 $+        inTopContext $ addContext tel $ nest 2 $ vcat+          [ "ps     =" <+> prettyTCMPatternList (fromSplitPatterns ps)+          ]++    debugPlugged delta' ps' = do+      liftTCM $ reportSDoc "tc.cover.split.con" 20 $+        inTopContext $ addContext delta' $ nest 2 $ vcat+          [ "ps'    =" <+> do prettyTCMPatternList $ fromSplitPatterns ps'+          ]++-- | Introduce trailing pattern variables?+data InsertTrailing+  = DoInsertTrailing+  | DontInsertTrailing+  deriving (Eq, Show)++-- | Allow partial covering for split?+data AllowPartialCover+  = YesAllowPartialCover  -- To try to coverage-check incomplete splits.+  | NoAllowPartialCover   -- Default.+  deriving (Eq, Show)++-- | Entry point from @Interaction.MakeCase@.+splitClauseWithAbsurd :: SplitClause -> Nat -> TCM (Either SplitError (Either SplitClause Covering))+splitClauseWithAbsurd c x =+  split' CheckEmpty Inductive NoAllowPartialCover DontInsertTrailing c (BlockingVar x [] [] True False)+  -- Andreas, 2016-05-03, issue 1950:+  -- Do not introduce trailing pattern vars after split,+  -- because this does not work for with-clauses.++-- | Entry point from @TypeChecking.Empty@ and @Interaction.BasicOps@.+--   @splitLast CoInductive@ is used in the @refine@ tactics.++splitLast :: Induction -> Telescope -> [NamedArg DeBruijnPattern] -> TCM (Either SplitError Covering)+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 (mkProp 0) $ __DUMMY_TERM_WITH__ "splitLastTarget")++-- | @split ind splitClause x = return res@+--   splits @splitClause@ at pattern var @x@ (de Bruijn index).+--+--   Possible results @res@ are:+--+--   1. @Left err@:+--      Splitting failed.+--+--   2. @Right covering@:+--      A covering set of split clauses, one for each valid constructor.+--      This could be the empty set (denoting an absurd clause).++split :: Induction+         -- ^ Coinductive constructors are allowed if this argument is+         -- 'CoInductive'.+      -> AllowPartialCover+         -- ^ Don't fail if computed 'Covering' does not cover all constructors.+      -> SplitClause+      -> BlockingVar+      -> TCM (Either SplitError Covering)+split ind allowPartialCover sc x =+  fmap blendInAbsurdClause <$> split' NoCheckEmpty ind allowPartialCover DoInsertTrailing sc x+  where+    n = lookupPatternVar sc $ blockingVarNo x+    blendInAbsurdClause :: Either SplitClause Covering -> Covering+    blendInAbsurdClause = fromRight (const $ Covering n [])++-- | Convert a de Bruijn index relative to the clause telescope to a de Bruijn+--   level. The result should be the argument position (counted from left,+--   starting with 0) to split at (dot patterns included!).+lookupPatternVar :: SplitClause -> Int -> Arg Nat+lookupPatternVar SClause{ scTel = tel, scPats = pats } x = arg $>+    if n < 0 then __IMPOSSIBLE__ else n+  where n = if k < 0+            then __IMPOSSIBLE__+            else fromMaybe __IMPOSSIBLE__ $ permPicks perm !!! k+        perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm $ fromSplitPatterns pats+        k = size tel - x - 1+        arg = indexWithDefault __IMPOSSIBLE__ (telVars (size tel) tel) k+++data CheckEmpty = CheckEmpty | NoCheckEmpty++-- | @split' ind pc ft splitClause x = return res@+--   splits @splitClause@ at pattern var @x@ (de Bruijn index).+--+--   Possible results @res@ are:+--+--   1. @Left err@:+--      Splitting failed.+--+--   2. @Right (Left splitClause')@:+--      Absurd clause (type of @x@ has 0 valid constructors).+--+--   3. @Right (Right covering)@:+--      A covering set of split clauses, one for each valid constructor.++split' :: CheckEmpty+          -- ^ Use isEmptyType to check whether the type of the variable to+          -- split on is empty. This switch is necessary to break the cycle+          -- between split' and isEmptyType.+       -> Induction+          -- ^ Coinductive constructors are allowed if this argument is+          -- 'CoInductive'.+       -> AllowPartialCover+          -- ^ Don't fail if computed 'Covering' does not cover all constructors.+       -> InsertTrailing+          -- ^ If 'DoInsertTrailing', introduce new trailing variable patterns.+       -> SplitClause+       -> BlockingVar+       -> TCM (Either SplitError (Either SplitClause Covering))+split' checkEmpty ind allowPartialCover inserttrailing+       sc@(SClause tel ps _ cps target) (BlockingVar x pcons' plits overlap lazy) =+ liftTCM $ runExceptT $ do+  debugInit tel x ps cps++  -- Split the telescope at the variable+  -- t = type of the variable,  Δ₁ ⊢ t+  (n, t, delta1, delta2) <- do+    let (tel1, dom : tel2) = splitAt (size tel - x - 1) $ telToList tel+    return (fst $ unDom dom, snd <$> dom, telFromList tel1, telFromList tel2)++  -- Compute the neighbourhoods for the constructors+  let computeNeighborhoods = do+        -- 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, 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 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?+               , length $ ns+               , ns ++ catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns])+               )++      computeLitNeighborhoods = do+        typeOk <- liftTCM $ do+          t' <- litType $ headWithDefault {-'-} __IMPOSSIBLE__ plits+          liftTCM $ dontAssignMetas $ tryConversion $ equalType (unDom t) t'+        unless typeOk $ throwError . NotADatatype =<< do liftTCM $ buildClosure (unDom t)+        ns <- forM plits $ \lit -> do+          let delta2' = subst 0 (Lit lit) delta2+              delta'  = delta1 `abstract` delta2'+              rho     = liftS x $ consS (litP lit) idS+              ps'     = applySubst rho ps+              cps'    = applySplitPSubst rho cps+          return (SplitLit lit , SClause delta' ps' rho cps' Nothing)+        ca <- do+          let delta' = tel -- telescope is unchanged for catchall branch+              varp   = VarP (PatternInfo PatOSplit []) $ SplitPatVar+                         { splitPatVarName   = underscore+                         , splitPatVarIndex  = 0+                         , splitExcludedLits = plits+                         }+              rho    = liftS x $ consS varp $ raiseS 1+              ps'    = applySubst rho ps+          return (SplitCatchall , SClause delta' ps' rho cps Nothing)++        -- If Agda is changed so that the type of a literal can belong+        -- to an inductive family (with at least one index), then the+        -- following code should be changed (the constructor False+        -- stands for "not indexed").+        let ns' = map ((fmap (,NoInfo))) $ ns ++ [ ca ]+        return (IsData, mkType 0, False, length ns', ns')++  -- 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,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,info)) ->+      (con,) . (,info) . snd <$> insertTrailingArgs False sc++  mHCompName <- getPrimitiveName' builtinHComp+  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 <- hasQuantity0 <$> viewTC eQuantity+  reportSLn "tc.cover.split" 60 $ "We are in erased context = " ++ show erased+  let erasedError reason =+        throwError . ErasedDatatype reason =<<+          do liftTCM $ inContextOfT $ buildClosure (unDom t)++  case numMatching of+    0  -> do+      let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 []+          rho = liftS x $ consS absurdp $ raiseS 1+          ps' = applySubst rho ps+      return $ Left $ SClause+               { scTel  = tel+               , scPats = ps'+               , scSubst              = __IMPOSSIBLE__ -- not used+               , scCheckpoints        = __IMPOSSIBLE__ -- not used+               , scTarget             = Nothing+               }++    -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase.+    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/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++      -- Andreas, 2012-10-10 fail if precomputed constructor set does not cover+      -- all the data type constructors+      -- Andreas, 2017-10-08 ... unless partial covering is explicitly allowed.+      let ptags = map (SplitCon . conName) pcons' ++ map SplitLit plits+      -- clauses for hcomp will be automatically generated.+      let inferred_tags = maybe Set.empty (Set.singleton . SplitCon) mHCompName+      let all_tags = Set.fromList ptags `Set.union` inferred_tags++      when (allowPartialCover == NoAllowPartialCover && not overlap) $+        for_ ns $ \(tag, (sc, _)) -> do+          unless (tag `Set.member` all_tags) $ do+            isImpossibleClause <- isEmptyTel $ scTel sc+            unless isImpossibleClause $ do+              liftTCM $ reportSDoc "tc.cover" 10 $ vcat+                [ text "Missing case for" <+> prettyTCM tag+                , nest 2 $ prettyTCM sc+                ]+              throwError (GenericSplitError "precomputed set of constructors does not cover all cases")++      let t' = set lensSort s $ unDom t+      liftTCM $ inContextOfT $ checkSortOfSplitVar dr t' delta2 target+      return $ Right $ Covering (lookupPatternVar sc x) ns++  where+    inContextOfT, inContextOfDelta2 :: (MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) => tcm a -> tcm a+    inContextOfT      = addContext tel . escapeContext impossible (x + 1)+    inContextOfDelta2 = addContext tel . escapeContext impossible x++    -- Debug printing+    debugInit tel x ps cps = liftTCM $ inTopContext $ do+      reportSDoc "tc.cover.top" 10 $ vcat+        [ "TypeChecking.Coverage.split': split"+        , nest 2 $ vcat+          [ "tel     =" <+> prettyTCM tel+          , "x       =" <+> prettyTCM x+          , "ps      =" <+> do addContext tel $ prettyTCMPatternList $ fromSplitPatterns ps+          , "cps     =" <+> prettyTCM cps+          ]+        ]+      reportSDoc "tc.cover.top" 60 $ vcat+        [ "TypeChecking.Coverage.split': split"+        , nest 2 $ vcat+          [ "tel     =" <+> (text . show) tel+          , "x       =" <+> (text . show) x+          , "ps      =" <+> (text . show) ps+          , "cps     =" <+> (text . show) cps+          ]+        ]++    debugHoleAndType delta1 delta2 s ps t =+      liftTCM $ reportSDoc "tc.cover.top" 10 $ nest 2 $ vcat $+        [ "p      =" <+> text (patVarNameToString s)+        , "ps     =" <+> prettyTCMPatternList ps+        , "delta1 =" <+> prettyTCM delta1+        , "delta2 =" <+> inContextOfDelta2 (prettyTCM delta2)+        , "t      =" <+> inContextOfT (prettyTCM t)+        ]+++-- | splitResult for MakeCase, tries to introduce IApply or ProjP copatterns+splitResult :: QName -> SplitClause -> TCM (Either SplitError [SplitClause])+splitResult f sc = do+  caseMaybeM (splitResultPath f sc)+             ((fmap . fmap) splitClauses $ splitResultRecord f sc)+             (return . Right . (:[]))+++-- | Tries to split the result to introduce an IApply pattern.+splitResultPath :: QName -> SplitClause -> TCM (Maybe SplitClause)+splitResultPath f sc@(SClause tel ps _ _ target) = do+  caseMaybe target (return Nothing) $ \ t -> do+        caseMaybeM (isPath (unDom t)) (return Nothing) $ \ _ -> do+               (TelV i b, boundary) <- telViewUpToPathBoundary' 1 (unDom t)+               let tel' = abstract tel i+                   rho  = raiseS 1+                   ps' = applySubst rho (scPats sc) ++ telePatterns i boundary+                   cps' = applySubst rho (scCheckpoints sc)+                   target' = Just $ b <$ t+               return . Just $ SClause tel' ps' idS cps' target'++-- | @splitResultRecord f sc = return res@+--+--   If the target type of @sc@ is a record type, a covering set of+--   split clauses is returned (@sc@ extended by all valid projection patterns),+--   otherwise @res == Left _@.+--   Note that the empty set of split clauses is returned if the record has no fields.+splitResultRecord :: QName -> SplitClause -> TCM (Either SplitError Covering)+splitResultRecord f sc@(SClause tel ps _ _ target) = do+  reportSDoc "tc.cover.split" 10 $ vcat+    [ "splitting result:"+    , nest 2 $ "f      =" <+> prettyTCM f+    , nest 2 $ "target =" <+> addContext tel (maybe empty prettyTCM target)+    ]+  -- if we want to split projections, but have no target type, we give up+  let failure = return . Left+  caseMaybe target (failure CosplitNoTarget) $ \ t -> 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)+          , text $ "and have fields       fs = " ++ prettyShow fs+          ]+        -- Andreas, 2018-06-09, issue #2170, we always have irrelevant projections+        -- available on the lhs.+        -- -- Andreas, 2018-03-19, issue #2971, check that we have a "strong" record type,+        -- -- i.e., with all the projections.  Otherwise, we may not split.+        -- ifNotM (strongRecord fs) (failure CosplitIrrelevantProjections) $ {-else-} do+        let es = patternsToElims $ fromSplitPatterns ps+        -- Note: module parameters are part of ps+        let self  = defaultArg $ Def f [] `applyE` es+            pargs = vs ++ [self]+            fieldValues = for fs $ \ proj -> unArg self `applyE` [Proj ProjSystem (unDom proj)]+        reportSDoc "tc.cover" 20 $ addContext tel $ sep+          [ text   "we are              self =" <+> prettyTCM (unArg self)+          , text   "            field values =" <+> prettyTCM fieldValues+          ]+        let n = defaultArg $ permRange $ fromMaybe __IMPOSSIBLE__ $ dbPatPerm $ fromSplitPatterns ps+            -- Andreas & James, 2013-11-19 includes the dot patterns!+            -- See test/succeed/CopatternsAndDotPatterns.agda for a case with dot patterns+            -- and copatterns which fails for @n = size tel@ with a broken case tree.++        -- Andreas, 2016-07-22 read the style of projections from the user's lips+        projOrigin <- ifM (optPostfixProjections <$> pragmaOptions) (return ProjPostfix) (return ProjPrefix)+        Right . Covering n <$> do+          forM (zip fs $ List.inits fieldValues) $ \ (proj, prevFields) -> do+            -- compute the new target+            dType <- defType <$> do getConstInfo $ unDom proj -- WRONG: typeOfConst $ unArg proj+            let -- Substitution for parameters and previous fields. Needs to be applied to potential+                -- tactic in proj.+                fieldSub = reverse (map unArg vs ++ prevFields) ++# EmptyS impossible+                proj'    = applySubst fieldSub proj+                -- type of projection instantiated at self+                target' = Just $ proj' $> dType `piApply` pargs      -- Always visible (#2287)+                projArg = fmap (Named Nothing . ProjP projOrigin) $ argFromDom $ setHiding NotHidden proj+                sc' = sc { scPats   = scPats sc ++ [projArg]+                         , scSubst  = idS+                         , scTarget = target'+                         }+            reportSDoc "tc.cover.copattern" 40 $ vcat+              [ "fieldSub for" <+> prettyTCM (unDom proj)+              , nest 2 $ pretty fieldSub ]+            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.+  -- -- This is the case if --irrelevant-projections or no field is irrelevant.+  -- -- TODO: what about shape irrelevance?+  -- strongRecord :: [Arg QName] -> TCM Bool+  -- strongRecord fs = (optIrrelevantProjections <$> pragmaOptions) `or2M`+  --   (return $ not $ any isIrrelevant fs)+++-- * Boring instances++-- | For debugging only.+instance PrettyTCM SplitClause where+  prettyTCM (SClause tel pats sigma cps target) = sep+    [ "SplitClause"+    , nest 2 $ vcat+      [ "tel          =" <+> prettyTCM tel+      , "pats         =" <+> sep (map (prettyTCM . namedArg) pats)+      , "subst        =" <+> prettyTCM sigma+      , "checkpoints  =" <+> prettyTCM cps+      , "target       =" <+> do+          caseMaybe target empty $ \ t -> do+            addContext tel $ prettyTCM t+      -- Triggers crash (see Issue 1374).+      -- , "subst target = " <+> do       --     caseMaybe target empty $ \ t -> do       --       addContext tel $ prettyTCM $ applySubst sigma t       ]
+ 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
@@ -1,188 +1,329 @@-{-# LANGUAGE CPP           #-} -module Agda.TypeChecking.Coverage.Match where+{-| Given -import Control.Applicative-import Control.Monad.State+    1. the function clauses @cs@+    2. the patterns @ps@ of the split clause +we want to compute a variable index (in the split clause) to split on next.++The matcher here checks whether the split clause is covered by one of+the given clauses @cs@ or whether further splitting is needed (and+when yes, where).+-}++module Agda.TypeChecking.Coverage.Match+  ( Match(..), match, matchClause+  , SplitPattern, SplitPatVar(..)+  , fromSplitPattern, fromSplitPatterns, toSplitPatterns+  , toSplitPSubst, applySplitPSubst+  , isTrivialPattern+  , BlockingVar(..), BlockingVars, BlockedOnResult(..)+  , setBlockingVarOverlap+  , ApplyOrIApply(..)+  ) where++import Prelude hiding ( null )++import Data.DList (DList)+import Data.Foldable (toList) import qualified Data.List as List-import Data.Maybe (mapMaybe, isJust)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat, Any(..))-import Data.Traversable (traverse)+import Data.Maybe (mapMaybe, fromMaybe)+import Data.Semigroup ( Semigroup, (<>)) -import Agda.Syntax.Abstract (IsProjP(..)) import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern () import Agda.Syntax.Literal +import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty ( PrettyTCM(..) )+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Permutation-import Agda.Utils.Size-import Agda.Utils.List+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ )+import Agda.Utils.Monad+import Agda.Utils.Singleton -#include "undefined.h" import Agda.Utils.Impossible -{-| Given+-- | If matching is inconclusive (@Block@) we want to know which+--   variables or projections are blocking the match.+data Match a+  = Yes a   -- ^ Matches unconditionally.+  | No      -- ^ Definitely does not match.+  | Block+    { blockedOnResult :: BlockedOnResult+      -- ^ @BlockedOnProj o@ if the clause has a result split.+    , blockedOnVars :: BlockingVars+      -- ^ @BlockingVar i cs ls o@ means variable @i@ is blocked on+      -- constructors @cs@ and literals @ls@.+    }+  deriving (Functor) -    1. the function clauses @cs@-    2. the patterns @ps@+-- | Missing elimination blocking a match.+data BlockedOnResult+  = BlockedOnProj      -- ^ Blocked on unsplit projection.+     { blockedOnResultOverlap :: Bool+       -- ^ True if there are also matching clauses without an unsplit+       -- copattern.+     }+  | BlockedOnApply     -- ^ Blocked on unintroduced argument.+     { blockedOnResultIApply :: ApplyOrIApply+       -- ^ Is the unintroduced argument an 'IApply' pattern?+     }+  | NotBlockedOnResult -we want to compute a variable index of the split clause to split on next.+data ApplyOrIApply = IsApply | IsIApply -First, we find the set @cs'@ of all the clauses that are-instances (via substitutions @rhos@) of the split clause.+-- | Variable blocking a match.+data BlockingVar = BlockingVar+  { blockingVarNo  :: Nat+    -- ^ De Bruijn index of variable blocking the match.+  , blockingVarCons :: [ConHead]+    -- ^ Constructors in this position.+  , blockingVarLits :: [Literal]+    -- ^ Literals in this position.+  , blockingVarOverlap :: Bool+    -- ^ True if at least one clause has a variable pattern in this+    --   position.+  , blockingVarLazy :: Bool+    -- ^ True if at least one clause has a lazy pattern in this position.+  } deriving (Show) -In these substitutions, we look for a column that has only constructor patterns.-We try to split on this column first.--}+type BlockingVars = [BlockingVar] --- | Match the given patterns against a list of clauses-match :: [Clause] -> [NamedArg DeBruijnPattern] -> Match (Nat,([DeBruijnPattern],[Literal]))-match cs ps = foldr choice No $ zipWith matchIt [0..] cs+-- | Substitution of 'SplitPattern's for de Bruijn indices in covering+--   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.+--+match :: PureTCM m+      => [Clause]                           -- ^ Search for clause that covers the patterns.+      -> [NamedArg SplitPattern]            -- ^ Patterns of the current 'SplitClause'.+      -> m (Match (Nat, SplitInstantiation))+match cs ps = foldr choice (return No) $ zipWith matchIt [0..] cs   where-    -- If liberal matching on literals fails or blocks we go with that.-    -- If it succeeds we use the result from conservative literal matching.-    -- This is to make sure that we split enough when literals are involved.-    -- For instance,-    --    f ('x' :: 'y' :: _) = ...-    --    f (c :: s) = ...-    -- would never split the tail of the list if we only used conservative-    -- literal matching.-    matchIt i c = (i,) <$>-      matchClause yesMatchLit ps i c +++-      matchClause noMatchLit  ps i c+    matchIt :: PureTCM m+            => Nat  -- Clause number.+            -> Clause+            -> m (Match (Nat, SplitInstantiation))+    matchIt i c = fmap (\s -> (i, toList s)) <$> matchClause ps c -    Yes _     +++ m = m-    No        +++ _ = No-    m@Block{} +++ _ = m+-- | For each variable in the patterns of a split clause, we remember the+--   de Bruijn-index and the literals excluded by previous matches. --- | Convert the root of a term into a pattern constructor, if possible.-buildPattern :: Term -> Maybe DeBruijnPattern-buildPattern (Con c ci args) = Just $-  ConP c (toConPatternInfo ci) $ map (fmap $ unnamed . DotP) args-buildPattern (Var i [])     = Just $ deBruijnVar i-buildPattern (Shared p)     = buildPattern (derefPtr p)-buildPattern _              = Nothing+--  (See issue #708.)+data SplitPatVar = SplitPatVar+  { splitPatVarName   :: PatVarName+  , splitPatVarIndex  :: Int+  , splitExcludedLits :: [Literal]+  } deriving (Show) +instance Pretty SplitPatVar where+  prettyPrec _ x =+    text (patVarNameToString (splitPatVarName x)) <>+    text ("@" ++ show (splitPatVarIndex x)) <>+    ifNull (splitExcludedLits x) empty (\lits ->+      "\\{" <> prettyList_ lits <> "}")++instance PrettyTCM SplitPatVar where+  prettyTCM = prettyTCM . var . splitPatVarIndex++type SplitPattern = Pattern' SplitPatVar++toSplitVar :: DBPatVar -> SplitPatVar+toSplitVar x = SplitPatVar (dbPatVarName x) (dbPatVarIndex x) []++fromSplitVar :: SplitPatVar -> DBPatVar+fromSplitVar x = DBPatVar (splitPatVarName x) (splitPatVarIndex x)++instance DeBruijn SplitPatVar where+  deBruijnView x = deBruijnView (fromSplitVar x)+  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 fromSplitPattern++type SplitPSubstitution = Substitution' SplitPattern++toSplitPSubst :: PatternSubstitution -> SplitPSubstitution+toSplitPSubst = (fmap . fmap) toSplitVar++fromSplitPSubst :: SplitPSubstitution -> PatternSubstitution+fromSplitPSubst = (fmap . fmap) fromSplitVar++applySplitPSubst :: TermSubst a => SplitPSubstitution -> a -> a+applySplitPSubst = applyPatSubst . fromSplitPSubst++-- TODO: merge this instance and the one for DeBruijnPattern in+-- Substitute.hs into one for Subst (Pattern' a) (Pattern' a).+instance Subst SplitPattern where+  type SubstArg SplitPattern = SplitPattern++  applySubst IdS = id+  applySubst rho = \case+    VarP i x        ->+      usePatternInfo i $+      useName (splitPatVarName x) $+      useExcludedLits (splitExcludedLits x) $+      lookupS rho $ splitPatVarIndex x+    DotP i u        -> DotP i $ applySplitPSubst rho u+    ConP c ci ps    -> ConP c ci $ applySubst rho ps+    DefP i q ps     -> DefP i q $ applySubst rho ps+    p@LitP{}        -> p+    p@ProjP{}       -> p+    IApplyP i l r x ->+      useEndPoints (applySplitPSubst rho l) (applySplitPSubst rho r) $+      usePatternInfo i $+      useName (splitPatVarName x) $+      useExcludedLits (splitExcludedLits x) $+      lookupS rho $ splitPatVarIndex x++    where+      -- see Subst for DeBruijnPattern+      useEndPoints :: Term -> Term -> SplitPattern -> SplitPattern+      useEndPoints l r (VarP o x)        = IApplyP o l r x+      useEndPoints l r (IApplyP o _ _ x) = IApplyP o l r x+      useEndPoints l r x                 = __IMPOSSIBLE__++      useName :: PatVarName -> SplitPattern -> SplitPattern+      useName n (VarP o x)+        | isUnderscore (splitPatVarName x)+        = VarP o $ x { splitPatVarName = n }+      useName _ x = x++      useExcludedLits :: [Literal] -> SplitPattern -> SplitPattern+      useExcludedLits lits = \case+        (VarP o x) -> VarP o $ x+          { splitExcludedLits = lits ++ splitExcludedLits x }+        p -> p+++{-# SPECIALIZE isTrivialPattern :: Pattern' a -> TCM Bool #-} -- | A pattern that matches anything (modulo eta).-isTrivialPattern :: Pattern' a -> Bool-isTrivialPattern p = case p of-  VarP{}      -> True-  DotP{}      -> True-  ConP c i ps -> isJust (conPRecord i) && all (isTrivialPattern . namedArg) ps-  LitP{}      -> False-  ProjP{}     -> False+isTrivialPattern :: (HasConstInfo m) => Pattern' a -> m Bool+isTrivialPattern = \case+  VarP{}      -> return True+  DotP{}      -> return True+  ConP c i ps -> andM $ ((conPLazy i ||) <$> isEtaCon (conName c))+                      : (map (isTrivialPattern . namedArg) ps)+  DefP{}      -> return False+  LitP{}      -> return False+  ProjP{}     -> return False+  IApplyP{}   -> return True  -- | If matching succeeds, we return the instantiation of the clause pattern vector---   to obtain the split clause pattern vector, plus the literals of the clause patterns---   matched against split clause variables.-type MatchResult = Match ([DeBruijnPattern],[Literal])+--   to obtain the split clause pattern vector.+type MatchResult = Match (DList (Nat, SplitPattern)) --- | If matching is inconclusive (@Block@) we want to know which---   variables are blocking the match.-data Match a-  = Yes a   -- ^ Matches unconditionally.-  | No      -- ^ Definitely does not match.-  | Block Any BlockingVars-            -- ^ Could match if non-empty list of blocking variables-            --   is instantiated properly.-            --   Also 'Any' is 'True' if all clauses have a result split.-            --   (Only then can we do result splitting.)-  deriving (Functor)+instance Pretty BlockingVar where+  pretty (BlockingVar i cs ls o l) = cat+    [ text ("variable " ++ show i)+    , if null cs then empty else " blocked on constructors" <+> pretty cs+    , if null ls then empty else " blocked on literals" <+> pretty ls+    , if o then " (overlapping)" else empty+    , if l then " (lazy)" else empty+    ] --- | Variable blocking a match.-data BlockingVar  = BlockingVar-  { blockingVarNo   :: Nat-    -- ^ De Bruijn index of variable blocking the match.-  , blockingVarCons :: Maybe [ConHead]-    -- ^ @Nothing@ means there is an overlapping match for this variable.-    --   This happens if one clause has a constructor pattern at this position,-    --   and another a variable.  It is also used for "just variable".-    ---    --   @Just cons@ means that it is an non-overlapping match and-    --   @cons@ are the encountered constructors.-  } deriving (Show)-type BlockingVars = [BlockingVar]+yes :: Monad m => a -> m (Match a)+yes = return . Yes --- | Lens for 'blockingVarCons'.-mapBlockingVarCons :: (Maybe [ConHead] -> Maybe [ConHead]) -> BlockingVar -> BlockingVar-mapBlockingVarCons f b = b { blockingVarCons = f (blockingVarCons b) }+no :: Monad m => m (Match a)+no = return No -clearBlockingVarCons :: BlockingVar -> BlockingVar-clearBlockingVarCons = mapBlockingVarCons $ const Nothing+blockedOnConstructor :: Monad m => Nat -> ConHead -> ConPatternInfo -> m (Match a)+blockedOnConstructor i c ci = return $ Block NotBlockedOnResult [BlockingVar i [c] [] False $ conPLazy ci] +blockedOnLiteral :: Monad m => Nat -> Literal -> m (Match a)+blockedOnLiteral i l = return $ Block NotBlockedOnResult [BlockingVar i [] [l] False False]++blockedOnProjection :: Monad m => m (Match a)+blockedOnProjection = return $ Block (BlockedOnProj False) []++blockedOnApplication :: Monad m => ApplyOrIApply -> m (Match a)+blockedOnApplication b = return $ Block (BlockedOnApply b) []+--UNUSED Liang-Ting Chen 2019-07-16+---- | Lens for 'blockingVarCons'.+--mapBlockingVarCons :: ([ConHead] -> [ConHead]) -> BlockingVar -> BlockingVar+--mapBlockingVarCons f b = b { blockingVarCons = f (blockingVarCons b) }+--+---- | Lens for 'blockingVarLits'.+--mapBlockingVarLits :: ([Literal] -> [Literal]) -> BlockingVar -> BlockingVar+--mapBlockingVarLits f b = b { blockingVarLits = f (blockingVarLits b) }++setBlockingVarOverlap :: BlockingVar -> BlockingVar+setBlockingVarOverlap = \x -> x { blockingVarOverlap = True }+ overlapping :: BlockingVars -> BlockingVars-overlapping = map clearBlockingVarCons+overlapping = map setBlockingVarOverlap  -- | Left dominant merge of blocking vars. zipBlockingVars :: BlockingVars -> BlockingVars -> BlockingVars zipBlockingVars xs ys = map upd xs   where-    upd (BlockingVar x (Just cons))-      | Just (BlockingVar _ (Just cons')) <- List.find ((x ==) . blockingVarNo) ys-                          = BlockingVar x (Just $ cons ++ cons')-    upd (BlockingVar x _) = BlockingVar x Nothing+    upd (BlockingVar x cons lits o l) = case List.find ((x ==) . blockingVarNo) ys of+      Just (BlockingVar _ cons' lits' o' l') -> BlockingVar x (cons ++ cons') (lits ++ lits') (o || o') (l || l')+      Nothing -> BlockingVar x cons lits True l +setBlockedOnResultOverlap :: BlockedOnResult -> BlockedOnResult+setBlockedOnResultOverlap b = case b of+  BlockedOnProj{}      -> b { blockedOnResultOverlap = True }+  BlockedOnApply{}     -> b+  NotBlockedOnResult{} -> b++anyBlockedOnResult :: BlockedOnResult -> BlockedOnResult -> BlockedOnResult+anyBlockedOnResult b1 b2 = case (b1,b2) of+  (NotBlockedOnResult , b2                ) -> b2+  (b1                 , NotBlockedOnResult) -> b1+  (_                  , _                 ) -> __IMPOSSIBLE__++-- | Left dominant merge of `BlockedOnResult`.+choiceBlockedOnResult :: BlockedOnResult -> BlockedOnResult -> BlockedOnResult+choiceBlockedOnResult b1 b2 = case (b1,b2) of+  (NotBlockedOnResult  , _                 ) -> NotBlockedOnResult+  (BlockedOnProj o1    , BlockedOnProj o2  ) -> BlockedOnProj (o1 || o2)+  (BlockedOnProj _     , _                 ) -> BlockedOnProj True+  (BlockedOnApply b    , _                 ) -> BlockedOnApply b+ -- | @choice m m'@ combines the match results @m@ of a function clause --   with the (already combined) match results $m'$ of the later clauses. --   It is for skipping clauses that definitely do not match ('No'). --   It is left-strict, to be used with @foldr@. --   If one clause unconditionally matches ('Yes') we do not look further.-choice :: Match a -> Match a -> Match a-choice (Yes a)      _            = Yes a-choice (Block r xs) (Block s ys) = Block (Any $ getAny r && getAny s) $-  zipBlockingVars xs ys-choice (Block r xs) (Yes _)      = Block r $ overlapping xs-choice m@Block{}    No           = m-choice No           m            = m---- | Could the literal cover (an instantiation of) the split clause pattern?---   Basically, the split clause pattern needs to be a variable.------   Note: literal patterns do not occur in the split clause---   since we cannot split into all possible literals (that would be infeasible).-type MatchLit = Literal -> DeBruijnPattern -> MatchResult---- | Use this function if literal patterns should not cover a split clause pattern.-noMatchLit :: MatchLit-noMatchLit _ _ = No---- | Use this function if a literal pattern should cover a split clause variable pattern.-yesMatchLit :: MatchLit-yesMatchLit l q@VarP{} = Yes ([q], [l])-yesMatchLit l (DotP t) = maybe No (yesMatchLit l) $ buildPattern t-yesMatchLit _ ConP{}   = No-yesMatchLit _ ProjP{}  = No-yesMatchLit _ LitP{}   = __IMPOSSIBLE__---- | Check if a clause could match given generously chosen literals-matchLits :: Clause -> [NamedArg DeBruijnPattern] -> Maybe [Literal]-matchLits c ps =-  case matchClause yesMatchLit ps 0 c of-    Yes (qs,ls) -> Just ls-    _ -> Nothing+choice :: Monad m => m (Match a) -> m (Match a) -> m (Match a)+choice m m' = m >>= \case+  Yes a -> yes a+  Block r xs -> m' >>= \case+    Block s ys -> return $ Block (choiceBlockedOnResult r s) $ zipBlockingVars xs ys+    Yes _      -> return $ Block (setBlockedOnResultOverlap r) $ overlapping xs+    No         -> return $ Block r xs+  No    -> m' --- | @matchClause mlit qs i c@ checks whether clause @c@ number @i@---   covers a split clause with patterns @qs@.+{-# SPECIALIZE matchClause :: [NamedArg SplitPattern] -> Clause -> TCM MatchResult #-} matchClause-  :: MatchLit-     -- ^ Consider literals?-  -> [NamedArg DeBruijnPattern]+  :: PureTCM m+  => [NamedArg SplitPattern]      -- ^ Split clause patterns @qs@.-  -> Nat-     -- ^ Clause number @i@.   -> Clause      -- ^ Clause @c@ to cover split clause.-  -> MatchResult+  -> m MatchResult      -- ^ Result.      --   If 'Yes' the instantiation @rs@ such that @(namedClausePats c)[rs] == qs@.-matchClause mlit qs i c = matchPats mlit (namedClausePats c) qs-+matchClause qs c = matchPats (namedClausePats c) qs --- | @matchPats mlit ps qs@ checks whether a function clause with patterns+{-# 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@. -- --   Issue #842 / #1986: This is accepted:@@ -198,40 +339,33 @@ --   in @mconcat []@ which is @Yes []@.  matchPats-  :: MatchLit-     -- ^ Matcher for literals.-  -> [NamedArg (Pattern' a)]+  :: (PureTCM m, DeBruijn a)+  => [NamedArg (Pattern' a)]      -- ^ Clause pattern vector @ps@ (to cover split clause pattern vector).-  -> [NamedArg DeBruijnPattern]+  -> [NamedArg SplitPattern]      -- ^ Split clause pattern vector @qs@ (to be covered by clause pattern vector).-  -> MatchResult+  -> m MatchResult      -- ^ Result.      --   If 'Yes' the instantiation @rs@ such that @ps[rs] == qs@.--matchPats mlit ps qs = mconcat $ [ projPatternsLeftInSplitClause ] ++-    zipWith (matchPat mlit) (map namedArg ps) (map namedArg qs) ++-    [ projPatternsLeftInMatchedClause ]-  where-    -- Patterns left in split clause:-    qsrest = drop (length ps) qs-    -- Andreas, 2016-06-03, issue #1986:-    -- catch-all for copatterns is inconsistent as found by Ulf.-    -- Thus, if the split clause has copatterns left,-    -- the current (shorter) clause is not considered covering.-    projPatternsLeftInSplitClause =-        case mapMaybe isProjP qsrest of-            [] -> mempty -- no proj. patterns left-            _  -> No     -- proj. patterns left+matchPats [] [] = yes mempty+matchPats (p:ps) (q:qs) =+  matchPat (namedArg p) (namedArg q) `combine` matchPats ps qs -    -- Patterns left in candidate clause:-    psrest = drop (length qs) ps-    -- If the current clause has additional copatterns in-    -- comparison to the split clause, we should split on them.-    projPatternsLeftInMatchedClause =-        case mapMaybe isProjP psrest of-            [] -> mempty               -- no proj. patterns left-            ds -> Block (Any True) []  -- proj. patterns left+-- Patterns left in split clause:+-- Andreas, 2016-06-03, issue #1986:+-- catch-all for copatterns is inconsistent as found by Ulf.+-- Thus, if the split clause has copatterns left,+-- the current (shorter) clause is not considered covering.+matchPats [] qs@(_:_) = case mapMaybe isProjP qs of+  [] -> yes mempty -- no proj. patterns left+  _  -> no         -- proj. patterns left +-- Patterns left in candidate clause:+-- If the current clause has additional copatterns in+-- comparison to the split clause, we should split on them.+matchPats (p:ps) [] = case isProjP p of+  Just{}  -> blockedOnProjection+  Nothing -> blockedOnApplication (case namedArg p of IApplyP{} -> IsIApply; _ -> IsApply)  -- | Combine results of checking whether function clause patterns --   covers split clause patterns.@@ -245,54 +379,141 @@ --   'Block' accumulates variables of the split clause --   that have to be instantiated (an projection names of copattern matches) --   to make the split clause an instance of the function clause.--instance Monoid a => Semigroup (Match a) where-  Yes a      <> Yes b      = Yes $ mappend a b-  Yes _      <> m          = m-  No         <> _          = No-  Block{}    <> No         = No-  Block r xs <> Block s ys = Block (mappend r s) $ mappend xs ys-  m@Block{}  <> Yes{}      = m--instance Monoid a => Monoid (Match a) where-  mempty  = Yes mempty-  mappend = (<>)-+combine :: (Monad m, Semigroup a) => m (Match a) -> m (Match a) -> m (Match a)+combine m m' = m >>= \case+    Yes a -> m' >>= \case+      Yes b -> yes (a <> b)+      y     -> return y+    No    -> no+    x@(Block r xs) -> m' >>= \case+      No    -> no+      Block s ys -> return $ Block (anyBlockedOnResult r s) (xs ++ ys)+      Yes{} -> return x --- | @matchPat mlit p q@ checks whether a function clause pattern @p@+{-# 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:---   @Yes rs@ means it covers, because @p@ is a variable pattern. @rs@ collects---   the instantiations of the variables in @p@ s.t. @p[rs] = q@.---   @No@ means it does not cover.---   @Block [x]@ means @p@ is a proper instance of @q@ and could become---   a cover if @q@ was split on variable @x@.+--+--   1. @Yes rs@ means it covers, because @p@ is a variable pattern. @rs@ collects+--      the instantiations of the variables in @p@ s.t. @p[rs] = q@.+--+--   2. @No@ means it does not cover.+--+--   3. @Block [x]@ means @p@ is a proper instance of @q@ and could become+--      a cover if @q@ was split on variable @x@.  matchPat-  :: MatchLit-     -- ^ Matcher for literals.-  -> Pattern' a+  :: (PureTCM m, DeBruijn a)+  => Pattern' a      -- ^ Clause pattern @p@ (to cover split clause pattern).-  -> DeBruijnPattern+  -> SplitPattern      -- ^ Split clause pattern @q@ (to be covered by clause pattern).-  -> MatchResult+  -> m MatchResult      -- ^ Result.      --   If 'Yes', also the instantiation @rs@ of the clause pattern variables      --   to produce the split clause pattern, @p[rs] = q@.+matchPat p q = case p of -matchPat _    VarP{}   q = Yes ([q],[])-matchPat _    DotP{}   q = 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--- on them doesn't change the reduction behaviour.-matchPat mlit (LitP l) q = mlit l q-matchPat _    (ProjP _ d) (ProjP _ d') = if d == d' then mempty else No-matchPat _    ProjP{} _ = __IMPOSSIBLE__-matchPat mlit p@(ConP c _ ps) q = case q of-  VarP x -> Block (Any False) [BlockingVar (dbPatVarIndex x) (Just [c])]-  ConP c' i qs-    | c == c'   -> matchPats mlit ps qs-    | otherwise -> No-  DotP t  -> maybe No (matchPat mlit p) $ buildPattern t-  LitP _  -> __IMPOSSIBLE__  -- split clause has no literal patterns-  ProjP{} -> __IMPOSSIBLE__  -- excluded by typing+  VarP _ x ->+    yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q)++  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+  -- on them doesn't change the reduction behaviour.++  p@(LitP _ l) -> case q of+    VarP _ x -> if l `elem` splitExcludedLits x+                then no+                else blockedOnLiteral (splitPatVarIndex x) l+    _ -> isLitP q >>= \case+      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 mempty else no+    VarP{}     -> no  -- not impossible, see issue #7753+    DotP{}     -> __IMPOSSIBLE__+    ConP{}     -> __IMPOSSIBLE__+    DefP{}     -> __IMPOSSIBLE__+    LitP{}     -> __IMPOSSIBLE__+    IApplyP{}  -> __IMPOSSIBLE__++  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.+  ConP c ci ps -> unDotP q >>= unLitP >>= \case+    VarP _ x -> blockedOnConstructor (splitPatVarIndex x) c ci+    ConP c' i qs+      | c == c'   -> matchPats ps qs+      | otherwise -> no+    DotP o t  -> no+    DefP{}   -> no+    LitP{}    -> __IMPOSSIBLE__  -- excluded by typing and unLitP+    ProjP{}   -> __IMPOSSIBLE__  -- excluded by typing+    IApplyP _ _ _ x -> blockedOnConstructor (splitPatVarIndex x) c ci++  DefP o c ps -> unDotP q >>= \case+    VarP _ x -> no+    ConP c' i qs -> no+    DotP o t  -> no+    LitP{}    -> no+    DefP o c' qs+      | c == c'   -> matchPats ps qs+      | otherwise -> no+    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+  Var i [] -> return $ deBruijnVar i+  Con c _ vs -> do+    let ps = map (fmap $ unnamed . DotP o) $ fromMaybe __IMPOSSIBLE__ $ allApplyElims vs+    return $ ConP c noConPatternInfo ps+  Lit l -> return $ LitP (PatternInfo PatODot []) l+  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+  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+  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSuc+  if conName c == suc+    then fmap inc <$> isLitP (namedArg a)+    else return Nothing+  where+    inc :: Literal -> Literal+    inc (LitNat n) = LitNat $ n + 1+    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+ 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,5 +1,6 @@-{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-}+ {-| Split tree for transforming pattern clauses into case trees.  The coverage checker generates a split tree from the clauses.@@ -13,19 +14,25 @@ -} module Agda.TypeChecking.Coverage.SplitTree where +import Control.DeepSeq+ import Data.Tree +import GHC.Generics (Generic)+ import Agda.Syntax.Abstract.Name import Agda.Syntax.Common-import Agda.Syntax.Internal as I+import Agda.Syntax.Concrete.Pretty () --instance only+import Agda.Syntax.Literal+import Agda.Syntax.Position -import Agda.Utils.Monad+import Agda.Syntax.Common.Pretty+import Agda.Utils.Null -#include "undefined.h" import Agda.Utils.Impossible -type SplitTree  = SplitTree'  QName-type SplitTrees = SplitTrees' QName+type SplitTree  = SplitTree'  SplitTag+type SplitTrees = SplitTrees' SplitTag  -- | Abstract case tree shape. data SplitTree' a@@ -37,34 +44,57 @@   | -- | A split is necessary.     SplitAt     { splitArg   :: Arg Int       -- ^ Arg. no to split at.+    , splitLazy  :: LazySplit     , splitTrees :: SplitTrees' a -- ^ Sub split trees.     }+  deriving (Show, Generic) +data LazySplit = LazySplit | StrictSplit+  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 --   so many constructors per data type, and there is no need for --   random access. type SplitTrees' a = [(a, SplitTree' a)] +-- | Tag for labeling branches of a split tree. Each branch is associated to+--   either a constructor or a literal, or is a catchall branch (currently+--   only used for splitting on a literal type).+data SplitTag+  = SplitCon QName+  | SplitLit Literal+  | SplitCatchall+  deriving (Show, Eq, Ord, Generic)++instance Pretty SplitTag where+  pretty (SplitCon c) = pretty c+  pretty (SplitLit l)  = pretty l+  pretty SplitCatchall = underscore+ -- * Printing a split tree  data SplitTreeLabel a = SplitTreeLabel   { lblConstructorName :: Maybe a   -- ^ 'Nothing' for root of split tree   , lblSplitArg        :: Maybe (Arg Int)+  , lblLazy            :: LazySplit   , lblBindings        :: Maybe Int   }-instance Show a => Show (SplitTreeLabel a) where-  show (SplitTreeLabel Nothing Nothing (Just n))  = "done, " ++ show n ++ " bindings"-  show (SplitTreeLabel Nothing (Just n) Nothing)  = "split at " ++ show n-  show (SplitTreeLabel (Just q) Nothing (Just n)) = show q ++ " -> done, " ++ show n ++ " bindings"-  show (SplitTreeLabel (Just q) (Just n) Nothing) = show q ++ " -> split at " ++ show n-  show _ = __IMPOSSIBLE__+instance Pretty a => Pretty (SplitTreeLabel a) where+  pretty = \case+    SplitTreeLabel Nothing Nothing   _  (Just n) -> text $ "done, " ++ prettyShow n ++ " bindings"+    SplitTreeLabel Nothing (Just n)  lz Nothing  -> lzp lz <+> text ("split at " ++ prettyShow n)+    SplitTreeLabel (Just q) Nothing  _  (Just n) -> pretty q <+> text ("-> done, " ++ prettyShow n ++ " bindings")+    SplitTreeLabel (Just q) (Just n) lz Nothing  -> pretty q <+> text "->" <+> lzp lz <+> text ("split at " ++ prettyShow n)+    _ -> __IMPOSSIBLE__+    where lzp lz | lz == LazySplit = "lazy"+                 | otherwise       = empty  -- | Convert a split tree into a 'Data.Tree' (for printing). toTree :: SplitTree' a -> Tree (SplitTreeLabel a)-toTree t = case t of-  SplittingDone n -> Node (SplitTreeLabel Nothing Nothing (Just n)) []-  SplitAt n ts    -> Node (SplitTreeLabel Nothing (Just n) Nothing) $ toTrees ts+toTree = \case+  SplittingDone n -> Node (SplitTreeLabel Nothing Nothing StrictSplit (Just n)) []+  SplitAt n lz ts    -> Node (SplitTreeLabel Nothing (Just n) lz Nothing) $ toTrees ts  toTrees :: SplitTrees' a -> Forest (SplitTreeLabel a) toTrees = map (\ (c,t) -> setCons c $ toTree t)@@ -72,5 +102,20 @@     setCons :: a -> Tree (SplitTreeLabel a) -> Tree (SplitTreeLabel a)     setCons c (Node l ts) = Node (l { lblConstructorName = Just c }) ts -instance Show a => Show (SplitTree' a) where-  show = drawTree . fmap show . toTree+instance Pretty a => Pretty (SplitTree' a) where+  pretty = text . drawTree . fmap prettyShow . toTree++instance KillRange SplitTag where+  killRange = \case+    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 -> killRangeN (SplitAt i lz) ts++instance NFData a => NFData (SplitTree' a)+instance NFData LazySplit+instance NFData SplitTag
src/full/Agda/TypeChecking/Datatypes.hs view
@@ -1,21 +1,26 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Datatypes where +import Control.Monad        ( filterM )+import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )+ import Data.Maybe (fromMaybe)  import Agda.Syntax.Common import Agda.Syntax.Internal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (constructorForm) import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Pretty -import Agda.Utils.Size+import Agda.Utils.Either import Agda.Utils.Functor+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -23,21 +28,28 @@ ---------------------------------------------------------------------------  -- | Get true constructor with record fields.-getConHead :: QName -> TCM ConHead-getConHead c = conSrcCon . theDef <$> getConstInfo c+getConHead :: (HasConstInfo m) => QName -> m (Either SigError ConHead)+getConHead c = runExceptT $ do+  def <- ExceptT $ getConstInfo' c+  case theDef def of+    Constructor { conSrcCon = c' } -> return c'+    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 ConHead-getConForm c = do-  ch <- getConHead c-  Con con _ [] <- ignoreSharing <$> constructorForm (Con ch ConOCon [])-  return con+getConForm :: QName -> TCM (Either SigError ConHead)+getConForm c = caseEitherM (getConHead c) (return . Left) $ \ ch -> do+  Con con _ [] <- constructorForm (Con ch ConOCon [])+  return $ Right con  -- | Augment constructor with record fields (preserve constructor name). --   The true constructor might only surface via 'reduce'.-getOrigConHead :: QName -> TCM ConHead-getOrigConHead c = setConName c <$> getConHead c+getOrigConHead :: QName -> TCM (Either SigError ConHead)+getOrigConHead c = mapRight (setConName c) <$> getConHead c  -- | Get the name of the datatype constructed by a given constructor. --   Precondition: The argument must refer to a constructor@@ -49,62 +61,178 @@     Constructor{conData = d} -> return d     _                        -> __IMPOSSIBLE__ --- | @getConType c t@ computes the constructor parameters from type @t@---   and returns the instantiated type of constructor @c@.+-- | Is the datatype of this constructor a Higher Inductive Type?+--   Precondition: The argument must refer to a constructor of a datatype or record.+consOfHIT :: HasConstInfo m => QName -> m Bool+consOfHIT c = do+  d <- getConstructorData c+  def <- theDef <$> getConstInfo d+  case def of+    Datatype {dataPathCons = xs} -> return $ not $ null xs+    Record{} -> return False+    _  -> __IMPOSSIBLE__++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+--   plus the instantiated type of constructor @c@.+-- --   @Nothing@ if @t@ is not a data/record type or does not have --   a constructor @c@.+-- --   Precondition: @t@ is reduced.-getConType :: ConHead -> Type -> TCM (Maybe Type)-getConType c t = do-  c <- getConHead $ conName c-  case ignoreSharing $ unEl t of-    Def d es -> do-      def <- theDef <$> getConstInfo d-      case def of-        Datatype { dataPars = n, dataCons   = cs  } | conName c `elem` cs -> cont n-        Record   { recPars  = n, recConHead = con } | c == con            -> cont n-        _ ->  return Nothing-      where-        cont n = do-          let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take n es-          Just <$> do (`piApplyM` pars) . defType =<< getConInfo c+getFullyAppliedConType+  :: PureTCM m+  => ConHead  -- ^ Constructor.+  -> Type     -- ^ Reduced type of the fully applied constructor.+  -> m (Maybe ((QName, Type, Args), Type))+       -- ^ @Nothing@ if not 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.+getFullyAppliedConType c t = do+  reportSLn "tc.getConType" 35 $ unwords $+    [ "getFullyAppliedConType", prettyShow c, prettyShow t ]+  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+    Def d es | d == cdata -> do+      reportSLn "tc.getConType" 35 $ unwords $+        [ "getFullyAppliedConType: case Def", prettyShow d, prettyShow es ]+      dt <- defType <$> getConstInfo d+      let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es+      ctPars <- ctype `piApplyM` pars+      return $ Just ((d, dt, pars), ctPars)     _ -> return Nothing -data HasEta = NoEta | YesEta-  deriving (Eq)+-- | 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) -data ConstructorInfo = DataCon Nat  -- arity-                     | RecordCon HasEta [Arg QName]+-- | 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 --- | Return the number of non-parameter arguments to a data constructor,---   or the field names of a record constructor.+-- | @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 -----   For getting just the arity of constructor @c@,---   use @either id size <$> getConstructorArity c@.-getConstructorInfo :: QName -> TCM ConstructorInfo-getConstructorInfo c = do-  Defn{ defType = t, theDef = def } <- getConstInfo c-  case def of-    Constructor{ conData = d, conPars = n } -> do-      def <- theDef <$> getConstInfo d-      case def of-        r@Record{ recFields = fs } ->-           return $ RecordCon (if recEtaEquality r then YesEta else NoEta) fs-        Datatype{} -> do-          -- TODO: I do not want to take the type of constructor apart-          -- to see its arity!-          TelV tel _ <- telView t-          return $ DataCon $ size tel - n-        _ -> __IMPOSSIBLE__-    _ -> __IMPOSSIBLE__+--   @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) -getConstructorArity :: QName -> TCM Nat-getConstructorArity c =-  for (getConstructorInfo c) $ \i ->-  case i of-    DataCon n      -> n-    RecordCon _ fs -> size fs+data ConstructorInfo+  = 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 constructor (arity).+--   In case of record constructors, also return the field names (plus other info).+--+getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo+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__+    _ -> return Nothing+ --------------------------------------------------------------------------- -- * Data types ---------------------------------------------------------------------------@@ -118,26 +246,27 @@     Record{recNamedCon = namedC} -> return namedC     _                            -> return False -data DataOrRecord = IsData | IsRecord-  deriving (Eq, Ord, Show)- -- | Check if a name refers to a datatype or a record. isDataOrRecordType :: QName -> TCM (Maybe DataOrRecord) isDataOrRecordType d = do-  def <- getConstInfo d-  case theDef def of+  (theDef <$> getConstInfo d) >>= \case+    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-    Record{}   -> return $ Just IsRecord     _          -> return $ Nothing  -- | Precodition: 'Term' is 'reduce'd.-isDataOrRecord :: Term -> TCM (Maybe QName)-isDataOrRecord v = do-  case ignoreSharing v of-    Def d _ -> fmap (const d) <$> isDataOrRecordType d+isDataOrRecord :: Term -> TCM (Maybe (QName, DataOrRecord))+isDataOrRecord = \case+    Def d _ -> fmap (d,) <$> isDataOrRecordType d     _       -> return Nothing -getNumberOfParameters :: QName -> TCM (Maybe Nat)+getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat) getNumberOfParameters d = do   def <- getConstInfo d   case theDef def of@@ -146,52 +275,39 @@     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+  filterM (usableModality <.> getConstInfo) =<< getConstructors d+ -- | Precondition: Name is a data or record type. getConstructors :: QName -> TCM [QName]-getConstructors d = do-  def <- theDef <$> getConstInfo d-  case def of-    Datatype{dataCons = cs} -> return cs-    Record{recConHead = h}  -> return [conName h]-    _                       -> __IMPOSSIBLE__+getConstructors d = fromMaybe __IMPOSSIBLE__ <$>+  getConstructors' d -{- UNUSED-data DatatypeInfo = DataInfo-  { datatypeName   :: QName-  , datatypeParTel :: Telescope-  , datatypePars   :: Args-  , datatypeIxTel  :: Telescope-  , datatypeIxs    :: Args-  }+-- | 'Nothing' if not data or record type name.+getConstructors' :: QName -> TCM (Maybe [QName])+getConstructors' d = getConstructors_ . theDef <$> getConstInfo d --- | Get the name and parameters from a type if it's a datatype or record type---   with a named constructor.-getDatatypeInfo :: Type -> TCM (Maybe DatatypeInfo)-getDatatypeInfo t = do-  t <- reduce t-  case unEl t of-    Def d args -> do-      n          <- getDefFreeVars d-      args       <- return $ genericDrop n args-      def        <- instantiateDef =<< getConstInfo d-      TelV tel _ <- telView (defType def)-      let npars  = case theDef def of-            Datatype{dataPars = np} -> Just np-            Record{recPars = np, recNamedCon = True}-              | genericLength args == np -> Just np-              | otherwise                -> __IMPOSSIBLE__-            _                            -> Nothing-      return $ do-        np <- npars-        let (pt, it) = genericSplitAt np $ telToList tel-            parTel   = telFromList pt-            ixTel    = telFromList it-            (ps, is) = genericSplitAt np args-        return $ DataInfo { datatypeName = d-                          , datatypeParTel = parTel-                          , datatypePars   = ps-                          , datatypeIxTel  = ixTel-                          , datatypeIxs    = is-                          }-    _ -> return Nothing--}+-- | 'Nothing' if not data or record definition.+getConstructors_ :: Defn -> Maybe [QName]+getConstructors_ = \case+    Datatype{dataCons = cs} -> Just cs+    Record{recConHead = h}  -> Just [conName h]+    _                       -> Nothing
src/full/Agda/TypeChecking/Datatypes.hs-boot view
@@ -1,9 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Datatypes where -import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Signature import Agda.Syntax.Internal -getConHead         :: QName -> TCM ConHead+getConHead         :: HasConstInfo m => QName -> m (Either SigError ConHead) getConstructorData :: HasConstInfo m => QName -> m QName
src/full/Agda/TypeChecking/DeadCode.hs view
@@ -1,63 +1,146 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where -import Control.Applicative-import Control.Monad-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Foldable (foldMap, Foldable)-import Data.Traversable (traverse)+import Control.Monad (filterM)+import Control.Monad.Trans -import Agda.Syntax.Common-import Agda.Syntax.Literal-import qualified Agda.Syntax.Concrete as C-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-import Agda.Syntax.Scope.Monad  import qualified Agda.Benchmarking as Bench import qualified Agda.TypeChecking.Monad.Benchmark as Bench  import Agda.TypeChecking.Monad-import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Reduce -import Agda.Utils.HashMap (HashMap)-import qualified Agda.Utils.HashMap as HMap+import Agda.Utils.Monad (mapMaybeM)+import Agda.Utils.Impossible import Agda.Utils.Lens -import Agda.Utils.Impossible-#include "undefined.h"+import Agda.Utils.HashTable (HashTable)+import qualified Agda.Utils.HashTable as HT --- | 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.map anameName . publicNames <$> getScope-  defs <- traverse instantiateFull $ sig ^. sigDefinitions-  let r     = reachableFrom public patsyn defs-      dead  = Set.fromList (HMap.keys defs) `Set.difference` r-      valid = Set.null . Set.intersection dead . namesIn-      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)+-- | 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 -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 = Set.filter (not . (`Set.member` visited)) $-                case HMap.lookup x defs of-                  Nothing -> namesIn (PSyn <$> Map.lookup x psyns)-                  Just d  -> namesIn d+  -- #2921: Eliminating definitions with attached COMPILE pragmas results in+  -- the pragmas not being checked. Simple solution: don't eliminate these.+  -- #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 +      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
@@ -1,15 +1,18 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}  -- for Arg a => Elim' a  -- | Tools for 'DisplayTerm' and 'DisplayForm'. -module Agda.TypeChecking.DisplayForm where+module Agda.TypeChecking.DisplayForm (displayForm) where -import Prelude hiding (all)-import Control.Applicative import Control.Monad import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe-import Data.Foldable (all)++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  import Agda.Syntax.Common@@ -22,44 +25,60 @@ import Agda.TypeChecking.Level import Agda.TypeChecking.Reduce (instantiate) +import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.List1 (List1) import Agda.Utils.Maybe-import Agda.Utils.Except-import Agda.Utils.Functor+import Agda.Syntax.Common.Pretty -#include "undefined.h" 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 (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 :: QName -> TCM [Int]+displayFormArities :: (HasConstInfo m, ReadTCState m) => QName -> m [Int] displayFormArities q = map (length . dfPats . dget) <$> getDisplayForms q +-- | Lift a local display form to an outer context. The substitution goes from the parent context to+--   the context of the local display form (see Issue 958). Current only handles pure extensions of+--   the parent context.+liftLocalDisplayForm :: Substitution -> DisplayForm -> Maybe DisplayForm+liftLocalDisplayForm IdS df = Just df+liftLocalDisplayForm (Wk n IdS) (Display m lhs rhs) =+  -- We lift a display form by turning matches on free variables into pattern variables, which can+  -- be done by simply adding to the dfPatternVars field.+  Just $ Display (n + m) lhs rhs+liftLocalDisplayForm _ _ = Nothing++type MonadDisplayForm m =+  ( MonadReduce m+  , ReadTCState m+  , HasConstInfo m+  , HasBuiltins m+  , MonadDebug m+  )+ -- | Find a matching display form for @q es@. --   In essence this tries to rewrite @q es@ with any --   display form @q ps --> dt@ and returns the instantiated --   @dt@ if successful.  First match wins.-displayForm :: QName -> Elims -> TCM (Maybe DisplayTerm)+displayForm :: MonadDisplayForm m => QName -> Elims -> m (Maybe DisplayTerm) displayForm q es = do-    -- Get display forms for name q.-    odfs  <- getDisplayForms q `catchError` \_ -> return []+  -- Get display forms for name q.+  odfs  <- getDisplayForms q+  if (null odfs) then do+    reportSLn "tc.display.top" 101 $ "no displayForm for " ++ prettyShow q+    return Nothing+  else do     -- Display debug info about the @Open@s.-    unless (null odfs) $ verboseS "tc.display.top" 100 $ do-      n <- getContextId-      reportSLn "tc.display.top" 100 $-        "displayForm for " ++ show q ++ ": context = " ++ show n ++-        ", dfs = " ++ show odfs+    unlessDebugPrinting $ reportSDoc "tc.display.top" 100 $ do+      cps <- viewTC eCheckpoints+      cxt <- getContextTelescope+      return $ vcat+        [ "displayForm for" <+> pretty q+        , nest 2 $ "cxt =" <+> pretty cxt+        , nest 2 $ "cps =" <+> vcat (map pretty (Map.toList cps))+        , nest 2 $ "dfs =" <+> vcat (map pretty odfs) ]     -- Use only the display forms that can be opened in the current context.-    dfs   <- catMaybes <$> mapM getLocal odfs+    dfs   <- catMaybes <$> mapM (tryGetOpen liftLocalDisplayForm) odfs     scope <- getScope     -- Keep the display forms that match the application @q es@.     ms <- do@@ -67,28 +86,22 @@       return [ m | Just (d, m) <- ms, wellScoped scope d ]     -- Not safe when printing non-terminating terms.     -- (nfdfs, us) <- normalise (dfs, es)-    unless (null odfs) $ reportSLn "tc.display.top" 100 $ unlines-      [ "name        : " ++ show q-      , "displayForms: " ++ show dfs-      , "arguments   : " ++ show es-      , "matches     : " ++ show ms-      , "result      : " ++ show (headMaybe ms)+    unlessDebugPrinting $ reportSDoc "tc.display.top" 100 $ return $ vcat+      [ "name        :" <+> pretty q+      , "displayForms:" <+> pretty dfs+      , "arguments   :" <+> pretty es+      , "matches     :" <+> pretty ms+      , "result      :" <+> pretty (listToMaybe ms)       ]     -- Return the first display form that matches.-    return $ headMaybe ms----  Andreas, 2014-06-11: The following error swallowing---  is potentially harmful, making debugging harder.---  I removed it, and it does not cause problems on the test suite.---  `catchError` \_ -> return Nothing-+    return $ listToMaybe ms   where     -- Look at the original display form, not the instantiated result when     -- checking if it's well-scoped. Otherwise we might pick up out of scope     -- identifiers coming from the source term.     wellScoped scope (Display _ _ d)       | isWithDisplay d = True-      | otherwise       = all (inScope scope) $ namesIn d+      | otherwise       = getAll $ namesIn' (All . inScope scope) d  -- all names in d should be in scope      inScope scope x = not $ null $ inverseScopeLookupName x scope @@ -98,66 +111,185 @@ -- | Match a 'DisplayForm' @q ps = v@ against @q es@. --   Return the 'DisplayTerm' @v[us]@ if the match was successful, --   i.e., @es / ps = Just us@.-matchDisplayForm :: DisplayForm -> Elims -> MaybeT TCM (DisplayForm, DisplayTerm)-matchDisplayForm d@(Display _ ps v) es+matchDisplayForm :: MonadDisplayForm m+                 => DisplayForm -> Elims -> MaybeT m (DisplayForm, DisplayTerm)+matchDisplayForm d@(Display n ps v) es   | length ps > length es = mzero   | otherwise             = do       let (es0, es1) = splitAt (length ps) es-      us <- match ps $ raise 1 es0-      return (d, applySubst (parallelS $ reverse us) v `applyE` es1) +      -- 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 $ 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 = IntMap (WithOrigin Term)++unionMatch :: Monad m => MatchResult -> MatchResult -> MaybeT m MatchResult+unionMatch 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 mempty++data Window = Window {dbLo, dbHi :: Nat}++inWindow :: Window -> Nat -> Maybe Nat+inWindow (Window lo hi) n | lo <= n, n < hi = Just (n - lo)+                          | otherwise       = Nothing++shiftWindow :: Window -> Window+shiftWindow (Window lo hi) = Window (lo + 1) (hi + 1)+ -- | Class @Match@ for matching a term @p@ in the role of a pattern --   against a term @v@. -----   The 0th variable in @p@ plays the role---   of a place holder (pattern variable).  Each occurrence of---   @var 0@ in @p@ stands for a different pattern variable.------   The result of matching, if successful, is a list of solutions for the---   pattern variables, in left-to-right order.------   The 0th variable is in scope in the input @v@, but should not---   actually occur!---   In the output solution, the @0th@ variable is no longer in scope.---   (It has been substituted by __IMPOSSIBLE__ which corresponds to---   a raise by -1).+--   Free variables inside the window in @p@ are pattern variables and+--   the result of matching is a map from pattern variables (shifted down to start at 0) to subterms+--   of @v@. class Match a where-  match :: a -> a -> MaybeT TCM [Term]+  match :: MonadDisplayForm m => Window -> a -> a -> MaybeT m MatchResult  instance Match a => Match [a] where-  match xs ys = concat <$> zipWithM match 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 p v = match (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 p v =+  match n p v =     case (p, v) of-      (Proj _ f, Proj _ f') | f == f' -> return []-      (Apply a, Apply a')         -> match a a'-      _                           -> mzero+      (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+      -- printing.+      _                               -> mzero  instance Match Term where-  match p v = lift (instantiate v) >>= \ v -> case (ignoreSharing p, ignoreSharing v) of-    (Var 0 [], v)                  -> return [strengthen __IMPOSSIBLE__ v]-    (Var i ps, Var j vs) | i == j  -> match ps vs-    (Def c ps, Def d vs) | c == d  -> match ps vs-    (Con c _ ps, Con d _ vs) | c == d -> match ps vs-    (Lit l, Lit l')      | l == l' -> return []-    (p, v)               | p == v  -> return []-    (p, Level l)                   -> match p =<< reallyUnLevelView l-    (Sort ps, Sort pv)             -> match ps pv-    (p, Sort (Type v))             -> match p =<< reallyUnLevelView v+  match w p v = lift (instantiate v) >>= \ v -> case (unSpine p, unSpine v) of+    (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 mempty+    (Lam h p, Lam h' v)  | h == h' -> match (shiftWindow w) (unAbs p) (unAbs v)+    (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     _                              -> mzero  instance Match Sort where-  match p v = case (p, v) of-    (Type pl, Type vl) -> match pl vl-    _ | p == v -> return []+  match w p v = case (p, v) of+    (Type pl, Type vl) -> match w pl vl+    _ | p == v -> return mempty     _          -> mzero  instance Match Level where-  match p v = do+  match w p v = do     p <- reallyUnLevelView p     v <- reallyUnLevelView v-    match p v+    match w p v++-- | Substitute terms with origin into display terms,+--   replacing variables along with their origins.+--+--   The purpose is to replace the pattern variables in a with-display form,+--   and only on the top level of the lhs.  Thus, we are happy to fall back+--   to ordinary substitution where it does not matter.+--   This fixes issue #2590.++class SubstWithOrigin a where+  substWithOrigin :: Substitution -> [WithOrigin Term] -> a -> a++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+  substWithOrigin rho ots (IApply u v w) = IApply+    (substWithOrigin rho ots u)+    (substWithOrigin rho ots v)+    (substWithOrigin rho ots w)++++instance SubstWithOrigin (Arg Term) where+  substWithOrigin rho ots (Arg ai v) =+    case v of+      -- pattern variable: replace origin if better+      Var x [] -> case ots !!! x of+        Just (WithOrigin o u) -> Arg (mapOrigin (replaceOrigin o) ai) u+        Nothing -> Arg ai $ applySubst rho v -- Issue #2717, not __IMPOSSIBLE__+      -- constructor: recurse+      Con c ci args -> Arg ai $ Con c ci $ substWithOrigin rho ots args+      -- def: recurse+      Def q es -> Arg ai $ Def q $ substWithOrigin rho ots es+      -- otherwise: fall back to ordinary substitution+      _ -> Arg ai $ applySubst rho v+    where+      replaceOrigin _ UserWritten = UserWritten+      replaceOrigin o _           = o++instance SubstWithOrigin Term where+  substWithOrigin rho ots v =+    case v of+      -- constructor: recurse+      Con c ci args -> Con c ci $ substWithOrigin rho ots args+      -- def: recurse+      Def q es -> Def q $ substWithOrigin rho ots es+      -- otherwise: fall back to oridinary substitution+      _ -> applySubst rho v++-- Do not go into dot pattern, otherwise interaction test #231 fails+instance SubstWithOrigin DisplayTerm where+  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+        (substWithOrigin rho ots t)+        (substWithOrigin rho ots ts)+        (substWithOrigin rho ots es)++-- Do not go into dot pattern, otherwise interaction test #231 fails+instance SubstWithOrigin (Arg DisplayTerm) where+  substWithOrigin rho ots (Arg ai dt) =+    case dt of+      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+        (substWithOrigin rho ots t)+        (substWithOrigin rho ots ts)+        (substWithOrigin rho ots es)
src/full/Agda/TypeChecking/DropArgs.hs view
@@ -1,19 +1,21 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.DropArgs where +import Control.Arrow (second)+ import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Substitute  import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Coverage.SplitTree  import Agda.Utils.Functor import Agda.Utils.Permutation -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -51,15 +53,13 @@ instance DropArgs FunctionInverse where   dropArgs n finv = fmap (dropArgs n) finv -{- UNUSED, but don't remove (Andreas, 2012-10-08)--- | Use for dropping initial lambdas in compiled clause bodies.+-- | Use for dropping initial lambdas in clause bodies. --   NOTE: does not reduce term, need lambdas to be present. instance DropArgs Term where-  dropArgs 0 v = v-  dropArgs n v = case ignoreSharing v of+  dropArgs 0 = id+  dropArgs n = \case     Lam h b -> dropArgs (n - 1) (absBody b)     _       -> __IMPOSSIBLE__--}  -- | To drop the first @n@ arguments in a compiled clause, --   we reduce the split argument indices by @n@ and@@ -72,4 +72,9 @@               | otherwise     -> Case (i <&> \ j -> j - n) $ fmap (dropArgs n) br     Done xs t | length xs < n -> __IMPOSSIBLE__               | otherwise     -> Done (drop n xs) t-    Fail                      -> Fail+    Fail xs   | length xs < n -> __IMPOSSIBLE__+              | otherwise     -> Fail (drop n xs)++instance DropArgs SplitTree where+  dropArgs n (SplittingDone m) = SplittingDone (m - n)+  dropArgs n (SplitAt i lz ts) = SplitAt (subtract n <$> i) lz $ map (second $ dropArgs n) ts
src/full/Agda/TypeChecking/Empty.hs view
@@ -1,42 +1,114 @@+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.TypeChecking.Empty where+module Agda.TypeChecking.Empty+  ( isEmptyType+  , isEmptyTel+  , ensureEmptyType+  , checkEmptyTel+  ) where -import Control.Applicative-import Control.Monad+import Control.Monad.Except ( MonadError(..) ) +import Data.Semigroup+ import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position  import Agda.TypeChecking.Monad import Agda.TypeChecking.Coverage-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Coverage.Match ( fromSplitPatterns )+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce ( instantiateFull ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope --- | Check whether a type is empty.+import Agda.Utils.Either+import Agda.Utils.List+import Agda.Utils.Monad++import Agda.Utils.Impossible++data ErrorNonEmpty+  = Fail               -- ^ Generic failure+  | FailBecause TCErr  -- ^ Failure with informative error+  | DontKnow Blocker   -- ^ Emptyness check blocked++instance Semigroup ErrorNonEmpty where+  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+  Fail            <> err          = err++instance Monoid ErrorNonEmpty where+  mempty  = Fail+  mappend = (Data.Semigroup.<>)++-- | Ensure that a type is empty. --   This check may be postponed as emptiness constraint.+ensureEmptyType+  :: Range -- ^ Range of the absurd pattern.+  -> Type  -- ^ Type that should be empty (empty data type or iterated product of such).+  -> TCM ()+ensureEmptyType r t = caseEitherM (checkEmptyType r t) failure return+  where+  failure (DontKnow u)      = addConstraint u $ IsEmpty r t+  failure (FailBecause err) = throwError err+  failure Fail              = typeError $ ShouldBeEmpty t [] -isEmptyType :: Range -> Type -> TCM ()-isEmptyType r t = do-  let postpone t = addConstraint $ IsEmpty r t-  -- If t is blocked or a meta, we cannot decide emptiness now.  Postpone.-  ifBlockedType t (\ _ t -> postpone t) $ {- else -} \ t -> do-    -- from the current context xs:ts, create a pattern list-    -- xs _ : ts t and try to split on _ (the last variable)-    tel0 <- getContextTelescope-    let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)]-        tel   = telFromList gamma-        ps    = teleNamedArgs tel+-- | Check whether a type is empty.+isEmptyType :: MonadTCM tcm => Type -> tcm Bool+isEmptyType ty = liftTCM $ isRight <$> checkEmptyType noRange ty -    dontAssignMetas $ do-      r <- splitLast Inductive tel ps-      case r of-        Left (CantSplit c tel us vs) -> postpone t-        Left _                       -> typeError $ ShouldBeEmpty t []-        Right cov -> do-          let cs = splitClauses cov-          unless (null cs) $-            typeError $ ShouldBeEmpty t $ map (namedArg . last . scPats) cs+-- | Check whether some type in a telescope is empty.+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 ()).+checkEmptyType :: Range -> Type -> TCM (Either ErrorNonEmpty ())+checkEmptyType range t = do+  mr <- tryRecordType t+  case mr of++    -- If t is blocked or a meta, we cannot decide emptiness now.  Postpone.+    Left (Blocked b t) -> return $ Left (DontKnow b)++    -- If t is not a record type, try to split+    Left (NotBlocked nb t) -> do+      -- from the current context xs:ts, create a pattern list+      -- xs _ : ts t and try to split on _ (the last variable)+      tel0 <- getContextTelescope+      let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)]+          tel   = telFromList gamma+          ps    = teleNamedArgs tel++      dontAssignMetas $ do+        r <- splitLast Inductive tel ps+        case r of+          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+            if (null ps) then return (Right ()) else+              Left . FailBecause <$> do typeError_ $ ShouldBeEmpty t ps++    -- If t is a record type, see if any of the field types is empty+    Right (r, pars, def) -> do+      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).+checkEmptyTel :: Range -> Telescope -> TCM (Either ErrorNonEmpty Int)+checkEmptyTel r = loop 0+  where+  loop i EmptyTel            = return $ Left Fail+  loop i (ExtendTel dom tel) = orEitherM+    [ (i <$) <$> checkEmptyType r (unDom dom)+    , underAbstraction dom tel $ loop (succ i)+    ]
src/full/Agda/TypeChecking/Empty.hs-boot view
@@ -1,9 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.TypeChecking.Empty where+module Agda.TypeChecking.Empty+  ( isEmptyType+  , isEmptyTel+  , ensureEmptyType+  , checkEmptyTel+  ) where -import Agda.TypeChecking.Monad (TCM)-import Agda.Syntax.Internal (Type)+import Agda.TypeChecking.Monad (TCM, MonadTCM)+import Agda.Syntax.Internal (Type, Telescope) import Agda.Syntax.Position (Range) --- isReallyEmptyType :: Type -> TCM ()-isEmptyType       :: Range -> Type -> TCM ()+data ErrorNonEmpty++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
@@ -1,1493 +1,2208 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.TypeChecking.Errors-  ( prettyError-  , tcErrString-  , prettyTCWarnings-  , tcWarningsToError-  , applyFlagsToTCWarnings-  ) where--import Prelude hiding (null)--import Control.Monad.Reader-import Control.Monad.State--import Data.Function-import Data.List (nub, sortBy, intersperse, isInfixOf)-import Data.Maybe-import Data.Char (toLower)-import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Text.PrettyPrint.Boxes as Boxes--import Agda.Interaction.Options-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Notation-import Agda.Syntax.Position-import qualified Agda.Syntax.Info as A-import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Concrete.Definitions as D-import Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views (deepUnscope)-import Agda.Syntax.Internal as I-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Translation.AbstractToConcrete-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.Options-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Positivity-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Reduce (instantiate)--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.FileName-import Agda.Utils.Function-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Size-import qualified Agda.Utils.Pretty as P--#include "undefined.h"-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) (text "panic: error when printing error!" $$) $ do-        (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))-        `catchError` \ err' -> prettyError' err' (err:errs)-------------------------------------------------------------------------------- * Warnings------------------------------------------------------------------------------instance PrettyTCM TCWarning where-  prettyTCM (TCWarning tcst clw) = localState $ do-    put tcst-    sayWhen (envRange  $ clEnv clw)-            (envCall   $ clEnv clw)-            (prettyTCM $ clValue clw)--instance PrettyTCM Warning where-  prettyTCM wng = case wng of--    UnsolvedMetaVariables ms  ->-      fsep ( pwords "Unsolved metas at the following locations:" )-      $$ nest 2 (vcat $ map prettyTCM ms)--    UnsolvedInteractionMetas is ->-      fsep ( pwords "Unsolved interaction metas at the following locations:" )-      $$ nest 2 (vcat $ map prettyTCM is)--    UnsolvedConstraints cs ->-      fsep ( pwords "Failed to solve the following constraints:" )-      $$ nest 2 (P.vcat . nub <$> mapM prettyConstraint cs)--      where prettyConstraint :: ProblemConstraint -> TCM Doc-            prettyConstraint c = f (prettyTCM c)-              where-              r   = getRange c-              f d = if null $ P.pretty r-                    then d-                    else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]")--    TerminationIssue tes ->-      fwords "Termination checking failed for the following functions:"-      $$ (nest 2 $ fsep $ punctuate comma $-           map (pretty . dropTopLevelModule) $-             concatMap termErrFunctions tes)-      $$ fwords "Problematic calls:"-      $$ (nest 2 $ fmap (P.vcat . nub) $-            mapM prettyTCM $ sortBy (compare `on` callInfoRange) $-            concatMap termErrCalls tes)--    NotStrictlyPositive d ocs -> fsep $-      [prettyTCM (dropTopLevelModule d)] ++-      pwords "is not strictly positive, because it occurs"-      ++ [prettyTCM ocs]--    OldBuiltin old new -> fwords $-      "Builtin " ++ old ++ " does no longer exist. " ++-      "It is now bound by BUILTIN " ++ new--    EmptyRewritePragma -> fsep . pwords $ "Empty REWRITE pragma"--    ParseWarning pw -> pretty pw--prettyTCWarnings :: [TCWarning] -> TCM String-prettyTCWarnings = fmap (unlines . intersperse " ") . prettyTCWarnings'--prettyTCWarnings' :: [TCWarning] -> TCM [String]-prettyTCWarnings' = mapM (fmap show . prettyTCM)---- | Turns all warnings into errors.-tcWarningsToError :: [TCWarning] -> TCM a-tcWarningsToError ws = typeError $ case ws of-  [] -> SolvedButOpenHoles-  _  -> NonFatalErrors ws----- | Depending which flags are set, one may happily ignore some--- warnings.--applyFlagsToTCWarnings :: IgnoreFlags -> [TCWarning] -> TCM [TCWarning]-applyFlagsToTCWarnings ifs ws = do--  unsolvedNotOK <- not . optAllowUnsolved <$> pragmaOptions-  negativeNotOK <- not . optDisablePositivity <$> pragmaOptions-  loopingNotOK  <- optTerminationCheck <$> pragmaOptions--  let cleanUp w =-        let ignore = ifs == IgnoreFlags-            keepUnsolved us = not (null us) && (ignore || unsolvedNotOK)-        in case w of-          TerminationIssue{}           -> ignore || loopingNotOK-          NotStrictlyPositive{}        -> ignore || negativeNotOK-          UnsolvedMetaVariables ums    -> keepUnsolved ums-          UnsolvedInteractionMetas uis -> keepUnsolved uis-          UnsolvedConstraints ucs      -> keepUnsolved ucs-          OldBuiltin{}                 -> True-          EmptyRewritePragma           -> True-          ParseWarning{}               -> True--  return $ filter (cleanUp . tcWarning) ws-------------------------------------------------------------------------------- * Helpers------------------------------------------------------------------------------sayWhere :: HasRange a => a -> TCM Doc -> TCM Doc-sayWhere x d = applyUnless (null r) (prettyTCM r $$) d-  where r = getRange x--sayWhen :: Range -> Maybe (Closure Call) -> TCM Doc -> TCM Doc-sayWhen r Nothing   m = sayWhere r m-sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl)--panic :: String -> TCM Doc-panic s = fwords $ "Panic: " ++ s--nameWithBinding :: QName -> TCM Doc-nameWithBinding q =-  sep [ prettyTCM q, text "bound at", prettyTCM r ]-  where-    r = nameBindingSite $ qnameName q--tcErrString :: TCErr -> String-tcErrString err = show (getRange err) ++ " " ++ case err of-  TypeError _ cl  -> errorString $ clValue cl-  Exception r s   -> show r ++ " " ++ show s-  IOException r e -> show r ++ " " ++ show e-  PatternErr{}    -> "PatternErr"--errorString :: TypeError -> String-errorString err = case err of-  AmbiguousModule{}                        -> "AmbiguousModule"-  AmbiguousName{}                          -> "AmbiguousName"-  AmbiguousParseForApplication{}           -> "AmbiguousParseForApplication"-  AmbiguousParseForLHS{}                   -> "AmbiguousParseForLHS"---  AmbiguousParseForPatternSynonym{}        -> "AmbiguousParseForPatternSynonym"-  AmbiguousTopLevelModuleName {}           -> "AmbiguousTopLevelModuleName"-  BadArgumentsToPatternSynonym{}           -> "BadArgumentsToPatternSynonym"-  TooFewArgumentsToPatternSynonym{}        -> "TooFewArgumentsToPatternSynonym"-  BothWithAndRHS                           -> "BothWithAndRHS"-  BuiltinInParameterisedModule{}           -> "BuiltinInParameterisedModule"-  BuiltinMustBeConstructor{}               -> "BuiltinMustBeConstructor"-  ClashingDefinition{}                     -> "ClashingDefinition"-  ClashingFileNamesFor{}                   -> "ClashingFileNamesFor"-  ClashingImport{}                         -> "ClashingImport"-  ClashingModule{}                         -> "ClashingModule"-  ClashingModuleImport{}                   -> "ClashingModuleImport"-  CompilationError{}                       -> "CompilationError"-  ConstructorPatternInWrongDatatype{}      -> "ConstructorPatternInWrongDatatype"-  CoverageFailure{}                        -> "CoverageFailure"-  CoverageCantSplitOn{}                    -> "CoverageCantSplitOn"-  CoverageCantSplitIrrelevantType{}        -> "CoverageCantSplitIrrelevantType"-  CoverageCantSplitType{}                  -> "CoverageCantSplitType"-  CoverageNoExactSplit{}                   -> "CoverageNoExactSplit"-  CyclicModuleDependency{}                 -> "CyclicModuleDependency"-  DataMustEndInSort{}                      -> "DataMustEndInSort"--- UNUSED:    DataTooManyParameters{}                  -> "DataTooManyParameters"-  CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype"-  DifferentArities                         -> "DifferentArities"-  DoesNotConstructAnElementOf{}            -> "DoesNotConstructAnElementOf"-  DuplicateBuiltinBinding{}                -> "DuplicateBuiltinBinding"-  DuplicateConstructors{}                  -> "DuplicateConstructors"-  DuplicateFields{}                        -> "DuplicateFields"-  DuplicateImports{}                       -> "DuplicateImports"-  FieldOutsideRecord                       -> "FieldOutsideRecord"-  FileNotFound{}                           -> "FileNotFound"-  GenericError{}                           -> "GenericError"-  GenericDocError{}                        -> "GenericDocError"-  IFSNoCandidateInScope{}                  -> "IFSNoCandidateInScope"-  IlltypedPattern{}                        -> "IlltypedPattern"-  IllformedProjectionPattern{}             -> "IllformedProjectionPattern"-  CannotEliminateWithPattern{}             -> "CannotEliminateWithPattern"-  IllegalLetInTelescope{}                  -> "IllegalLetInTelescope"-  IncompletePatternMatching{}              -> "IncompletePatternMatching"-  IndexVariablesNotDistinct{}              -> "IndexVariablesNotDistinct"-  IndicesFreeInParameters{}                -> "IndicesFreeInParameters"-  IndicesNotConstructorApplications{}      -> "IndicesNotConstructorApplications"-  InternalError{}                          -> "InternalError"-  InvalidPattern{}                         -> "InvalidPattern"-  LocalVsImportedModuleClash{}             -> "LocalVsImportedModuleClash"-  MetaCannotDependOn{}                     -> "MetaCannotDependOn"-  MetaOccursInItself{}                     -> "MetaOccursInItself"-  ModuleArityMismatch{}                    -> "ModuleArityMismatch"-  ModuleDefinedInOtherFile {}              -> "ModuleDefinedInOtherFile"-  ModuleDoesntExport{}                     -> "ModuleDoesntExport"-  ModuleNameUnexpected{}                   -> "ModuleNameUnexpected"-  ModuleNameDoesntMatchFileName {}         -> "ModuleNameDoesntMatchFileName"-  NeedOptionCopatterns{}                   -> "NeedOptionCopatterns"-  NeedOptionRewriting{}                    -> "NeedOptionRewriting"-  NoBindingForBuiltin{}                    -> "NoBindingForBuiltin"-  NoParseForApplication{}                  -> "NoParseForApplication"-  NoParseForLHS{}                          -> "NoParseForLHS"---  NoParseForPatternSynonym{}               -> "NoParseForPatternSynonym"-  NoRHSRequiresAbsurdPattern{}             -> "NoRHSRequiresAbsurdPattern"-  NotInductive {}                          -> "NotInductive"-  AbsurdPatternRequiresNoRHS{}             -> "AbsurdPatternRequiresNoRHS"-  NoSuchBuiltinName{}                      -> "NoSuchBuiltinName"-  NoSuchModule{}                           -> "NoSuchModule"-  NoSuchPrimitiveFunction{}                -> "NoSuchPrimitiveFunction"-  NotAModuleExpr{}                         -> "NotAModuleExpr"-  NotAProperTerm                           -> "NotAProperTerm"-  SetOmegaNotValidType{}                   -> "SetOmegaNotValidType"-  InvalidType{}                            -> "InvalidType"-  InvalidTypeSort{}                        -> "InvalidTypeSort"-  FunctionTypeInSizeUniv{}                 -> "FunctionTypeInSizeUniv"-  NotAValidLetBinding{}                    -> "NotAValidLetBinding"-  NotValidBeforeField{}                    -> "NotValidBeforeField"-  NotAnExpression{}                        -> "NotAnExpression"-  NotImplemented{}                         -> "NotImplemented"-  NotSupported{}                           -> "NotSupported"-  NotInScope{}                             -> "NotInScope"-  NotLeqSort{}                             -> "NotLeqSort"-  NothingAppliedToHiddenArg{}              -> "NothingAppliedToHiddenArg"-  NothingAppliedToInstanceArg{}            -> "NothingAppliedToInstanceArg"-  OverlappingProjects {}                   -> "OverlappingProjects"-  OperatorChangeMessage {}                 -> "OperatorChangeMessage"-  OperatorInformation {}                   -> "OperatorInformation"-  PatternShadowsConstructor {}             -> "PatternShadowsConstructor"-  PropMustBeSingleton                      -> "PropMustBeSingleton"-  RepeatedVariablesInPattern{}             -> "RepeatedVariablesInPattern"-  SafeFlagPostulate{}                      -> "SafeFlagPostulate"-  SafeFlagPragma{}                         -> "SafeFlagPragma"-  SafeFlagNonTerminating{}                 -> "SafeFlagNonTerminating"-  SafeFlagTerminating{}                    -> "SafeFlagTerminating"-  SafeFlagPrimTrustMe{}                    -> "SafeFlagPrimTrustMe"-  SafeFlagNoPositivityCheck{}              -> "SafeFlagNoPositivityCheck"-  SafeFlagPolarity{}                       -> "SafeFlagPolarity"-  ShadowedModule{}                         -> "ShadowedModule"-  ShouldBeASort{}                          -> "ShouldBeASort"-  ShouldBeApplicationOf{}                  -> "ShouldBeApplicationOf"-  ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters"-  ShouldBeEmpty{}                          -> "ShouldBeEmpty"-  ShouldBePi{}                             -> "ShouldBePi"-  ShouldBeRecordType{}                     -> "ShouldBeRecordType"-  ShouldBeRecordPattern{}                  -> "ShouldBeRecordPattern"-  NotAProjectionPattern{}                  -> "NotAProjectionPattern"-  ShouldEndInApplicationOfTheDatatype{}    -> "ShouldEndInApplicationOfTheDatatype"-  SplitError{}                             -> "SplitError"-  TerminationCheckFailed{}                 -> "TerminationCheckFailed"-  TooFewFields{}                           -> "TooFewFields"-  TooManyArgumentsInLHS{}                  -> "TooManyArgumentsInLHS"-  TooManyFields{}                          -> "TooManyFields"-  TooManyPolarities{}                      -> "TooManyPolarities"-  SplitOnIrrelevant{}                      -> "SplitOnIrrelevant"-  DefinitionIsIrrelevant{}                 -> "DefinitionIsIrrelevant"-  VariableIsIrrelevant{}                   -> "VariableIsIrrelevant"-  UnequalBecauseOfUniverseConflict{}       -> "UnequalBecauseOfUniverseConflict"-  UnequalRelevance{}                       -> "UnequalRelevance"-  UnequalHiding{}                          -> "UnequalHiding"---  UnequalLevel{}                           -> "UnequalLevel" -- UNUSED-  UnequalSorts{}                           -> "UnequalSorts"-  UnequalTerms{}                           -> "UnequalTerms"-  UnequalTypes{}                           -> "UnequalTypes"-  UnifyConflict{}                          -> "UnifyConflict"-  UnifyCycle{}                             -> "UnifyCycle"-  UnifyIndicesNotVars{}                    -> "UnifyIndicesNotVars"-  UnificationRecursiveEq{}                 -> "UnificationRecursiveEq"-  UnificationStuck{}                       -> "UnificationStuck"---  UnequalTelescopes{}                      -> "UnequalTelescopes" -- UNUSED-  HeterogeneousEquality{}                  -> "HeterogeneousEquality"-  WithOnFreeVariable{}                     -> "WithOnFreeVariable"-  UnexpectedWithPatterns{}                 -> "UnexpectedWithPatterns"-  UninstantiatedDotPattern{}               -> "UninstantiatedDotPattern"-  UninstantiatedModule{}                   -> "UninstantiatedModule"-  UnreachableClauses{}                     -> "UnreachableClauses"-  SolvedButOpenHoles{}                     -> "SolvedButOpenHoles"-  UnusedVariableInPatternSynonym           -> "UnusedVariableInPatternSynonym"-  UnquoteFailed{}                          -> "UnquoteFailed"-  DeBruijnIndexOutOfScope{}                -> "DeBruijnIndexOutOfScope"-  WithClausePatternMismatch{}              -> "WithClausePatternMismatch"-  WithoutKError{}                          -> "WithoutKError"-  WrongHidingInApplication{}               -> "WrongHidingInApplication"-  WrongHidingInLHS{}                       -> "WrongHidingInLHS"-  WrongHidingInLambda{}                    -> "WrongHidingInLambda"-  WrongInstanceDeclaration{}               -> "WrongInstanceDeclaration"-  WrongIrrelevanceInLambda{}               -> "WrongIrrelevanceInLambda"-  WrongNamedArgument{}                     -> "WrongNamedArgument"-  WrongNumberOfConstructorArguments{}      -> "WrongNumberOfConstructorArguments"-  HidingMismatch{}                         -> "HidingMismatch"-  RelevanceMismatch{}                      -> "RelevanceMismatch"-  NonFatalErrors{}                         -> "NonFatalErrors"-  InstanceSearchDepthExhausted{}           -> "InstanceSearchDepthExhausted"--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 _ (Closure _ _ _ _ (NonFatalErrors ws)) -> foldr1 ($$) $ fmap prettyTCM ws-    -- Andreas, 2014-03-23-    -- This use of localState seems ok since we do not collect-    -- Benchmark info during printing errors.-    TypeError s e -> localState $ do-      put s-      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"--instance PrettyTCM CallInfo where-  prettyTCM c = do-    let call = prettyTCM $ callInfoCall c-        r    = callInfoRange c-    if null $ P.pretty r-      then call-      else call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")")---- | Drops the filename component of the qualified name.-dropTopLevelModule' :: Int -> QName -> QName-dropTopLevelModule' k (QName (MName ns) n) = QName (MName (drop k ns)) n--dropTopLevelModule :: QName -> QName-dropTopLevelModule = dropTopLevelModule' 1--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--    TerminationCheckFailed because -> do-      dropTopLevelModule <- do-        caseMaybeM (asks envCurrentPath) (return id) $ \ f -> do-        m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f-        return $ dropTopLevelModule' $ size m-      fwords "Termination checking failed for the following functions:"-        $$ (nest 2 $ fsep $ punctuate comma $-             map (pretty . dropTopLevelModule) $-               concatMap termErrFunctions because)-        $$ fwords "Problematic calls:"-        $$ (nest 2 $ fmap (P.vcat . nub) $-              mapM prettyTCM $ sortBy (compare `on` callInfoRange) $-              concatMap termErrCalls because)--    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 ]--    DifferentArities ->-      fwords "The number of arguments in the defining equations differ"--    WrongHidingInLHS -> fwords "Unexpected implicit argument"--    WrongHidingInLambda t ->-      fwords "Found an implicit lambda where an explicit lambda was expected"--    WrongIrrelevanceInLambda t ->-      fwords "Found an irrelevant lambda where a relevant lambda was expected"--    WrongNamedArgument a -> fsep $-      pwords "Function does not accept argument "-      ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"--    WrongHidingInApplication t ->-      fwords "Found an implicit application where an explicit application was expected"--    WrongInstanceDeclaration -> fwords "Terms marked as eligible for instance search should end with a name"--    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"--    NotInductive t -> fsep $-      [prettyTCM t] ++ pwords "is not an inductive data type"--    UninstantiatedDotPattern e -> fsep $-      pwords "Failed to infer the value of dotted pattern"--    IlltypedPattern p a -> fsep $-      pwords "Type mismatch"--    IllformedProjectionPattern p -> fsep $-      pwords "Ill-formed projection pattern " ++ [prettyA p]--    CannotEliminateWithPattern p a -> do-      let isProj = isJust (isProjP p)-      fsep $-        pwords "Cannot eliminate type" ++ prettyTCM a :-        if isProj then-           pwords "with projection pattern" ++ [prettyA p]-         else-           pwords "with pattern" ++ prettyA p :-           pwords "(did you supply too many arguments?)"--    TooManyArgumentsInLHS a -> fsep $-      pwords "Left hand side gives too many arguments to a function of type"-      ++ [prettyTCM a]--    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 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]--    IndicesNotConstructorApplications [i] ->-      fwords "The index"-      $$ nest 2 (prettyTCM i)-      $$ fsep (pwords "is not a constructor (or literal) applied to variables" ++-               pwords "(note that parameters count as constructor arguments)")--    IndicesNotConstructorApplications is ->-      fwords "The indices"-      $$ nest 2 (vcat $ map prettyTCM is)-      $$ fsep (pwords "are not constructors (or literals) applied to variables" ++-               pwords "(note that parameters count as constructor arguments)")--    IndexVariablesNotDistinct vs is ->-      fwords "The variables"-      $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)-      $$ fwords "in the indices"-      $$ nest 2 (vcat $ map prettyTCM is)-      $$ fwords "are not distinct (note that parameters count as constructor arguments)"--    IndicesFreeInParameters vs indices pars ->-      fwords "The variables"-      $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs)-      $$ fwords "which are used (perhaps as constructor parameters) in the index expressions"-      $$ nest 2 (vcat $ map prettyTCM indices)-      $$ fwords "are free in the parameters"-      $$ nest 2 (vcat $ map prettyTCM pars)--    ShadowedModule x [] -> __IMPOSSIBLE__--    ShadowedModule x ms@(m : _) -> fsep $-      pwords "Duplicate definition of module" ++ [prettyTCM x <> text "."] ++-      pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++-      pwords "at" ++ [prettyTCM r]-      where-        help m = do-          b <- isDatatypeModule m-          if b then text "datatype" else empty--        r = case [ r | r <- map (defSiteOfLast . mnameToList) ms-                     , r /= noRange ] of-              []    -> noRange-              r : _ -> r--        defSiteOfLast [] = noRange-        defSiteOfLast ns = nameBindingSite (last ns)--    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"--    NotAProperTerm -> fwords "Found a malformed term"--    SetOmegaNotValidType -> fwords "Setω is not a valid type"--    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 p t -> fsep $-      pwords "Cannot pattern match" ++ [prettyA p] ++-      pwords "against irrelevant type" ++ [prettyTCM t]--    DefinitionIsIrrelevant x -> fsep $-      text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"-    VariableIsIrrelevant x -> fsep $-      text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"-    UnequalBecauseOfUniverseConflict cmp s t -> fsep $-      [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ]--    UnequalTerms cmp s t a -> do-      (d1, d2, d) <- prettyInEqual s t-      fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d]---- UnequalLevel is UNUSED---   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]--    HeterogeneousEquality u a v b -> fsep $-      pwords "Refuse to solve heterogeneous constraint" ++-      [prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++-      [prettyTCM v] ++ pwords ":" ++ [prettyTCM b]--    UnequalRelevance cmp a b -> fsep $-      [prettyTCM a, notCmp cmp, prettyTCM b] ++--- Andreas 2010-09-21 to reveal Forced annotations, print also uglily---            [text $ show a, notCmp cmp, text $ show b] ++-      pwords "because one is a relevant function type and the other is an irrelevant function type"--    UnequalHiding a b -> fsep $-      [prettyTCM a, text "!=", prettyTCM b] ++-      pwords "because one is an implicit function type and the other is an explicit function type"--    UnequalSorts s1 s2 -> fsep $-      [prettyTCM s1, text "!=", prettyTCM s2]--    NotLeqSort s1 s2 -> fsep $-      pwords "The type of the constructor does not fit in the sort of the datatype, since"-      ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]--    TooFewFields r xs -> fsep $-      pwords "Missing fields" ++ punctuate comma (map pretty xs) ++-      pwords "in an element of the record" ++ [prettyTCM r]--    TooManyFields r xs -> fsep $-      pwords "The record type" ++ [prettyTCM r] ++-      pwords "does not have the fields" ++ punctuate comma (map pretty xs)--    DuplicateConstructors xs -> fsep $-      pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++-      pwords "in datatype"--    DuplicateFields xs -> fsep $-      pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++-      pwords "in record"--    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 (text " |") $ map prettyA ps)--    WithClausePatternMismatch p q -> fsep $-      pwords "With clause pattern " ++ [prettyA p] ++-      pwords " is not an instance of its parent pattern " ++ [prettyTCM q]-         -- TODO: prettier printing for internal patterns--    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--    MetaOccursInItself m -> fsep $-      pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]--    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-      | elem x [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'")--    NoSuchPrimitiveFunction x -> fsep $-      pwords "There is no primitive function called" ++ [text x]--    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."--    NoRHSRequiresAbsurdPattern ps -> fwords $-      "The right-hand side can only be omitted if there " ++-      "is an absurd pattern, () or {}, in the left-hand side."--    AbsurdPatternRequiresNoRHS ps -> fwords $-      "The right-hand side must 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 ->-      text "Module cannot be imported since it has open interaction points"--    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 ->-      fsep ( pwords "The file" ++ [text (filePath f)] ++-             pwords "can be accessed via several project roots. Both" ++-             [pretty m1] ++ pwords "and" ++ [pretty m2] ++-             pwords "point to this file."-           )--    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 <> text "."] ++-      pwords "However, according to the include path this module should" ++-      pwords "be defined in" ++ [text (filePath file') <> text "."]--    ModuleNameUnexpected given expected -> fsep $-      pwords "The name of the top level module does not match the file name. The module" ++-      [ pretty given ] ++-      pwords "should probably be named" ++-      [ 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"--    NotInScope xs -> do-      inscope <- Set.toList . concreteNamesInScope <$> getScope-      fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map (name inscope) xs)-      where-      name inscope x =-        fsep [ pretty x-             , text "at" <+> prettyTCM (getRange x)-             , suggestion inscope x-             ]-      suggestion inscope x = nest 2 $ par $-        [ text "did you forget space around the ':'?"  | elem ':' s ] ++-        [ text "did you forget space around the '->'?" | isInfixOf "->" s ] ++-        [ sep [ text "did you mean"-              , nest 2 $ vcat (punctuate (text " or") $ map (\ y -> text $ "'" ++ y ++ "'") ys) <> text "?" ]-          | not $ null ys ]-        where-          s = P.prettyShow x-          par []  = empty-          par [d] = parens d-          par ds  = parens $ vcat ds--          strip x = map toLower $ filter (/= '_') $ P.prettyShow $ C.unqualify x-          maxDist n = div n 3-          close a b = editDistance a b <= maxDist (length a)-          ys = map P.prettyShow $ filter (close (strip x) . strip) inscope--    NoSuchModule x -> fsep $ pwords "No such module" ++ [pretty x]--    AmbiguousName x ys -> vcat-      [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++-               pwords "It could refer to any one of"-      , nest 2 $ vcat $ map 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 <> text "."] ++-               pwords "It could refer to any one of"-      , nest 2 $ vcat $ map help ys-      , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"-      ]-      where-        help :: ModuleName -> TCM Doc-        help m = do-          b <- isDatatypeModule m-          sep [prettyTCM m, if b then text "(datatype module)" else empty]--    UninstantiatedModule x -> fsep (-      pwords "Cannot access the contents of the parameterised module"-      ++ [pretty x <> text "."] ++-      pwords "To do this the module first has to be instantiated. For instance:"-        ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ])--    ClashingDefinition x y -> fsep $-      pwords "Multiple definitions of" ++ [pretty x <> text "."] ++-      pwords "Previous definition at"-      ++ [prettyTCM $ nameBindingSite $ qnameName y]--    ClashingModule m1 m2 -> fsep $-      pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2]-      ++ pwords "clash."--    ClashingImport x y -> fsep $-      pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y]--    ClashingModuleImport x y -> fsep $-      pwords "Module import clash between" ++ [pretty x, text "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)--    ModuleDoesntExport m xs -> fsep $-      pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++-      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, text "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 <> (text ".")] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty' es')-      where-        pretty_es :: TCM Doc-        pretty_es = pretty $ C.RawApp noRange es--        pretty' :: C.Expr -> TCM Doc-        pretty' e = do-          p1 <- pretty_es-          p2 <- pretty e-          if show p1 == show p2 then unambiguous e else pretty e--        unambiguous :: C.Expr -> TCM Doc-        unambiguous e@(C.OpApp r op _ xs)-          | all (isOrdinary . namedArg) xs =-            pretty $-              foldl (C.App r) (C.Ident op) $-                (map . fmap . fmap) fromOrdinary xs-          | any (isPlaceholder . namedArg) xs =-              pretty e <+> text "(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 x]--    TooFewArgumentsToPatternSynonym x -> fsep $-      pwords "Too few arguments to pattern synonym " ++ [prettyTCM x]--    UnusedVariableInPatternSynonym -> fsep $-      pwords "Unused variable in pattern synonym."--    NoParseForLHS IsLHS p -> fsep (-      pwords "Could not parse the left-hand side" ++ [pretty p])--    NoParseForLHS IsPatSyn p -> fsep (-      pwords "Could not parse the pattern synonym" ++ [pretty p])--{- UNUSED-    NoParseForPatternSynonym p -> fsep $-      pwords "Could not parse the pattern synonym" ++ [pretty p]--}--    AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (-      pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty' ps)-      where-        pretty_p :: TCM Doc-        pretty_p = pretty p--        pretty' :: C.Pattern -> TCM Doc-        pretty' p' = do-          p1 <- pretty_p-          p2 <- pretty p'-          pretty $ if show p1 == show p2 then unambiguousP p' else p'--        -- 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 text "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` show . notaName . sectNotation) $-               filter (not . closedWithoutHoles) sects))-      where-      trimLeft  = dropWhile isNormalHole-      trimRight = reverse . dropWhile isNormalHole . reverse--      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 n) -> ", level " ++ show n) ++-             ")")-            Boxes.//-          strut-        , Boxes.text "["-            Boxes.<>-          Boxes.vcat Boxes.left-            (map (\n -> prettyName n Boxes.<> Boxes.text ",") names ++-             [prettyName name Boxes.<> Boxes.text "]"])-        )-        where-        nota    = sectNotation sect-        section = qualifyFirstIdPart-                    (foldr (\x s -> C.nameToRawName x ++ "." ++ s)-                           ""-                           (init (C.qnameParts (notaName nota))))-                    (trim (notation nota))--        qualifyFirstIdPart _ []              = []-        qualifyFirstIdPart q (IdPart x : ps) = IdPart (q ++ x) : ps-        qualifyFirstIdPart q (p : ps)        = p : qualifyFirstIdPart q ps--        trim = case sectKind sect of-          InfixNotation   -> trimLeft . trimRight-          PrefixNotation  -> trimRight-          PostfixNotation -> trimLeft-          NonfixNotation  -> id-          NoNotation      -> __IMPOSSIBLE__--        (names, name) = case Set.toList $ notaNames nota of-          [] -> __IMPOSSIBLE__-          ns -> (init ns, last ns)--        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"--    OperatorChangeMessage err@(OperatorInformation [] _) ->-      prettyTCM err-    OperatorChangeMessage err ->-      prettyTCM err-        $+$-      fsep (pwords $-        "(the treatment of operators was changed in Agda 2.5.1, " ++-        "so code that used to parse may have to be changed)")--{- UNUSED-    AmbiguousParseForPatternSynonym p ps -> fsep (-      pwords "Don't know how to parse" ++ [pretty p <> text "."] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty ps)--}--    IncompletePatternMatching v args -> fsep $-      pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++-      pwords "No match for" ++ map prettyTCM args--    UnreachableClauses f pss -> fsep $-      pwords "Unreachable" ++ pwords (plural (length pss) "clause")-        where-          plural 1 thing = thing-          plural n thing = thing ++ "s"--    CoverageFailure f pss -> fsep (-      pwords "Incomplete pattern matching for" ++ [prettyTCM f <> text "."] ++-      pwords "Missing cases:") $$ nest 2 (vcat $ map display pss)-        where-          display ps = do-            ps <- nicify f ps-            prettyTCM f <+> fsep (map (prettyArg . fmap namedThing) ps)--          nicify f ps = do-            showImp <- showImplicitArguments-            if showImp-              then return ps-              else return ps  -- TODO: remove implicit arguments which aren't constructors--    CoverageCantSplitOn c tel cIxs gIxs-      | length cIxs /= length gIxs -> __IMPOSSIBLE__-      | otherwise                  -> addContext tel $ vcat (-          [ fsep $ pwords "I'm not sure if there should be a case for the constructor" ++-                   [prettyTCM c <> text ","] ++-                   pwords "because I get stuck when trying to solve the following" ++-                   pwords "unification problems (inferred index ≟ expected index):"-          ] ++-          zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs)--    CoverageCantSplitIrrelevantType a -> fsep $-      pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a]---    CoverageCantSplitType a -> fsep $-      pwords "Cannot split on argument of non-datatype" ++ [prettyTCM a]--    CoverageNoExactSplit f cs -> fsep $-      pwords "Exact splitting is enabled, but not all clauses can be preserved as definitional equalities in the translation to a case tree"--    SplitError e -> prettyTCM e--    WithoutKError a u v -> fsep $-      pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++-      pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++-      pwords "because K has been disabled."--    UnifyConflict c c' -> fsep $-      pwords "This case is impossible because of a conflict between the constructors " ++-      [prettyTCM c] ++ pwords " and " ++ [prettyTCM c' <> text "."] ++-      pwords "Possible solution: remove the clause, or use an absurd pattern ()."--    UnifyCycle i u -> fsep $-      pwords "This case is impossible because the variable " ++ [prettyTCM (var i)] ++-      pwords "occurs strongly rigid in" ++ [prettyTCM u <> text "."] ++-      pwords "Possible solution: remove the clause, or use an absurd pattern ()."--    UnifyIndicesNotVars a u v ixs -> 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]--    UnificationRecursiveEq a i u -> 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 one of the variables in the solution"--    UnificationStuck tel us vs -> fsep $-      pwords "I got stuck on unifying" ++ [prettyList (map prettyTCM us)] ++-      pwords "with" ++ [prettyList (map prettyTCM vs)] ++-      pwords "in the telescope" ++ [prettyTCM tel]--    TooManyPolarities x n -> fsep $-      pwords "Too many polarities given in the POLARITY pragma for" ++-      [prettyTCM x] ++-      pwords "(at most" ++ [text (show n)] ++ pwords "allowed)."--    IFSNoCandidateInScope t -> fsep $-      pwords "No instance of type" ++ [prettyTCM t] ++ pwords "was found in scope."--    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 "_" $ prettyTCM cxt' ]-      where-        cxt' = cxt `abstract` raise (size cxt) (nameCxt names)-        nameCxt [] = EmptyTel-        nameCxt (x : xs) = ExtendTel (defaultDom (El I.Prop $ I.Var 0 [])) $ NoAbs (show x) $ nameCxt xs--    SafeFlagPostulate e -> fsep $-      pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"--    SafeFlagPragma xs ->-      let plural | length xs == 1 = ""-                 | otherwise      = "s"-      in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)]-                ++ map text xs ++ [fwords "with safe flag."]--    SafeFlagNonTerminating -> fsep $-      pwords "Cannot use NON_TERMINATING pragma with safe flag."--    SafeFlagTerminating -> fsep $-      pwords "Cannot use TERMINATING pragma with safe flag."--    SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag")--    SafeFlagNoPositivityCheck -> fsep $-      pwords "Cannot use NO_POSITIVITY_CHECK pragma with safe flag."--    SafeFlagPolarity -> fsep $-      pwords "The POLARITY pragma must not be used in safe mode."--    NeedOptionCopatterns -> fsep $-      pwords "Option --copatterns needed to enable destructor patterns"--    NeedOptionRewriting  -> fsep $-      pwords "Option --rewriting needed to add and use rewrite rules"--    NonFatalErrors ws -> foldr1 ($$) $ fmap prettyTCM ws--    InstanceSearchDepthExhausted c a d -> fsep $-      pwords ("Instance search depth exhaused (max depth: " ++ show d ++ ") for candidate") ++-      [hang (prettyTCM c <+> text ":") 2 (prettyTCM a)]--    where-    mpar n args-      | n > 0 && not (null args) = parens-      | otherwise                = id--    prettyArg :: Arg (I.Pattern' a) -> TCM Doc-    prettyArg (Arg info x) = case getHiding info of-      Hidden    -> braces $ prettyPat 0 x-      Instance  -> dbraces $ prettyPat 0 x-      NotHidden -> prettyPat 1 x--    prettyPat :: Integer -> (I.Pattern' a) -> TCM Doc-    prettyPat _ (I.VarP _) = text "_"-    prettyPat _ (I.DotP _) = text "._"-    prettyPat n (I.ConP c _ args) =-      mpar n args $-        prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args)-    prettyPat _ (I.LitP l) = prettyTCM l-    prettyPat _ (I.ProjP _ p) = text "." <> prettyTCM p--notCmp :: Comparison -> TCM Doc-notCmp cmp = text "!" <> 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 :: Term -> Term -> TCM (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 (ignoreSharing v1, ignoreSharing 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 :: TCM 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 :: Int -> Int -> TCM Doc-    varVar i j = parens $ fwords $-                   "because one has de Bruijn index " ++ show i-                   ++ " and the other " ++ show j--class PrettyUnequal a where-  prettyUnequal :: a -> TCM Doc -> a -> TCM 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 err = case err of-    NotADatatype t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot pattern match on non-datatype" ++ [prettyTCM t]--    IrrelevantDatatype t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot pattern match on datatype" ++ [prettyTCM t] ++-      pwords "since it is declared irrelevant"--    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"- -}--    CantSplit c tel cIxs gIxs ->-      prettyTCM $ CoverageCantSplitOn c tel cIxs gIxs--    GenericSplitError s -> fsep $ pwords "Split failed:" ++ pwords s--instance PrettyTCM Call where-  prettyTCM c = case c of-    CheckClause t cl -> do-      reportSLn "error.checkclause" 60 $ "prettyTCM CheckClause: cl = " ++ show (deepUnscope cl)-      clc <- abstractToConcrete_ cl-      reportSLn "error.checkclause" 40 $ "cl (Concrete) = " ++ show clc-      fsep $-        pwords "when checking that the clause"-        ++ [prettyA cl] ++ pwords "has type" ++ [prettyTCM t]--    CheckPattern p tel t -> addContext tel $ fsep $-      pwords "when checking that the pattern"-      ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]--    CheckLetBinding b -> fsep $-      pwords "when checking the let binding" ++ [prettyA b]--    InferExpr e -> fsep $ pwords "when inferring the type of" ++ [prettyA e]--    CheckExprCall e t -> fsep $-      pwords "when checking that the expression"-      ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]--    IsTypeCall e s -> fsep $-      pwords "when checking that the expression"-      ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]--    IsType_ e -> fsep $-      pwords "when checking that the expression"-      ++ [prettyA e] ++ pwords "is a type"--    CheckProjection _ x t -> fsep $-      pwords "when checking the projection" ++-      [ sep [ prettyTCM x <+> text ":"-            , nest 2 $ prettyTCM t ] ]--    CheckArguments r es t0 t1 -> fsep $-      pwords "when checking that" ++-      map hPretty es ++-      pwords (singPlural es "is a valid argument" "are valid arguments") ++-      pwords "to a function of type" ++-      [prettyTCM t0]--    CheckRecDef _ x ps cs ->-      fsep $ pwords "when checking the definition of" ++ [prettyTCM x]--    CheckDataDef _ x ps cs ->-      fsep $ pwords "when checking the definition of" ++ [prettyTCM x]--    CheckConstructor d _ _ (A.Axiom _ _ _ _ c _) -> fsep $-      pwords "when checking the constructor" ++ [prettyTCM c] ++-      pwords "in the declaration of" ++ [prettyTCM d]--    CheckConstructor{} -> __IMPOSSIBLE__--    CheckFunDef _ f _ ->-      fsep $ pwords "when checking the definition of" ++ [prettyTCM f]--    CheckPragma _ p ->-      fsep $ pwords "when checking the pragma"-             ++ [prettyA $ RangeAndPragma noRange p]--    CheckPrimitive _ x e -> fsep $-      pwords "when checking that the type of the primitive function" ++-      [prettyTCM x] ++ pwords "is" ++ [prettyA e]--    CheckWithFunctionType e -> fsep $-      pwords "when checking that the type" ++-      [prettyA e] ++ pwords "of the generated with function is well-formed"--    CheckDotPattern e v -> fsep $-      pwords "when checking that the given dot pattern" ++ [prettyA e] ++-      pwords "matches the inferred value" ++ [prettyTCM v]--    CheckPatternShadowing c -> fsep $-      pwords "when checking the clause" ++ [prettyA c]--    InferVar x ->-      fsep $ pwords "when inferring the type of" ++ [prettyTCM x]--    InferDef x ->-      fsep $ pwords "when inferring the type of" ++ [prettyTCM x]--    CheckIsEmpty r t ->-      fsep $ pwords "when checking that" ++ [prettyTCM t] ++-             pwords "has no constructors"--    ScopeCheckExpr e -> fsep $ pwords "when scope checking" ++ [pretty e]--    ScopeCheckDeclaration d ->-      fwords ("when scope checking the declaration" ++ suffix) $$-      nest 2 (vcat $ map 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] ++-             pwords "in the definition of" ++ [pretty x]--    NoHighlighting -> empty--    SetRange r -> fsep (pwords "when doing something at") <+> prettyTCM r--    CheckSectionApplication _ m1 modapp -> fsep $-      pwords "when checking the module application" ++-      [prettyA $ A.Apply info m1 modapp initCopyInfo defaultImportDir]-      where-      info = A.ModuleInfo noRange noRange Nothing Nothing Nothing--    ModuleContents -> fsep $ pwords "when retrieving the contents of a module"--    where-    hPretty :: Arg (Named_ Expr) -> TCM Doc-    hPretty a = pretty =<< abstractToConcreteCtx (hiddenArgumentCtx (getHiding a)) a-------------------------------------------------------------------------------- * 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"-      Forced{}   -> __IMPOSSIBLE__-      UnusedArg  -> __IMPOSSIBLE__---- | Indefinite article.-data Indefinite a = Indefinite a--instance Verbalize a => Verbalize (Indefinite a) where-  verbalize (Indefinite a) =-    case verbalize a of-      "" -> ""-      w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w-               | otherwise                  -> "a " ++ w-      -- Aarne Ranta would whip me if he saw this.--singPlural :: Sized a => a -> c -> c -> c-singPlural xs singular plural = if size xs == 1 then singular else plural+{-# LANGUAGE NondecreasingIndentation #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Agda.TypeChecking.Errors+  ( 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++instance Verbalize a => Verbalize (Indefinite a) where+  verbalize (Indefinite a) =+    case verbalize a of+      "" -> ""+      w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w+               | otherwise                  -> "a " ++ w+      -- Aarne Ranta would whip me if he saw this.
src/full/Agda/TypeChecking/Errors.hs-boot view
@@ -1,7 +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,22 +1,22 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Compute eta short normal forms. module Agda.TypeChecking.EtaContract where -import Control.Monad.Reader- import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic+ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free import Agda.TypeChecking.Monad-import Agda.TypeChecking.Reduce.Monad ()+import Agda.TypeChecking.Reduce.Monad () --instance only import {-# SOURCE #-} Agda.TypeChecking.Records import {-# SOURCE #-} Agda.TypeChecking.Datatypes+ import Agda.Utils.Monad+import Agda.Utils.List (initLast) -#include "undefined.h" import Agda.Utils.Impossible  -- TODO: move to Agda.Syntax.Internal.SomeThing@@ -33,8 +33,10 @@   -- At least record constructors should be fully applied where possible!   -- TODO: also for ordinary constructors (\ x -> suc x  vs.  suc)?   Con c ci xs-    | null (conFields c) -> app (Con c ci) xs-    | otherwise          -> noApp+    | IsData <- conDataRecord c+             -> appE (Con c ci) xs+    | otherwise+             -> noApp   Lit _      -> noApp   Level _    -> noApp   -- could be an application, but let's not eta contract levels   Lam _ _    -> noApp@@ -42,59 +44,80 @@   Sort _     -> noApp   MetaV _ _  -> noApp   DontCare _ -> noApp-  Shared p   -> binAppView (derefPtr p)  -- destroys sharing+  Dummy{}    -> __IMPOSSIBLE__   where     noApp = NoApp t-    app f [] = noApp-    app f xs = App (f $ init xs) (last xs)-    appE f [] = noApp-    appE f xs-      | Apply v <- last xs = App (f $ init xs) v-      | otherwise          = noApp+    appE f es0 | Just (es, Apply v) <- initLast es0 = App (f es) v+    appE _ _ = noApp  -- | Contracts all eta-redexes it sees without reducing. {-# SPECIALIZE etaContract :: TermLike a => a -> TCM a #-} {-# SPECIALIZE etaContract :: TermLike a => a -> ReduceM a #-}-etaContract :: (MonadReader TCEnv m, HasConstInfo m, HasOptions m, TermLike a) => a -> m a+etaContract :: (MonadTCEnv m, HasConstInfo m, HasOptions m, TermLike a) => a -> m a etaContract = traverseTermM etaOnce  {-# SPECIALIZE etaOnce :: Term -> TCM Term #-} {-# SPECIALIZE etaOnce :: Term -> ReduceM Term #-}-etaOnce :: (MonadReader TCEnv m, HasConstInfo m, HasOptions m) => Term -> m Term-etaOnce v = case v of+etaOnce :: (MonadTCEnv m, HasConstInfo m, HasOptions m) => Term -> m Term+etaOnce = \case   -- Andreas, 2012-11-18: this call to reportSDoc seems to cost me 2%   -- performance on the std-lib-  -- reportSDoc "tc.eta" 70 $ text "eta-contracting" <+> prettyTCM v-  Shared{} -> updateSharedTerm etaOnce v-  Lam i (Abs _ b) -> do  -- NoAbs can't be eta'd-      tyty <- typeInType-      case binAppView b of-        App u (Arg info v)-          | (isIrrelevant info || isVar0 tyty v)-                    && getHiding i == getHiding info-                    && not (freeIn 0 u) ->-            return $ strengthen __IMPOSSIBLE__ u-        _ -> return v-    where-      isVar0 tyty (Shared p)            = isVar0 tyty (derefPtr p)-      isVar0 _ (Var 0 [])               = True-      -- Andreas, 2016-01-08 If --type-in-type, all levels are equal.-      isVar0 True Level{}               = True-      isVar0 tyty (Level (Max [Plus 0 l])) = case l of-        NeutralLevel _ v -> isVar0 tyty v-        UnreducedLevel v -> isVar0 tyty v-        BlockedLevel{}   -> False-        MetaLevel{}      -> False-      isVar0 _ _ = False+  -- reportSDoc "tc.eta" 70 $ "eta-contracting" <+> prettyTCM v+  Lam i (Abs x b) -> etaLam i x b  -- NoAbs can't be eta'd    -- Andreas, 2012-12-18:  Abstract definitions could contain   -- abstract records whose constructors are not in scope.   -- To be able to eta-contract them, we ignore abstract.-  Con c ci args -> ignoreAbstractMode $ do-      -- reportSDoc "tc.eta" 20 $ text "eta-contracting record" <+> prettyTCM t-      r <- getConstructorData $ conName c -- fails in ConcreteMode if c is abstract-      ifM (isEtaRecord r)-          (do -- reportSDoc "tc.eta" 20 $ text "eta-contracting record" <+> prettyTCM t-              etaContractRecord r c ci args)-          (return v)+  Con c ci es -> etaCon c ci es etaContractRecord+   v -> return v++-- | If record constructor, call eta-contraction function.+etaCon :: (MonadTCEnv m, HasConstInfo m, HasOptions m)+  => ConHead  -- ^ Constructor name @c@.+  -> ConInfo  -- ^ Constructor info @ci@.+  -> Elims     -- ^ Constructor arguments @args@.+  -> (QName -> ConHead -> ConInfo -> Args -> m Term)+              -- ^ Eta-contraction workhorse, gets also name of record type.+  -> m Term   -- ^ Returns @Con c ci args@ or its eta-contraction.+etaCon c ci es cont = ignoreAbstractMode $ do+  let fallback = return $ Con c ci es+  -- reportSDoc "tc.eta" 20 $ "eta-contracting record" <+> prettyTCM t+  r <- getConstructorData $ conName c -- fails in ConcreteMode if c is abstract+  ifNotM (isEtaRecord r) fallback $ {-else-} do+    -- reportSDoc "tc.eta" 20 $ "eta-contracting record" <+> prettyTCM t+    let Just args = allApplyElims es+    cont r c ci args++-- | Try to contract a lambda-abstraction @Lam i (Abs x b)@.+etaLam :: (MonadTCEnv m, HasConstInfo m, HasOptions m)+  => ArgInfo  -- ^ Info @i@ of the 'Lam'.+  -> ArgName  -- ^ Name @x@ of the abstraction.+  -> Term     -- ^ Body ('Term') @b@ of the 'Abs'.+  -> m Term   -- ^ @Lam i (Abs x b)@, eta-contracted if possible.+etaLam i x b = do+    let fallback = return $ Lam i $ Abs x b+    case binAppView b of+      App u (Arg info v) -> do+        tyty <- typeInType+        if isVar0 tyty v+        -- Andreas, 2017-02-20 issue #2464+        -- Contracting with any irrelevant argument breaks subject reduction.+        -- E.g. \ .x -> f .(subst P eq x)  can in general not be contracted to f.+        -- -- (isIrrelevant info || isVar0 tyty v)+             && sameHiding i info+             && sameModality i info+             && not (freeIn 0 u)+           then return $ strengthen impossible u+           else fallback+      _ -> fallback+  where+    isVar0 _ (Var 0 [])               = True+    -- Andreas, 2016-01-08 If --type-in-type, all levels are equal.+    -- Jesper, 2019-10-15 issue #3073+    -- Contracting level arguments is not sound unless the domain type+    -- is in fact @Level@, e.g. @\(A : Set) → F lzero@ should not be+    -- eta-contracted to @F@.+    -- isVar0 True Level{}               = True+    isVar0 tyty (Level (Max 0 [Plus 0 l])) = isVar0 tyty l+    isVar0 _ _ = False
src/full/Agda/TypeChecking/Forcing.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP               #-}  {-| A constructor argument is forced if it appears as pattern variable in an index of the target.@@ -15,12 +14,12 @@ @  At runtime, forced constructor arguments may be erased as they can be-recovered from dot patterns.  In the epic backend,+recovered from dot patterns.  For instance, @   unsing : {A : Set} (x : A) -> Sing x -> A   unsing .x (sing x) = x @-becomes+can become @   unsing x sing = x @@@ -36,6 +35,10 @@   proj (suc n) (suc i) = n @ +This module implements the analysis of which constructor arguments are forced. The process of moving+the binding site of forced arguments is implemented in the unifier (see the Solution step of+Agda.TypeChecking.Rules.LHS.Unify.unifyStep).+ Forcing is a concept from pattern matching and thus builds on the concept of equality (I) used there (closed terms, extensional) which is different from the equality (II) used in conversion checking and the@@ -43,8 +46,8 @@  Up to issue 1441 (Feb 2015), the forcing analysis here relied on the wrong equality (II), considering type constructors as injective.  This is-unsound for Epic's program extraction, but ok if forcing is only used-to decide which arguments to skip during conversion checking.+unsound for program extraction, but ok if forcing is only used to decide which+arguments to skip during conversion checking.  From now on, forcing uses equality (I) and does not search for forced variables under type constructors.  This may lose some savings during@@ -55,13 +58,19 @@  -} -module Agda.TypeChecking.Forcing where+module Agda.TypeChecking.Forcing+  ( computeForcingAnnotations,+    isForced,+    nextIsForced ) where -import Prelude hiding (elem, maximum)+import Control.Monad.Reader ( MonadReader, ask, local, ReaderT, runReaderT )+import Control.Monad.State  ( MonadState, modify, StateT, execStateT ) -import Control.Applicative-import Data.Foldable-import Data.Traversable+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 @@ -69,81 +78,171 @@ import Agda.Syntax.Internal  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Datatypes (consOfHIT) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Telescope -import Agda.Utils.Function+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.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size+import Agda.Utils.Singleton -#include "undefined.h" import Agda.Utils.Impossible  -- | Given the type of a constructor (excluding the parameters), --   decide which arguments are forced.---   Update the relevance info in the domains accordingly.---   Precondition: the type is of the form @Γ → D vs@ and the @vs@---   are in normal form.-addForcingAnnotations :: Type -> TCM Type-addForcingAnnotations t =-  ifM (not . optForcing <$> commandLineOptions)-      (return t) $ do-  -- Andreas, 2015-03-10  Normalization prevents Issue 1454.-  -- t <- normalise t-  -- 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-  let TelV tel (El s a) = telView' t-      vs = case ignoreSharing a of-        Def _ us -> us-        _        -> __IMPOSSIBLE__-      n  = size tel-      indexToLevel x = n - x - 1-  -- Note: data parameters will be negative levels.-  let xs = filter (>=0) $ map indexToLevel $ forcedVariables vs-  let s0 = raise (0 - size tel) s-  t' <- force s0 xs t-  reportSLn "tc.force" 60 $ unlines-    [ "Forcing analysis"-    , "  xs = " ++ show xs-    , "  t  = " ++ show t-    , "  t' = " ++ show t'-    ]-  return t'+computeForcingAnnotations :: QName -> Type -> TCM [IsForced]+computeForcingAnnotations c t =+  ifNotM (optForcing <$> pragmaOptions {-then-}) (return []) $ {-else-} do+    -- Andreas, 2015-03-10  Normalization prevents Issue 1454.+    -- t <- normalise t+    -- 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+    -- 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__+    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+      , "  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 -> [Nat]+  forcedVariables :: a -> ForcedVariableCollection -instance (ForcedVariables a, Foldable t) => ForcedVariables (t a) where+  default forcedVariables ::+    (ForcedVariables b, Foldable t, a ~ t b) =>+    a -> ForcedVariableCollection   forcedVariables = foldMap forcedVariables +instance ForcedVariables a => ForcedVariables [a] where++-- 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{}  = mempty  -- No forced variables in path applications+  forcedVariables Proj{}    = mempty++instance ForcedVariables a => ForcedVariables (Arg a) where+  forcedVariables x =+    underModality m $ forcedVariables $ unArg x+    where m = getModality x+ -- | Assumes that the term is in normal form. instance ForcedVariables Term where-  forcedVariables t = case ignoreSharing t of-    Var i [] -> [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 --- | @force s xs t@ marks the domains @xs@ in function type @t@ as forced.---   Domains bigger than @s@ are marked as @'Forced' 'Big'@, others as---   @'Forced' 'Small'@.---   Counting left-to-right, starting with 0.---   Precondition: function type is exposed.-force :: Sort -> [Nat] -> Type -> TCM Type-force s0 xs t = loop 0 t-  where-    m = maximum (-1:xs)  -- number of domains to look at-    loop i t | i > m = return t-    loop i t = case ignoreSharingType t of-      El s (Pi a b) -> do-        a' <- if not (i `elem` xs) then return a else do-          -- If the sort of the data type is >= the sort of the argument type-          -- then the index is small, else big.-          b <- ifM (tryConversion $ leqSort (getSort a) (raise i s0)) (return Small) (return Big)-          return $ mapRelevance (composeRelevance $ Forced b) a-        El s . Pi a' <$> traverse (loop $ i + 1) b-      _ -> __IMPOSSIBLE__+isForced :: IsForced -> Bool+isForced Forced    = True+isForced NotForced = False++nextIsForced :: [IsForced] -> (IsForced, [IsForced])+nextIsForced []     = (NotForced, [])+nextIsForced (f:fs) = (f, fs)
src/full/Agda/TypeChecking/Free.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances       #-} -- Due to underdetermined var in IsVarSet multi-param typeclass  -- | Computing the free variables of a term. --@@ -15,256 +16,202 @@ -- Also, function types and lambdas do not establish strong rigidity. -- Only inductive constructors do so. -- (See issue 1271).+--+-- If you need the occurrence information for all free variables, you can use+-- @freeVars@ which has amoungst others this instance+-- @+--    freeVars :: Term -> VarMap+-- @+-- From @VarMap@, specific information can be extracted, e.g.,+-- @+--    relevantVars :: VarMap -> VarSet+--    relevantVars = filterVarMap isRelevant+-- @+--+-- To just check the status of a single free variable, there are more+-- efficient methods, e.g.,+-- @+--    freeIn :: Nat -> Term -> Bool+-- @+--+-- Tailored optimized variable checks can be implemented as semimodules to 'VarOcc',+-- see, for example, 'VarCounts' or 'SingleFlexRig'.  module Agda.TypeChecking.Free-    ( FreeVars(..)-    , Free, Free', FreeV, FreeVS+    ( VarCounts(..)+    , Free+    , IsVarSet(..)     , IgnoreSorts(..)-    , runFree , rigidVars, relevantVars, allVars+    , freeVars, freeVars', filterVarMap, filterVarMapToList+    , runFree, rigidVars, stronglyRigidVars, unguardedVars, allVars+    , flexibleVars     , allFreeVars     , allRelevantVars, allRelevantVarsIgnoring-    , allRelevantOrUnusedVars, allRelevantOrUnusedVarsIgnoring+    , freeVarsIgnore     , freeIn, freeInIgnoringSorts, isBinderUsed     , relevantIn, relevantInIgnoringSortAnn-    , Occurrence(..)-    , occurrence+    , FlexRig'(..), FlexRig+    , LensFlexRig(..), isFlexible, isUnguarded, isStronglyRigid, isWeaklyRigid+    , VarOcc'(..), VarOcc+    , varOccurrenceIn+    , flexRigOccurrenceIn     , closed-    , freeVars -- only for testing-    , freeVars'+    , MetaSet+    , insertMetaSet, foldrMetaSet, metaSetToBlocker     ) where  import Prelude hiding (null) -import Control.Monad.Reader--import Data.Maybe-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat, Any(..), All(..))+import Data.Semigroup ( Semigroup, (<>), Any(..), All(..) ) import Data.IntSet (IntSet)-import qualified Data.IntSet as Set+import qualified Data.IntSet as IntSet import Data.IntMap (IntMap)-import qualified Data.IntMap as Map-import Data.Set (Set)+import qualified Data.IntMap as IntMap  import qualified Agda.Benchmarking as Bench -import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)+import Agda.Syntax.Common hiding (Arg, NamedArg) import Agda.Syntax.Internal  import Agda.TypeChecking.Free.Lazy-  ( Free'(..) , FreeEnv(..), initFreeEnv-  , VarOcc(..), IgnoreSorts(..), Variable, SingleVar-  , MetaSet-  )-import qualified Agda.TypeChecking.Free.Lazy as Free+  -- ( Free(..) , FreeEnv(..), initFreeEnv+  -- , FlexRig, FlexRig'(..)+  -- , VarOcc(..), topVarOcc, TheVarMap, theVarMap, IgnoreSorts(..), Variable, SingleVar+  -- , MetaSet, insertMetaSet, foldrMetaSet+  -- , IsVarSet(..), runFreeM+  -- ) -import Agda.Utils.Null import Agda.Utils.Singleton +---------------------------------------------------------------------------+-- * Simple variable set implementations.+ type VarSet = IntSet --- | Free variables of a term, (disjointly) partitioned into strongly and---   and weakly rigid variables, flexible variables and irrelevant variables.-data FreeVars = FV-  { stronglyRigidVars :: VarSet-    -- ^ Variables under only and at least one inductive constructor(s).-  , unguardedVars     :: VarSet-    -- ^ Variables at top or only under inductive record constructors-    --   λs and Πs.-    --   The purpose of recording these separately is that they-    --   can still become strongly rigid if put under a constructor-    --   whereas weakly rigid ones stay weakly rigid.-  , weaklyRigidVars   :: VarSet-    -- ^ Ordinary rigid variables, e.g., in arguments of variables.-  , flexibleVars      :: IntMap MetaSet-    -- ^ Variables occuring in arguments of metas.-    --   These are only potentially free, depending how the meta variable is instantiated.-    --   The set contains the id's of the meta variables that this variable is an argument to.-  , irrelevantVars    :: VarSet-    -- ^ Variables in irrelevant arguments and under a @DontCare@, i.e.,-    --   in irrelevant positions.-  , unusedVars        :: VarSet-    -- ^ Variables in 'UnusedArg'uments.-  } deriving (Eq, Show)+-- In most cases we don't care about the VarOcc. -mapSRV, mapUGV, mapWRV, mapIRV, mapUUV-  :: (VarSet -> VarSet) -> FreeVars -> FreeVars-mapSRV f fv = fv { stronglyRigidVars = f $ stronglyRigidVars fv }-mapUGV f fv = fv { unguardedVars     = f $ unguardedVars     fv }-mapWRV f fv = fv { weaklyRigidVars   = f $ weaklyRigidVars   fv }-mapIRV f fv = fv { irrelevantVars    = f $ irrelevantVars    fv }-mapUUV f fv = fv { unusedVars        = f $ unusedVars        fv }+instance IsVarSet () VarSet where withVarOcc _ = id+instance IsVarSet () [Int]  where withVarOcc _ = id+instance IsVarSet () Any    where withVarOcc _ = id+instance IsVarSet () All    where withVarOcc _ = id -mapFXV :: (IntMap MetaSet -> IntMap MetaSet) -> FreeVars -> FreeVars-mapFXV f fv = fv { flexibleVars      = f $ flexibleVars      fv }+---------------------------------------------------------------------------+-- * Plain variable occurrence counting. --- | Rigid variables: either strongly rigid, unguarded, or weakly rigid.-rigidVars :: FreeVars -> VarSet-rigidVars fv = Set.unions-  [ stronglyRigidVars fv-  ,     unguardedVars fv-  ,   weaklyRigidVars fv-  ]+newtype VarCounts = VarCounts { varCounts :: IntMap Int } --- | All but the irrelevant variables.-relevantVars :: FreeVars -> VarSet-relevantVars fv = Set.unions [rigidVars fv, Map.keysSet (flexibleVars fv)]+instance Semigroup VarCounts where+  VarCounts fv1 <> VarCounts fv2 = VarCounts (IntMap.unionWith (+) fv1 fv2) --- | @allVars fv@ includes irrelevant variables.-allVars :: FreeVars -> VarSet-allVars fv = Set.unions [relevantVars fv, irrelevantVars fv, unusedVars fv]+instance Monoid VarCounts where+  mempty = VarCounts IntMap.empty+  mappend = (<>) -data Occurrence-  = NoOccurrence-  | Irrelevantly-  | StronglyRigid     -- ^ Under at least one and only inductive constructors.-  | Unguarded         -- ^ In top position, or only under inductive record constructors.-  | WeaklyRigid       -- ^ In arguments to variables and definitions.-  | Flexible MetaSet  -- ^ In arguments of metas.-  | Unused-  deriving (Eq,Show)+instance IsVarSet () VarCounts where+  withVarOcc _ = id --- | Compute an occurrence of a single variable in a piece of internal syntax.-occurrence :: FreeV a => Nat -> a -> Occurrence-occurrence x v = occurrenceFV x $ freeVars v+instance Singleton Variable VarCounts where+  singleton i = VarCounts $ IntMap.singleton i 1 --- | Extract occurrence of a single variable from computed free variables.-occurrenceFV :: Nat -> FreeVars -> Occurrence-occurrenceFV x fv-  | x `Set.member` stronglyRigidVars fv = StronglyRigid-  | x `Set.member` unguardedVars     fv = Unguarded-  | x `Set.member` weaklyRigidVars   fv = WeaklyRigid-  | Just ms <- Map.lookup x (flexibleVars fv) = Flexible ms-  | x `Set.member` irrelevantVars    fv = Irrelevantly-  | x `Set.member` unusedVars        fv = Unused-  | otherwise                           = NoOccurrence+---------------------------------------------------------------------------+-- * Collecting free variables (generic). --- | Mark variables as flexible.  Useful when traversing arguments of metas.-flexible :: MetaSet -> FreeVars -> FreeVars-flexible ms fv =-    fv { stronglyRigidVars = Set.empty-       , unguardedVars     = Set.empty-       , weaklyRigidVars   = Set.empty-       , flexibleVars      = Map.unionsWith mappend-                               [ Map.fromSet (const ms) (rigidVars fv)-                               , fmap (mappend ms) (flexibleVars fv) ]-       }+-- | Collect all free variables together with information about their occurrence.+--+-- Doesn't go inside solved metas, but collects the variables from a+-- metavariable application @X ts@ as @flexibleVars@.+{-# SPECIALIZE freeVars :: Free a => a -> VarMap #-}+freeVars :: (IsVarSet a c, Singleton Variable c, Free t) => t -> c+freeVars = freeVarsIgnore IgnoreNot --- | Mark rigid variables as non-strongly.  Useful when traversing arguments of variables.-weakly :: FreeVars -> FreeVars-weakly fv = fv-  { stronglyRigidVars = Set.empty-  , unguardedVars     = Set.empty-  , weaklyRigidVars   = rigidVars fv-  }+freeVarsIgnore :: (IsVarSet a c, Singleton Variable c, Free t) =>+                  IgnoreSorts -> t -> c+freeVarsIgnore = runFree singleton --- | Mark unguarded variables as strongly rigid.  Useful when traversing arguments of inductive constructors.-strongly :: FreeVars -> FreeVars-strongly fv = fv-  { stronglyRigidVars = stronglyRigidVars fv `Set.union` unguardedVars fv-  , unguardedVars     = Set.empty-  }+-- Specialization to typical monoids+{-# SPECIALIZE runFree :: Free a => SingleVar Any      -> IgnoreSorts -> a -> Any #-}+-- Specialization to Term+{-# SPECIALIZE runFree :: SingleVar Any      -> IgnoreSorts -> Term -> Any #-} --- | What happens to the variables occurring under a constructor?-underConstructor :: ConHead -> FreeVars -> FreeVars-underConstructor (ConHead c i fs) =-  case (i,fs) of-    -- Coinductive (record) constructors admit infinite cycles:-    (CoInductive, _)   -> weakly-    -- Inductive data constructors do not admit infinite cycles:-    (Inductive, [])    -> strongly-    -- Inductive record constructors do not admit infinite cycles,-    -- but this cannot be proven inside Agda.-    -- Thus, unification should not prove it either.-    (Inductive, (_:_)) -> id+-- | Compute free variables.+runFree :: (IsVarSet a c, Free t) => SingleVar c -> IgnoreSorts -> t -> c+runFree single i t = -- bench $  -- Benchmarking is expensive (4% on std-lib)+  runFreeM single i (freeVars' t)+  where+  bench = Bench.billToPure [ Bench.Typing , Bench.Free ] --- | Mark all free variables as irrelevant.-irrelevantly :: FreeVars -> FreeVars-irrelevantly fv = empty { irrelevantVars = allVars fv }+---------------------------------------------------------------------------+-- * Occurrence computation for a single variable. --- | Mark all free variables as unused, except for irrelevant vars.-unused :: FreeVars -> FreeVars-unused fv = empty-  { irrelevantVars = irrelevantVars fv-  , unusedVars     = Set.unions [ rigidVars fv, Map.keysSet (flexibleVars fv), unusedVars fv ]-  }+-- ** Full free occurrence info for a single variable. --- | Pointwise union.-union :: FreeVars -> FreeVars -> FreeVars-union (FV sv1 gv1 rv1 fv1 iv1 uv1) (FV sv2 gv2 rv2 fv2 iv2 uv2) =-  FV (Set.union sv1 sv2) (Set.union gv1 gv2) (Set.union rv1 rv2) (Map.unionWith mappend fv1 fv2) (Set.union iv1 iv2) (Set.union uv1 uv2)+-- | Get the full occurrence information of a free variable.+varOccurrenceIn :: Free a => Nat -> a -> Maybe VarOcc+varOccurrenceIn = varOccurrenceIn' IgnoreNot -unions :: [FreeVars] -> FreeVars-unions = foldr union empty+varOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe VarOcc+varOccurrenceIn' ig x t = theSingleVarOcc $ runFree sg ig t+  where+  sg y = if x == y then oneSingleVarOcc else mempty -instance Null FreeVars where-  empty = FV Set.empty Set.empty Set.empty Map.empty Set.empty Set.empty-  null (FV a b c d e f) = null a && null b && null c && null d && null e && null f+-- | "Collection" just keeping track of the occurrence of a single variable.+--   'Nothing' means variable does not occur freely.+newtype SingleVarOcc = SingleVarOcc { theSingleVarOcc :: Maybe VarOcc } --- | Free variable sets form a monoid under 'union'.-instance Semigroup FreeVars where-  (<>) = union+oneSingleVarOcc :: SingleVarOcc+oneSingleVarOcc = SingleVarOcc $ Just $ oneVarOcc -instance Monoid FreeVars where-  mempty  = empty+-- | Hereditary Semigroup instance for 'Maybe'.+--   (The default instance for 'Maybe' may not be the hereditary one.)+instance Semigroup SingleVarOcc where+  SingleVarOcc Nothing <> s = s+  s <> SingleVarOcc Nothing = s+  SingleVarOcc (Just o) <> SingleVarOcc (Just o') = SingleVarOcc $ Just $ o <> o'++instance Monoid SingleVarOcc where+  mempty = SingleVarOcc Nothing   mappend = (<>)-  mconcat = unions --- | @delete x fv@ deletes variable @x@ from variable set @fv@.-delete :: Nat -> FreeVars -> FreeVars-delete n (FV sv gv rv fv iv uv) = FV (Set.delete n sv) (Set.delete n gv) (Set.delete n rv) (Map.delete n fv) (Set.delete n iv) (Set.delete n uv)+instance IsVarSet MetaSet SingleVarOcc where+  withVarOcc o = SingleVarOcc . fmap (composeVarOcc o) . theSingleVarOcc -instance Singleton Variable FreeVars where-  singleton (i, VarOcc o r) = mod empty where-    mod :: FreeVars -> FreeVars-    mod = case (o, r) of-      (_, Irrelevant) -> mapIRV (Set.insert i)-      (_, UnusedArg ) -> mapUUV (Set.insert i)-      (Free.StronglyRigid, _) -> mapSRV (Set.insert i)-      (Free.Unguarded    , _) -> mapUGV (Set.insert i)-      (Free.WeaklyRigid  , _) -> mapWRV (Set.insert i)-      (Free.Flexible ms  , _) -> mapFXV (Map.insert i ms)+-- ** Flexible /rigid occurrence info for a single variable. --- * Collecting free variables.+-- | Get the full occurrence information of a free variable.+flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig+flexRigOccurrenceIn = flexRigOccurrenceIn' IgnoreNot -bench :: a -> a-bench = Bench.billToPure [ Bench.Typing , Bench.Free ]+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 -type Free a = Free' a Any-type FreeV a = Free' a FreeVars-type FreeVS a = Free' a VarSet+-- | "Collection" just keeping track of the occurrence of a single variable.+--   'Nothing' means variable does not occur freely.+newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe FlexRig } --- | Doesn't go inside solved metas, but collects the variables from a--- metavariable application @X ts@ as @flexibleVars@.-{-# SPECIALIZE freeVars :: FreeV a => a -> FreeVars #-}-freeVars :: (Monoid c, Singleton Variable c, Free' a c) => a -> c-freeVars = freeVarsIgnore IgnoreNot+oneSingleFlexRig :: SingleFlexRig+oneSingleFlexRig = SingleFlexRig $ Just $ oneFlexRig -{-# SPECIALIZE freeVarsIgnore :: FreeV a => IgnoreSorts -> a -> FreeVars #-}-freeVarsIgnore :: (Monoid c, Singleton Variable c, Free' a c) => IgnoreSorts -> a -> c-freeVarsIgnore = runFree singleton+-- | Hereditary Semigroup instance for 'Maybe'.+--   (The default instance for 'Maybe' may not be the hereditary one.)+instance Semigroup SingleFlexRig where+  SingleFlexRig Nothing <> s = s+  s <> SingleFlexRig Nothing = s+  SingleFlexRig (Just o) <> SingleFlexRig (Just o') = SingleFlexRig $ Just $ addFlexRig o o' --- Specialization to typical monoids-{-# SPECIALIZE runFree :: Free' a Any      => SingleVar Any      -> IgnoreSorts -> a -> Any #-}-{-# SPECIALIZE runFree :: Free' a All      => SingleVar All      -> IgnoreSorts -> a -> All #-}-{-# SPECIALIZE runFree :: Free' a VarSet   => SingleVar VarSet   -> IgnoreSorts -> a -> VarSet #-}-{-# SPECIALIZE runFree :: Free' a FreeVars => SingleVar FreeVars -> IgnoreSorts -> a -> FreeVars #-}--- Specialization to Term-{-# SPECIALIZE runFree :: SingleVar Any      -> IgnoreSorts -> Term -> Any #-}-{-# SPECIALIZE runFree :: SingleVar All      -> IgnoreSorts -> Term -> All #-}-{-# SPECIALIZE runFree :: SingleVar VarSet   -> IgnoreSorts -> Term -> VarSet #-}-{-# SPECIALIZE runFree :: SingleVar FreeVars -> IgnoreSorts -> Term -> FreeVars #-}-runFree :: (Monoid c, Free' a c) => SingleVar c -> IgnoreSorts -> a -> c-runFree singleton i t = -- bench $  -- Benchmarking is expensive (4% on std-lib)-  freeVars' t `runReader` (initFreeEnv singleton) { feIgnoreSorts = i }+instance Monoid SingleFlexRig where+  mempty = SingleFlexRig Nothing+  mappend = (<>) -freeIn'' :: Free a => (VarOcc -> Bool) -> IgnoreSorts -> Nat -> a -> Bool-freeIn'' test ig x t =-  getAny $ runFree (\ (y, o) -> Any $ x == y && test o) ig t+instance IsVarSet MetaSet SingleFlexRig where+  withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ varFlexRig o) . theSingleFlexRig --- | @freeIn' = freeIn'' (const True)@+-- ** Plain free occurrence.++-- | Check if a variable is free, possibly ignoring sorts. freeIn' :: Free a => IgnoreSorts -> Nat -> a -> Bool-freeIn' ig x t =-  getAny $ runFree (Any . (x ==) . fst) ig t+freeIn' ig x t = getAny $ runFree (Any . (x ==)) ig t  {-# SPECIALIZE freeIn :: Nat -> Term -> Bool #-} freeIn :: Free a => Nat -> a -> Bool@@ -273,42 +220,102 @@ freeInIgnoringSorts :: Free a => Nat -> a -> Bool freeInIgnoringSorts = freeIn' IgnoreAll -freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool-freeInIgnoringSortAnn = freeIn' IgnoreInAnnotations--relevantInIgnoringSortAnn :: Free a => Nat -> a -> Bool-relevantInIgnoringSortAnn = freeIn'' (not . irrelevantOrUnused . varRelevance) IgnoreInAnnotations--relevantIn :: Free a => Nat -> a -> Bool-relevantIn = freeIn'' (not . irrelevantOrUnused . varRelevance) IgnoreAll+-- UNUSED Liang-Ting Chen 2019-07-16+--freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool+--freeInIgnoringSortAnn = freeIn' IgnoreInAnnotations  -- | Is the variable bound by the abstraction actually used? isBinderUsed :: Free a => Abs a -> Bool isBinderUsed NoAbs{}   = False isBinderUsed (Abs _ x) = 0 `freeIn` x +-- ** Relevant free occurrence.++newtype RelevantIn c = RelevantIn {getRelevantIn :: c}+  deriving (Semigroup, Monoid)++instance IsVarSet a c => IsVarSet a (RelevantIn c) where  -- UndecidableInstances+  withVarOcc o x+    | isIrrelevant o = mempty+    | otherwise = RelevantIn $ withVarOcc o $ getRelevantIn x++relevantIn' :: Free t => IgnoreSorts -> Nat -> t -> Bool+relevantIn' ig x t = getAny . getRelevantIn $ runFree (RelevantIn . Any . (x ==)) ig t++relevantInIgnoringSortAnn :: Free t => Nat -> t -> Bool+relevantInIgnoringSortAnn = relevantIn' IgnoreInAnnotations++relevantIn :: Free t => Nat -> t -> Bool+relevantIn = relevantIn' IgnoreAll++---------------------------------------------------------------------------+-- * Occurrences of all free variables.+ -- | Is the term entirely closed (no free variables)?-closed :: Free' a All => a -> Bool+closed :: Free t => t -> Bool closed t = getAll $ runFree (const $ All False) IgnoreNot t  -- | Collect all free variables.-allFreeVars :: Free' a VarSet => a -> VarSet-allFreeVars = runFree (Set.singleton . fst) IgnoreNot+allFreeVars :: Free t => t -> VarSet+allFreeVars = runFree IntSet.singleton IgnoreNot --- | Collect all relevant free variables, excluding the "unused" ones, possibly ignoring sorts.-allRelevantVarsIgnoring :: Free' a VarSet => IgnoreSorts -> a -> VarSet-allRelevantVarsIgnoring = runFree sg-  where sg (i, VarOcc _ r) = if irrelevantOrUnused r then Set.empty else Set.singleton i+-- | Collect all relevant free variables, possibly ignoring sorts.+allRelevantVarsIgnoring :: Free t => IgnoreSorts -> t -> VarSet+allRelevantVarsIgnoring ig = getRelevantIn . runFree (RelevantIn . IntSet.singleton) ig  -- | Collect all relevant free variables, excluding the "unused" ones.-allRelevantVars :: Free' a VarSet => a -> VarSet+allRelevantVars :: Free t => t -> VarSet allRelevantVars = allRelevantVarsIgnoring IgnoreNot --- | Collect all relevant free variables, possibly ignoring sorts.-allRelevantOrUnusedVarsIgnoring :: Free' a VarSet => IgnoreSorts -> a -> VarSet-allRelevantOrUnusedVarsIgnoring = runFree sg-  where sg (i, VarOcc _ r) = if isIrrelevant r then Set.empty else Set.singleton i+---------------------------------------------------------------------------+-- * Backwards-compatible interface to 'freeVars'. --- | Collect all relevant free variables.-allRelevantOrUnusedVars :: Free' a VarSet => a -> VarSet-allRelevantOrUnusedVars = allRelevantOrUnusedVarsIgnoring IgnoreNot+filterVarMap :: (VarOcc -> Bool) -> VarMap -> VarSet+filterVarMap f = IntMap.keysSet . IntMap.filter f . theVarMap++filterVarMapToList :: (VarOcc -> Bool) -> VarMap -> [Variable]+filterVarMapToList f = map fst . filter (f . snd) . IntMap.toList . theVarMap++-- | Variables under only and at least one inductive constructor(s).+stronglyRigidVars :: VarMap -> VarSet+stronglyRigidVars = filterVarMap $ \case+  VarOcc StronglyRigid _ -> True+  _ -> False++-- | Variables at top or only under inductive record constructors+--   λs and Πs.+--   The purpose of recording these separately is that they+--   can still become strongly rigid if put under a constructor+--   whereas weakly rigid ones stay weakly rigid.+unguardedVars :: VarMap -> VarSet+unguardedVars = filterVarMap $ \case+  VarOcc Unguarded _ -> True+  _ -> False++-- UNUSED Liang-Ting Chen 2019-07-16+---- | Ordinary rigid variables, e.g., in arguments of variables or functions.+--weaklyRigidVars :: VarMap -> VarSet+--weaklyRigidVars = filterVarMap $ \case+--  VarOcc WeaklyRigid _ -> True+--  _ -> False++-- | Rigid variables: either strongly rigid, unguarded, or weakly rigid.+rigidVars :: VarMap -> VarSet+rigidVars = filterVarMap $ \case+  VarOcc o _ -> o `elem` [ WeaklyRigid, Unguarded, StronglyRigid ]++-- | Variables occuring in arguments of metas.+--  These are only potentially free, depending how the meta variable is instantiated.+--  The set contains the id's of the meta variables that this variable is an argument to.+flexibleVars :: VarMap -> IntMap MetaSet+flexibleVars (VarMap m) = (`IntMap.mapMaybe` m) $ \case+ VarOcc (Flexible ms) _ -> Just ms+ _ -> Nothing++---- | Variables in irrelevant arguments and under a @DontCare@, i.e.,+----   in irrelevant positions.+--irrelevantVars :: VarMap -> VarSet+--irrelevantVars = filterVarMap isIrrelevant++allVars :: VarMap -> VarSet+allVars = IntMap.keysSet . theVarMap
src/full/Agda/TypeChecking/Free/Lazy.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UndecidableInstances #-}  -- | Computing the free variables of a term lazily. --@@ -9,7 +8,7 @@ -- Worst-case complexity does not change (i.e. the case when a variable -- does not occur), but best case-complexity does matter.  For instance, -- see 'Agda.TypeChecking.Substitute.mkAbs': each time we construct--- a dependent function type, we check it is actually dependent.+-- a dependent function type, we check whether it is actually dependent. -- -- The distinction between rigid and strongly rigid occurrences comes from: --   Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)@@ -25,55 +24,177 @@ -- Also, function types and lambdas do not establish strong rigidity. -- Only inductive constructors do so. -- (See issue 1271).+--+-- For further reading on semirings and semimodules for variable occurrence,+-- see e.g. Conor McBrides "I got plenty of nuttin'" (Wadlerfest 2016).+-- There, he treats the "quantity" dimension of variable occurrences.+--+-- The semiring has an additive operation for combining occurrences of subterms,+-- and a multiplicative operation of representing function composition.  E.g.+-- if variable @x@ appears @o@ in term @u@, but @u@ appears in context @q@ in+-- term @t@ then occurrence of variable @x@ coming from @u@ is accounted for+-- as @q o@ in @t@.+--+-- Consider example @(λ{ x → (x,x)}) y@:+--+--   * Variable @x@ occurs once unguarded in @x@.+--+--   * It occurs twice unguarded in the aggregation @x@ @x@+--+--   * Inductive constructor @,@ turns this into two strictly rigid occurrences.+--+--     If @,@ is a record constructor, then we stay unguarded.+--+--   * The function @({λ x → (x,x)})@ provides a context for variable @y@.+--     This context can be described as weakly rigid with quantity two.+--+--   * The final occurrence of @y@ is obtained as composing the context with+--     the occurrence of @y@ in itself (which is the unit for composition).+--     Thus, @y@ occurs weakly rigid with quantity two.+--+-- It is not a given that the context can be described in the same way+-- as the variable occurrence.  However, for quantity it is the case+-- and we obtain a semiring of occurrences with 0, 1, and even ω, which+-- is an absorptive element for addition.  module Agda.TypeChecking.Free.Lazy where  import Control.Applicative hiding (empty)-import Control.Monad.Reader+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, Reader, runReader ) -import Data.Foldable (foldMap) import Data.IntMap (IntMap)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat)+import qualified Data.IntMap as IntMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import Data.Set (Set)+import qualified Data.Set as Set + import Agda.Syntax.Common import Agda.Syntax.Internal --- import Agda.TypeChecking.Irrelevance- 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 import Agda.Utils.Singleton import Agda.Utils.Size -type MetaSet = Set MetaId+---------------------------------------------------------------------------+-- * Set of meta variables. +-- | A set of meta variables.  Forms a monoid under union.++newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId }+  deriving (Eq, Show, Null, Semigroup, Monoid)++instance Singleton MetaId MetaSet where+  singleton = MetaSet . singleton++insertMetaSet :: MetaId -> MetaSet -> MetaSet+insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms++foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a+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)+ -- | Depending on the surrounding context of a variable, --   it's occurrence can be classified as flexible or rigid, --   with finer distinctions. -- --   The constructors are listed in increasing order (wrt. information content).-data FlexRig-  = Flexible MetaSet  -- ^ In arguments of metas.+data FlexRig' a+  = Flexible a        -- ^ In arguments of metas.+                      --   The set of metas is used by ''Agda.TypeChecking.Rewriting.NonLinMatch''+                      --   to generate the right blocking information.+                      --   The semantics is that the status of a variable occurrence may change+                      --   if one of the metas in the set gets solved.  We may say the occurrence+                      --   is tainted by the meta variables in the set.   | WeaklyRigid       -- ^ In arguments to variables and definitions.-  | Unguarded         -- ^ In top position, or only under inductive record constructors.+  | Unguarded         -- ^ In top position, or only under inductive record constructors (unit).   | StronglyRigid     -- ^ Under at least one and only inductive constructors.-  deriving (Eq, Ord, Show)+  deriving (Eq, Show, Functor, Foldable) --- | 'FlexRig' composition.  For accumulating the context of a variable.+type FlexRig = FlexRig' MetaSet++class LensFlexRig o a | o -> a where+  lensFlexRig :: Lens' o (FlexRig' a)++instance LensFlexRig (FlexRig' a) a where+  lensFlexRig = id++isFlexible :: LensFlexRig o a => o -> Bool+isFlexible o = case o ^. lensFlexRig of+  Flexible {} -> True+  _ -> False++isUnguarded :: LensFlexRig o a => o -> Bool+isUnguarded o = case o ^. lensFlexRig of+  Unguarded -> True+  _ -> False++isWeaklyRigid :: LensFlexRig o a => o -> Bool+isWeaklyRigid o = case o ^. lensFlexRig of+   WeaklyRigid -> True+   _ -> False++isStronglyRigid :: LensFlexRig o a => o -> Bool+isStronglyRigid o = case o ^. lensFlexRig of+  StronglyRigid -> True+  _ -> False++-- | 'FlexRig' aggregation (additive operation of the semiring).+--   For combining occurrences of the same variable in subterms.+--   This is a refinement of the 'max' operation for 'FlexRig'+--   which would work if 'Flexible' did not have the 'MetaSet' as an argument.+--   Now, to aggregate two 'Flexible' occurrences, we union the involved 'MetaSet's.++addFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a+addFlexRig = curry $ \case+  -- StronglyRigid is dominant+  (StronglyRigid, _) -> StronglyRigid+  (_, StronglyRigid) -> StronglyRigid+  -- Next is Unguarded+  (Unguarded, _) -> Unguarded+  (_, Unguarded) -> Unguarded+  -- Then WeaklyRigid+  (WeaklyRigid, _) -> WeaklyRigid+  (_, WeaklyRigid) -> WeaklyRigid+  -- Least is Flexible.  We union the meta sets, as the variable+  -- is tainted by all of the involved meta variable.+  (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2++-- | Unit for 'addFlexRig'.+zeroFlexRig :: Monoid a => FlexRig' a+zeroFlexRig = Flexible mempty++-- | Absorptive for 'addFlexRig'.+omegaFlexRig :: FlexRig' a+omegaFlexRig = StronglyRigid++-- | 'FlexRig' composition (multiplicative operation of the semiring).+--   For accumulating the context of a variable. -- --   'Flexible' is dominant.  Once we are under a meta, we are flexible---   regardless what else comes.+--   regardless what else comes.  We taint all variable occurrences+--   under a meta by this meta. -- --   'WeaklyRigid' is next in strength.  Destroys strong rigidity. -- --   'StronglyRigid' is still dominant over 'Unguarded'. -- --   'Unguarded' is the unit.  It is the top (identity) context.-composeFlexRig :: FlexRig -> FlexRig -> FlexRig-composeFlexRig o o' =-  case (o, o') of-    (Flexible ms1, Flexible ms2) -> Flexible $ ms1 `mappend` ms2+--+composeFlexRig :: Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a+composeFlexRig = curry $ \case+    (Flexible ms1, Flexible ms2) -> Flexible $ ms1 <> ms2     (Flexible ms1, _) -> Flexible ms1     (_, Flexible ms2) -> Flexible ms2     (WeaklyRigid, _) -> WeaklyRigid@@ -82,36 +203,178 @@     (_, StronglyRigid) -> StronglyRigid     (Unguarded, Unguarded) -> Unguarded --- -- | 'FlexRig' supremum.  Extract the most information about a variable.--- ----- --   We make this the default 'Monoid' for 'FlexRig'.--- instance Monoid FlexRig where---   mempty  = minBound---   mappend = max+-- | Unit for 'composeFlexRig'.+oneFlexRig :: FlexRig' a+oneFlexRig = Unguarded +---------------------------------------------------------------------------+-- * Multi-dimensional feature vector for variable occurrence (semigroup)+ -- | Occurrence of free variables is classified by several dimensions.---   Currently, we have 'FlexRig' and 'Relevance'.-data VarOcc = VarOcc-  { varFlexRig   :: FlexRig-  , varRelevance :: Relevance+--   Currently, we have 'FlexRig' and 'Modality'.+data VarOcc' a = VarOcc+  { varFlexRig   :: FlexRig' a+  , varModality  :: Modality   }+  deriving (Show)+type VarOcc = VarOcc' MetaSet++-- | Equality up to origin.+instance Eq a => Eq (VarOcc' a) where+  VarOcc fr m == VarOcc fr' m' = fr == fr' && sameModality m m'++instance LensModality (VarOcc' a) where+  getModality = varModality+  mapModality f (VarOcc x r) = VarOcc x $ f r++instance LensRelevance (VarOcc' a) where+instance LensQuantity (VarOcc' a) where++-- | Access to 'varFlexRig' in 'VarOcc'.+instance LensFlexRig (VarOcc' a) a where+  lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m+-- lensFlexRig :: Lens' (VarOcc' a) (FlexRig' a)+-- lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m+++-- | The default way of aggregating free variable info from subterms is by adding+--   the variable occurrences.  For instance, if we have a pair @(t₁,t₂)@ then+--   and @t₁@ has @o₁@ the occurrences of a variable @x@+--   and @t₂@ has @o₂@ the occurrences of the same variable, then+--   @(t₁,t₂)@ has @mappend o₁ o₂@ occurrences of that variable.+--+--   From counting 'Quantity', we extrapolate this to 'FlexRig' and 'Relevance':+--   we care most about about 'StronglyRigid' 'Relevant' occurrences.+--   E.g., if @t₁@ has a 'StronglyRigid' occurrence and @t₂@ a 'Flexible' occurrence,+--   then @(t₁,t₂)@ still has a 'StronglyRigid' occurrence.+--   Analogously, @Relevant@ occurrences count most, as we wish e.g. to forbid+--   relevant occurrences of variables that are declared to be irrelevant.+--+--   'VarOcc' forms a semiring, and this monoid is the addition of the semiring.++instance Semigroup a => Semigroup (VarOcc' a) where+  VarOcc o m <> VarOcc o' m' = VarOcc (addFlexRig o o') (addModality m m')++-- | The neutral element for variable occurrence aggregation is least serious+--   occurrence: flexible, irrelevant.+--   This is also the absorptive element for 'composeVarOcc', if we ignore+--   the 'MetaSet' in 'Flexible'.+instance (Semigroup a, Monoid a) => Monoid (VarOcc' a) where+  mempty  = VarOcc (Flexible mempty) zeroModality+  mappend = (<>)++-- | The absorptive element of variable occurrence under aggregation:+--   strongly rigid, relevant.+topVarOcc :: VarOcc' a+topVarOcc = VarOcc StronglyRigid topModality++-- | First argument is the outer occurrence (context) and second is the inner.+--   This multiplicative operation is to modify an occurrence under a context.+composeVarOcc :: Semigroup a => VarOcc' a -> VarOcc' a -> VarOcc' a+composeVarOcc (VarOcc o m) (VarOcc o' m') = VarOcc (composeFlexRig o o') (composeModality m m')+  -- We use the multipicative modality monoid (composition).++oneVarOcc :: VarOcc' a+oneVarOcc = VarOcc Unguarded unitModality++---------------------------------------------------------------------------+-- * Storing variable occurrences (semimodule).++-- | Any representation @c@ of a set of variables need to be able to be modified by+--   a variable occurrence. This is to ensure that free variable analysis is+--   compositional. For instance, it should be possible to compute `fv (v [u/x])`+--   from `fv v` and `fv u`.+--+--   In algebraic terminology, a variable set @a@ needs to be (almost) a left semimodule+--   to the semiring 'VarOcc'.+class (Singleton MetaId a, Semigroup a, Monoid a, Semigroup c, Monoid c) => IsVarSet a c | c -> a where+  -- | Laws+  --    * Respects monoid operations:+  --      ```+  --        withVarOcc o mempty   == mempty+  --        withVarOcc o (x <> y) == withVarOcc o x <> withVarOcc o y+  --      ```+  --    * Respects VarOcc composition:+  --      ```+  --        withVarOcc oneVarOcc             = id+  --        withVarOcc (composeVarOcc o1 o2) = withVarOcc o1 . withVarOcc o2+  --      ```+  --    * Respects VarOcc aggregation:+  --      ```+  --        withVarOcc (o1 <> o2) x = withVarOcc o1 x <> withVarOcc o2 x+  --      ```+  --      Since the corresponding unit law may fail,+  --      ```+  --        withVarOcc mempty x = mempty+  --      ```+  --      it is not quite a semimodule.+  withVarOcc :: VarOcc' a -> c -> c++-- | Representation of a variable set as map from de Bruijn indices+--   to 'VarOcc'.+type TheVarMap' a = IntMap (VarOcc' a)+newtype VarMap' a = VarMap { theVarMap :: TheVarMap' a }   deriving (Eq, Show) --- | When we extract information about occurrence, we care most about---   about 'StronglyRigid' 'Relevant' occurrences.-maxVarOcc :: VarOcc -> VarOcc -> VarOcc-maxVarOcc (VarOcc o r) (VarOcc o' r') = VarOcc (max o o') (min r r')+type TheVarMap = TheVarMap' MetaSet+type    VarMap =    VarMap' MetaSet -topVarOcc :: VarOcc-topVarOcc = VarOcc StronglyRigid Relevant+-- | A "set"-style 'Singleton' instance with default/initial variable occurrence.+instance Singleton Variable (VarMap' a) where+  singleton i = VarMap $ IntMap.singleton i oneVarOcc -botVarOcc :: VarOcc-botVarOcc = VarOcc (Flexible mempty) Irrelevant+mapVarMap :: (TheVarMap' a -> TheVarMap' b) -> VarMap' a -> VarMap' b+mapVarMap f = VarMap . f . theVarMap -type VarMap = IntMap VarOcc+lookupVarMap :: Variable -> VarMap' a -> Maybe (VarOcc' a)+lookupVarMap i = IntMap.lookup i . theVarMap --- * Collecting free variables.+-- Andreas & Jesper, 2018-05-11, issue #3052: +-- | Proper monoid instance for @VarMap@ rather than inheriting the broken one from IntMap.+--   We combine two occurrences of a variable using 'mappend'.+instance Semigroup a => Semigroup (VarMap' a) where+  VarMap m <> VarMap m' = VarMap $ IntMap.unionWith (<>) m m'++instance Semigroup a => Monoid (VarMap' a) where+  mempty  = VarMap IntMap.empty+  mappend = (<>)+  mconcat = VarMap . IntMap.unionsWith (<>) . map theVarMap+  -- mconcat = VarMap . IntMap.unionsWith mappend . coerce   -- ghc 8.6.5 does not seem to like this coerce++instance (Singleton MetaId a, Semigroup a, Monoid a) => IsVarSet a (VarMap' a) where+  withVarOcc o = mapVarMap $ fmap $ composeVarOcc o+++---------------------------------------------------------------------------+-- * Simple flexible/rigid variable collection.++-- | Keep track of 'FlexRig' for every variable, but forget the involved meta vars.+type TheFlexRigMap = IntMap (FlexRig' ())+newtype FlexRigMap = FlexRigMap { theFlexRigMap :: TheFlexRigMap }+  deriving (Show, Singleton (Variable, FlexRig' ()))++mapFlexRigMap :: (TheFlexRigMap -> TheFlexRigMap) -> FlexRigMap -> FlexRigMap+mapFlexRigMap f = FlexRigMap . f . theFlexRigMap++instance Semigroup FlexRigMap where+  FlexRigMap m <> FlexRigMap m' = FlexRigMap $ IntMap.unionWith addFlexRig m m'++instance Monoid FlexRigMap where+  mempty  = FlexRigMap IntMap.empty+  mappend = (<>)+  mconcat = FlexRigMap . IntMap.unionsWith addFlexRig . map theFlexRigMap++-- | Compose everything with the 'varFlexRig' part of the 'VarOcc'.+instance IsVarSet () FlexRigMap where+  withVarOcc o = mapFlexRigMap $ fmap $ composeFlexRig $ () <$ varFlexRig o++instance Singleton MetaId () where+  singleton _ = ()++---------------------------------------------------------------------------+-- * Environment for collecting free variables.+ -- | Where should we skip sorts in free variable analysis?  data IgnoreSorts@@ -122,108 +385,151 @@  -- | The current context. -data FreeEnv c = FreeEnv-  { feIgnoreSorts   :: !IgnoreSorts-    -- ^ Ignore free variables in sorts.-  , feBinders       :: !Int-    -- ^ Under how many binders have we stepped?-  , feFlexRig       :: !FlexRig+data FreeEnv' a b c = FreeEnv+  { feExtra     :: !b+    -- ^ Additional context, e.g., whether to ignore free variables in sorts.+  , feFlexRig   :: !(FlexRig' a)     -- ^ Are we flexible or rigid?-  , feRelevance     :: !Relevance-    -- ^ What is the current relevance?-  , feSingleton     :: SingleVar c+  , feModality  :: !Modality+    -- ^ What is the current relevance and quantity?+  , feSingleton :: Maybe Variable -> c     -- ^ Method to return a single variable.   } -type Variable    = (Int, VarOcc)+type Variable    = Int type SingleVar c = Variable -> c +type FreeEnv c = FreeEnv' MetaSet IgnoreSorts c++-- | Ignore free variables in sorts.+feIgnoreSorts :: FreeEnv' a IgnoreSorts c -> IgnoreSorts+feIgnoreSorts = feExtra++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+  getModality = feModality+  mapModality f e = e { feModality = f (feModality e) }++instance LensRelevance (FreeEnv' a b c) where+instance LensQuantity (FreeEnv' a b c) where+ -- | The initial context. -initFreeEnv :: SingleVar c -> FreeEnv c-initFreeEnv sing = FreeEnv-  { feIgnoreSorts = IgnoreNot-  , feBinders     = 0+initFreeEnv :: Monoid c => b -> SingleVar c -> FreeEnv' a b c+initFreeEnv e sing = FreeEnv+  { feExtra       = e   , feFlexRig     = Unguarded-  , feRelevance   = Relevant-  , feSingleton   = sing+  , feModality    = unitModality      -- multiplicative monoid+  , feSingleton   = maybe mempty sing   } -type FreeM c = Reader (FreeEnv c) c+type FreeT a b m c = ReaderT (FreeEnv' a b c) m c+type FreeM a c = Reader (FreeEnv' a IgnoreSorts c) c -instance Monoid c => Semigroup (FreeM c) where-  (<>) = liftA2 mappend-instance Monoid c => Monoid (FreeM c) where+-- | Run function for FreeM.+runFreeM :: IsVarSet a c => SingleVar c -> IgnoreSorts -> FreeM a c -> c+runFreeM single i m = runReader m $ initFreeEnv i single++instance (Functor m, Applicative m, Monad m, Semigroup c, Monoid c) => Monoid (FreeT a b m c) where   mempty  = pure mempty   mappend = (<>)   mconcat = mconcat <.> sequence --- instance Singleton a c => Singleton a (FreeM c) where---   singleton = pure . singleton- -- | Base case: a variable.-variable :: (Monoid c) => Int -> FreeM c+variable :: (Monad m, IsVarSet a c) => Int -> FreeT a b m c variable n = do-  m <- (n -) <$> asks feBinders-  if m < 0 then mempty else do-    o <- asks feFlexRig-    r <- asks feRelevance-    s <- asks feSingleton-    pure $ s (m, VarOcc o r)+  o <- asks feFlexRig+  r <- asks feModality+  s <- asks feSingleton+  return $ withVarOcc (VarOcc o r) (s $ Just n) +-- | Subtract, but return Nothing if result is negative.+subVar :: Int -> Maybe Variable -> Maybe Variable+-- subVar n x = x >>= \ i -> (i - n) <$ guard (n <= i)+subVar n x = do+  i <- x+  guard $ i >= n+  return $ i - n+ -- | Going under a binder.-bind :: FreeM a -> FreeM a-bind = bind' 1+underBinder :: MonadReader (FreeEnv' a b c) m => m z -> m z+underBinder = underBinder' 1 -bind' :: Nat -> FreeM a -> FreeM a-bind' n = local $ \ e -> e { feBinders = n + feBinders e }+-- | Going under @n@ binders.+underBinder' :: MonadReader (FreeEnv' a b c) m => Nat -> m z -> m z+underBinder' n = local $ \ e -> e { feSingleton = feSingleton e . subVar n } --- | Changing the 'FlexRig' context.-go :: FlexRig -> FreeM a -> FreeM a-go o = local $ \ e -> e { feFlexRig = composeFlexRig o $ feFlexRig e }+-- | Changing the 'Modality'.+underModality :: (MonadReader r m, LensModality r, LensModality o) => o -> m z -> m z+underModality = local . mapModality . composeModality . getModality  -- | Changing the 'Relevance'.-goRel :: Relevance-> FreeM a -> FreeM a-goRel r = local $ \ e -> e { feRelevance = composeRelevance r $ feRelevance e }+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 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 :: ConHead -> FreeM a -> FreeM a-underConstructor (ConHead c i fs) =-  case (i,fs) of+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, _)   -> go WeaklyRigid-    -- Inductive data constructors do not admit infinite cycles:-    (Inductive, [])    -> go StronglyRigid-    -- Inductive record constructors do not admit infinite cycles,-    -- but this cannot be proven inside Agda.-    -- Thus, unification should not prove it either.-    (Inductive, (_:_)) -> id+    CoInductive -> underFlexRig WeaklyRigid+    -- Inductive constructors do not admit infinite cycles:+    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+    -- the same as datatypes, so absense of infinite cycles can be proven in Agda, and thus+    -- the unifier is allowed to do it too. Test case: test/Succeed/Issue1271a.agda+    -- WAS:+    -- -- Inductive record constructors do not admit infinite cycles,+    -- -- but this cannot be proven inside Agda.+    -- -- Thus, unification should not prove it either. +---------------------------------------------------------------------------+-- * Recursively collecting free variables.+ -- | Gather free variables in a collection.-class Free' a c where+class Free t where   -- Misplaced SPECIALIZE pragma:   -- {-# SPECIALIZE freeVars' :: a -> FreeM Any #-}   -- So you cannot specialize all instances in one go. :(-  freeVars' :: (Monoid c) => a -> FreeM c+  freeVars' :: IsVarSet a c => t -> FreeM a c -instance Free' Term c where+  default freeVars' :: (t ~ f b, Foldable f, Free b) => IsVarSet a c => t -> FreeM a c+  freeVars' = foldMap freeVars'+++instance Free Term where   -- SPECIALIZE instance does not work as well, see   -- https://ghc.haskell.org/trac/ghc/ticket/10434#ticket-  -- {-# SPECIALIZE instance Free' Term All #-}+  -- {-# SPECIALIZE instance Free Term All #-}   -- {-# SPECIALIZE freeVars' :: Term -> FreeM Any #-}   -- {-# SPECIALIZE freeVars' :: Term -> FreeM All #-}   -- {-# SPECIALIZE freeVars' :: Term -> FreeM VarSet #-}-  freeVars' t = case t of-    Var n ts     -> variable n `mappend` do go WeaklyRigid $ freeVars' ts+  freeVars' t = case unSpine t of -- #4484: unSpine to avoid projected variables being treated as StronglyRigid+    Var n ts     -> variable n `mappend` do underFlexRig WeaklyRigid $ freeVars' ts     -- λ is not considered guarding, as     -- we cannot prove that x ≡ λy.x is impossible.-    Lam _ t      -> freeVars' t+    Lam _ t      -> underFlexRig WeaklyRigid $ freeVars' t     Lit _        -> mempty-    Def _ ts     -> go WeaklyRigid $ freeVars' ts  -- because we are not in TCM+    Def _ ts     -> underFlexRig WeaklyRigid $ freeVars' ts  -- because we are not in TCM       -- we cannot query whether we are dealing with a data/record (strongly r.)       -- or a definition by pattern matching (weakly rigid)       -- thus, we approximate, losing that x = List x is unsolvable-    Con c _ ts   -> underConstructor c $ freeVars' ts+    Con c _ ts   -> underConstructor c ts $ freeVars' ts     -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.     -- Even as we do not permit infinite type expressions,     -- we cannot prove their absence (as Set is not inductive).@@ -231,140 +537,77 @@     Pi a b       -> freeVars' (a,b)     Sort s       -> freeVars' s     Level l      -> freeVars' l-    MetaV m ts   -> go (Flexible $ singleton m) $ freeVars' ts-    DontCare mt  -> goRel Irrelevant $ freeVars' mt-    Shared p     -> freeVars' (derefPtr p)+    MetaV m ts   -> underFlexRig (Flexible $ singleton m) $ freeVars' ts+    DontCare mt  -> underModality (Modality irrelevant unitQuantity unitCohesion unitPolarity) $ freeVars' mt+    Dummy{}      -> mempty -instance Free' a c => Free' (Type' a) c where-  -- {-# SPECIALIZE instance Free' Type All #-}-  -- {-# SPECIALIZE freeVars' :: Type -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Type -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Type -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Type -> FreeM VarMap #-}+instance Free t => Free (Type' t) where   freeVars' (El s t) =-    ifM ((IgnoreNot ==) <$> asks feIgnoreSorts)+    ifM (asks ((IgnoreNot ==) . feIgnoreSorts))       {- then -} (freeVars' (s, t))       {- else -} (freeVars' t) -instance Free' Sort c where-  -- {-# SPECIALIZE instance Free' Sort All #-}-  -- {-# SPECIALIZE freeVars' :: Sort -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Sort -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Sort -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Sort -> FreeM VarMap #-}+instance Free Sort where   freeVars' s =-    ifM ((IgnoreAll ==) <$> asks feIgnoreSorts) mempty $ {- else -}+    ifM (asks ((IgnoreAll ==) . feIgnoreSorts)) mempty $ {- else -}     case s of-      Type a     -> freeVars' a-      Prop       -> mempty-      Inf        -> mempty+      Univ _ a   -> freeVars' a+      Inf _ _    -> mempty       SizeUniv   -> mempty-      DLub s1 s2 -> go WeaklyRigid $ freeVars' (s1, s2)+      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+      UnivSort s -> underFlexRig WeaklyRigid $ freeVars' s+      MetaS x es -> underFlexRig (Flexible $ singleton x) $ freeVars' es+      DefS _ es  -> underFlexRig WeaklyRigid $ freeVars' es+      DummyS{}   -> mempty -instance Free' Level c where-  -- {-# SPECIALIZE instance Free' Level All #-}-  -- {-# SPECIALIZE freeVars' :: Level -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Level -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Level -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Level -> FreeM VarMap #-}-  freeVars' (Max as) = freeVars' as+instance Free Level where+  freeVars' (Max _ as) = freeVars' as -instance Free' PlusLevel c where-  -- {-# SPECIALIZE instance Free' PlusLevel All #-}-  -- {-# SPECIALIZE freeVars' :: PlusLevel -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: PlusLevel -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: PlusLevel -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: PlusLevel -> FreeM VarMap #-}-  freeVars' ClosedLevel{} = mempty+instance Free t => Free (PlusLevel' t) where   freeVars' (Plus _ l)    = freeVars' l -instance Free' LevelAtom c where-  -- {-# SPECIALIZE instance Free' LevelAtom All #-}-  -- {-# SPECIALIZE freeVars' :: LevelAtom -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: LevelAtom -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: LevelAtom -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: LevelAtom -> FreeM VarMap #-}-  freeVars' l = case l of-    MetaLevel m vs   -> go (Flexible $ singleton m) $ freeVars' vs-    NeutralLevel _ v -> freeVars' v-    BlockedLevel _ v -> freeVars' v-    UnreducedLevel v -> freeVars' v--instance Free' a c => Free' [a] c where-  -- {-# SPECIALIZE instance Free' a All => Free' [a] All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => [a] -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => [a] -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => [a] -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => [a] -> FreeM VarMap #-}-  freeVars' = foldMap freeVars'+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' a c => Free' (Maybe a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Maybe a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Maybe a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Maybe a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Maybe a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Maybe a -> FreeM VarMap #-}-  freeVars' = foldMap freeVars'+instance (Free t, Free u) => Free (t, u) where+  freeVars' (t, u) = freeVars' t `mappend` freeVars' u -instance (Free' a c, Free' b c) => Free' (a,b) c where-  -- {-# SPECIALIZE instance (Free' a All, Free' b All) => Free' (a,b) All #-}-  -- {-# SPECIALIZE freeVars' :: (Free' a Any, Free' b Any) => (a,b) -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: (Free' a All, Free' b All) => (a,b) -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: (Free' a VarSet, Free' b VarSet) => (a,b) -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: (Free' a VarMap, Free' b VarMap) => (a,b) -> FreeM VarMap #-}-  freeVars' (x,y) = freeVars' x `mappend` freeVars' y+instance (Free t, Free u, Free v) => Free (t, u, v) where+  freeVars' (t, u, v) = freeVars' t `mappend` freeVars' u `mappend` freeVars' v -instance Free' a c => Free' (Elim' a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Elim' a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Elim' a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Elim' a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Elim' a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Elim' a -> FreeM VarMap #-}-  freeVars' (Apply a) = freeVars' a+instance Free t => Free (Elim' t) where+  freeVars' (Apply t) = freeVars' t   freeVars' (Proj{} ) = mempty+  freeVars' (IApply x y r) = freeVars' (x,y,r) -instance Free' a c => Free' (Arg a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Arg a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Arg a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Arg a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Arg a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Arg a -> FreeM VarMap #-}-  freeVars' a = goRel (getRelevance a) $ freeVars' $ unArg a+instance Free t => Free (Arg t) where+  freeVars' t = underModality (getModality t) $ freeVars' $ unArg t -instance Free' a c => Free' (Dom a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Dom a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Dom a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Dom a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Dom a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Dom a -> FreeM VarMap #-}-  freeVars' = freeVars' . unDom+instance Free t => Free (Dom t) where+  freeVars' d = freeVars' (domTactic d, unDom d) -instance Free' a c => Free' (Abs a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Abs a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Abs a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Abs a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Abs a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Abs a -> FreeM VarMap #-}-  freeVars' (Abs   _ b) = bind $ freeVars' b+instance Free t => Free (Abs t) where+  freeVars' (Abs   _ b) = underBinder $ freeVars' b   freeVars' (NoAbs _ b) = freeVars' b -instance Free' a c => Free' (Tele a) c where-  -- {-# SPECIALIZE instance Free' a All => Free' (Tele a) All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a Any => Tele a -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Free' a All => Tele a -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarSet => Tele a -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Free' a VarMap => Tele a -> FreeM VarMap #-}+instance Free t => Free (Tele t) where   freeVars' EmptyTel          = mempty-  freeVars' (ExtendTel a tel) = freeVars' (a, tel)+  freeVars' (ExtendTel t tel) = freeVars' (t, tel) -instance Free' Clause c where-  -- {-# SPECIALIZE instance Free' Clause All #-}-  -- {-# SPECIALIZE freeVars' :: Clause -> FreeM Any #-}-  -- {-# SPECIALIZE freeVars' :: Clause -> FreeM All #-}-  -- {-# SPECIALIZE freeVars' :: Clause -> FreeM VarSet #-}-  -- {-# SPECIALIZE freeVars' :: Clause -> FreeM VarMap #-}-  freeVars' cl = bind' (size $ clauseTel cl) $ freeVars' $ clauseBody cl+instance Free Clause where+  freeVars' cl = underBinder' (size $ clauseTel cl) $ freeVars' $ clauseBody cl -instance Free' EqualityView c where-  freeVars' (OtherType t) = freeVars' t-  freeVars' (EqualityType s _eq l t a b) = freeVars' s `mappend` freeVars' [l, t, a, b]+instance Free EqualityView where+  freeVars' = \case+    OtherType t -> freeVars' t+    IdiomType t -> freeVars' t+    EqualityType _r s _eq l t a b -> freeVars' (s, l, [t, a, b])
− src/full/Agda/TypeChecking/Free/Old.hs 
@@ -1,363 +0,0 @@---- | Computing the free variables of a term.------ This is the old version of ''Agda.TypeChecking.Free'', using--- 'IntSet's for the separate variable categories.--- We keep it as a specification.------ The distinction between rigid and strongly rigid occurrences comes from:---   Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)------ The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly--- in t.  It might have a solution if the occurrence is not strongly rigid, e.g.------   x = \f -> suc (f (x (\ y -> k)))  has  x = \f -> suc (f (suc k))------ [Jason C. Reed, PhD thesis, page 106]------ Under coinductive constructors, occurrences are never strongly rigid.--- Also, function types and lambdas do not establish strong rigidity.--- Only inductive constructors do so.--- (See issue 1271).--module Agda.TypeChecking.Free.Old-    ( FreeVars(..)-    , Free-    , IgnoreSorts(..)-    , freeVars-    , freeVarsIgnore-    , allVars-    , relevantVars-    , rigidVars-    , freeIn, isBinderUsed-    , freeInIgnoringSorts, freeInIgnoringSortAnn-    , relevantIn, relevantInIgnoringSortAnn-    , Occurrence(..)-    , occurrence-    ) where--import Control.Applicative hiding (empty)-import Control.Monad.Reader--import Data.Foldable (foldMap)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat)--import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.Utils.Functor-import Agda.Utils.Monad-import Agda.Utils.Size-import Agda.Utils.VarSet (VarSet)-import qualified Agda.Utils.VarSet as Set---- | Free variables of a term, (disjointly) partitioned into strongly and---   and weakly rigid variables, flexible variables and irrelevant variables.-data FreeVars = FV-  { stronglyRigidVars :: VarSet-    -- ^ Variables under only and at least one inductive constructor(s).-  , unguardedVars     :: VarSet-    -- ^ Variables at top or only under inductive record constructors-    --   λs and Πs.-    --   The purpose of recording these separately is that they-    --   can still become strongly rigid if put under a constructor-    --   whereas weakly rigid ones stay weakly rigid.-  , weaklyRigidVars   :: VarSet-    -- ^ Ordinary rigid variables, e.g., in arguments of variables.-  , flexibleVars      :: VarSet-    -- ^ Variables occuring in arguments of metas.-    --   These are only potentially free, depending how the meta variable is instantiated.-  , irrelevantVars    :: VarSet-    -- ^ Variables in irrelevant arguments and under a @DontCare@, i.e.,-    --   in irrelevant positions.-  , unusedVars        :: VarSet-    -- ^ Variables in 'UnusedArg'uments.-  } deriving (Eq, Show)---- | Rigid variables: either strongly rigid, unguarded, or weakly rigid.-rigidVars :: FreeVars -> VarSet-rigidVars fv = Set.unions-  [ stronglyRigidVars fv-  ,     unguardedVars fv-  ,   weaklyRigidVars fv-  ]---- | All but the irrelevant variables.-relevantVars :: FreeVars -> VarSet-relevantVars fv = Set.unions [rigidVars fv, flexibleVars fv]---- | @allVars fv@ includes irrelevant variables.-allVars :: FreeVars -> VarSet-allVars fv = Set.unions [relevantVars fv, irrelevantVars fv, unusedVars fv]--data Occurrence-  = NoOccurrence-  | Irrelevantly-  | StronglyRigid -- ^ Under at least one and only inductive constructors.-  | Unguarded     -- ^ In top position, or only under inductive record constructors.-  | WeaklyRigid   -- ^ In arguments to variables and definitions.-  | Flexible      -- ^ In arguments of metas.-  | Unused-  deriving (Eq,Show)--{- NO LONGER--- | @occurrence x fv@ ignores irrelevant variables in @fv@--}-occurrence :: Nat -> FreeVars -> Occurrence-occurrence x fv-  | x `Set.member` stronglyRigidVars fv = StronglyRigid-  | x `Set.member` unguardedVars     fv = Unguarded-  | x `Set.member` weaklyRigidVars   fv = WeaklyRigid-  | x `Set.member` flexibleVars      fv = Flexible-  | x `Set.member` irrelevantVars    fv = Irrelevantly-  | x `Set.member` unusedVars        fv = Unused-  | otherwise                           = NoOccurrence---- | Mark variables as flexible.  Useful when traversing arguments of metas.-flexible :: FreeVars -> FreeVars-flexible fv =-    fv { stronglyRigidVars = Set.empty-       , unguardedVars     = Set.empty-       , weaklyRigidVars   = Set.empty-       , flexibleVars      = relevantVars fv-       }---- | Mark rigid variables as non-strongly.  Useful when traversion arguments of variables.-weakly :: FreeVars -> FreeVars-weakly fv = fv-  { stronglyRigidVars = Set.empty-  , unguardedVars     = Set.empty-  , weaklyRigidVars   = rigidVars fv-  }---- | Mark unguarded variables as strongly rigid.  Useful when traversion arguments of inductive constructors.-strongly :: FreeVars -> FreeVars-strongly fv = fv-  { stronglyRigidVars = stronglyRigidVars fv `Set.union` unguardedVars fv-  , unguardedVars     = Set.empty-  }---- | What happens to the variables occurring under a constructor?-underConstructor :: ConHead -> FreeVars -> FreeVars-underConstructor (ConHead c i fs) =-  case (i,fs) of-    -- Coinductive (record) constructors admit infinite cycles:-    (CoInductive, _)   -> weakly-    -- Inductive data constructors do not admit infinite cycles:-    (Inductive, [])    -> strongly-    -- Inductive record constructors do not admit infinite cycles,-    -- but this cannot be proven inside Agda.-    -- Thus, unification should not prove it either.-    (Inductive, (_:_)) -> id---- | Mark all free variables as irrelevant.-irrelevantly :: FreeVars -> FreeVars-irrelevantly fv = empty { irrelevantVars = allVars fv }---- | Mark all free variables as unused, except for irrelevant vars.-unused :: FreeVars -> FreeVars-unused fv = empty-  { irrelevantVars = irrelevantVars fv-  , unusedVars     = Set.unions [ rigidVars fv, flexibleVars fv, unusedVars fv ]-  }---- | Pointwise union.-union :: FreeVars -> FreeVars -> FreeVars-union (FV sv1 gv1 rv1 fv1 iv1 uv1) (FV sv2 gv2 rv2 fv2 iv2 uv2) =-  FV (Set.union sv1 sv2) (Set.union gv1 gv2) (Set.union rv1 rv2) (Set.union fv1 fv2) (Set.union iv1 iv2) (Set.union uv1 uv2)--unions :: [FreeVars] -> FreeVars-unions = foldr union empty--empty :: FreeVars-empty = FV Set.empty Set.empty Set.empty Set.empty Set.empty Set.empty---- | Free variable sets form a monoid under 'union'.-instance Semigroup FreeVars where-  (<>) = union--instance Monoid FreeVars where-  mempty  = empty-  mappend = (<>)-  mconcat = unions---- | @delete x fv@ deletes variable @x@ from variable set @fv@.-delete :: Nat -> FreeVars -> FreeVars-delete n (FV sv gv rv fv iv uv) = FV (Set.delete n sv) (Set.delete n gv) (Set.delete n rv) (Set.delete n fv) (Set.delete n iv) (Set.delete n uv)---- | @subtractFV n fv@ subtracts $n$ from each free variable in @fv@.-subtractFV :: Nat -> FreeVars -> FreeVars-subtractFV n (FV sv gv rv fv iv uv) = FV (Set.subtract n sv) (Set.subtract n gv) (Set.subtract n rv) (Set.subtract n fv) (Set.subtract n iv) (Set.subtract n uv)---- | A single unguarded variable.-singleton :: Nat -> FreeVars-singleton x = empty { unguardedVars = Set.singleton x }---- * Collecting free variables.---- | Where should we skip sorts in free variable analysis?-data IgnoreSorts-  = IgnoreNot            -- ^ Do not skip.-  | IgnoreInAnnotations  -- ^ Skip when annotation to a type.-  | IgnoreAll            -- ^ Skip unconditionally.-  deriving (Eq, Show)--data FreeConf = FreeConf-  { fcIgnoreSorts   :: !IgnoreSorts-    -- ^ Ignore free variables in sorts.-  , fcContext       :: !Int-    -- ^ Under how many binders have we stepped?-  }--initFreeConf :: FreeConf-initFreeConf = FreeConf-  { fcIgnoreSorts = IgnoreNot-  , fcContext     = 0-  }---- | Doesn't go inside solved metas, but collects the variables from a--- metavariable application @X ts@ as @flexibleVars@.-freeVars :: Free a => a -> FreeVars-freeVars t = freeVars' t `runReader` initFreeConf--freeVarsIgnore :: Free a => IgnoreSorts -> a -> FreeVars-freeVarsIgnore i t = freeVars' t `runReader` initFreeConf{ fcIgnoreSorts = i }---- | Return type of fold over syntax.-type FreeT = Reader FreeConf FreeVars--instance Semigroup FreeT where-  (<>) = liftA2 mappend--instance Monoid FreeT where-  mempty  = pure mempty-  mappend = (<>)-  mconcat = mconcat <.> sequence---- | Base case: a variable.-variable :: Int -> FreeT-variable n = do-  m <- (n -) <$> asks fcContext-  if m >= 0 then pure $ singleton m else mempty---- | Going under a binder.-bind :: FreeT -> FreeT-bind = bind' 1---- | Going under n binders.-bind' :: Nat -> FreeT -> FreeT-bind' n = local $ \ e -> e { fcContext = n + fcContext e }--class Free a where-  freeVars'   :: a -> FreeT--instance Free Term where-  freeVars' t = case t of-    Var n ts   -> variable n `mappend` do weakly <$> freeVars' ts-    -- λ is not considered guarding, as-    -- we cannot prove that x ≡ λy.x is impossible.-    Lam _ t    -> freeVars' t-    Lit _      -> mempty-    Def _ ts   -> weakly <$> freeVars' ts  -- because we are not in TCM-      -- we cannot query whether we are dealing with a data/record (strongly r.)-      -- or a definition by pattern matching (weakly rigid)-      -- thus, we approximate, losing that x = List x is unsolvable-    Con c _ ts -> underConstructor c <$> freeVars' ts-    -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.-    -- Even as we do not permit infinite type expressions,-    -- we cannot prove their absence (as Set is not inductive).-    -- Also, this is incompatible with univalence (HoTT).-    Pi a b     -> freeVars' (a,b)-    Sort s     -> freeVars' s-    Level l    -> freeVars' l-    MetaV _ ts -> flexible <$> freeVars' ts-    DontCare mt -> irrelevantly <$> freeVars' mt-    Shared p    -> freeVars' (derefPtr p)--instance Free Type where-  freeVars' (El s t) =-    ifM ((IgnoreNot ==) <$> asks fcIgnoreSorts)-      {- then -} (freeVars' (s, t))-      {- else -} (freeVars' t)--instance Free Sort where-  freeVars' s =-    ifM ((IgnoreAll ==) <$> asks fcIgnoreSorts) mempty $ {- else -}-    case s of-      Type a     -> freeVars' a-      Prop       -> mempty-      Inf        -> mempty-      SizeUniv   -> mempty-      DLub s1 s2 -> weakly <$> freeVars' (s1, s2)--instance Free Level where-  freeVars' (Max as) = freeVars' as--instance Free PlusLevel where-  freeVars' ClosedLevel{} = mempty-  freeVars' (Plus _ l)    = freeVars' l--instance Free LevelAtom where-  freeVars' l = case l of-    MetaLevel _ vs   -> flexible <$> freeVars' vs-    NeutralLevel _ v -> freeVars' v-    BlockedLevel _ v -> freeVars' v-    UnreducedLevel v -> freeVars' v--instance Free a => Free [a] where-  freeVars' = foldMap freeVars'--instance Free a => Free (Maybe a) where-  freeVars' = foldMap freeVars'--instance (Free a, Free b) => Free (a,b) where-  freeVars' (x,y) = freeVars' x `mappend` freeVars' y--instance Free a => Free (Elim' a) where-  freeVars' (Apply a) = freeVars' a-  freeVars' (Proj{} ) = mempty--instance Free a => Free (Arg a) where-  freeVars' a = f <$> freeVars' (unArg a)-    where f = case getRelevance a of-               Irrelevant -> irrelevantly-               UnusedArg  -> unused-               _          -> id---instance Free a => Free (Dom a) where-  freeVars' = freeVars' . unDom--instance Free a => Free (Abs a) where-  freeVars' (Abs   _ b) = bind $ freeVars' b-  freeVars' (NoAbs _ b) = freeVars' b--instance Free a => Free (Tele a) where-  freeVars' EmptyTel          = mempty-  freeVars' (ExtendTel a tel) = freeVars' (a, tel)--instance Free Clause where-  freeVars' cl = bind' (size $ clauseTel cl) $ freeVars' $ clauseBody cl--freeIn :: Free a => Nat -> a -> Bool-freeIn v t = v `Set.member` allVars (freeVars t)--freeInIgnoringSorts :: Free a => Nat -> a -> Bool-freeInIgnoringSorts v t =-  v `Set.member` allVars (freeVarsIgnore IgnoreAll t)--freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool-freeInIgnoringSortAnn v t =-  v `Set.member` allVars (freeVarsIgnore IgnoreInAnnotations t)--relevantInIgnoringSortAnn :: Free a => Nat -> a -> Bool-relevantInIgnoringSortAnn v t =-  v `Set.member` relevantVars (freeVarsIgnore IgnoreInAnnotations t)--relevantIn :: Free a => Nat -> a -> Bool-relevantIn v t = v `Set.member` relevantVars (freeVarsIgnore IgnoreAll t)---- | Is the variable bound by the abstraction actually used?-isBinderUsed :: Free a => Abs a -> Bool-isBinderUsed NoAbs{}   = False-isBinderUsed (Abs _ x) = 0 `freeIn` x
+ src/full/Agda/TypeChecking/Free/Precompute.hs view
@@ -0,0 +1,114 @@+{-# 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 ( 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 VarSet++precomputeFreeVars_ :: PrecomputeFreeVars a => a -> a+precomputeFreeVars_ = fst . runWriter . precomputeFreeVars++precomputedFreeVars :: PrecomputeFreeVars a => a -> VarSet+precomputedFreeVars = snd . runWriter . precomputeFreeVars++class PrecomputeFreeVars a where+  precomputeFreeVars :: a -> FV a++  default precomputeFreeVars :: (Traversable c, PrecomputeFreeVars x, a ~ c x) => a -> FV a+  precomputeFreeVars = traverse precomputeFreeVars++-- The instances where things actually happen: Arg, Abs and Term.++maybePrecomputed :: PrecomputeFreeVars a => ArgInfo -> a -> FV (ArgInfo, a)+maybePrecomputed i x =+  case getFreeVariables i of+    KnownFVs fv -> (i, x) <$ tell fv+    UnknownFVs -> do+      (x', fv) <- listen $ precomputeFreeVars x+      return (setFreeVariables (KnownFVs fv) i, x')++instance PrecomputeFreeVars a => PrecomputeFreeVars (Arg a) where+  precomputeFreeVars arg@(Arg i x) = uncurry Arg <$> maybePrecomputed i x++-- Note that we don't store free variables in the Dom. The reason is that the+-- ArgInfo in the Dom tends to get reused during type checking for the argument+-- of that domain type, and it would be tedious and error prone to ensure that+-- we don't accidentally inherit also the free variables. Moreover we don't+-- really need the free variables of the Dom.+instance PrecomputeFreeVars a => PrecomputeFreeVars (Dom a) where++instance PrecomputeFreeVars a => PrecomputeFreeVars (Abs a) where+  precomputeFreeVars (NoAbs x b) = NoAbs x <$> precomputeFreeVars b+  precomputeFreeVars (Abs x b) =+    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 (VarSet.singleton x)+        Var x <$> precomputeFreeVars es+      Lam i b    -> Lam i      <$> precomputeFreeVars b+      Lit{}      -> pure t+      Def f es   -> Def f      <$> precomputeFreeVars es+      Con c i es -> Con c i    <$> precomputeFreeVars es+      Pi a b     -> uncurry Pi <$> precomputeFreeVars (a, b)+      Sort s     -> Sort       <$> precomputeFreeVars s+      Level l    -> Level      <$> precomputeFreeVars l+      MetaV x es -> MetaV x    <$> precomputeFreeVars es+      DontCare t -> DontCare   <$> precomputeFreeVars t+      Dummy{}    -> pure t++-- The other instances are boilerplate.++instance PrecomputeFreeVars Sort where+  precomputeFreeVars s =+    case s of+      Univ u a   -> Univ u <$> precomputeFreeVars a+      Inf _ _    -> pure s+      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+      MetaS x es -> MetaS x <$> precomputeFreeVars es+      DefS d es  -> DefS d <$> precomputeFreeVars es+      DummyS{}   -> pure s++instance PrecomputeFreeVars Level where+  precomputeFreeVars (Max n ls) = Max n <$> precomputeFreeVars ls++instance PrecomputeFreeVars PlusLevel where+  precomputeFreeVars (Plus n l) = Plus n <$> precomputeFreeVars l++instance PrecomputeFreeVars Type where+  precomputeFreeVars (El s t) = uncurry El <$> precomputeFreeVars (s, t)++-- Note: don't use default instance, since that bypasses the 'Arg' in 'Apply'.+instance PrecomputeFreeVars a => PrecomputeFreeVars (Elim' a) where+  precomputeFreeVars e =+    case e of+      Apply x      -> Apply <$> precomputeFreeVars x+      IApply a x y -> IApply <$> precomputeFreeVars a <*> precomputeFreeVars x <*> precomputeFreeVars y+      Proj{}       -> pure e++-- The very boilerplate instances++instance PrecomputeFreeVars a => PrecomputeFreeVars [a] where+instance PrecomputeFreeVars a => PrecomputeFreeVars (Maybe a) where++instance (PrecomputeFreeVars a, PrecomputeFreeVars b) => PrecomputeFreeVars (a, b) where+  precomputeFreeVars (x, y) = (,) <$> precomputeFreeVars x <*> precomputeFreeVars y
+ src/full/Agda/TypeChecking/Free/Reduce.hs view
@@ -0,0 +1,189 @@+{-# 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++import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Reduce+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+--   depending on the instantiation of some set of metas.+data IsFree+  = MaybeFree MetaSet+  | NotFree+  deriving (Eq, Show)++-- | Try to enforce a set of variables not occurring in a given+--   type. Returns a possibly reduced version of the type and for each+--   of the given variables whether it is either not free, or+--   maybe free depending on some metavariables.+forceNotFree :: (ForceNotFree a, Reduce a, MonadReduce m)+             => IntSet -> a -> m (IntMap IsFree, a)+forceNotFree xs a = do+  -- Initially, all variables are marked as `NotFree`. This is changed+  -- to `MaybeFree` when we find an occurrence.+  let mxs = IntMap.fromSet (const NotFree) xs+  (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+  , MonadReduce m+  )++class (PrecomputeFreeVars a, Subst a) => ForceNotFree a where+  -- Reduce the argument if necessary, to make as many as possible of+  -- the variables in the state not free. Updates the state, marking+  -- the variables that couldn't be make not free as `MaybeFree`. By+  -- updating the state as soon as a variable can not be reduced away,+  -- we avoid trying to get rid of it in other places.+  forceNotFree' :: (MonadFreeRed m) => a -> m a++-- Return the set of variables for which there is still hope that they+-- may not occur.+varsToForceNotFree :: (MonadFreeRed m) => m IntSet+varsToForceNotFree = gets (IntMap.keysSet . (IntMap.filter (== NotFree)))++-- Reduce the argument if there are offending free variables. Doesn't call the+-- continuation when no reduction is required.+reduceIfFreeVars :: (Reduce a, ForceNotFree a, MonadFreeRed m)+                 => (a -> m a) -> a -> m a+reduceIfFreeVars k a = do+  xs <- varsToForceNotFree+  let fvs     = precomputedFreeVars a+      notfree = IntSet.disjoint xs fvs+  if notfree+    then return a+    else k . precomputeFreeVars_ =<< reduce a++-- Careful not to define forceNotFree' = forceNotFreeR since that would loop.+forceNotFreeR :: (Reduce a, ForceNotFree a, MonadFreeRed m)+              => a -> m a+forceNotFreeR = reduceIfFreeVars forceNotFree'++instance (Reduce a, ForceNotFree a) => ForceNotFree (Arg a) where+  -- Precomputed free variables are stored in the Arg so reduceIf outside the+  -- traverse.+  forceNotFree' = reduceIfFreeVars (traverse forceNotFree')++instance (Reduce a, ForceNotFree a, TermSubst a) => ForceNotFree (Dom a) where+  forceNotFree' = traverse forceNotFreeR++instance (Reduce a, ForceNotFree a) => ForceNotFree (Abs a) where+  -- Reduction stops at abstractions (lambda/pi) so do reduceIf/forceNotFreeR here.+  forceNotFree' a@NoAbs{} = traverse forceNotFreeR a+  forceNotFree' a@Abs{} =+    -- Shift variables up when going under the abstraction and back down when+    -- coming out of it. Since we never add new indices to the state+    -- there's no danger of getting negative indices.+    reduceIfFreeVars (bracket_ (modify $ IntMap.mapKeys succ) (\ _ -> modify $ IntMap.mapKeys pred) .+                      traverse forceNotFree') a++instance ForceNotFree a => ForceNotFree [a] where+  forceNotFree' = traverse forceNotFree'++instance (Reduce a, ForceNotFree a) => ForceNotFree (Elim' a) where+  -- There's an Arg inside Elim' which stores precomputed free vars, so let's+  -- not skip over that.+  forceNotFree' (Apply arg)    = Apply <$> forceNotFree' arg+  forceNotFree' e@Proj{}       = return e+  forceNotFree' (IApply x y r) = IApply <$> forceNotFreeR x <*> forceNotFreeR y <*> forceNotFreeR r++instance ForceNotFree Type where+  forceNotFree' (El s t) = El <$> forceNotFree' s <*> forceNotFree' t++instance ForceNotFree Term where+  forceNotFree' = \case+    Var x es   -> do+      metas <- ask+      modify $ IntMap.adjust (const $ MaybeFree metas) x+      Var x <$> forceNotFree' es+    Def f es   -> Def f    <$> forceNotFree' es+    Con c h es -> Con c h  <$> forceNotFree' es+    MetaV x es -> local (insertMetaSet x) $+                  MetaV x  <$> forceNotFree' es+    Lam h b    -> Lam h    <$> forceNotFree' b+    Pi a b     -> Pi       <$> forceNotFree' a <*> forceNotFree' b  -- Dom and Abs do reduceIf so not needed here+    Sort s     -> Sort     <$> forceNotFree' s+    Level l    -> Level    <$> forceNotFree' l+    DontCare t -> DontCare <$> forceNotFreeR t  -- Reduction stops at DontCare so reduceIf+    t@Lit{}    -> return t+    t@Dummy{}  -> return t++instance ForceNotFree Level where+  forceNotFree' (Max m as) = Max m <$> forceNotFree' as++instance ForceNotFree PlusLevel where+  forceNotFree' (Plus k a) = Plus k <$> forceNotFree' a++instance ForceNotFree Sort where+  -- Reduce for sorts already goes under all sort constructors, so we can get+  -- away without forceNotFreeR here.+  forceNotFree' = \case+    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+    MetaS x es -> MetaS x  <$> forceNotFree' es+    DefS d es  -> DefS d   <$> forceNotFree' es+    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
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Functions+  ( etaExpandClause+  , getDef+  ) where++import Control.Arrow ( first )++import Agda.Syntax.Common+import Agda.Syntax.Internal++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+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Impossible+import Agda.Utils.Functor ( ($>) )+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Monad+import Agda.Utils.Size+++-- | Expand a clause to the maximal arity, by inserting variable+--   patterns and applying the body to variables.++--  Fixes issue #2376.+--  Replaces 'introHiddenLambdas'.+--  See, e.g., test/Succeed/SizedTypesExtendedLambda.agda.++--  This is used instead of special treatment of lambdas+--  (which was unsound: Issue #121)++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 recursive unreachable ell wm -> do++      -- Get the telescope to expand the clause with.+      TelV tel0 t' <- addContext ctel $ telView $ unArg t++      -- If the rhs has lambdas, harvest the names of the bound variables.+      let xs   = peekLambdas body+      let ltel = useNames xs $ telToList tel0+      let tel  = telFromList ltel+      let n    = size tel+      unless (n == size tel0) __IMPOSSIBLE__  -- useNames should not drop anything+      -- Join with lhs telescope, extend patterns and apply body.+      -- NB: no need to raise ctel!+      let ctel' = telFromList $ telToList ctel ++ ltel+          ps'   = raise n ps ++ teleNamedArgs tel+          body' = raise n body `apply` teleArgs tel+      reportSDoc "term.clause.expand" 30 $ inTopContext $ vcat+        [ "etaExpandClause"+        , "  body    = " <+> addContext ctel' (prettyTCM body)+        , "  xs      = " <+> text (prettyShow xs)+        , "  new tel = " <+> prettyTCM ctel'+        ]+      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]+    peekLambdas v =+      case v of+        Lam info b -> Arg info (absName b) : peekLambdas (unAbs b)+        _ -> []++    -- Use the names of the first argument, and set the Origin all other+    -- parts of the telescope to Inserted.+    -- The first list of arguments is a subset of the telescope.+    -- Thus, if compared pointwise, if the hiding does not match,+    -- it means we skipped an element of the telescope.+    useNames :: [Arg ArgName] -> ListTel -> ListTel+    useNames []     tel       = map (setOrigin Inserted) tel+    -- Andrea: we can have more Lam's than Pi's, because they might be for Path+    -- Andreas, 2017-03-24: the following case is not IMPOSSIBLE when positivity checking comes before termination checking, see examples/tactics/ac/AC.agda+    useNames (_:_)  []        = []+    useNames (x:xs) (dom:tel)+      | sameHiding x dom =+          -- set the ArgName of the dom+          fmap (first $ const $ unArg x) dom : useNames xs tel+      | otherwise =+          setOrigin Inserted dom : useNames (x:xs) tel++-- | Get the name of defined symbol of the head normal form of a term.+--   Returns 'Nothing' if no such head exists.++getDef :: Term -> TCM (Maybe QName)+getDef t = reduce t >>= \case+  Def d _    -> return $ Just d+  Lam _ v    -> underAbstraction_ v getDef+  Level v    -> getDef =<< reallyUnLevelView v+  DontCare v -> getDef v+  _          -> return Nothing
+ src/full/Agda/TypeChecking/Generalize.hs view
@@ -0,0 +1,1052 @@+{-# 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'+  , generalizeTelescope ) where++import Prelude hiding (null)++import Control.Monad.Except ( MonadError(..) )++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 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+import Agda.Syntax.Scope.Monad (bindVariable, outsideLocalVars)+import Agda.Syntax.Scope.Base (BindingSource(..))+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Free+import Agda.TypeChecking.InstanceArguments (postponeInstanceConstraints)+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings++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.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++-- | 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 [])+generalizeTelescope vars typecheckAction ret = billTo [Typing, Generalize] $ withGenRecVar $ \ genRecMeta -> do+  let s = Map.keysSet vars+  ((cxtNames, tel, letbinds), namedMetas, allmetas) <-+    createMetasAndTypeCheck s $ typecheckAction $ \ tel -> do+      xs <- take (size tel) <$> getContextNames'+      lbs <- getLetBindings -- This gives let-bindings valid in the current context+      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++  let boundVar q = fromMaybe __IMPOSSIBLE__ $ Map.lookup q vars+      genTelVars = (map . fmap) boundVar genTelNames++  tel' <- applySubst sub <$> instantiateFull tel++  -- This is not so nice. When changing the context from Γ (r : R) to Γ Δ we need to do this at the+  -- 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, dom) = do+          let s = fst $ unDom dom+          name <- maybe (setNotInScope <$> freshName_ s) return mname+          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 :: [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+  --   Γ (r : R) ⊢ Θ            Θ = tel+  --   Γ ⊢ Δ                    Δ = genTel+  --   Γ Δ ⊢ ρ : Γ (r : R)      ρ = sub+  --   Γ ⊢ Δ Θρ                 Θρ = tel'+  -- 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, LetBinding o v dom) = addLetBinding' o x v dom++  updateContext sub ((genTelCxt ++) . drop 1) $+    updateContext (raiseS (size tel')) (newTelCxt ++) $+      foldr addLet (ret genTelVars $ abstract genTel tel') letbinds'+++-- | Generalize a type over a set of (used) generalizable variables.+generalizeType :: Set QName -> TCM Type -> TCM ([Maybe QName], Type)+generalizeType s typecheckAction = do+  (ns, t, _) <- generalizeType' s $ (,()) <$> typecheckAction+  return (ns, t)++-- | Allow returning additional information from the type checking action.+generalizeType' :: Set QName -> TCM (Type, a) -> TCM ([Maybe QName], Type, a)+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++  reportSDoc "tc.generalize" 40 $ vcat+    [ "generalized"+    , nest 2 $ "t =" <+> escapeContext impossible 1 (prettyTCM t') ]++  return (genTelNames, t', userdata)++-- | Create metas for the generalizable variables and run the type check action.+createMetasAndTypeCheck ::+  Set QName -> TCM a -> TCM (a, Map MetaId QName, LocalMetaStores)+createMetasAndTypeCheck s typecheckAction = do+  ((namedMetas, x), allmetas) <- metasCreatedBy $ do+    (metamap, genvals) <- createGenValues s+    x <- locallyTC eGeneralizedVars (const genvals) typecheckAction+    return (metamap, x)+  return (x, namedMetas, allmetas)++-- | Add a placeholder variable that will be substituted with a record value packing up all the+--   generalized variables.+withGenRecVar :: (Type -> TCM a) -> TCM a+withGenRecVar ret = do+  -- Create a meta type (in Set₀) for the telescope record. It won't+  -- necessarily fit in Set₀, but since it's only used locally the sort+  -- shouldn't matter. Another option would be to put it in Setω, which is a+  -- bit more honest, but this leads to performance problems (see #3306).+  genRecMeta <- newTypeMeta (mkType 0)+  addContext (defaultDom ("genTel" :: String, genRecMeta)) $ ret genRecMeta++-- | 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+       -- ^ 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+  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 :: MonadReduce m => MetaVariable -> m Bool+      isFreshMeta mv = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp+  mvs :: [(MetaId, MetaVariable)] <- filterM (isFreshMeta . snd) mvs++  cs <- (++) <$> useTC stAwakeConstraints+             <*> useTC stSleepingConstraints++  reportSDoc "tc.generalize" 50 $ "current constraints:" <?> vcat (map prettyTCM cs)++  constrainedMetas <- Set.unions <$> mapM (constraintMetas . clValue . theConstraint) cs++  reportSDoc "tc.generalize" 30 $ nest 2 $+    "constrainedMetas     = " <+> prettyList_ (map prettyTCM $ Set.toList constrainedMetas)++  let isConstrained x = Set.member x constrainedMetas+      -- Note: Always generalize named metas even if they are constrained. We+      -- freeze them so they won't be instantiated by the constraint, and we do+      -- want the nice error from checking the constraint after generalization.+      -- See #3276.+      isGeneralizable (x, mv) = Map.member x nameMap ||+                                not (isConstrained x) && NoGeneralize /= unArg (miGeneralizable (mvInfo mv))+      isSort = isSortMeta_ . snd+      isOpen = isOpenMeta . mvInstantiation . snd++  -- Split the generalizable metas in open and closed+  let (generalizable, nongeneralizable)         = partition isGeneralizable mvs+      (generalizableOpen', generalizableClosed) = partition isOpen generalizable+      (openSortMetas, generalizableOpen)        = partition isSort generalizableOpen'+      nongeneralizableOpen                      = filter isOpen nongeneralizable++  reportSDoc "tc.generalize" 30 $ nest 2 $ vcat+    [ "generalizable        = " <+> prettyList_ (map (prettyTCM . fst) generalizable)+    , "generalizableOpen    = " <+> prettyList_ (map (prettyTCM . fst) generalizableOpen)+    , "openSortMetas        = " <+> prettyList_ (map (prettyTCM . fst) openSortMetas)+    ]++  -- Issue 3301: We can't generalize over sorts+  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   <- lookupLocalMeta x+          msub <- enterClosure mv $ \ _ ->+                    checkpointSubstitution' cp+          let sameContext =+                -- We can only generalize if the metavariable takes the context variables of the+                -- current context as arguments. This happens either when the context of the meta+                -- is the same as the current context and there is no pruning, or the meta context+                -- is a weakening but the extra variables have been pruned.+                -- It would be possible to generalize also in the case when some context variables+                -- (other than genTel) have been pruned, but it's hard to construct an example+                -- where this actually happens.+                case (msub, mvPermutation mv) of+                  (Just IdS, Perm m xs)        -> xs == [0 .. m - 1]+                  (Just (Wk n IdS), Perm m xs) -> xs == [0 .. m - n - 1]+                  _                            -> False+          unless sameContext $ reportSDoc "tc.generalize" 20 $ do+            ty <- getMetaType x+            let Perm m xs = mvPermutation mv+            vcat+              [ text "Don't know how to generalize over"+              , nest 2 $ prettyTCM x <+> text ":" <+> prettyTCM ty+              , text "in context"+              , nest 2 $ inTopContext . prettyTCM =<< getContextTelescope+              , text "permutation:" <+> text (show (m, xs))+              , text "subst:" <+> pretty msub ]+          return sameContext++  inherited :: Set MetaId <- Set.unions <$> forM generalizableClosed \ (x, mv) ->+    case mvInstantiation mv of+      InstV inst -> do+        parentName <- getMetaNameSuggestion x+        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+      generalizeOver   = map fst generalizableOpen ++ alsoGeneralize+      shouldGeneralize = (generalizeOver `hasElem`)++  reportSDoc "tc.generalize" 30 $ nest 2 $ vcat+    [ "alsoGeneralize       = " <+> prettyList_ (map prettyTCM alsoGeneralize)+    , "reallyDontGeneralize = " <+> prettyList_ (map prettyTCM reallyDontGeneralize)+    ]++  reportSDoc "tc.generalize" 10 $ "we're generalizing over" <+> prettyList_ (map prettyTCM generalizeOver)++  -- Sort metas in dependency order. Include open metas that we are not+  -- generalizing over, since they will need to be pruned appropriately (see+  -- Issue 3672).+  allSortedMetas <- fromMaybeM (typeError GeneralizeCyclicDependency) $+    dependencySortMetas (generalizeOver ++ reallyDontGeneralize ++ map fst openSortMetas)+  let sortedMetas = filter shouldGeneralize allSortedMetas++  let dropCxt err = updateContext (strengthenS err 1) (drop 1)++  -- Create the pre-record type (we don't yet know the types of the fields)+  (genRecName, genRecCon, genRecFields) <- dropCxt __IMPOSSIBLE__ $+      createGenRecordType genRecMeta sortedMetas++  reportSDoc "tc.generalize" 30 $ vcat $+    [ "created genRecordType"+    , nest 2 $ "genRecName   = " <+> prettyTCM genRecName+    , nest 2 $ "genRecCon    = " <+> prettyTCM genRecCon+    , nest 2 $ "genRecFields = " <+> prettyList_ (map prettyTCM genRecFields)+    ]++  -- Solve the generalizable metas. Each generalizable meta is solved by projecting the+  -- corresponding field from the genTel record.+  cxtTel <- getContextTelescope+  let solve m field = do+        reportSDoc "tc.generalize" 30 $ "solving generalized meta" <+>+          prettyTCM m <+> ":=" <+> prettyTCM (Var 0 [Proj ProjSystem field])+        -- m should not be instantiated, but if we don't check constraints+        -- properly it could be (#3666 and #3667). Fail hard instead of+        -- generating bogus types.+        whenM (isInstantiatedMeta m) __IMPOSSIBLE__+        assignTerm' m (telToArgs cxtTel) $ Var 0 [Proj ProjSystem field]+  zipWithM_ solve sortedMetas genRecFields++  -- Record the named variables in the telescope+  let telNames = map (`Map.lookup` nameMap) sortedMetas++  -- Build the telescope of generalized metas+  teleTypes <- do+    args <- getContextArgs+    concat <$> forM sortedMetas \ m -> do+      mv <- lookupLocalMeta m+      let info =+            (hideOrKeepInstance $+            getArgInfo $ miGeneralizable $ mvInfo mv) { argInfoOrigin = Generalization }+          HasType{ jMetaType = t } = mvJudgement mv+          perm = mvPermutation mv+      t' <- piApplyM t $ permute (takeP (length args) perm) args+      return [(Arg info $ miNameSuggestion $ mvInfo mv, t')]+  let genTel = buildGeneralizeTel genRecCon teleTypes++  reportSDoc "tc.generalize" 40 $ vcat+    [ 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})+        | 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++  -- Fill in the missing details of the telescope record.+  dropCxt __IMPOSSIBLE__ $ fillInGenRecordDetails genRecName genRecCon genRecFields genRecMeta genTel++  -- Now abstract over the telescope. We need to apply the substitution that subsitutes a record+  -- 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+-- dependency order. The telescope is the generalized telescope.+pruneUnsolvedMetas :: QName -> ConHead -> Telescope -> [QName] -> Map MetaId InteractionId -> (MetaId -> Bool) -> [MetaId] -> TCM ()+pruneUnsolvedMetas genRecName genRecCon genTel genRecFields interactionPoints isGeneralized metas+  | all isGeneralized metas = return ()+  | otherwise               = prune [] genTel metas+  where+    prune _ _ [] = return ()+    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 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+      where x = absName tel+    prune _ _ _ = __IMPOSSIBLE__++    sub = unpackSub genRecCon $ map getArgInfo $ telToList genTel++    prepruneErrorRefinedContext = prepruneError $+      "Failed to generalize because some of the generalized variables depend on an " +++      "unsolved meta created in a refined context (not a simple extension of the context where " +++      "generalization happens)."++    prepruneErrorCyclicDependencies = prepruneError $+      "Failed to generalize due to circular dependencies between the generalized " +++      "variables and an unsolved meta."++    prepruneErrorFailedToInstantiate = prepruneError $+      "Failed to generalize because the generalized variables depend on an unsolved meta " +++      "that could not be lifted outside the generalization."++    prepruneError :: String -> MetaId -> TCM a+    prepruneError msg x = do+      r <- getMetaRange x+      genericDocError =<<+        (fwords (msg ++ " The problematic unsolved meta is") $$+                 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 <- lookupLocalMeta x+      (i, _A) <- enterClosure mv $ \ _ -> do+        δ <- checkpointSubstitution cp+        _A <- case mvJudgement mv of+                IsSort{}  -> return Nothing+                HasType{} -> Just <$> getMetaTypeInContext x+        case δ of+          Wk n IdS -> return (n, _A)+          IdS      -> return (0, _A)+          _        -> prepruneErrorRefinedContext x+      if i == 0 then return x else do+        reportSDoc "tc.generalize.prune.pre" 40 $ vcat+          [ "prepruning"+          , nest 2 $ pretty x <+> ":" <+> pretty (jMetaType $ mvJudgement mv)+          , nest 2 $ "|Δ| =" <+> pshow i ]++        -- We have+        --   Γ (r : GenRec)            current context+        --   Γ (r : GenRec) Δ ⊢ x : A  with |Δ| = i+        -- and we need to get rid of the dependency on Δ.++        -- We can only do this if A does not depend on Δ, so check this first.+        case IntSet.minView (allFreeVars _A) of+          Just (j, _) | j < i -> prepruneErrorCyclicDependencies x+          _                   -> return ()++        -- If it doesn't we can strenghten it to the current context (this is done by+        -- newMetaFromOld).+        --   Γ (r : GenRec) ⊢ ρ : Γ (r : GenRec) Δ+        let ρ  = strengthenS impossible i+            ρ' = raiseS i++        (y, u) <- newMetaFromOld mv ρ _A++        let uρ' = applySubst ρ' u++        reportSDoc "tc.generalize.prune.pre" 40 $ nest 2 $ vcat+          [ "u    =" <+> pretty u+          , "uρ⁻¹ =" <+> pretty uρ' ]++        -- To solve it we enter the context of x again+        enterClosure mv $ \ _ -> do+          -- v is x applied to the context variables+          v <- case _A of+                 Nothing -> Sort . MetaS x . map Apply <$> getMetaContextArgs mv+                 Just{}  -> MetaV x . map Apply <$> getMetaContextArgs mv+          noConstraints (doPrune x mv _A v uρ') `catchError` \ _ -> prepruneErrorFailedToInstantiate x+          setInteractionPoint x y+          return y++    pruneMeta _Θ x = do+      cp <- viewTC eCurrentCheckpoint+      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 $ \ _ ->+        -- If we can't find the generalized record, it's already been pruned and we don't have to do+        -- anything.+        whenJustM (findGenRec mv) $ \ i -> do++        reportSDoc "tc.generalize.prune" 30 $ vcat+          [ "pruning"+          , nest 2 $ inTopContext $ prettyTCM (mvJudgement mv)+          , nest 2 $ "GenRecTel is var" <+> pretty i ]++        _ΓrΔ <- getContextTelescope+        let (_Γ, _Δ) = (telFromList gs, telFromList ds)+              where (gs, _ : ds) = splitAt (size _ΓrΔ - i - 1) (telToList _ΓrΔ)++        -- Get the type of x. By doing this here we let the checkpoint machinery sort out the+        _A <- case mvJudgement mv of+                IsSort{}  -> return Nothing+                HasType{} -> Just <$> getMetaTypeInContext x++        -- We have+        --   Γ  (r : GenTel) Δ         current context+        --   Γ₀ (r : GenTel)           top context+        --   Γ₀ ⊢ Θ                    prefix of the generalized telescope currently in scope+        --   Γ (r : GenTel) Δ ⊢ x : A  the meta to prune++        -- Get the substitution from the point of generalization to the current context. This always+        -- succeeds since if the meta depends on GenTel it must have been created inside the+        -- generalization:+        --   Γ (r : GenTel) Δ ⊢ δ : Γ₀ (r : GenTel)+        δ <- checkpointSubstitution cp++        -- v is x applied to the context variables+        v <- case _A of+               Nothing -> Sort . MetaS x . map Apply <$> getMetaContextArgs mv+               Just{}  -> MetaV x . map Apply <$> getMetaContextArgs mv++        -- Now ultimately we want to create the fresh meta in the context+        --   Γ Θγ Δσ where Γ    ⊢ γ : Γ₀+        --                 Γ Θγ ⊢ σ : Γ (r : GenTel)+        -- σ is the unpacking substitution (which is polymorphic in Γ)+        let σ   = sub (size _Θ)+            --    Γ <- Γ (r : GenTel) Δ <- Γ₀ (r : GenTel) <- Γ₀+            γ   = strengthenS impossible (i + 1) `composeS` δ `composeS` raiseS 1+            _Θγ = applySubst γ _Θ+            _Δσ = applySubst σ _Δ++        -- The substitution into the new context is simply lifting σ over Δ:+        --   Γ Θγ Δσ ⊢ lift i σ : Γ (r : GenTel) Δ+        let ρ  = liftS i σ+            -- We also need ρ⁻¹, which is a lot easier to construct.+            ρ' = liftS i $ [ Var 0 [Proj ProjSystem fld] | fld <- reverse $ take (size _Θ) $ genRecFields ] ++# raiseS 1++        reportSDoc "tc.generalize.prune" 30 $ nest 2 $ vcat+          [ "Γ   =" <+> pretty _Γ+          , "Θ   =" <+> pretty _Θ+          , "Δ   =" <+> pretty _Δ+          , "σ   =" <+> pretty σ+          , "γ   =" <+> pretty γ+          , "δ   =" <+> pretty δ+          , "ρ   =" <+> pretty ρ+          , "ρ⁻¹ =" <+> pretty ρ'+          , "Θγ  =" <+> pretty _Θγ+          , "Δσ  =" <+> pretty _Δσ+          , "_A  =" <+> pretty _A+          ]++        -- When updating the context we also need to pick names for the variables. Get them from the+        -- current context and generate fresh ones for the generalized variables in Θ.+        (newCxt, rΘ) <- do+          (rΔ, _ : rΓ) <- splitAt i <$> getContext+          let setName dom@(Dom {unDom = (s,ty)}) = CtxVar <$> freshName_ s <*> (pure $ dom $> ty)+          rΘ <- mapM setName $ reverse $ telToList _Θγ+          let rΔσ = zipWith (\ name dom -> CtxVar name (snd <$> dom))+                            (map ctxEntryName rΔ)+                            (reverse $ telToList _Δσ)+          return (rΔσ ++ rΘ ++ rΓ, rΘ)++        -- Now we can enter the new context and create our meta variable.+        (y, u) <- updateContext ρ (const newCxt) $ localScope $ do++          -- First, we add the named variables to the scope, to allow+          -- them to be used in holes (#3341). These should go outside Δ (#3735).+          outsideLocalVars i $ addNamedVariablesToScope rΘ++          -- Now we can create the new meta+          newMetaFromOld mv ρ _A++        -- Finally we solve x := yρ⁻¹. The reason for solving it this way instead of xρ := y is that+        -- ρ contains dummy terms for the variables that are not in scope.+        -- If x has been instantiated by some constraint unblocked by previous pruning or+        -- generalization, use equalTerm instead of assigning to x. If this fails (see+        -- test/Fail/Issue3655b.agda for a test case), we need to give an error. This can happen if+        -- there are dependencies between generalized variables that are hidden by constraints and+        -- the dependency sorting happens to pick the wrong order. For instance, if we have+        --    α : Nat   (unsolved meta)+        --    t : F α   (named variable)+        --    n : Nat   (named variable)+        -- and a constraint F α == F n, where F does some pattern matching preventing the constraint+        -- to be solved when n is still a meta. If t appears before n in the type these will be sorted+        -- as α, t, n, but we will solve α := n before we get to the pruning here. It's good that we+        -- solve first though, because that means we can give a more informative error message than+        -- the "Cannot instantiate..." we would otherwise get.+        let uρ' = applySubst ρ' u+        reportSDoc "tc.generalize.prune" 80 $ vcat+          [ "solving"+          , nest 2 $ sep [ pretty v   <+> "=="+                         , pretty uρ' <+> ":"+                         , pretty _A ] ]+        noConstraints (doPrune x mv _A v uρ') `catchError` niceError x v++        reportSDoc "tc.generalize.prune" 80 $ vcat+          [ "solved"+          , nest 2 $ "v    =" <+> (pretty =<< instantiateFull v)+          , nest 2 $ "uρ⁻¹ =" <+> (pretty =<< instantiateFull uρ') ]++        setInteractionPoint x y++    findGenRec :: MetaVariable -> TCM (Maybe Int)+    findGenRec mv = do+      cxt <- instantiateFull =<< getContext+      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)+                                                    -- Nothing if sort meta+    newMetaFromOld :: MetaVariable -> Substitution -> Maybe Type -> TCM (MetaId, Term)+    newMetaFromOld mv ρ mA = setCurrentRange mv $+      case mA of+        Nothing -> do+          s@(MetaS y _) <- newSortMeta+          return (y, Sort s)+        Just _A -> do+          let _Aρ = applySubst ρ _A+          newNamedValueMeta DontRunMetaOccursCheck+                            (miNameSuggestion $ mvInfo mv)+                            (jComparison $ mvJudgement mv) _Aρ++    -- If x is a hole, update the hole to point to y instead.+    setInteractionPoint x y =+      whenJust (Map.lookup x interactionPoints) (`connectInteractionPoint` y)++    doPrune :: MetaId -> MetaVariable -> Maybe Type -> Term -> Term -> TCM ()+    doPrune x mv mt v u =+      case mt of+        _ | isOpen -> assign DirEq x (getArgs v) u $ maybe AsTypes AsTermsOf mt+        Nothing    -> equalSort (unwrapSort v) (unwrapSort u)+        Just t     -> equalTerm t v u+      where+        isOpen = isOpenMeta $ mvInstantiation mv+        getArgs = \case+            Sort (MetaS _ es) -> fromMaybe __IMPOSSIBLE__ $ allApplyElims es+            MetaV _ es        -> fromMaybe __IMPOSSIBLE__ $ allApplyElims es+            _                 -> __IMPOSSIBLE__+        unwrapSort (Sort s) = s+        unwrapSort _        = __IMPOSSIBLE__++    niceError x u err = do+      u <- instantiateFull u+      let err' = case err of+                   TypeError{tcErrClosErr = cl} ->+                     -- Remove the 'when' part from the error since it's most like the same as ours.+                     err{ tcErrClosErr = cl{ clEnv = (clEnv cl) { envCall = Nothing } } }+                   _ -> err+          telList = telToList genTel+          names   = map (fst . unDom) telList+          late    = map (fst . unDom) $ filter (getAny . allMetas (Any . (== x))) telList+          projs (Proj _ q)+            | 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+                  _          -> Set.empty+          commas []       = __IMPOSSIBLE__+          commas [x]      = x+          commas [x, y]   = x ++ ", and " ++ y+          commas (x : xs) = x ++ ", " ++ commas xs+          cause = "There were unsolved constraints that obscured the " +++                  "dependencies between the generalized variables."+          solution = "The most reliable solution is to provide enough information to make the dependencies " +++                     "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 = 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]+        , nest 2 $ sep ["- Suggestion", nest 4 $ fwords solution]+        , nest 2 $ sep $ ["- Further information"+                         , nest 2 $ "-" <+> order ] +++                         [ nest 2 $ "-" <+> fwords guess | not (null late), not (null early) ] +++                         [ nest 2 $ "-" <+> sep [ fwords "The dependency error is", prettyTCM err' ] ]+        ]++    addNamedVariablesToScope cxt =+      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+          reportSLn "tc.generalize.eta.scope" 40 "  (added)"+          bindVariable LambdaBound (nameConcrete x) x++-- | Create a substition from a context where the i first record fields are variables to a context+--   where you have a single variable of the record type. Packs up the field variables in a record+--   constructor and pads with __DUMMY_TERM__s for the missing fields. Important that you apply this+--   to terms that only projects the defined fields from the record variable.+--   Used with partial record values when building the telescope of generalized variables in which+--   case we have done the dependency analysis that guarantees it is safe.+unpackSub :: ConHead -> [ArgInfo] -> Int -> Substitution+unpackSub con infos i = recSub+  where+    ar = length infos+    appl info v = Apply (Arg info v)+    recVal = Con con ConOSystem $ zipWith appl infos $ [var j | j <- [i - 1, i - 2..0]] ++ replicate (ar - i) __DUMMY_TERM__++    -- want: Γ Δᵢ ⊢ recSub i : Γ (r : R)+    -- have:+    -- Γ Δᵢ ⊢ recVal i :# σ : Θ (r : R),  if Γ Δᵢ ⊢ σ : Θ+    -- Γ Δᵢ ⊢ WkS i IdS : Γ+    recSub = recVal :# Wk i IdS++-- | Takes the list of types+--    A₁ []+--    A₂ [r.f₁]+--    A₃ [r.f₂, r.f₃]+--    ...+--   And builds the telescope+--    (x₁ : A₁ [ r := c _       .. _ ])+--    (x₂ : A₂ [ r := c x₁ _    .. _ ])+--    (x₃ : A₃ [ r := c x₁ x₂ _ .. _ ])+--    ...+buildGeneralizeTel :: ConHead -> [(Arg MetaNameSuggestion, Type)] -> Telescope+buildGeneralizeTel con xs = go 0 xs+  where+    infos = map (argInfo . fst) xs+    recSub i = unpackSub con infos i+    go _ [] = EmptyTel+    go i ((name, ty) : xs) = ExtendTel (dom ty') $ Abs (unArg name) $ go (i + 1) xs+      where ty' = applySubst (recSub i) ty+            dom = defaultNamedArgDom (getArgInfo name) (unArg name)++-- | Create metas for all used generalizable variables and their dependencies.+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) $+    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 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+  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+  (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 ->+    setModality (getModality (defArgInfo def)) $+    mv { mvFrozen = Frozen }++  -- Set up names of arg metas+  forM_ (zip3 [1..] (map unArg args) (telToList argTel)) $ \ case+    (i, MetaV m _, Dom{unDom = (x, _)}) -> do+      let suf "_" = show i+          suf ""  = show i+          suf x   = x+      setMetaNameSuggestion m (name ++ "." ++ suf x)+    _ -> return ()  -- eta expanded++  -- Update the ArgInfos for the named meta. The argument metas are+  -- created with the correct ArgInfo.+  setMetaGeneralizableArgInfo m $ hideExplicit (defArgInfo def)++  reportSDoc "tc.generalize" 50 $ vcat+    [ "created metas for generalized variable" <+> prettyTCM x+    , nest 2 $ "top  =" <+> prettyTCM term+    , nest 2 $ "args =" <+> prettyTCM args ]++  case term of+    MetaV{} -> return ()+    _       -> genericDocError =<< ("Cannot generalize over" <+> prettyTCM x <+> "of eta-expandable type") <?>+                                    prettyTCM 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 = noMutualBlock $ do+  current <- currentModule+  let freshQName s = qualify current <$> freshName_ (s :: String)+      mkFieldName  = freshQName . (generalizedFieldName ++) <=< getMetaNameSuggestion+  genRecFields <- mapM (defaultDom <.> mkFieldName) sortedMetas+  genRecName   <- freshQName "GeneralizeTel"+  genRecCon    <- freshQName "mkGeneralizeTel" <&> \ con -> ConHead+                  { conName      = con+                  , conDataRecord= IsRecord CopatternMatching+                  , conInductive = Inductive+                  , 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) 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+                , 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 (sort genRecSort) $+    Record { recPars         = 0+           , recClause       = Nothing+           , recConHead      = genRecCon+           , recNamedCon     = False+           , recFields       = genRecFields+           , recTel          = dummyTel (length genRecFields) -- Filled in later+           , recMutual       = Just []+           , recEtaEquality' = Inferred YesEta+           , recPatternMatching = CopatternMatching+           , recInduction    = Nothing+           , recTerminates   = Just True    -- not recursive+           , recAbstr        = ConcreteDef+           , recComp         = emptyCompKit+           }+  reportSDoc "tc.generalize" 20 $ vcat+    [ text "created genRec" <+> prettyList_ (map (text . prettyShow . unDom) genRecFields) ]+  reportSDoc "tc.generalize" 80 $ vcat+    [ text "created genRec" <+> text (prettyShow genRecFields) ]+  -- Solve the genRecMeta+  args <- getContextArgs+  let genRecTy = El genRecSort $ Def genRecName $ map Apply args+  noConstraints $ equalType genRecTy genRecMeta+  return (genRecName, genRecCon, map unDom genRecFields)++-- | Once we have the generalized telescope we can fill in the missing details of the record type.+fillInGenRecordDetails :: QName -> ConHead -> [QName] -> Type -> Telescope -> TCM ()+fillInGenRecordDetails name con fields recTy fieldTel = do+  cxtTel <- fmap hideAndRelParams <$> getContextTelescope+  let fullTel = cxtTel `abstract` fieldTel+  -- Field types+  let mkFieldTypes [] EmptyTel = []+      mkFieldTypes (fld : flds) (ExtendTel ty ftel) =+          abstract cxtTel (El s $ Pi (defaultDom recTy) (Abs "r" $ unDom ty)) :+          mkFieldTypes flds (absApp ftel proj)+        where+          s = mkPiSort (defaultDom recTy) (Abs "r" $ unDom ty)+          proj = Var 0 [Proj ProjSystem fld]+      mkFieldTypes _ _ = __IMPOSSIBLE__+  let fieldTypes = mkFieldTypes fields (raise 1 fieldTel)+  reportSDoc "tc.generalize" 40 $ text "Field types:" <+> inTopContext (nest 2 $ vcat $ map prettyTCM fieldTypes)+  zipWithM_ setType fields fieldTypes+  -- Constructor type+  let conType = fullTel `abstract` raise (size fieldTel) recTy+  reportSDoc "tc.generalize" 40 $ text "Final genRecCon type:" <+> inTopContext (prettyTCM conType)+  setType (conName con) conType+  -- Record telescope: Includes both parameters and fields.+  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
@@ -0,0 +1,239 @@+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.IApplyConfluence where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++import Control.Monad.Except ( MonadError(..) )++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+import Agda.Syntax.Internal.Pattern++import Agda.Interaction.Options++import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Substitute++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 <$> cubicalOption) $ do+  -- Andreas, 2019-03-27, iapply confluence should only be checked+  -- when --cubical or --erased-cubical is active. See+  -- test/Succeed/CheckIApplyConfluence.agda.+  -- We cannot reach the following crash point unless+  -- --cubical/--erased-cubical is active.+  __CRASH_WHEN__ "tc.cover.iapply.confluence.crash" 666+  reportSDoc "tc.cover.iapply" 10 $ text "Checking IApply confluence of" <+> pretty f+  inConcreteOrAbstractMode f $ \ d -> do+  case theDef d of+    Function{funClauses = cls', funCovering = cls} -> do+      reportSDoc "tc.cover.iapply" 10 $ text "length cls =" <+> pretty (length cls)+      when (null cls && any (not . null . iApplyVars . namedClausePats) cls') $+        __IMPOSSIBLE__+      unlessM (optKeepCoveringClauses <$> pragmaOptions) $+        modifySignature $ updateDefinition f $ updateTheDef+          $ updateCovering (const [])++      traceCall (CheckFunDefCall (getRange f) f [] False) $+        forM_ cls $ checkIApplyConfluence f+    _ -> return ()++-- | @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 (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+          forM_ (iApplyVars ps) $ \ i -> do+            unview <- intervalUnview'+            let phi = unview $ IMax (argN $ unview (INeg $ argN $ var i)) $ argN $ var i+            let es = patternsToElims ps+            let lhs = Def f es++            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++            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)++                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++                  -- 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'++                        -- 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++                -- 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+              -- ^ variables to keep   Γ ⊢ x_n .. x_0 : Γ+           -> Args+              -- ^ variables to solve  Γ.Δ ⊢ ts : Γ+           -> (Substitution -> [(Term,Term)] -> TCM a)+              -- Γ.Δ' ⊢ σ : Γ.Δ+              -- Γ.Δ' new current context.+              -- Γ.Δ' ⊢ [(x = u)]+              -- Γ.Δ', [(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, 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, 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__++  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 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 <$> cubicalOption) (enterClosure cl $ k []) $ do+                  mv <- lookupLocalMeta m+                  enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢+                  ty <- metaType m+                  mTel0 <- getContextTelescope+                  unless (size mTel0 == size es_m) $ reportSDoc "tc.iapply.ip.meta" 20 $ "funny number of elims" <+> text (show (size mTel0, size es_m))+                  unless (size mTel0 <= size es_m) $ __IMPOSSIBLE__ -- meta has at least enough arguments to fill its creation context.+                  reportSDoc "tc.iapply.ip.meta" 20 $ "ty: " <+> prettyTCM ty++                  -- if we have more arguments we extend the telescope accordingly.+                  TelV mTel1 _ <- telViewUpToPath (size es_m) ty+                  addContext (mTel1 `apply` teleArgs mTel0) $ do+                  mTel <- getContextTelescope+                  reportSDoc "tc.iapply.ip.meta" 20 $ "mTel: " <+> prettyTCM mTel++                  es_m <- return $ take (size mTel) es_m+                  -- invariant: size mTel == size es_m++                  (c,cxt) <- enterClosure cl $ \ c -> (c,) <$> getContextTelescope+                  reportSDoc "tc.iapply.ip.meta" 20 $ prettyTCM cxt++                  addContext cxt $ do++                  reportSDoc "tc.iapply.ip.meta" 20 $ "es_m" <+> prettyTCM es_m++                  reportSDoc "tc.iapply.ip.meta" 20 $ "trying unifyElims"++                  unifyElims (teleArgs mTel) es_m $ \ sigma eqs -> do++                  reportSDoc "tc.iapply.ip.meta" 20 $ "gotten a substitution"++                  reportSDoc "tc.iapply.ip.meta" 20 $ "sigma:" <+> prettyTCM sigma+                  reportSDoc "tc.iapply.ip.meta" 20 $ "sigma:" <+> pretty sigma++                  k eqs (sigma `applySubst` c)
src/full/Agda/TypeChecking/Implicit.hs view
@@ -1,125 +1,199 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}  {-| Functions for inserting implicit arguments at the right places. -} module Agda.TypeChecking.Implicit where -import Control.Applicative import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class +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 import {-# SOURCE #-} Agda.TypeChecking.MetaVars+import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (unquoteTactic) import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute 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+import Agda.Utils.Maybe import Agda.Utils.Tuple -#include "undefined.h"-import Agda.Utils.Impossible+-- Cut and paste from insertImplicitPatternsT: --- | @implicitArgs n expand eti t@ generates up to @n@ implicit arguments+-- | 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++  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.------   If explicit arguments are to be inserted as well, they are---   inserted as instance arguments (used for recursive instance search). -implicitArgs :: Int -> (Hiding -> Bool) -> Type -> TCM (Args, Type)+implicitArgs+  :: (PureTCM m, MonadMetaSolver m, MonadTCM m)+  => Int               -- ^ @n@, the maximum number of implicts to be inserted.+  -> (Hiding -> Bool)  -- ^ @expand@, the predicate to test whether we should keep inserting.+  -> Type              -- ^ The (function) type @t@ we are eliminating.+  -> m (Args, Type)  -- ^ The eliminating arguments and the remaining type. implicitArgs n expand t = mapFst (map (fmap namedThing)) <$> do   implicitNamedArgs n (\ h x -> expand h) t --- | @implicitNamedArgs n expand eti t@ generates up to @n@ named implicit arguments+-- | @implicitNamedArgs n expand t@ generates up to @n@ named implicit arguments --   metas (unbounded if @n<0@), as long as @t@ is a function type --   and @expand@ holds on the hiding and name info of its domain.------   If explicit arguments are to be inserted as well, they are---   inserted as instance arguments (used for recursive instance search). -implicitNamedArgs :: Int -> (Hiding -> ArgName -> Bool) -> Type -> TCM (NamedArgs, Type)+implicitNamedArgs+  :: (PureTCM m, MonadMetaSolver m, MonadTCM m)+  => Int                          -- ^ @n@, the maximum number of implicts to be inserted.+  -> (Hiding -> ArgName -> Bool)  -- ^ @expand@, the predicate to test whether we should keep inserting.+  -> Type                         -- ^ The (function) type @t@ we are eliminating.+  -> m (NamedArgs, Type)        -- ^ The eliminating arguments and the remaining type. implicitNamedArgs 0 expand t0 = return ([], t0) implicitNamedArgs n expand t0 = do     t0' <- reduce t0-    case ignoreSharing $ unEl t0' of-      Pi (Dom info a) b | let x = absName b, expand (getHiding info) x -> do-          info' <- if getHiding info == Hidden then return info else do+    reportSDoc "tc.term.args" 30 $ "implicitNamedArgs" <+> prettyTCM t0'+    reportSDoc "tc.term.args" 80 $ "implicitNamedArgs" <+> text (show t0')+    case unEl t0' of+      Pi dom@Dom{domInfo = info, domTactic = tac, unDom = a} b+        | let x = bareNameWithDefault "_" dom, expand (getHiding info) x -> do+          kind <- if hidden info then return UnificationMeta else do             reportSDoc "tc.term.args.ifs" 15 $-              text "inserting instance meta for type" <+> prettyTCM a-            return $ setHiding Instance info-          (_, v) <- newMetaArg info' x a-          let narg = Arg info (Named (Just $ unranged x) v)+              "inserting instance meta for type" <+> prettyTCM a+            reportSDoc "tc.term.args.ifs" 40 $ nest 2 $ vcat+              [ "x      = " <+> text (show x)+              , "hiding = " <+> text (show $ getHiding info)+              ]++            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-  :: ArgInfo   -- ^ Kind/relevance of meta.-  -> ArgName   -- ^ Name suggestion for meta.-  -> Type      -- ^ Type of meta.-  -> TCM (MetaId, Term)  -- ^ The created meta as id and as term.-newMetaArg info x a = do-  applyRelevanceToContext (getRelevance info) $-    newMeta (getHiding info) (argNameToString x) a+  :: (PureTCM m, MonadMetaSolver m)+  => 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 kind info x cmp a = do+  prp <- runBlocked $ isPropM a+  let irrelevantIfProp =+        applyWhen (prp == Right True) $ applyRelevanceToContext irrelevant+  applyModalityToContext info $ irrelevantIfProp $+    newMeta (argNameToString x) kind a   where-    newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term)-    newMeta Instance  = newIFSMeta-    newMeta Hidden    = newNamedValueMeta RunMetaOccursCheck-    newMeta NotHidden = newNamedValueMeta RunMetaOccursCheck+    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.-  -> ArgName   -- ^ Name suggestion for meta.-  -> Type      -- ^ Type 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 a = do-  applyRelevanceToContext (getRelevance info) $-    newMeta (getHiding info) (argNameToString x) a-  where-    newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term)-    newMeta Instance  = newIFSMeta-    newMeta Hidden    = newNamedValueMeta' DontRunMetaOccursCheck-    newMeta NotHidden = newNamedValueMeta' DontRunMetaOccursCheck+newInteractionMetaArg info x cmp a = do+  applyModalityToContext info $+    newNamedValueMeta' RunMetaOccursCheck (argNameToString x) cmp a  --------------------------------------------------------------------------- +-- | Possible results of 'insertImplicit'. data ImplicitInsertion-      = ImpInsert [Hiding]        -- ^ this many implicits have to be inserted-      | BadImplicits      -- ^ hidden argument where there should have been a non-hidden arg-      | NoSuchName ArgName -- ^ bad named argument-      | NoInsertNeeded+      = ImpInsert [Dom ()] -- ^ Success: this many implicits have to be inserted (list can be empty).+      | BadImplicits       -- ^ Error: hidden argument where there should have been a non-hidden argument.+      | NoSuchName ArgName -- ^ Error: bad named argument.   deriving (Show) -impInsert :: [Hiding] -> ImplicitInsertion-impInsert [] = NoInsertNeeded-impInsert hs = ImpInsert hs+pattern NoInsertNeeded :: ImplicitInsertion+pattern NoInsertNeeded = ImpInsert [] --- | The list should be non-empty.-insertImplicit :: NamedArg e -> [Arg ArgName] -> ImplicitInsertion-insertImplicit _ [] = __IMPOSSIBLE__-insertImplicit a ts | notHidden a = impInsert $ nofHidden ts-  where-    nofHidden :: [Arg a] -> [Hiding]-    nofHidden = takeWhile (NotHidden /=) . map getHiding-insertImplicit a ts =-  case nameOf (unArg a) of-    Nothing -> maybe BadImplicits impInsert $ upto (getHiding a) $ map getHiding ts-    Just x  -> find [] (rangedThing x) (getHiding a) ts-  where-    upto h [] = Nothing-    upto h (NotHidden:_) = Nothing-    upto h (h':_) | h == h' = Just []-    upto h (h':hs) = (h':) <$> upto h hs-    find :: [Hiding] -> ArgName -> Hiding -> [Arg ArgName] -> ImplicitInsertion-    find _ x _ (a@(Arg{}) : _) | notHidden a = NoSuchName x-    find hs x hidingx (a@(Arg _ y) : ts)-      | x == y && hidingx == getHiding a = impInsert $ reverse hs-      | x == y && hidingx /= getHiding a = BadImplicits-      | otherwise = find (getHiding a:hs) x hidingx ts-    find i x _ []                            = NoSuchName x+-- | If the next given argument is @a@ and the expected arguments are @ts@+--   @insertImplicit' a ts@ returns the prefix of @ts@ that precedes @a@.+--+--   If @a@ is named but this name does not appear in @ts@, the 'NoSuchName' exception is thrown.+--+insertImplicit+  :: NamedArg e  -- ^ Next given argument @a@.+  -> [Dom a]     -- ^ Expected arguments @ts@.+  -> ImplicitInsertion+insertImplicit a doms = insertImplicit' a $+  for doms $ \ dom ->+    dom $> bareNameWithDefault "_" dom++-- | If the next given argument is @a@ and the expected arguments are @ts@+--   @insertImplicit' a ts@ returns the prefix of @ts@ that precedes @a@.+--+--   If @a@ is named but this name does not appear in @ts@, the 'NoSuchName' exception is thrown.+--+insertImplicit'+  :: NamedArg e     -- ^ Next given argument @a@.+  -> [Dom ArgName]  -- ^ Expected arguments @ts@.+  -> ImplicitInsertion+insertImplicit' _ [] = BadImplicits+insertImplicit' a ts++  -- If @a@ is visible, then take the non-visible prefix of @ts@.+  | visible a = ImpInsert $ takeWhile notVisible $ map void ts++  -- If @a@ is named, take prefix of @ts@ until the name of @a@ (with correct hiding).+  -- If the name is not found, throw exception 'NoSuchName'.+  | Just x <- bareNameOf a = maybe (NoSuchName x) ImpInsert $+      takeHiddenUntil (\ t -> x == unDom t && sameHiding a t) ts++  -- If @a@ is neither visible nor named, take prefix of @ts@ with different hiding than @a@.+  | otherwise = maybe BadImplicits ImpInsert $+      takeHiddenUntil (sameHiding a) ts++    where+    -- @takeHiddenUntil p ts@ returns the 'getHiding' of the prefix of @ts@+    -- until @p@ holds or a visible argument is encountered.+    -- If @p@ never holds, 'Nothing' is returned.+    --+    --   Precondition: @p@ should imply @not . visible@.+    takeHiddenUntil :: (Dom ArgName -> Bool) -> [Dom ArgName] -> Maybe [Dom ()]+    takeHiddenUntil p ts =+      case ts2 of+        []      -> Nothing  -- Predicate was never true+        (t : _) -> if visible t then Nothing else Just $ map void ts1+      where+      (ts1, ts2) = break (\ t -> p t || visible t) ts
src/full/Agda/TypeChecking/Injectivity.hs view
@@ -1,49 +1,95 @@-{-# LANGUAGE CPP           #-}+{- | -module Agda.TypeChecking.Injectivity where+"Injectivity", or more precisely, "constructor headedness", is a+property of functions defined by pattern matching that helps us solve+constraints involving blocked applications of such functions.+"Blocked" shall mean here that pattern matching is blocked on a meta+variable, and constructor headedness lets us learn more about that+meta variable. -import Prelude hiding (mapM)+Consider the simple example:+@+  isZero : Nat -> Bool+  isZero zero    = true+  isZero (suc n) = false+@+This function is constructor-headed, meaning that all rhss are headed+by a distinct constructor.  Thus, on a constraint like+@+  isZero ?X = false : Bool+@+involving an application of @isZero@ that is blocked on meta variable @?X@,+we can exploit injectivity and learn that @?X = suc ?Y@ for a new+meta-variable @?Y@. +Which functions qualify for injectivity?++1. The function needs to have at least one non-absurd clause that has+a proper match, meaning that the function can actually be blocked on a+meta.  Proper matches are these patterns:++  - data constructor (@ConP@, but not record constructor)+  - literal (@LitP@)+  - HIT-patterns (@DefP@)++Projection patterns (@ProjP@) are excluded because metas cannot occupy their place!++2. All the clauses that satisfy (1.) need to be headed by a distinct constructor.++-}++module Agda.TypeChecking.Injectivity where+ import Control.Applicative-import Control.Monad.State hiding (mapM, forM)-import Control.Monad.Reader hiding (mapM, forM)+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 Data.Map (Map) 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 Agda.TypeChecking.Primitive import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Conversion import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Constraints import Agda.TypeChecking.Polarity+import Agda.TypeChecking.Warnings -import Agda.Utils.Except ( MonadError(catchError, throwError) )+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.Syntax.Common.Pretty ( prettyShow )+import qualified Agda.Utils.ProfileOptions as Profile -#include "undefined.h" import Agda.Utils.Impossible  headSymbol :: Term -> TCM (Maybe TermHead) headSymbol v = do -- ignoreAbstractMode $ do   -- Andreas, 2013-02-18 ignoreAbstractMode leads to information leakage -  v <- ignoreBlocking <$> reduceHead v-  case ignoreSharing v of+  v <- constructorForm =<< ignoreBlocking <$> reduceHead v+  case v of     Def f _ -> do       let yes = return $ Just $ ConsHead f           no  = return $ Nothing@@ -54,210 +100,406 @@       case def of         Datatype{}  -> yes         Record{}    -> yes+        DataOrRecSig{} -> yes         Axiom{}     -> do-          reportSLn "tc.inj.axiom" 50 $ "headSymbol: " ++ show f ++ " is an Axiom."+          reportSLn "tc.inj.axiom" 50 $ "headSymbol: " ++ prettyShow f ++ " is an Axiom."           -- Don't treat axioms in the current mutual block           -- as constructors (they might have definitions we           -- don't know about yet).-          caseMaybeM (asks envMutualBlock) yes $ \ mb -> do+          caseMaybeM (asksTC envMutualBlock) yes $ \ mb -> do             fs <- mutualNames <$> lookupMutualBlock mb             if Set.member f fs then no else yes         Function{}    -> no         Primitive{}   -> no+        PrimitiveSort{} -> no+        GeneralizableVar{} -> __IMPOSSIBLE__         Constructor{} -> __IMPOSSIBLE__-        AbstractDefn  -> __IMPOSSIBLE__-    Con c _ _ -> return (Just $ ConsHead $ conName c)+        AbstractDefn{}-> __IMPOSSIBLE__+    -- Andreas, 2019-07-10, issue #3900: canonicalName needs ignoreAbstractMode+    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)-    Lit _   -> return Nothing -- handle literal heads as well? can't think of-                              -- any examples where it would be useful...+    Var i [] -> return (Just $ VarHead i) -- Only naked variables. Otherwise substituting a neutral term is not guaranteed to stay neutral.+    Lit _   -> return Nothing -- TODO: LitHead (for literals with no constructorForm)     Lam{}   -> return Nothing     Var{}   -> return Nothing     Level{} -> return Nothing     MetaV{} -> return Nothing     DontCare{} -> return Nothing-    Shared{}   -> __IMPOSSIBLE__+    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. 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)+headSymbol' v = do+  v <- traverse constructorForm =<< reduceB v+  case v of+    Blocked{} -> return Nothing+    NotBlocked _ v -> case v of+      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+      Lit _      -> return Nothing+      Lam{}      -> return Nothing+      Level{}    -> return Nothing+      DontCare{} -> return Nothing+      MetaV{}    -> __IMPOSSIBLE__+      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++-- | Does deBruijn variable i correspond to a top-level argument, and if so+--   which one (index from the left).+topLevelArg :: Clause -> Int -> Maybe TermHead+topLevelArg Clause{ namedClausePats = ps } i =+  case [ n | (n, VarP _ (DBPatVar _ j)) <- zip [0..] $ map namedArg ps, i == j ] of+    []    -> Nothing+    [n]   -> Just (VarHead n)+    _:_:_ -> __IMPOSSIBLE__++-- | Join a list of inversion maps.+joinHeadMaps :: [InversionMap c] -> InversionMap c+joinHeadMaps = Map.unionsWith (<>)++-- | Update the heads of an inversion map.+updateHeads :: Monad m => (TermHead -> [c] -> m TermHead) -> InversionMap c -> m (InversionMap c)+updateHeads f m = joinHeadMaps <$> mapM f' (Map.toList m)+  where f' (h, c) = (`Map.singleton` c) <$> f h c+ checkInjectivity :: QName -> [Clause] -> TCM FunctionInverse-checkInjectivity f cs-  | pointLess cs = do-      reportSLn "tc.inj.check.pointless" 20 $-        "Injectivity of " ++ show (A.qnameToConcrete f) ++ " would be pointless."+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   where-    -- Is it pointless to use injectivity for this function?-    pointLess []      = True-    pointLess (_:_:_) = False-    pointLess [cl] = not $ any (properlyMatching . namedArg) $ namedClausePats cl-        -- Andreas, 2014-06-12-        -- If we only have record patterns, it is also pointless.-        -- We need at least one proper match.-checkInjectivity f cs = do-  reportSLn "tc.inj.check" 40 $ "Checking injectivity of " ++ show f-  -- Extract the head symbol of the rhs of each clause (skip absurd clauses)-  es <- catMaybes <$> do-    forM cs $ \ c -> do             -- produces a list ...-      mapM ((,c) <.> headSymbol) $ clauseBody c -- ... of maybes-  let (hs, ps) = unzip es-  reportSLn "tc.inj.check" 40 $ "  right hand sides: " ++ show hs-  if all isJust hs && distinct hs-    then do-      let inv = Map.fromList (map fromJust hs `zip` ps)-      reportSLn "tc.inj.check" 20 $ show f ++ " is injective."-      reportSDoc "tc.inj.check" 30 $ nest 2 $ vcat $-        for (Map.toList inv) $ \ (h, c) ->-          text (show h) <+> text "-->" <+>-          fsep (punctuate comma $ map (prettyTCM . namedArg) $ namedClausePats c)-      return $ Inverse inv-    else return NotInjective+    -- We can filter out absurd clauses.+    cs = filter (isJust . clauseBody) cs0+    -- We cannot filter out clauses that have no proper match, because+    -- these could be catch-all clauses.+    -- However, we need at least one proper match to get injectivity started.+    properlyMatchingClause =+      anyM (properlyMatching' False False . namedArg) . namedClausePats +-- | Precondition: all the given clauses are non-absurd and contain a proper match.+checkInjectivity' :: QName -> [Clause] -> TCM FunctionInverse+checkInjectivity' f cs = fromMaybe NotInjective <.> runMaybeT $ do+  reportSLn "tc.inj.check" 40 $ "Checking injectivity of " ++ prettyShow f++  let varToArg :: Clause -> TermHead -> MaybeT TCM TermHead+      varToArg c (VarHead i) = MaybeT $ return $ topLevelArg c i+      varToArg _ h           = return h++  -- We don't need to consider absurd clauses+  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+              headSymbol body+        return [Map.singleton h [c]]+      computeHead _ = return []++  hdMap <- joinHeadMaps . concat <$> mapM computeHead cs++  case Map.lookup UnknownHead hdMap of+    Just (_:_:_) -> empty -- More than one unknown head: we can't really do anything in that case.+    _            -> return ()++  reportSLn  "tc.inj.check" 20 $ prettyShow f ++ " is potentially injective."+  reportSDoc "tc.inj.check" 30 $ nest 2 $ vcat $+    for (Map.toList hdMap) $ \ (h, uc) ->+      text (prettyShow h) <+> "-->" <+>+      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+--   instance, the clause might be `f ps = u , v` and the actual call `f vs+--   .fst`. In this case the head will be the head of `u` rather than `_,_`.+checkOverapplication+  :: forall m. (HasConstInfo m)+  => Elims -> InversionMap Clause -> m (InversionMap Clause)+checkOverapplication es = updateHeads overapplied+  where+    overapplied :: TermHead -> [Clause] -> m TermHead+    overapplied h cs | all (not . isOverapplied) cs = return h+    overapplied h cs = ifM (isSuperRigid h) (return h) (return UnknownHead)++    -- A super-rigid head is one that can't be eliminated. Crucially, this is+    -- applied after instantiateVars, so VarHeads are really bound variables.+    isSuperRigid SortHead     = return True+    isSuperRigid PiHead       = return True+    isSuperRigid VarHead{}    = return True+    isSuperRigid UnknownHead  = return True -- or False, doesn't matter+    isSuperRigid (ConsHead q) = do+      def <- getConstInfo q+      return $ case theDef def of+        Axiom{}        -> True+        DataOrRecSig{} -> True+        AbstractDefn{} -> True+        Function{}     -> False+        Datatype{}     -> True+        Record{}       -> True+        Constructor{conSrcCon = ConHead{ conDataRecord = d, conFields = fs }}+                       -> d == IsData || null fs   -- Record constructors can be eliminated by projections+        Primitive{}    -> False+        PrimitiveSort{} -> __IMPOSSIBLE__+        GeneralizableVar{} -> __IMPOSSIBLE__+++    isOverapplied Clause{ namedClausePats = ps } = length es > length ps++-- | Turn variable heads, referring to top-level argument positions, into+--   proper heads. These might still be `VarHead`, but in that case they refer to+--   deBruijn variables. Checks that the instantiated heads are still rigid and+--   distinct.+instantiateVarHeads+  :: forall m c. (PureTCM m, MonadError TCErr m)+  => QName -> Elims -> InversionMap c -> m (Maybe (InversionMap c))+instantiateVarHeads f es m = runMaybeT $ updateHeads (const . instHead) m+  where+    instHead :: TermHead -> MaybeT m TermHead+    instHead h@(VarHead i)+      | Just (Apply arg) <- es !!! i = MaybeT $ headSymbol' (unArg arg)+      | otherwise = empty   -- impossible?+    instHead h = return h+ -- | Argument should be in weak head normal form.-functionInverse :: Term -> TCM InvView-functionInverse v = case ignoreSharing v of+functionInverse+  :: (PureTCM m, MonadError TCErr m)+  => Term -> m InvView+functionInverse = \case   Def f es -> do-    d <- theDef <$> getConstInfo f-    case d of-      Function{ funInv = inv } -> case inv of-        NotInjective  -> return NoInv-        Inverse m     -> return $ Inv 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)-      _ -> return NoInv+    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)+        -- NB: Invertible functions are never classified as+        --     projection-like, so this is fine, we are not+        --     missing parameters.  (Andreas, 2013-11-01)   _ -> return NoInv -data InvView = Inv QName [Elim] (Map TermHead Clause)+data InvView = Inv QName [Elim] (InversionMap Clause)              | NoInv -data MaybeAbort = Abort | KeepGoing+-- | Precondition: The first term must be blocked on the given meta and the second must be neutral.+useInjectivity :: MonadConversion m => CompareDirection -> Blocker -> CompareAs -> Term -> Term -> m ()+useInjectivity dir blocker ty blk neu = locallyTC eInjectivityDepth succ $ do+  inv <- functionInverse blk+  -- Injectivity might cause non-termination for unsatisfiable constraints+  -- (#431, #3067). Look at the number of active problems and the injectivity+  -- depth to detect this.+  nProblems <- Set.size <$> viewTC eActiveProblems+  injDepth  <- viewTC eInjectivityDepth+  let depth = max nProblems injDepth+  maxDepth  <- maxInversionDepth+  case inv of+    NoInv            -> fallback  -- not invertible+    Inv f blkArgs hdMap+      | depth > maxDepth -> warning (InversionDepthReached f) >> fallback+      | otherwise -> do+      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+        -- Crucially, this relies on `f vs` being neutral and only works+        -- if `f` is not a possible head for `f us`.+        Def f' neuArgs | f == f', not canReduceToSelf -> do+          fTy <- defType <$> getConstInfo f+          reportSDoc "tc.inj.use" 20 $ vcat+            [ fsep (pwords "comparing application of injective function" ++ [prettyTCM f] +++                  pwords "at")+            , nest 2 $ fsep $ punctuate comma $ map prettyTCM blkArgs+            , nest 2 $ fsep $ punctuate comma $ map prettyTCM neuArgs+            , nest 2 $ "and type" <+> prettyTCM fTy+            ]+          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 -useInjectivity :: Comparison -> Type -> Term -> Term -> TCM ()-useInjectivity cmp a u v = do-  reportSDoc "tc.inj.use" 30 $ fsep $-    pwords "useInjectivity on" ++-    [ prettyTCM u, prettyTCM cmp, prettyTCM v, text ":", prettyTCM a-    ]-  uinv <- functionInverse u-  vinv <- functionInverse v-  case (uinv, vinv) of-    -- Andreas, Francesco, 2014-06-12:-    -- We know that one of u,v is neutral-    -- (see calls to useInjectivity in Conversion.hs).-    -- Otherwise, (e.g. if both were Blocked), the following case would be-    -- unsound, since it assumes the arguments to be pointwise equal.-    -- It would deliver non-unique solutions for metas.-    (Inv f fArgs _, Inv g gArgs _)-      | f == g    -> do-        a <- defType <$> getConstInfo f-        reportSDoc "tc.inj.use" 20 $ vcat-          [ fsep (pwords "comparing application of injective function" ++ [prettyTCM f] ++-                pwords "at")-          , nest 2 $ fsep $ punctuate comma $ map prettyTCM fArgs-          , nest 2 $ fsep $ punctuate comma $ map prettyTCM gArgs-          , nest 2 $ text "and type" <+> prettyTCM a-          ]-        pol <- getPolarity' cmp f-        compareElims pol a (Def f []) fArgs gArgs-      | otherwise -> fallBack-    (Inv f args inv, NoInv) -> do-      a <- defType <$> getConstInfo f-      reportSDoc "tc.inj.use" 20 $ fsep $-        pwords "inverting injective function" ++-        [ prettyTCM f, text ":", prettyTCM a, text "for", prettyTCM v-        , parens $ text "args =" <+> prettyList (map prettyTCM args)-        ]-      invert u f a inv args =<< headSymbol v-    (NoInv, Inv g args inv) -> do-      a <- defType <$> getConstInfo g-      reportSDoc "tc.inj.use" 20 $ fsep $-        pwords "inverting injective function" ++-        [ prettyTCM g, text ":", prettyTCM a,  text "for", prettyTCM u-        , parens $ text "args =" <+> prettyList (map prettyTCM args)-        ]-      invert v g a inv args =<< headSymbol u-    (NoInv, NoInv)          -> fallBack+        -- f us == c vs+        --    Find the clause unique clause `f ps` with head `c` and unify+        --    us == ps  with fresh metas for the pattern variables of ps.+        --    If there's no such clause we can safely throw an error.+        _ -> headSymbol' neu >>= \ case+          Nothing -> do+            reportSDoc "tc.inj.use" 20 $ fsep $+              pwords "no head symbol found for" ++ [prettyTCM neu] ++ pwords ", so not inverting"+            fallback+          Just (ConsHead f') | f == f', canReduceToSelf -> do+            reportSDoc "tc.inj.use" 20 $ fsep $+              pwords "head symbol" ++ [prettyTCM f'] ++ pwords "can reduce to self, so not inverting"+            fallback+                                    -- We can't invert in this case, since we can't+                                    -- tell the difference between a solution that makes+                                    -- the blocked term neutral and one that makes progress.+          Just hd -> invertFunction cmp blk inv hd fallback err success+            where err = typeError $ app (\ u v -> UnequalTerms cmp u v ty) blk neu   where-    fallBack = addConstraint $ ValueCmp cmp a u v+    fallback     = addConstraint blocker $ app (ValueCmp cmp ty) blk neu+    success blk' = app (compareAs cmp ty) blk' neu -    invert :: Term -> QName -> Type -> Map TermHead Clause -> [Elim] -> Maybe TermHead -> TCM ()-    invert _ _ a inv args Nothing  = fallBack-    invert org f ftype inv args (Just h) = case Map.lookup h inv of-      Nothing -> typeError $ UnequalTerms cmp u v a-      Just cl@Clause{ clauseTel  = tel } -> maybeAbort $ do+    cmpApp :: (Comparison, (a -> a -> b) -> a -> a -> b)+    cmpApp = case dir of+      DirEq -> (CmpEq, id)+      DirLeq -> (CmpLeq, id)+      DirGeq -> (CmpLeq, flip)+    (cmp, app) = cmpApp++-- | The second argument should be a blocked application and the third argument+--   the inverse of the applied function.+invertFunction+  :: MonadConversion m+  => Comparison -> Term -> InvView -> TermHead -> m () -> m () -> (Term -> m ()) -> m ()+invertFunction _ _ NoInv _ fallback _ _ = fallback+invertFunction cmp blk (Inv f blkArgs hdMap) hd fallback err success = do+    fTy <- defType <$> getConstInfo f+    reportSDoc "tc.inj.use" 20 $ vcat+      [ "inverting injective function" <?> hsep [prettyTCM f, ":", prettyTCM fTy]+      , "for" <?> pretty hd+      , nest 2 $ "args =" <+> prettyList (map prettyTCM blkArgs)+      ]                         -- Clauses with unknown heads are also possible candidates+    case fromMaybe [] $ Map.lookup hd hdMap <> Map.lookup UnknownHead hdMap of+      [] -> err+      _:_:_ -> fallback+      [cl@Clause{ clauseTel  = tel }] -> speculateMetas fallback $ do           let ps   = clausePats cl               perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl           -- These are what dot patterns should be instantiated at           ms <- map unArg <$> newTelMeta tel           reportSDoc "tc.inj.invert" 20 $ vcat-            [ text "meta patterns" <+> prettyList (map prettyTCM ms)-            , text "  perm =" <+> text (show perm)-            , text "  tel  =" <+> prettyTCM tel-            , text "  ps   =" <+> prettyList (map (text . show) ps)+            [ "meta patterns" <+> prettyList (map prettyTCM ms)+            , "  perm =" <+> text (show perm)+            , "  tel  =" <+> prettyTCM tel+            , "  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           let sub   = parallelS (reverse ms)           margs <- runReaderT (evalStateT (mapM metaElim ps) msAux) sub           reportSDoc "tc.inj.invert" 20 $ vcat-            [ text "inversion"+            [ "inversion"             , nest 2 $ vcat-              [ text "lhs  =" <+> prettyTCM margs-              , text "rhs  =" <+> prettyTCM args-              , text "type =" <+> prettyTCM ftype+              [ "lhs  =" <+> prettyTCM margs+              , "rhs  =" <+> prettyTCM blkArgs+              , "type =" <+> prettyTCM fTy               ]             ]           -- Since we do not care for the value of non-variant metas here,           -- we can treat 'Nonvariant' as 'Invariant'.           -- That ensures these metas do not remain unsolved.           pol <- purgeNonvariant <$> getPolarity' cmp f+          fs  <- getForcedArgs f           -- The clause might not give as many patterns as there           -- are arguments (point-free style definitions).-          let args' = take (length margs) args-          compareElims pol ftype (Def f []) margs args'-{- Andreas, 2011-05-09 allow unsolved constraints as long as progress-          unless (null cs) $ do-            reportSDoc "tc.inj.invert" 30 $-              text "aborting inversion; remaining constraints" <+> prettyTCM cs-            patternViolation--}-          -- Check that we made progress, i.e. the head symbol-          -- of the original term should be a constructor.-          org <- reduce org-          h <- headSymbol org-          case h of-            Just h  -> KeepGoing <$ compareTerm cmp a u v-            Nothing -> do+          let blkArgs' = take (length margs) blkArgs+          compareElims pol fs fTy (Def f []) margs blkArgs'++          -- Check that we made progress.+          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]+              KeepMetas <$ success blk'+            NoReduction{}       -> do               reportSDoc "tc.inj.invert" 30 $ vcat-                [ text "aborting inversion;" <+> prettyTCM org-                , text "plainly," <+> text (show org)-                , text "has TermHead" <+> text (show h)-                , text "which does not expose a constructor"+                [ "aborting inversion;" <+> prettyTCM blk+                , "does not reduce"                 ]-              return Abort--    maybeAbort m = do-      (a, s) <- localTCStateSaving m-      case a of-        KeepGoing -> put s-        Abort     -> fallBack-+              return RollBackMetas+  where+    nextMeta :: (MonadState [Term] m) => m Term     nextMeta = do-      m : ms <- get+      (m, ms) <- gets (fromMaybe __IMPOSSIBLE__ . uncons)       put ms       return m -    dotP :: Monad m => Term -> StateT [Term] (ReaderT Substitution m) Term+    dotP :: MonadReader Substitution m => Term -> m Term     dotP v = do       sub <- ask       return $ applySubst sub v -    metaElim (Arg _ (ProjP o p))  = lift $ lift $ Proj o <$> getOriginalProjection p+    metaElim+      :: (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)+      => [NamedArg DeBruijnPattern] -> m Args     metaArgs args = mapM (traverse $ metaPat . namedThing) args -    metaPat (DotP v)         = dotP v-    metaPat (VarP _)         = nextMeta-    metaPat (ConP c mt args) = Con c (fromConPatternInfo mt) <$> metaArgs args-    metaPat (LitP l)         = return $ Lit l+    metaPat+      :: (MonadState [Term] m, MonadReader Substitution m)+      => DeBruijnPattern -> m Term+    metaPat (DotP _ v)       = dotP v+    metaPat (VarP _ _)       = nextMeta+    metaPat (IApplyP{})      = nextMeta+    metaPat (ConP c mt args) = Con c (fromConPatternInfo mt) . map Apply <$> metaArgs args+    metaPat (DefP o q args)  = Def q . map Apply <$> metaArgs args+    metaPat (LitP _ l)       = return $ Lit l     metaPat ProjP{}          = __IMPOSSIBLE__++forcePiUsingInjectivity :: Type -> TCM Type+forcePiUsingInjectivity t = reduceB t >>= \ case+    Blocked _ blkTy -> do+      let blk = unEl blkTy+      inv <- functionInverse blk+      blkTy <$ invertFunction CmpEq blk inv PiHead fallback err success+    NotBlocked _ t -> return t+  where+    fallback  = return ()+    err       = typeError (ShouldBePi t)+    success _ = return ()
+ src/full/Agda/TypeChecking/Inlining.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Logic for deciding which functions should be automatically inlined.+module Agda.TypeChecking.Inlining (autoInline) where++import qualified Data.IntMap as IntMap++import Agda.Interaction.Options+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Free+import Agda.Utils.Lens++-- | Mark a definition to be inlined if it satisfies the inlining criterion.+autoInline :: Defn -> TCM Defn+autoInline defn = do+  inlining <- optAutoInline <$> pragmaOptions+  if | inlining, shouldInline defn -> return $ set funInline True defn+     | otherwise                   -> return defn++shouldInline :: Defn -> Bool+shouldInline Function{funCompiled = Just cc} = shouldInline' cc+shouldInline _ = False++-- Only auto-inline simple definitions (no pattern matching) where no variable+-- is used more than once, and some variables are not used at all.+shouldInline' :: CompiledClauses -> Bool+shouldInline' (Done xs body) = all (< 2) counts && length counts < length xs+  where counts = IntMap.elems $ varCounts $ freeVars body+shouldInline' _ = False
src/full/Agda/TypeChecking/InstanceArguments.hs view
@@ -1,566 +1,1222 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.InstanceArguments where--import Control.Applicative hiding (empty)-import Control.Monad.Reader-import Control.Monad.State-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List as List--import Agda.Syntax.Common-import Agda.Syntax.Internal as I-import Agda.Syntax.Scope.Base (isNameInScope)--import Agda.TypeChecking.Errors ()-import Agda.TypeChecking.Implicit (implicitArgs)-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Records-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Free--import {-# SOURCE #-} Agda.TypeChecking.Constraints-import {-# SOURCE #-} Agda.TypeChecking.MetaVars-import {-# SOURCE #-} Agda.TypeChecking.Conversion--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Functor-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.Null (empty)--#include "undefined.h"-import Agda.Utils.Impossible---- | Compute a list of instance candidates.---   'Nothing' if type is a meta, error if type is not eligible---   for instance search.-initialIFSCandidates :: Type -> TCM (Maybe [Candidate])-initialIFSCandidates t = do-  cands1 <- getContextVars-  otn <- getOutputTypeName t-  case otn of-    NoOutputTypeName -> typeError $ GenericError $ "Instance search can only be used to find elements in a named type"-    OutputTypeNameNotYetKnown -> return Nothing-    OutputTypeVar -> return $ Just cands1-    OutputTypeName n -> do-      cands2 <- getScopeDefs n-      return $ Just $ cands1 ++ cands2-  where-    -- get a list of variables with their type, relative to current context-    getContextVars :: TCM [Candidate]-    getContextVars = do-      ctx <- getContext-      let vars = [ Candidate (var i) (raise (i + 1) t) ExplicitStayExplicit (argInfoOverlappable info)-                 | (Dom info (x, t), i) <- zip ctx [0..]-                 , getHiding info == Instance-                 , not (unusableRelevance $ argInfoRelevance info)-                 ]--      -- {{}}-fields of variables are also candidates-      let cxtAndTypes = [ (var i, snd $ unDom $ raise (i + 1) t) | (i, t) <- zip [0..] ctx ]-      fields <- concat <$> mapM instanceFields (reverse cxtAndTypes)-      reportSDoc "tc.instance.fields" 30 $ text "instance field candidates" $$ nest 2 (vcat-        [ sep [ (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":"-              , nest 2 $ prettyTCM t ] | Candidate v t _ overlap <- fields ])--      -- get let bindings-      env <- asks envLetBindings-      env <- mapM (getOpen . snd) $ Map.toList env-      let lets = [ Candidate v t ExplicitStayExplicit False-                 | (v, Dom info t) <- env-                 , getHiding info == Instance-                 , not (unusableRelevance $ argInfoRelevance info)-                 ]-      return $ vars ++ fields ++ lets--    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 qnameToList r `isPrefixOf` mnameToList m-                then return (Just (r, vs))-                else return Nothing-        r -> return r--    instanceFields = instanceFields' True-    instanceFields' etaOnce (v, t) =-      caseMaybeM (etaExpand etaOnce =<< reduce t) (return []) $ \ (r, pars) -> do-        (tel, args) <- 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 (unArg arg) t ExplicitStayExplicit (argInfoOverlappable $ argInfo arg)-           | getHiding arg == Instance ] ++) <$>-          instanceFields' False (unArg arg, t)--    getScopeDefs :: QName -> TCM [Candidate]-    getScopeDefs n = do-      instanceDefs <- getInstanceDefs-      rel          <- asks envRelevance-      let qs = maybe [] Set.toList $ Map.lookup n instanceDefs-      catMaybes <$> mapM (candidate rel) qs--    candidate :: Relevance -> QName -> TCM (Maybe Candidate)-    candidate rel q =-      -- 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-        let r = defRelevance def-        if not (r `moreRelevant` rel) then return Nothing else do-          t   <- defType <$> instantiateDef def-          args <- freeVarsToApply q-          let v = case theDef def of-               -- drop parameters if it's a projection function...-               Function{ funProjection = Just p } -> projDropParsApply p ProjSystem 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-          inScope <- isNameInScope q <$> getScope-          return $ Candidate v t ExplicitToInstance False <$ guard inScope-      where-        -- unbound constant throws an internal error-        handle (TypeError _ (Closure {clValue = InternalError _})) = return Nothing-        handle err                                                 = throwError err---- | @findInScope 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.-findInScope :: MetaId -> Maybe [Candidate] -> TCM ()-findInScope 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 FindInScope constraint isn't known, trying to find it again."-    t <- getMetaType m----     -- We create a new meta (which can have additional leading lambdas, if the---     -- type @t@ now happens to be a function type) and the associated constraint---     newM <- initializeIFSMeta (miNameSuggestion $ mvInfo mv) t----     -- ... and we assign it to the previous one---     ctxElims <- map Apply <$> getContextArgs---     solveConstraint $ ValueCmp CmpEq t (MetaV m ctxElims) newM---- {--    cands <- initialIFSCandidates t-    case cands of-      Nothing -> addConstraint $ FindInScope m Nothing Nothing-      Just {} -> findInScope m cands--- -}-findInScope m (Just cands) =-  whenJustM (findInScope' m cands) $ (\ (cands, b) -> addConstraint $ FindInScope m b $ Just cands)---- | Result says whether we need to add constraint, and if so, the set of---   remaining candidates and an eventual blocking metavariable.-findInScope' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Maybe MetaId))-findInScope' m cands = ifM (isFrozen m) (return (Just (cands, Nothing))) $ do-  -- Andreas, 2013-12-28 issue 1003:-  -- If instance meta is already solved, simply discard the constraint.-  -- Ulf, 2016-12-06 issue 2325: But only if *fully* instantiated.-  ifM (isFullyInstantiatedMeta m) (return 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" 15 $-        "findInScope 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)-      reportSDoc "tc.instance" 60 $ nest 2 $ vcat-        [ sep [ (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":"-              , nest 2 $ prettyTCM t ] | Candidate v t _ overlap <- cands ]-      t <- normalise =<< getMetaTypeInContext m-      insidePi t $ \ t -> do-      reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t-      reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t--      -- If one of the arguments of the typeclass is a meta which is not rigidly-      -- constrained, then don’t do anything because it may loop.-      ifJustM (areThereNonRigidMetaArguments (unEl t)) (\ m -> do-        reportSLn "tc.instance" 15 "aborting due to non-rigidly constrained metas"-        return (Just (cands, Just m))) $ do--        mcands <- checkCandidates m t cands-        debugConstraints-        case mcands of--          Just [] -> do-            reportSDoc "tc.instance" 15 $-              text "findInScope 5: not a single candidate found..."-            typeError $ IFSNoCandidateInScope t--          Just [Candidate term t' _ _] -> do-            reportSDoc "tc.instance" 15 $ vcat-              [ text "findInScope 5: solved by instance search using the only candidate"-              , nest 2 $ prettyTCM term-              , text "of type " <+> prettyTCM t'-              , text "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.-            wakeConstraints (return . const True)-            solveAwakeConstraints' False-            return Nothing  -- We’re done--          _ -> do-            let cs = fromMaybe cands mcands -- keep the current candidates if Nothing-            reportSDoc "tc.instance" 15 $-              text ("findInScope 5: refined candidates: ") <+>-              prettyTCM (List.map candidateTerm cs)-            return (Just (cs, Nothing))---- | Precondition: type is spine reduced and ends in a Def or a Var.-insidePi :: Type -> (Type -> TCM a) -> TCM a-insidePi t ret =-  case ignoreSharing $ unEl t of-    Pi a b     -> addContext' (absName b, a) $ insidePi (unAbs b) ret-    Def{}      -> ret t-    Var{}      -> ret t-    Sort{}     -> __IMPOSSIBLE__-    Con{}      -> __IMPOSSIBLE__-    Lam{}      -> __IMPOSSIBLE__-    Lit{}      -> __IMPOSSIBLE__-    Level{}    -> __IMPOSSIBLE__-    MetaV{}    -> __IMPOSSIBLE__-    Shared{}   -> __IMPOSSIBLE__-    DontCare{} -> __IMPOSSIBLE__---- | A meta _M is rigidly constrained if there is a constraint _M us == D vs,--- for inert D. Such metas can safely be instantiated by recursive instance--- search, since the constraint limits the solution space.-rigidlyConstrainedMetas :: TCM [MetaId]-rigidlyConstrainedMetas = do-  cs <- (++) <$> use stSleepingConstraints <*> use stAwakeConstraints-  catMaybes <$> mapM rigidMetas cs-  where-    isRigid v = do-      bv <- reduceB v-      case ignoreSharing <$> bv of-        Blocked{}    -> return False-        NotBlocked _ v -> case v of-          MetaV{}    -> return False-          Def f _    -> return True-          Con{}      -> return True-          Lit{}      -> return True-          Var{}      -> return True-          Sort{}     -> return True-          Pi{}       -> return True-          Level{}    -> return False-          DontCare{} -> return False-          Lam{}      -> __IMPOSSIBLE__-          Shared{}   -> __IMPOSSIBLE__-    rigidMetas c =-      case clValue $ theConstraint c of-        ValueCmp _ _ u v ->-          case (ignoreSharing u, ignoreSharing v) of-            (MetaV m us, _) | isJust (allApplyElims us) -> ifM (isRigid v) (return $ Just m) (return Nothing)-            (_, MetaV m vs) | isJust (allApplyElims vs) -> ifM (isRigid u) (return $ Just m) (return Nothing)-            _              -> return Nothing-        ElimCmp{}     -> return Nothing-        TypeCmp{}     -> return Nothing-        TelCmp{}      -> return Nothing-        SortCmp{}     -> return Nothing-        LevelCmp{}    -> return Nothing-        UnBlock{}     -> return Nothing-        Guarded{}     -> return Nothing  -- don't look inside Guarded, since the inner constraint might not fire-        IsEmpty{}     -> return Nothing-        CheckSizeLtSat{} -> return Nothing-        FindInScope{} -> return Nothing--isRigid :: MetaId -> TCM Bool-isRigid i = do-  rigid <- rigidlyConstrainedMetas-  return (elem i rigid)---- | Returns True if one of the arguments of @t@ is a meta which isn’t rigidly---   constrained. Note that level metas are never considered rigidly constrained---   (#1865).-areThereNonRigidMetaArguments :: Term -> TCM (Maybe MetaId)-areThereNonRigidMetaArguments t = case ignoreSharing t of-    Def n args -> do-      TelV tel _ <- telView . defType =<< getConstInfo n-      let varOccs EmptyTel           = []-          varOccs (ExtendTel a btel)-            | getRelevance a == Irrelevant = WeaklyRigid : varOccs tel  -- #2171: ignore irrelevant arguments-            | otherwise                    = occurrence 0 tel : varOccs tel-            where tel = unAbs btel-          rigid StronglyRigid = True-          rigid Unguarded     = True-          rigid WeaklyRigid   = True-          rigid _             = False-      reportSDoc "tc.instance.rigid" 70 $ text "class args:" <+> prettyTCM tel $$-                                          nest 2 (text $ "used: " ++ show (varOccs tel))-      areThereNonRigidMetaArgs [ arg | (o, arg) <- zip (varOccs tel) args, not $ rigid o ]-    Var n args -> return Nothing  -- TODO check what’s the right thing to do, doing the same-                                  -- thing as above makes some examples fail-    Sort{}   -> __IMPOSSIBLE__-    Con{}    -> __IMPOSSIBLE__-    Lam{}    -> __IMPOSSIBLE__-    Lit{}    -> __IMPOSSIBLE__-    Level{}  -> __IMPOSSIBLE__-    MetaV{}  -> __IMPOSSIBLE__-    Pi{}     -> __IMPOSSIBLE__-    Shared{} -> __IMPOSSIBLE__-    DontCare{} -> __IMPOSSIBLE__-  where-    areThereNonRigidMetaArgs :: Elims -> TCM (Maybe MetaId)-    areThereNonRigidMetaArgs []             = return Nothing-    areThereNonRigidMetaArgs (Proj{}  : xs) = areThereNonRigidMetaArgs xs-    areThereNonRigidMetaArgs (Apply x : xs) = do-      ifJustM (isNonRigidMeta $ unArg x) (return . Just) (areThereNonRigidMetaArgs xs)--    isNonRigidMeta :: Term -> TCM (Maybe MetaId)-    isNonRigidMeta v =-      case ignoreSharing v of-        Def _ es  -> areThereNonRigidMetaArgs es-        Var _ es  -> areThereNonRigidMetaArgs es-        Con _ _ vs-> areThereNonRigidMetaArgs (map Apply vs)-        MetaV i _ -> ifM (isRigid i) (return Nothing) $ do-                      -- Ignore unconstrained level and size metas (#1865)-                      Def lvl [] <- ignoreSharing <$> primLevel-                      sz <- for (fmap ignoreSharing <$> getBuiltin' builtinSize) $ \case-                              Just (Def sz []) -> [sz]-                              Nothing          -> []-                              _                -> __IMPOSSIBLE__-                      o          <- getOutputTypeName . jMetaType . mvJudgement =<< lookupMeta i-                      case o of-                        OutputTypeName l | elem l (lvl : sz) -> return Nothing-                        _                                   -> return (Just i)-        Lam _ t   -> isNonRigidMeta (unAbs t)-        _         -> return Nothing---- | 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 reseted.-filterResetingState :: MetaId -> [Candidate] -> (Candidate -> TCM YesNoMaybe) -> TCM [Candidate]-filterResetingState m cands f = disableDestructiveUpdate $ do-  ctxArgs  <- getContextArgs-  let ctxElims = map Apply ctxArgs-      tryC c = do-        ok <- f c-        v  <- instantiateFull (MetaV m ctxElims)-        a  <- instantiateFull =<< (`piApplyM` ctxArgs) =<< getMetaType m-        return (ok, v, a)-  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 ()--  let result' = [ (c, v, a, s) | (c, ((r, v, a), s)) <- result, not (isNo r) ]-      noMaybes = null [ Maybe | (_, ((Maybe, _, _), _)) <- result ]-            -- It's not safe to compare maybes for equality because they might-            -- not have instantiated at all.-  result <- if noMaybes then dropSameCandidates m result' else return result'-  case result of-    [(c, _, _, s)] -> [c] <$ put s-    _              -> return [ c | (c, _, _, _) <- result ]---- 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, Type, a)] -> TCM [(Candidate, Term, Type, a)]-dropSameCandidates m cands0 = do-  metas <- Set.fromList . Map.keys <$> getMetaStore-  let freshMetas x = not $ Set.null $ Set.difference (Set.fromList $ allMetas x) metas--  -- Take overlappable candidates into account-  let cands =-        case partition (\ (c, _, _, _) -> candidateOverlappable c) cands0 of-          (cand : _, []) -> [cand]  -- only overlappable candidates: pick the first one-          _              -> cands0  -- otherwise require equality--  reportSDoc "tc.instance" 50 $ vcat-    [ text "valid candidates:"-    , nest 2 $ vcat [ if freshMetas (v, a) then text "(redacted)" else-                      sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM a ]-                    | (_, v, a, _) <- cands ] ]-  rel <- getMetaRelevance <$> lookupMeta m-  case cands of-    []            -> return cands-    cvd@(_, v, a, _) : vas -> do-        if freshMetas (v, a)-          then return (cvd : vas)-          else (cvd :) <$> dropWhileM equal vas-      where-        equal _ | isIrrelevant rel = return True-        equal (_, v', a', _)-            | freshMetas (v', a') = return False  -- If there are fresh metas we can't compare-            | otherwise           =-          verboseBracket "tc.instance" 30 "checkEqualCandidates" $ do-          reportSDoc "tc.instance" 30 $ sep [ prettyTCM v <+> text "==", nest 2 $ prettyTCM v' ]-          localTCState $ dontAssignMetas $ ifNoConstraints_ (equalType a a' >> equalTerm a v v')-                             {- then -} (return True)-                             {- else -} (\ _ -> return False)-                             `catchError` (\ _ -> return False)--data YesNoMaybe = Yes | No | Maybe | HellNo TCErr-  deriving (Show)--isNo :: YesNoMaybe -> Bool-isNo No = 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.-checkCandidates :: MetaId -> Type -> [Candidate] -> TCM (Maybe [Candidate])-checkCandidates m t cands = disableDestructiveUpdate $-  verboseBracket "tc.instance.candidates" 20 ("checkCandidates " ++ prettyShow m) $-  ifM (anyMetaTypes cands) (return Nothing) $-  holdConstraints (\ _ -> isIFSConstraint . clValue . theConstraint) $ Just <$> do-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ text "target:" <+> prettyTCM t-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat-      [ text "candidates"-      , vcat [ text "-" <+> (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":" <+> prettyTCM t-             | Candidate v t _ overlap <- cands ] ]-    cands' <- filterResetingState m cands (checkCandidateForMeta m t)-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat-      [ text "valid candidates"-      , vcat [ text "-" <+> (if overlap then text "overlap" else empty) <+> prettyTCM v <+> text ":" <+> prettyTCM t-             | Candidate v t _ overlap <- cands' ] ]-    return cands'-  where-    anyMetaTypes :: [Candidate] -> TCM Bool-    anyMetaTypes [] = return False-    anyMetaTypes (Candidate _ a _ _ : cands) = do-      a <- instantiate a-      case ignoreSharing $ unEl a of-        MetaV{} -> return True-        _       -> anyMetaTypes cands--    checkDepth :: Term -> Type -> TCM YesNoMaybe -> TCM YesNoMaybe-    checkDepth c a k = locally eInstanceDepth succ $ do-      d        <- view eInstanceDepth-      maxDepth <- maxInstanceSearchDepth-      when (d > maxDepth) $ typeError $ InstanceSearchDepthExhausted c a maxDepth-      k--    checkCandidateForMeta :: MetaId -> Type -> Candidate -> TCM YesNoMaybe-    checkCandidateForMeta m t (Candidate term t' eti _) = 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: " ++ show t ++ "\n  t':" ++ show t' ++ "\n  term: " ++ show term ++ "."-            reportSDoc "tc.instance" 20 $ vcat-              [ text "checkCandidateForMeta"-              , text "t    =" <+> prettyTCM t-              , text "t'   =" <+> prettyTCM t'-              , text "term =" <+> prettyTCM term-              ]--            -- Apply hidden and instance arguments (recursive inst. search!).-            (args, t'') <- implicitArgs (-1) (\h -> h /= NotHidden || eti == ExplicitToInstance) t'--            reportSDoc "tc.instance" 20 $-              text "instance search: checking" <+> prettyTCM t''-              <+> text "<=" <+> prettyTCM t-            ctxElims <- map Apply <$> getContextArgs-            v <- (`applyDroppingParameters` args) =<< reduce term-            reportSDoc "tc.instance" 15 $ vcat-              [ text "instance search: attempting"-              , nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM 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).-            guardConstraint (ValueCmp CmpEq 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 FindInScope's-            -- to prevent loops. We currently also ignore UnBlock constraints-            -- to be on the safe side.-            debugConstraints-            solveAwakeConstraints' True--            verboseS "tc.instance" 15 $ do-              sol <- instantiateFull (MetaV m ctxElims)-              case sol of-                MetaV m' _ | m == m' ->-                  reportSDoc "tc.instance" 15 $-                    sep [ text "instance search: maybe solution for" <+> prettyTCM m <> text ":"-                        , nest 2 $ prettyTCM v ]-                _ ->-                  reportSDoc "tc.instance" 15 $-                    sep [ text "instance search: found solution for" <+> prettyTCM m <> text ":"-                        , nest 2 $ prettyTCM sol ]-        where-          runCandidateCheck check =-            flip catchError handle $-            ifNoConstraints_ check-              (return Yes)-              (\ _ -> Maybe <$ reportSLn "tc.instance" 50 "assignment inconclusive")--          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       = do-              reportSDoc "tc.instance" 50 $-                text "assignment failed:" <+> prettyTCM err-              return No--isIFSConstraint :: Constraint -> Bool-isIFSConstraint FindInScope{} = True-isIFSConstraint UnBlock{}     = True -- otherwise test/fail/Issue723 loops-isIFSConstraint _             = False---- | 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 ignoreSharing t of-    Con c ci [] -> do-      def <- theDef <$> getConInfo c-      case def of-        Constructor {conPars = n} -> return $ Con c ci (genericDrop n vs)-        _ -> __IMPOSSIBLE__-    Def f [] -> do-      mp <- isProjection 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,79 +1,384 @@--- {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} -{-| Irrelevant function types.--}-module Agda.TypeChecking.Irrelevance where+{-# LANGUAGE NondecreasingIndentation #-} -import Control.Applicative-import Control.Monad.Reader+{-| Compile-time irrelevance. -import qualified Data.Map as Map+In type theory with compile-time irrelevance à la Pfenning (LiCS 2001),+variables in the context are annotated with relevance attributes.+@@+  Γ = r₁x₁:A₁, ..., rⱼxⱼ:Aⱼ+@@+To handle irrelevant projections, we also record the current relevance+attribute in the judgement.  For instance, this attribute is equal to+to 'Irrelevant' if we are in an irrelevant position, like an+irrelevant argument.+@@+  Γ ⊢r t : A+@@+Only relevant variables can be used:+@@ -import Agda.Interaction.Options+  (Relevant x : A) ∈ Γ+  --------------------+  Γ  ⊢r  x  :  A+@@+Irrelevant global declarations can only be used if @r = Irrelevant@. +When we enter a @r'@-relevant function argument, we compose the @r@ with @r'@+and (left-)divide the attributes in the context by @r'@.+@@+  Γ  ⊢r  t  :  (r' x : A) → B      r' \ Γ  ⊢(r'·r)  u  :  A+  ---------------------------------------------------------+  Γ  ⊢r  t u  :  B[u/x]+@@+No surprises for abstraction:+@@++  Γ, (r' x : A)  ⊢r  :  B+  -----------------------------+  Γ  ⊢r  λxt  :  (r' x : A) → B+@@++This is different for runtime irrelevance (erasure) which is ``flat'',+meaning that once one is in an irrelevant context, all new assumptions will+be usable, since they are turned relevant once entering the context.+See Conor McBride (WadlerFest 2016), for a type system in this spirit:++We use such a rule for runtime-irrelevance:+@@+  Γ, (q \ q') x : A  ⊢q  t  :  B+  ------------------------------+  Γ  ⊢q  λxt  :  (q' x : A) → B+@@++Conor's system is however set up differently, with a very different+variable rule:++@@++  (q x : A) ∈ Γ+  --------------+  Γ  ⊢q  x  :  A++  Γ, (q·p) x : A  ⊢q  t  :  B+  -----------------------------+  Γ  ⊢q  λxt  :  (p x : A) → B++  Γ  ⊢q  t  :  (p x : A) → B       Γ'  ⊢qp  u  :  A+  -------------------------------------------------+  Γ + Γ'  ⊢q  t u  :  B[u/x]+@@+++-}++module Agda.TypeChecking.Irrelevance where++import Control.Monad.Except ( MonadError(..), runExceptT )+ import Agda.Syntax.Common import Agda.Syntax.Internal  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute.Class+import Agda.TypeChecking.Telescope --- | data 'Relevance'---   see "Agda.Syntax.Common".+import Agda.Utils.Either (fromRightM)+import Agda.Utils.Maybe+import Agda.Utils.Monad --- * Operations on 'Dom'.+import Agda.Utils.Impossible --- | Prepare parts of a parameter telescope for abstraction in constructors---   and projections.-hideAndRelParams :: Dom a -> Dom a-hideAndRelParams = hideOrKeepInstance . mapRelevance nonStrictToIrr+-- | Check whether something can be used in a position of the given relevance.+--+--   This is a substitute for double-checking that only makes sure+--   relevances are correct.  See issue #2640.+--+--   Used in unifier (@ unifyStep Solution{}@).+--+--   At the moment, this implements McBride-style irrelevance,+--   where Pfenning-style would be the most accurate thing.+--   However, these two notions only differ how they handle+--   bound variables in a term.  Here, we are only concerned+--   in the free variables, used meta-variables, and used+--   (irrelevant) definitions.+--+class UsableRelevance a where+  usableRel+    :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m)+    => Relevance -> a -> m Bool --- | Used to modify context when going into a @rel@ argument.-inverseApplyRelevance :: Relevance -> Dom a -> Dom a-inverseApplyRelevance rel = mapRelevance (rel `inverseComposeRelevance`)+instance UsableRelevance Term where+  usableRel rel = \case+    Var i vs -> do+      irel <- getRelevance <$> domOfBV i+      let ok = irel `moreRelevant` rel+      reportSDoc "tc.irr" 50 $+        "Variable" <+> prettyTCM (var i) <+>+        text ("has relevance " ++ show irel ++ ", which is " +++              (if ok then "" else "NOT ") ++ "more relevant than " ++ show rel)+      return ok `and2M` usableRel rel vs+    Def f vs -> do+      frel <- relOfConst f+      return (frel `moreRelevant` rel) `and2M` usableRel rel vs+    Con c _ vs -> usableRel rel vs+    Lit l    -> return True+    Lam _ v  -> usableRel rel v+    Pi a b   -> usableRel rel (a,b)+    Sort s   -> usableRel rel s+    Level l  -> return True+    MetaV m vs -> do+      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 --- | Compose two relevance flags.---   This function is used to update the relevance information---   on pattern variables @a@ after a match against something @rel@.-applyRelevance :: Relevance -> Dom a -> Dom a-applyRelevance rel = mapRelevance (rel `composeRelevance`)+instance UsableRelevance a => UsableRelevance (Type' a) where+  usableRel rel (El _ t) = usableRel rel t --- * Operations on 'Context'.+instance UsableRelevance Sort where+  usableRel rel = \case+    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+    MetaS x es -> usableRel rel es+    DefS d es  -> usableRel rel $ Def d es+    DummyS{} -> return True --- | Modify the context whenever going from the l.h.s. (term side)---   of the typing judgement to the r.h.s. (type side).-workOnTypes :: TCM a -> TCM a-workOnTypes cont = do-  allowed <- optExperimentalIrrelevance <$> pragmaOptions-  verboseBracket "tc.irr" 20 "workOnTypes" $ workOnTypes' allowed cont+instance UsableRelevance Level where+  usableRel rel (Max _ ls) = usableRel rel ls --- | Internal workhorse, expects value of --experimental-irrelevance flag---   as argument.-workOnTypes' :: Bool -> TCM a -> TCM a-workOnTypes' experimental cont = modifyContext (modifyContextEntries $ mapRelevance f) cont-  where-    f | experimental = irrToNonStrict-      | otherwise    = nonStrictToRel+instance UsableRelevance PlusLevel where+  usableRel rel (Plus _ l) = usableRel rel l --- | (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.-applyRelevanceToContext :: Relevance -> TCM a -> TCM a-applyRelevanceToContext rel =-  case rel of-    Relevant -> id-    Forced{} -> id-    _        -> local $ \ e -> e-      { envContext   = modifyContextEntries (inverseApplyRelevance rel) (envContext e)-      , envLetBindings = Map.map-          (fmap $ \ (t, a) -> (t, inverseApplyRelevance rel a))-          (envLetBindings e)-                                                  -- enable local  irr. defs-      , envRelevance = composeRelevance rel (envRelevance e)-                                                  -- enable global irr. defs-      }+instance UsableRelevance a => UsableRelevance [a] where+  usableRel rel = andM . map (usableRel rel) --- | 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.-wakeIrrelevantVars :: TCM a -> TCM a-wakeIrrelevantVars = applyRelevanceToContext Irrelevant+instance (UsableRelevance a, UsableRelevance b) => UsableRelevance (a,b) where+  usableRel rel (a,b) = usableRel rel a `and2M` usableRel rel b++instance (UsableRelevance a, UsableRelevance b, UsableRelevance c) => UsableRelevance (a,b,c) where+  usableRel rel (a,b,c) = usableRel rel a `and2M` usableRel rel b `and2M` usableRel rel c++instance UsableRelevance a => UsableRelevance (Elim' a) where+  usableRel rel (Apply a) = usableRel rel a+  usableRel rel (Proj _ p) = do+    prel <- relOfConst p+    return $ prel `moreRelevant` rel+  usableRel rel (IApply x y v) = usableRel rel v++instance UsableRelevance a => UsableRelevance (Arg a) where+  usableRel rel (Arg info u) =+    let rel' = getRelevance info+    in  usableRel (rel `composeRelevance` rel') u++instance UsableRelevance a => UsableRelevance (Dom a) where+  usableRel rel Dom{unDom = u} = usableRel rel u++instance (Subst a, UsableRelevance a) => UsableRelevance (Abs a) where+  usableRel rel abs = underAbstraction_ abs $ \u -> usableRel rel u++-- | Check whether something can be used in a position of the given modality.+--+--   This is a substitute for double-checking that only makes sure+--   modalities are correct.  See issue #2640.+--+--   Used in unifier (@ unifyStep Solution{}@).+--+--   This uses McBride-style modality checking.+--   It does not differ from Pfenning-style if we+--   are only interested in the modality of the+--   free variables, used meta-variables, and used+--   definitions.+--+class UsableModality a where+  usableMod+    :: (ReadTCState m, HasConstInfo m, MonadTCEnv m, MonadAddContext m, MonadDebug m, MonadReduce m, MonadError Blocker m)+    => Modality -> a -> m Bool++instance UsableModality Term where+  usableMod mod u = do+   case u of+    Var i vs -> do+      imod <- getModality <$> domOfBV i+      let ok = imod `moreUsableModality` mod+      reportSDoc "tc.irr" 50 $+        "Variable" <+> prettyTCM (var i) <+>+        text ("has modality " ++ show imod ++ ", which is a " +++              (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod)+      return ok `and2M` usableMod mod vs+    Def f vs -> do+      fmod <- modalityOfConst f+      -- 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 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) $+                 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 <- lookupMetaModality m+      let ok = mmod `moreUsableModality` mod+      reportSDoc "tc.irr" 50 $+        "Metavariable" <+> prettyTCM (MetaV m []) <+>+        text ("has modality " ++ show mmod ++ ", which is a " +++              (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod)+      (return ok `and2M` usableMod mod vs) `or2M` do+        u <- instantiate u+        caseMaybe (isMeta u) (usableMod mod u) $ \ m -> throwError (UnblockOnMeta m)+    DontCare v -> usableMod mod v+    Dummy{}  -> return True++usableModAbs :: (Subst a, MonadAddContext m, UsableModality a,+                       ReadTCState m, HasConstInfo m, MonadReduce m, MonadError Blocker m) =>+                      ArgInfo -> Modality -> Abs a -> m Bool+usableModAbs info mod abs = underAbstraction (setArgInfo info $ __DUMMY_DOM__) abs $ \ u -> usableMod mod u++instance UsableRelevance a => UsableModality (Type' a) where+  usableMod mod (El _ t) = usableRel (getRelevance mod) t++instance UsableModality Sort where+  usableMod mod s = usableRel (getRelevance mod) s++instance UsableModality Level where+  usableMod mod (Max _ ls) = usableRel (getRelevance mod) ls++-- instance UsableModality PlusLevel where+--   usableMod mod ClosedLevel{} = return True+--   usableMod mod (Plus _ l)    = usableMod mod l++instance UsableModality a => UsableModality [a] where+  usableMod mod = andM . map (usableMod mod)++instance (UsableModality a, UsableModality b) => UsableModality (a,b) where+  usableMod mod (a,b) = usableMod mod a `and2M` usableMod mod b++instance UsableModality a => UsableModality (Elim' a) where+  usableMod mod (Apply a) = usableMod mod a+  usableMod mod (Proj _ p) = do+    pmod <- modalityOfConst p+    return $ pmod `moreUsableModality` mod+  usableMod mod (IApply x y v) = usableMod mod v++instance UsableModality a => UsableModality (Arg a) where+  usableMod mod (Arg info u) =+    let mod' = getModality info+    in  usableMod (mod `composeModality` mod') u++instance UsableModality a => UsableModality (Dom a) where+  usableMod mod Dom{unDom = u} = usableMod mod u++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.)++{-# SPECIALIZE isPropM :: Dom Type -> TCM Bool #-}+isPropM :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) => a -> m Bool+isPropM a = do+  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 = 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) => 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
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Irrelevance where++import Agda.Syntax.Internal (LensSort)++import Agda.TypeChecking.Monad.Base (MonadBlock)+import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM)+import Agda.TypeChecking.Monad.Pure (PureTCM)++isPropM+  :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)+  => a -> m Bool
src/full/Agda/TypeChecking/Level.hs view
@@ -1,24 +1,23 @@-{-# LANGUAGE CPP #-}  module Agda.TypeChecking.Level where -import Control.Applicative import Data.Maybe-import Data.List as List-import Data.Traversable (Traversable,traverse)+import qualified Data.List as List+import Data.Traversable (Traversable)  import Agda.Syntax.Common import Agda.Syntax.Internal++import Agda.TypeChecking.Free.Lazy import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad ()-import Agda.TypeChecking.Monad.Builtin -import Agda.Utils.Except ( MonadError(catchError) )+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.Maybe ( caseMaybeM, allJustM ) import Agda.Utils.Monad ( tryMaybe )+import Agda.Utils.Singleton -#include "undefined.h" import Agda.Utils.Impossible  data LevelKit = LevelKit@@ -32,127 +31,228 @@   , zeroName :: QName   } --- | Get the 'primLevel' as a 'Type'.-levelType :: TCM Type-levelType = El (mkType 0) <$> primLevel+{-# 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. -levelSucFunction :: TCM (Term -> Term)-levelSucFunction = apply1 <$> primLevelSuc+{-# 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+    lvl <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevel+    return $ f == lvl+  _ -> return False+ {-# SPECIALIZE builtinLevelKit :: TCM LevelKit #-} {-# SPECIALIZE builtinLevelKit :: ReduceM LevelKit #-} builtinLevelKit :: (HasBuiltins m) => m LevelKit builtinLevelKit = do-    level@(Def l []) <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel-    zero@(Def z [])  <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-    suc@(Def s [])   <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-    max@(Def m [])   <- ignoreSharing . 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 :: TCM 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+haveLevels = caseMaybeM (allJustM $ map getBuiltin' levelBuiltins)+    (return False)+    (\ _bs -> return True)+  where+  levelBuiltins =+    [ builtinLevelUniv+    , builtinLevel+    , builtinLevelZero+    , builtinLevelSuc+    , builtinLevelMax+    ]+ {-# SPECIALIZE unLevel :: Term -> TCM Term #-} {-# SPECIALIZE unLevel :: Term -> ReduceM Term #-} unLevel :: (HasBuiltins m) => Term -> m Term unLevel (Level l)  = reallyUnLevelView l-unLevel (Shared p) = unLevel (derefPtr p) unLevel v = return v  {-# 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 []              -> return zer-    Max [Plus 0 a]      -> return $ unLevelAtom a-    Max [a]             -> do-      return $ unPlusV zer (apply1 suc) a-    _ -> (`unlevelWithKit` nv) <$> builtinLevelKit+reallyUnLevelView nv = (`unlevelWithKit` nv) <$> builtinLevelKit  unlevelWithKit :: LevelKit -> Level -> Term-unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } (Max as) =-  case map (unPlusV zer suc) as of-    [a] -> a-    []  -> zer-    as  -> foldr1 max as--unPlusV :: Term -> (Term -> Term) -> PlusLevel -> Term-unPlusV zer suc (ClosedLevel n) = foldr (.) id (genericReplicate n suc) zer-unPlusV _   suc (Plus n a)      = foldr (.) id (genericReplicate n suc) (unLevelAtom a)+unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax } = \case+  Max m []  -> unConstV zer suc m+  Max 0 [a] -> unPlusV suc a+  Max m as  -> foldl1 lvlMax $ [ unConstV zer suc m | m > 0 ] ++ map (unPlusV suc) as -maybePrimCon :: TCM Term -> TCM (Maybe ConHead)-maybePrimCon prim = tryMaybe $ do-    Con c ci [] <- prim-    return c+unConstV :: Term -> (Term -> Term) -> Integer -> Term+unConstV zer suc n = foldr ($) zer (List.genericReplicate n suc) -maybePrimDef :: TCM Term -> TCM (Maybe QName)-maybePrimDef prim = tryMaybe $ do-    Def f [] <- prim-    return f+unPlusV :: (Term -> Term) -> PlusLevel -> Term+unPlusV suc (Plus n a) = foldr ($) a (List.genericReplicate n suc) -levelView :: Term -> TCM Level+{-# SPECIALIZE levelView :: Term -> TCM Level #-}+levelView :: PureTCM m => Term -> m Level levelView a = do   reportSLn "tc.level.view" 50 $ "{ levelView " ++ show a-  v <- runReduceM $ levelView' a+  v <- levelView' a   reportSLn "tc.level.view" 50 $ "  view: " ++ show v ++ "}"   return v -levelView' :: Term -> ReduceM Level+{-# SPECIALIZE levelView' :: Term -> TCM Level #-}+levelView' :: PureTCM m => Term -> m Level levelView' a = do-  Def lzero [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-  Def lsuc  [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-  Def lmax  [] <- ignoreSharing . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelMax+  lzero <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelZero+  lsuc  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelSuc+  lmax  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelMax   let view a = do-        a <- reduce' a-        case ignoreSharing a of+        ba <- reduceB a+        case ignoreBlocking ba of           Level l -> return l           Def s [Apply arg]-            | s == lsuc  -> inc <$> view (unArg arg)+            | s == lsuc  -> levelSuc <$> view (unArg arg)           Def z []-            | z == lzero -> return $ closed 0+            | z == lzero -> return $ ClosedLevel 0           Def m [Apply arg1, Apply arg2]             | m == lmax  -> levelLub <$> view (unArg arg1) <*> view (unArg arg2)-          _              -> mkAtom a-  v <- view a-  return v+          l              -> return $ atomicLevel l+  view a++-- | Given a level @l@, find the maximum constant @n@ such that @l = n + l'@+levelPlusView :: Level -> (Integer, Level)+levelPlusView (Max 0 []) = (0 , Max 0 [])+levelPlusView (Max 0 as@(_:_)) = (minN , Max 0 (map sub as))   where-    mkAtom a = do-      b <- reduceB' a-      return $ case ignoreSharing <$> b of-        NotBlocked _ (MetaV m as) -> atom $ MetaLevel m as-        NotBlocked r _            -> atom $ NeutralLevel r $ ignoreBlocking b-        Blocked m _               -> atom $ BlockedLevel m $ ignoreBlocking b+    minN = minimum [ n | Plus n _ <- as ]+    sub (Plus n a) = Plus (n - minN) a+levelPlusView (Max n as) = (minN , Max (n - minN) (map sub as))+  where+    minN = minimum $ n : [ n' | Plus n' _ <- as ]+    sub (Plus n' a) = Plus (n' - minN) a -    atom a = Max [Plus 0 a]+-- | Given a level @l@, find the biggest constant @n@ such that @n <= l@+levelLowerBound :: Level -> Integer+levelLowerBound (Max m as) = maximum $ m : [n | Plus n _ <- as] -    closed n = Max [ClosedLevel n | n > 0]+-- | Given a constant @n@ and a level @l@, find the level @l'@ such+--   that @l = n + l'@ (or Nothing if there is no such level).+--   Operates on levels in canonical form.+subLevel :: Integer -> Level -> Maybe Level+subLevel n (Max m ls) = Max <$> m' <*> traverse subPlus ls+  where+    m' :: Maybe Integer+    m' | m == 0, not (null ls) = Just 0+       | otherwise             = sub m -    inc (Max as) = Max $ map inc' as-      where-        inc' (ClosedLevel n) = ClosedLevel $ n + 1-        inc' (Plus n a)    = Plus (n + 1) a+    -- General purpose function.+    nonNeg :: Integer -> Maybe Integer+    nonNeg j | j >= 0 = Just j+             | otherwise = Nothing -levelLub :: Level -> Level -> Level-levelLub (Max as) (Max bs) = levelMax $ as ++ bs+    sub :: Integer -> Maybe Integer+    sub = nonNeg . subtract n -subLevel :: Integer -> Level -> Maybe Level-subLevel n (Max ls) = Max <$> traverse sub ls+    subPlus :: PlusLevel -> Maybe PlusLevel+    subPlus (Plus j l) = Plus <$> sub j <*> Just l++-- | Given two levels @a@ and @b@, try to decompose the first one as+-- @a = a' ⊔ b@ (for the minimal value of @a'@).+levelMaxDiff :: Level -> Level -> Maybe Level+levelMaxDiff (Max m as) (Max n bs) = Max <$> diffC m n <*> diffP as bs   where-    sub :: PlusLevel -> Maybe PlusLevel-    sub (ClosedLevel j) | j >= n    = Just $ ClosedLevel $ j - n-                        | otherwise = Nothing-    sub (Plus j l)      | j >= n    = Just $ Plus (j - n) l-                        | otherwise = Nothing+    diffC :: Integer -> Integer -> Maybe Integer+    diffC m n+      | m == n    = Just 0+      | m > n     = Just m+      | otherwise = Nothing++    diffP :: [PlusLevel] -> [PlusLevel] -> Maybe [PlusLevel]+    diffP as     []     = Just as+    diffP []     bs     = Nothing+    diffP (a@(Plus m x) : as) (b@(Plus n y) : bs)+      | x == y = if+        | m == n    -> diffP as bs+        | m > n     -> (Plus m x:) <$> diffP as bs+        | otherwise -> Nothing+      | otherwise = (a:) <$> diffP as (b:bs)++-- | A @SingleLevel@ is a @Level@ that cannot be further decomposed as+--   a maximum @a ⊔ b@.+data SingleLevel' t = SingleClosed Integer | SinglePlus (PlusLevel' t)+  deriving (Show, Functor, Foldable, Traversable)++type SingleLevel = SingleLevel' Term++deriving instance Eq SingleLevel++unSingleLevel :: SingleLevel' t -> Level' t+unSingleLevel (SingleClosed m) = Max m []+unSingleLevel (SinglePlus a)   = Max 0 [a]++-- | Return the maximum of the given @SingleLevel@s+unSingleLevels :: [SingleLevel] -> Level+unSingleLevels ls = levelMax n as+  where+    n = maximum $ 0 : [m | SingleClosed m <- ls]+    as = [a | SinglePlus a <- ls]++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++singleLevelView :: Level' t -> Maybe (SingleLevel' t)+singleLevelView l = case levelMaxView l of+  s :| [] -> Just s+  _       -> Nothing++instance Subst t => Subst (SingleLevel' t) where+  type SubstArg (SingleLevel' t) = SubstArg t++  applySubst sub (SingleClosed m) = SingleClosed m+  applySubst sub (SinglePlus a)   = SinglePlus $ applySubst sub a++instance Free t => Free (SingleLevel' t) where+  freeVars' (SingleClosed m) = mempty+  freeVars' (SinglePlus a)   = freeVars' a
src/full/Agda/TypeChecking/Level.hs-boot view
@@ -1,7 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Level where -import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Builtin (HasBuiltins) import Agda.Syntax.Internal -levelView :: Term -> TCM Level+reallyUnLevelView :: (HasBuiltins m) => Level -> m Term
+ src/full/Agda/TypeChecking/Level/Solve.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Level.Solve where++import Control.Monad.Except ( catchError )++import qualified Data.Map.Strict as MapS+import Data.Maybe++import Agda.Interaction.Options++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Level+import Agda.TypeChecking.MetaVars.Mention+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Functor+import Agda.Utils.Monad++-- | 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 (openMetas newMetas)+  return result++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 <$> lookupMetaInstantiation x+      xs <- filterM isOpen xs+      allMetaTypes <- getOpenMetas >>= traverse metaType+      let notInTypeOfMeta x = not $ mentionsMeta x allMetaTypes+      progress <- forM xs $ \x -> do+        cs <- filter (mentionsMeta x) <$> getAllConstraints+        if | notInTypeOfMeta x , all (`isUpperBoundFor` x) cs -> do+               m <- lookupMeta x+               TelV tel t <- telView =<< metaType x+               addContext tel $ assignV DirEq x (teleArgs tel) (Level $ ClosedLevel 0) (AsTermsOf t)+               return True+             `catchError` \_ -> return False+           | otherwise -> return False++      when (or progress) $ (loop xs)++    openLevelMetas :: [MetaId] -> m [MetaId]+    openLevelMetas xs = filterM (isNothing <.> isInteractionMeta) xs+      >>= filterM (fmap (== NoGeneralize) . isGeneralizableMeta)+      >>= filterM isLevelMeta++    isLevelMeta :: MetaId -> m Bool+    isLevelMeta x = do+      TelV tel t <- telView =<< metaType x+      addContext tel $ isLevelType t++    isUpperBoundFor :: ProblemConstraint -> MetaId -> Bool+    isUpperBoundFor c x = case clValue (theConstraint c) of+      LevelCmp CmpLeq l u -> not $ mentionsMeta x u+      _                   -> False
src/full/Agda/TypeChecking/LevelConstraints.hs view
@@ -1,32 +1,47 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.LevelConstraints ( simplifyLevelConstraint ) where -import Data.List as List+import qualified Data.List as List+ import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free-import Agda.Utils.Impossible+import Agda.TypeChecking.Level -#include "undefined.h"+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  -- | @simplifyLevelConstraint c cs@ turns an @c@ into an equality --   constraint if it is an inequality constraint and the reverse --   inequality is contained in @cs@. -----   The constraints doesn't necessarily have to live in the same context, but+--   The constraints don't necessarily have to live in the same context, but --   they do need to be universally quanitfied over the context. This function --   takes care of renaming variables when checking for matches.-simplifyLevelConstraint :: Constraint -> [Constraint] -> Constraint-simplifyLevelConstraint new old =-  case inequalities new of-    [a :=< b] | any (matchLeq (b :=< a)) leqs -> LevelCmp CmpEq (Max [a]) (Max [b])-    _ -> new+simplifyLevelConstraint+  :: Constraint          -- ^ Constraint @c@ to simplify.+  -> 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+    cs <- inequalities c+    case runChange $ mapM simpl cs of+      (cs', True) -> Just cs'+      (_,  False) -> Nothing+   where-    leqs = concatMap inequalities old+    simpl :: Leq -> Change (Constraint)+    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 $ List1.mapMaybe inequalities others -data Leq = PlusLevel :=< PlusLevel+data Leq = SingleLevel :=< SingleLevel   deriving (Show, Eq)  -- | Check if two inequality constraints are the same up to variable renaming.@@ -35,8 +50,8 @@   | length xs == length ys = (a, b) == applySubst rho (c, d)   | otherwise              = False   where-    free :: Free' a [Int] => a -> [Int]-    free = nub . runFree ((:[]) . fst) IgnoreNot+    free :: Free a => a -> [Int]+    free = nubOn id . runFree (:[]) IgnoreNot  -- Note: use a list to preserve order of variables     xs  = free (a, b)     ys  = free (c, d)     rho = mkSub $ List.sort $ zip ys xs@@ -45,21 +60,31 @@         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 level inequalities, if possible.+-- | Turn a level constraint into a list of inequalities between+--   single levels, if possible. -inequalities :: Constraint -> [Leq]+inequalities :: Constraint -> Maybe [Leq] -inequalities (LevelCmp CmpLeq (Max as) (Max [b])) = map (:=< b) as  -- Andreas, 2016-09-28+inequalities (LevelCmp CmpLeq a b)+  | Just b' <- singleLevelView b = Just $ map (:=< b') $ List1.toList $ levelMaxView a+  -- Andreas, 2016-09-28   -- Why was this most natural case missing?   -- See test/Succeed/LevelLeqGeq.agda for where it is useful!  -- These are very special cases only, in no way complete:-inequalities (LevelCmp CmpEq (Max [a, b]) (Max [c]))-  | a == c = [b :=< a]-  | b == c = [a :=< b]-inequalities (LevelCmp CmpEq (Max [a]) (Max [b, c]))-  | a == b = [c :=< b]-  | a == c = [b :=< c]-inequalities _ = []+-- E.g.: a = a ⊔ b ⊔ c --> b ≤ a & c ≤ a++inequalities (LevelCmp CmpEq a b)+  | Just a' <- singleLevelView a =+  case List1.break (== a') (levelMaxView b) of+    (bs0, _ : bs1) -> Just [ b' :=< a' | b' <- bs0 ++ bs1 ]+    _              -> Nothing++inequalities (LevelCmp CmpEq a b)+  | Just b' <- singleLevelView b =+  case List1.break (== b') (levelMaxView a) of+    (as0, _ : as1) -> Just [ a' :=< b' | a' <- as0 ++ as1 ]+    _              -> Nothing+inequalities _ = Nothing
+ src/full/Agda/TypeChecking/Lock.hs view
@@ -0,0 +1,138 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Lock+  ( isTimeless+  , checkLockedVars+  , checkEarlierThan+  )+where++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.TypeChecking.Monad+import Agda.TypeChecking.Pretty+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++checkLockedVars+  :: Term+     -- ^ term to check+  -> Type+     -- ^ its type+  -> Arg Term+     -- ^ the lock+  -> Type+     -- ^ 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+     , text "ty    = " <+> pretty ty+     , text "lk    = " <+> pretty lk+     , text "lk_ty = " <+> pretty lk_ty+     ]++  -- Strategy: compute allowed variables, check that @t@ doesn't use more.+  mi <- getLockVar (unArg lk)+  caseMaybe mi (typeError (DoesNotMentionTicks t ty lk)) $ \ i -> do++  cxt <- getContext+  let toCheck = zip [0..] $ zipWith raise [1..] (take i cxt)++  let fv = freeVarsIgnore IgnoreInAnnotations (t,ty)+  let+    rigid = rigidVars fv+    -- flexible = IMap.keysSet $ flexibleVars fv+    termVars = allVars fv -- ISet.union rigid flexible+    earlierVars = ISet.fromList [i + 1 .. size cxt - 1]+  if termVars `ISet.isSubsetOf` earlierVars then return () else do++  checked <- fmap catMaybes . forM toCheck $ \ (j,ce) -> do+    ifM (isTimeless (ctxEntryType ce))+        (return $ Just j)+        (return $ Nothing)++  let allowedVars = ISet.union earlierVars (ISet.fromList checked)++  if termVars `ISet.isSubsetOf` allowedVars then return () else do+  let+    illegalVars = rigid ISet.\\ allowedVars+    -- flexVars = flexibleVars fv+    -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars)+  if ISet.null illegalVars then  -- only flexible vars are infringing+    -- TODO: be more precise about which metas+    -- flexVars = flexibleVars fv+    -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars)+    patternViolation alwaysUnblock+  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+      -- 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++  -- Out of the lock variables that appear in @lk@ the one in the+  -- left-most position in the context is what will determine the+  -- available context for the head.+  let mi | Prelude.null is   = Nothing+         | otherwise = Just $ maximum is++  pure mi++isTimeless :: Type -> TCM Bool+isTimeless t = do+  t <- abortIfBlocked t+  timeless <- mapM getName' [builtinInterval, builtinIsOne]+  case unEl t of+    Def q _ | Just q `elem` timeless -> return True+    _                                -> return False++-- | 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+  getLockVar lk >>= \case+    Nothing -> return True+    Just i  -> allM (isTimeless <=< typeOfBV) $ filter (<= i) $ VSet.toList fvs
+ src/full/Agda/TypeChecking/Lock.hs-boot view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Lock where++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad.Base+-- import Agda.TypeChecking.Monad.Context+-- import Agda.TypeChecking.Pretty+-- import Agda.TypeChecking.Reduce+-- import Agda.TypeChecking.Substitute.Class+-- import Agda.TypeChecking.Telescope+-- import Agda.TypeChecking.Free++-- import Agda.Utils.Function+-- import Agda.Utils.Lens+-- import Agda.Utils.Maybe+-- import Agda.Utils.Monad+-- import Agda.Utils.Size++-- #include "undefined.h"+-- import Agda.Utils.Impossible++++checkLockedVars+  :: Term+     -- ^ term to check+  -> Type+     -- ^ its type+  -> Arg Term+     -- ^ the lock+  -> Type+     -- ^ type of the lock+  -> TCM ()
src/full/Agda/TypeChecking/MetaVars.hs view
@@ -1,1250 +1,1958 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.MetaVars where--import Prelude hiding (null)--import Control.Monad.Reader--import Data.Function-import Data.List hiding (sort, null)-import qualified Data.List as List-import qualified Data.Map as Map-import qualified Data.Foldable as Fold--import Agda.Syntax.Abstract.Name as A-import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Generic-import Agda.Syntax.Position (killRange)--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Free-import Agda.TypeChecking.Level-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---- import Agda.TypeChecking.CheckInternal--- import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (checkInternal)-import Agda.TypeChecking.MetaVars.Occurs--import Agda.Utils.Except-  ( ExceptT-#if !MIN_VERSION_transformers(0,4,1)-  , Error(noMsg)-#endif-  , MonadError(throwError)-  , runExceptT-  )--import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Size-import Agda.Utils.Tuple-import Agda.Utils.Permutation-import Agda.Utils.Pretty ( prettyShow, render )-import qualified Agda.Utils.VarSet as Set--#include "undefined.h"-import Agda.Utils.Impossible---- | Find position of a value in a list.---   Used to change metavar argument indices during assignment.------   @reverse@ is necessary because we are directly abstracting over the list.----findIdx :: Eq a => [a] -> a -> Maybe Int-findIdx vs v = findIndex (==v) (reverse vs)---- | 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-    let r = case i of-            BlockedConst{}                 -> True-            PostponedTypeCheckingProblem{} -> True-            InstV{}                        -> False-            Open{}                         -> False-            OpenIFS{}                      -> False-    reportSLn "tc.meta.blocked" 12 $-      if r then "  yes, because " ++ show i else "  no"-    return r--isEtaExpandable :: [MetaKind] -> MetaId -> TCM Bool-isEtaExpandable kinds x = do-    i <- mvInstantiation <$> lookupMeta x-    return $ case i of-      Open{}                         -> True-      OpenIFS{}                      -> notElem Records kinds-      InstV{}                        -> False-      BlockedConst{}                 -> False-      PostponedTypeCheckingProblem{} -> False---- * Performing the assignment---- | Performing the meta variable assignment.------   The instantiation should not be an 'InstV' and the 'MetaId'---   should point to something 'Open' or a 'BlockedConst'.---   Further, the meta variable may not be 'Frozen'.-assignTerm :: MetaId -> [Arg ArgName] -> Term -> TCM ()-assignTerm x tel v = do-     -- verify (new) invariants-    whenM (isFrozen x) __IMPOSSIBLE__-    assignTerm' x tel v---- | Skip frozen check.  Used for eta expanding frozen metas.-assignTerm' :: MetaId -> [Arg ArgName] -> Term -> TCM ()-assignTerm' x tel v = do-    reportSLn "tc.meta.assign" 70 $ prettyShow x ++ " := " ++ show v ++ "\n  in " ++ show tel-     -- verify (new) invariants-    whenM (not <$> asks envAssignMetas) __IMPOSSIBLE__--{- TODO make double-checking work--- currently, it does not work since types of sort-metas are inaccurate!--    -- Andreas, 2013-10-25 double check solution before assigning-    m <- lookupMeta x-    case mvJudgement m of-      HasType _ a -> dontAssignMetas $ checkInternal t a-      IsSort{}    -> return ()  -- skip double check since type of meta is not accurate--}-    -- Andreas, 2013-10-25 double check solution before assigning-    -- Andreas, 2013-11-30 this seems to open a can of worms...-    -- dontAssignMetas $ do-    --   checkInternal t . jMetaType . mvJudgement =<< lookupMeta x--    let i = metaInstance tel $ killRange v-    verboseS "profile.metas" 10 $ liftTCM $ tickMax "max-open-metas" . size =<< getOpenMetas-    modifyMetaStore $ ins x i-    etaExpandListeners x-    wakeupConstraints x-    reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x-  where-    metaInstance tel v = InstV tel v-    ins x i store = Map.adjust (inst i) x store-    inst i mv = mv { mvInstantiation = i }--    -- Andreas, 2013-10-25 hack to fool the unused-imports-checking-Nazi-    -- phantomUseToOverruleStrictImportsChecking = checkInternal---- * Creating meta variables.---- | Create a sort meta that cannot be instantiated with 'Inf' (Setω).-newSortMetaBelowInf :: TCM Sort-newSortMetaBelowInf = newSortMeta' $ HasType ()---- | Create a sort meta that may be instantiated with 'Inf' (Setω).-newSortMeta :: TCM Sort-newSortMeta = newSortMeta' $ IsSort ()--newSortMeta' :: (Type -> Judgement ()) -> TCM Sort-newSortMeta' judge =-  ifM typeInType (return $ mkType 0) $ {- else -}-  ifM hasUniversePolymorphism (newSortMetaCtx' judge =<< getContextArgs)-  -- else (no universe polymorphism)-  $ do i   <- createMetaInfo-       lvl <- levelType-       x   <- newMeta i normalMetaPriority (idP 0) $ judge lvl-       return $ Type $ Max [Plus 0 $ MetaLevel x []]---- | Create a sort meta that may be instantiated with 'Inf' (Setω).-newSortMetaCtx :: Args -> TCM Sort-newSortMetaCtx = newSortMetaCtx' $ IsSort ()--newSortMetaCtx' :: (Type -> Judgement ()) -> Args -> TCM Sort-newSortMetaCtx' judge vs = do-  ifM typeInType (return $ mkType 0) $ {- else -} do-    i   <- createMetaInfo-    tel <- getContextTelescope-    lvl <- levelType-    let t = telePi_ tel lvl-    x   <- newMeta i normalMetaPriority (idP 0) $ judge t-    reportSDoc "tc.meta.new" 50 $-      text "new sort meta" <+> prettyTCM x <+> text ":" <+> prettyTCM t-    return $ Type $ Max [Plus 0 $ MetaLevel x $ map Apply vs]--newTypeMeta :: Sort -> TCM Type-newTypeMeta s = El s . snd <$> newValueMeta RunMetaOccursCheck (sort s)--newTypeMeta_ ::  TCM Type-newTypeMeta_  = newTypeMeta =<< (workOnTypes $ newSortMeta)--- TODO: (this could be made work with new uni-poly)--- Andreas, 2011-04-27: If a type meta gets solved, than we do not have to check--- that it has a sort.  The sort comes from the solution.--- newTypeMeta_  = newTypeMeta Inf---- | @newIFSMeta s t cands@ creates a new "implicit from scope" metavariable---   of type the output type of @t@ with name suggestion @s@.---   If @t@ is a function type, then insert enough---   lambdas in front of it.-newIFSMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term)-newIFSMeta s t = do-  TelV tel t' <- telView t-  addContext tel $ do-    vs  <- getContextArgs-    ctx <- getContextTelescope-    mapSnd (teleLam tel) <$> newIFSMetaCtx s (telePi_ ctx t') vs--newIFSMetaCtx :: MetaNameSuggestion -> Type -> Args -> TCM (MetaId, Term)-newIFSMetaCtx s t vs = do-  reportSDoc "tc.meta.new" 50 $ fsep-    [ text "new ifs meta:"-    , nest 2 $ prettyTCM vs <+> text "|-"-    ]-  i0 <- createMetaInfo-  let i = i0 { miNameSuggestion = s }-  TelV tel _ <- telView t-  let perm = idP (size tel)-  x <- newMeta' OpenIFS i normalMetaPriority perm (HasType () t)-  reportSDoc "tc.meta.new" 50 $ fsep-    [ nest 2 $ pretty x <+> text ":" <+> prettyTCM t-    ]-  addConstraint $ FindInScope x Nothing Nothing-  etaExpandMetaSafe x-  return (x, MetaV x $ map Apply vs)---- | Create a new value meta with specific dependencies, possibly η-expanding in the process.-newNamedValueMeta :: RunMetaOccursCheck -> MetaNameSuggestion -> Type -> TCM (MetaId, Term)-newNamedValueMeta b s t = do-  (x, v) <- newValueMeta b t-  setMetaNameSuggestion x s-  return (x, v)---- | Create a new value meta with specific dependencies without η-expanding.-newNamedValueMeta' :: RunMetaOccursCheck -> MetaNameSuggestion -> Type -> TCM (MetaId, Term)-newNamedValueMeta' b s t = do-  (x, v) <- newValueMeta' b t-  setMetaNameSuggestion x s-  return (x, v)---- | Create a new metavariable, possibly η-expanding in the process.-newValueMeta :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)-newValueMeta b t = do-  vs  <- getContextArgs-  tel <- getContextTelescope-  newValueMetaCtx b t tel (idP $ size tel) vs--newValueMetaCtx :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)-newValueMetaCtx b t tel perm ctx =-  mapSndM instantiateFull =<< newValueMetaCtx' b t tel perm ctx---- | Create a new value meta without η-expanding.-newValueMeta' :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)-newValueMeta' b t = do-  vs  <- getContextArgs-  tel <- getContextTelescope-  newValueMetaCtx' b t tel (idP $ size tel) vs---- | Create a new value meta with specific dependencies.-newValueMetaCtx' :: RunMetaOccursCheck -> Type -> Telescope -> Permutation -> Args -> TCM (MetaId, Term)-newValueMetaCtx' b a tel perm vs = do-  i <- createMetaInfo' b-  let t     = telePi_ tel a-  x <- newMeta i normalMetaPriority perm (HasType () t)-  reportSDoc "tc.meta.new" 50 $ fsep-    [ text "new meta:"-    , nest 2 $ prettyTCM vs <+> text "|-"-    , nest 2 $ pretty x <+> text ":" <+> prettyTCM t-    ]-  etaExpandMetaSafe x-  -- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u-  u <- shared $ MetaV x $ map Apply vs-  boundedSizeMetaHook u tel a-  return (x, u)--newTelMeta :: Telescope -> TCM Args-newTelMeta tel = newArgsMeta (abstract tel $ typeDontCare)--type Condition = Dom Type -> Abs Type -> Bool--trueCondition :: Condition-trueCondition _ _ = True--newArgsMeta :: Type -> TCM Args-newArgsMeta = newArgsMeta' trueCondition--newArgsMeta' :: Condition -> Type -> TCM Args-newArgsMeta' condition t = do-  args <- getContextArgs-  tel  <- getContextTelescope-  newArgsMetaCtx' condition t tel (idP $ size tel) args--newArgsMetaCtx :: Type -> Telescope -> Permutation -> Args -> TCM Args-newArgsMetaCtx = newArgsMetaCtx' trueCondition--newArgsMetaCtx' :: Condition -> Type -> Telescope -> Permutation -> Args -> TCM Args-newArgsMetaCtx' condition (El s tm) tel perm ctx = do-  tm <- reduce tm-  case ignoreSharing tm of-    Pi dom@(Dom info a) codom | condition dom codom -> do-      (_, u) <- applyRelevanceToContext (getRelevance info) $-               {--                 -- Andreas, 2010-09-24 skip irrelevant record fields when eta-expanding a meta var-                 -- Andreas, 2010-10-11 this is WRONG, see Issue 347-                if r == Irrelevant then return DontCare else-                -}-                 newValueMetaCtx RunMetaOccursCheck a tel perm ctx-      args <- newArgsMetaCtx' condition (codom `absApp` u) tel perm ctx-      return $ Arg info u : args-    _  -> return []---- | 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 r pars tel (idP $ size tel) args--newRecordMetaCtx :: QName -> Args -> Telescope -> Permutation -> Args -> TCM Term-newRecordMetaCtx r pars tel perm ctx = do-  ftel   <- flip apply pars <$> getRecordFieldTypes r-  fields <- newArgsMetaCtx (telePi_ ftel $ sort Prop) tel perm ctx-  con    <- getRecordConstructor r-  return $ Con con ConOSystem fields--newQuestionMark :: InteractionId -> Type -> TCM (MetaId, Term)-newQuestionMark = newQuestionMark' $ newValueMeta' DontRunMetaOccursCheck--newQuestionMark' :: (Type -> TCM (MetaId, Term)) -> InteractionId -> Type -> TCM (MetaId, Term)-newQuestionMark' new ii t = do-  -- Andreas, 2016-07-29, issue 1720-2-  -- This is slightly risky, as the same interaction id-  -- maybe be shared between different contexts.-  -- Blame goes to the record processing hack, see issue #424-  -- and @ConcreteToAbstract.recordConstructorType@.-  let existing x = (x,) . MetaV x . map Apply <$> getContextArgs-  flip (caseMaybeM $ lookupInteractionMeta ii) existing $ {-else-} do--  -- Do not run check for recursive occurrence of meta in definitions,-  -- because we want to give the recursive solution interactively (Issue 589)-  (x, m) <- new t-  connectInteractionPoint ii x-  return (x, m)---- | Construct a blocked constant if there are constraints.-blockTerm :: Type -> TCM Term -> TCM Term-blockTerm t blocker = do-  (pid, v) <- newProblem blocker-  blockTermOnProblem t v pid--blockTermOnProblem :: Type -> Term -> ProblemId -> TCM Term-blockTermOnProblem t v pid =-  -- Andreas, 2012-09-27 do not block on unsolved size constraints-  ifM (isProblemSolved pid `or2M` isSizeProblem pid) (return v) $ do-    i   <- createMetaInfo-    es  <- map Apply <$> getContextArgs-    tel <- getContextTelescope-    x   <- newMeta' (BlockedConst $ abstract tel v)-                    i lowMetaPriority (idP $ size tel)-                    (HasType () $ telePi_ tel t)-                    -- we don't instantiate blocked terms-    inTopContext $ addConstraint (Guarded (UnBlock x) pid)-    reportSDoc "tc.meta.blocked" 20 $ vcat-      [ text "blocked" <+> prettyTCM x <+> text ":=" <+> inTopContext (prettyTCM $ abstract tel v)-      , text "     by" <+> (prettyTCM =<< getConstraintsForProblem pid) ]-    inst <- isInstantiatedMeta x-    case inst of-      True  -> instantiate (MetaV x es)-      False -> do-        -- We don't return the blocked term instead create a fresh metavariable-        -- that we compare against the blocked term once it's unblocked. This way-        -- blocked terms can be instantiated before they are unblocked, thus making-        -- constraint solving a bit more robust against instantiation order.-        -- Andreas, 2015-05-22: DontRunMetaOccursCheck to avoid Issue585-17.-        (_, v) <- newValueMeta DontRunMetaOccursCheck t-        i   <- liftTCM fresh-        -- This constraint is woken up when unblocking, so it doesn't need a problem id.-        cmp <- buildProblemConstraint_ (ValueCmp CmpEq t v (MetaV x es))-        listenToMeta (CheckConstraint i cmp) x-        return v--blockTypeOnProblem :: Type -> ProblemId -> TCM Type-blockTypeOnProblem (El s a) pid = El s <$> blockTermOnProblem (El Inf $ Sort s) a pid---- | @unblockedTester t@ returns @False@ if @t@ is a meta or a blocked term.------   Auxiliary function to create a postponed type checking problem.-unblockedTester :: Type -> TCM Bool-unblockedTester t = ifBlockedType t (\ m t -> return False) (\ t -> return True)---- | Create a postponed type checking problem @e : t@ that waits for type @t@---   to unblock (become instantiated or its constraints resolved).-postponeTypeCheckingProblem_ :: TypeCheckingProblem -> TCM Term-postponeTypeCheckingProblem_ p = do-  postponeTypeCheckingProblem p (unblock p)-  where-    unblock (CheckExpr _ t)           = unblockedTester t-    unblock (CheckArgs _ _ _ t _ _)   = unblockedTester t  -- The type of the head of the application.-    unblock (CheckLambda _ _ t)       = unblockedTester t-    unblock (UnquoteTactic _ _ _)     = __IMPOSSIBLE__     -- unquote problems must be supply their own tester---- | 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---   instantiation the postponed type checking problem.  An 'UnBlock' constraint---   is added for this meta, which links to this meta.-postponeTypeCheckingProblem :: TypeCheckingProblem -> TCM Bool -> TCM Term-postponeTypeCheckingProblem p unblock = do-  i   <- createMetaInfo' DontRunMetaOccursCheck-  tel <- getContextTelescope-  cl  <- buildClosure p-  t   <- problemType p-  m   <- newMeta' (PostponedTypeCheckingProblem cl unblock)-                  i normalMetaPriority (idP (size tel))-         $ HasType () $ telePi_ tel t--  -- Create the meta that we actually return-  -- Andreas, 2012-03-15-  -- This is an alias to the pptc meta, in order to allow pruning (issue 468)-  -- and instantiation.-  -- Since this meta's solution comes from user code, we do not need-  -- to run the extended occurs check (metaOccurs) to exclude-  -- non-terminating solutions.-  es  <- map Apply <$> getContextArgs-  (_, v) <- newValueMeta DontRunMetaOccursCheck t-  cmp <- buildProblemConstraint_ (ValueCmp CmpEq t v (MetaV m es))-  i   <- liftTCM fresh-  listenToMeta (CheckConstraint i cmp) m-  addConstraint (UnBlock m)-  return v---- | Type of the term that is produced by solving the 'TypeCheckingProblem'.-problemType :: TypeCheckingProblem -> TCM Type-problemType (CheckExpr _ t           ) = return t-problemType (CheckArgs _ _ _ _ t _ )   = return t  -- The target type of the application.-problemType (CheckLambda _ _ t       ) = return t-problemType (UnquoteTactic tac hole t) = return 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 $ text "waking boxed constraint" <+> prettyTCM c-  addAwakeConstraints [c]-  solveAwakeConstraints---- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).-etaExpandMetaSafe :: MetaId -> TCM ()-etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels]---- | Various kinds of metavariables.--data MetaKind =-    Records-    -- ^ Meta variables of record type.-  | SingletonRecords-    -- ^ Meta variables of \"hereditarily singleton\" record type.-  | Levels-    -- ^ Meta variables of level type, if type-in-type is activated.-  deriving (Eq, Enum, Bounded, Show)---- | All possible metavariable kinds.--allMetaKinds :: [MetaKind]-allMetaKinds = [minBound .. maxBound]---- | 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 -> TCM ()-etaExpandMeta kinds m = whenM (isEtaExpandable kinds m) $ do-  verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do-    let waitFor x = do-          reportSDoc "tc.meta.eta" 20 $ do-            text "postponing eta-expansion of meta variable" <+>-              prettyTCM m <+>-              text "which is blocked by" <+> prettyTCM x-          listenToMeta (EtaExpand m) x-        dontExpand = do-          reportSDoc "tc.meta.eta" 20 $ do-            text "we do not expand meta variable" <+> prettyTCM m <+>-              text ("(requested was expansion of " ++ show kinds ++ ")")-    meta           <- lookupMeta m-    let HasType _ a = mvJudgement meta-    TelV tel b     <- telView a-    -- if the target type @b@ of @m@ is a meta variable @x@ itself-    -- (@NonBlocked (MetaV{})@),-    -- or it is blocked by a meta-variable @x@ (@Blocked@), we cannot-    -- eta expand now, we have to postpone this.  Once @x@ is-    -- instantiated, we can continue eta-expanding m.  This is realized-    -- by adding @m@ to the listeners of @x@.-    ifBlocked (unEl b) (\ x _ -> waitFor x) $ \ t -> case ignoreSharing t of-      lvl@(Def r es) ->-        ifM (isEtaRecord r) {- then -} (do-          let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          let expand = do-                u <- withMetaInfo' meta $ newRecordMetaCtx r ps tel (idP $ size tel) $ teleArgs tel-                inTopContext $ do-                  verboseS "tc.meta.eta" 15 $ do-                    du <- prettyTCM u-                    reportSDoc "tc.meta.eta" 15 $ sep-                      [ text "eta expanding: " <+> pretty m <+> text " --> "-                      , nest 2 $ prettyTCM u-                      ]-                  -- Andreas, 2012-03-29: No need for occurrence check etc.-                  -- we directly assign the solution for the meta-                  -- 2012-05-23: We also bypass the check for frozen.-                  noConstraints $ assignTerm' m (telToArgs tel) u  -- should never produce any constraints-          if Records `elem` kinds then-            expand-           else if (SingletonRecords `elem` kinds) then do-             singleton <- isSingletonRecord r ps-             case singleton of-               Left x      -> waitFor x-               Right False -> dontExpand-               Right True  -> expand-            else dontExpand-        ) $ {- else -} ifM (andM [ return $ Levels `elem` kinds-                        , typeInType-                        , (Just lvl ==) <$> getBuiltin' builtinLevel-                        ]) (do-          reportSLn "tc.meta.eta" 20 $ "Expanding level meta to 0 (type-in-type)"-          -- Andreas, 2012-03-30: No need for occurrence check etc.-          -- we directly assign the solution for the meta-          noConstraints $ assignTerm m (telToArgs tel) (Level $ Max [])-       ) $ {- else -} dontExpand-      _ -> dontExpand---- | Eta expand blocking metavariables of record type, and reduce the--- blocked thing.--etaExpandBlocked :: Reduce t => Blocked t -> TCM (Blocked t)-etaExpandBlocked t@NotBlocked{} = return t-etaExpandBlocked (Blocked m t)  = do-  etaExpandMeta [Records] m-  t <- reduceB t-  case t of-    Blocked m' _ | m /= m' -> etaExpandBlocked t-    _                      -> return t---- * Solve constraint @x vs = v@.---- | Assign to an open metavar which may not be frozen.---   First check that metavar args are in pattern fragment.---     Then do extended occurs check on given thing.------   Assignment is aborted by throwing a @PatternErr@ via a call to---   @patternViolation@.  This error is caught by @catchConstraint@---   during equality checking (@compareAtom@) and leads to---   restoration of the original constraints.--assignV :: CompareDirection -> MetaId -> Args -> Term -> TCM ()-assignV dir x args v = assignWrapper dir x (map Apply args) v $ assign dir x args v--assignWrapper :: CompareDirection -> MetaId -> Elims -> Term -> TCM () -> TCM ()-assignWrapper dir x es v doAssign = do-  ifNotM (asks envAssignMetas) patternViolation $ {- else -} do-    reportSDoc "tc.meta.assign" 10 $ do-      text "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ show dir) <+> prettyTCM v-    liftTCM $ nowSolvingConstraints doAssign `finally` solveAwakeConstraints----- | Miller pattern unification:------   @assign x vs v@ solves problem @x vs = v@ for meta @x@---   if @vs@ are distinct variables (linearity check)---   and @v@ depends only on these variables---   and does not contain @x@ itself (occurs check).------   This is the basic story, but we have added some features:------   1. Pruning.---   2. Benign cases of non-linearity.---   3. @vs@ may contain record patterns.------   For a reference to some of these extensions, read---   Andreas Abel and Brigitte Pientka's TLCA 2011 paper.--assign :: CompareDirection -> MetaId -> Args -> Term -> TCM ()-assign dir x args v = do--  mvar <- lookupMeta x  -- information associated with meta x-  let t = jMetaType $ mvJudgement mvar--  -- Andreas, 2011-05-20 TODO!-  -- full normalization  (which also happens during occurs check)-  -- is too expensive! (see Issue 415)-  -- need to do something cheaper, especially if-  -- we are dealing with a Miller pattern that can be solved-  -- immediately!-  -- Ulf, 2011-08-25 DONE!-  -- Just instantiating the top-level meta, which is cheaper. The occurs-  -- check will first try without unfolding any definitions (treating-  -- arguments to definitions as flexible), if that fails it tries again-  -- with full unfolding.-  v <- instantiate v-  reportSLn "tc.meta.assign" 50 $ "MetaVars.assign: assigning to " ++ show v--  case (ignoreSharing v, mvJudgement mvar) of-      (Sort Inf, HasType{}) -> typeError SetOmegaNotValidType-      _                     -> return ()--  -- We don't instantiate frozen mvars-  when (mvFrozen mvar == Frozen) $ do-    reportSLn "tc.meta.assign" 25 $ "aborting: meta is frozen!"-    patternViolation--  -- We never get blocked terms here anymore. TODO: we actually do. why?-  whenM (isBlockedTerm x) patternViolation--  -- Andreas, 2010-10-15 I want to see whether rhs is blocked-  reportSLn "tc.meta.assign" 50 $ "MetaVars.assign: I want to see whether rhs is blocked"-  reportSDoc "tc.meta.assign" 25 $ do-    v0 <- reduceB v-    case v0 of-      Blocked m0 _ -> text "r.h.s. blocked on:" <+> prettyTCM m0-      NotBlocked{} -> text "r.h.s. not blocked"--  -- 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--    -- Normalise and eta contract the arguments to the meta. These are-    -- usually small, and simplifying might let us instantiate more metas.--    -- MOVED TO expandProjectedVars:-    -- args <- etaContract =<< normalise args--    -- Also, try to expand away projected vars in meta args.-    expandProjectedVars args v $ \ args v -> do--      -- If we had the type here we could save the work we put-      -- into expanding projected variables.-      -- catchConstraint (ValueCmp CmpEq ? (MetaV m $ map Apply args) v) $ do--      -- Andreas, 2011-04-21 do the occurs check first-      -- e.g. _1 x (suc x) = suc (_2 x y)-      -- even though the lhs is not a pattern, we can prune the y from _2--      (relVL, irrVL) <- do-        -- Andreas, 2016-11-03 #2211 attempt to do s.th. for unused-        if False -- irrelevantOrUnused $ getMetaRelevance mvar-          then do-            reportSDoc "tc.meta.assign" 25 $ text "meta is irrelevant or unused"-            return (Set.toList $ allFreeVars args, empty)-          else do-            -- Andreas, 2016-11-03, issue #2211-            -- treating UnusedArg as Irrelevant bears trouble-            -- since the UnusedArg info is not consistently present-            -- Thus, make sure we include the "unused" variables.-            let relVL = Set.toList $ allRelevantOrUnusedVars args-            -- 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)-            -- Update 2011-03-27: Also irr. vars under record constructors.-            let fromIrrVar (Var i [])   = return [i]-                fromIrrVar (Con c _ vs)   =-                  ifM (isNothing <$> isRecordConstructor (conName c)) (return []) $-                    concat <$> mapM (fromIrrVar . {- stripDontCare .-} unArg) vs-                fromIrrVar (Shared p)   = fromIrrVar (derefPtr p)-                fromIrrVar _ = return []-            irrVL <- concat <$> mapM fromIrrVar-                       [ v | Arg info v <- args, isIrrelevant info ]-                          -- irrelevantOrUnused (getRelevance info) ]-            return (relVL, irrVL)-      reportSDoc "tc.meta.assign" 20 $-          let pr (Var n []) = text (show n)-              pr (Def c []) = prettyTCM c-              pr _          = text ".."-          in vcat-               [ text "mvar args:" <+> sep (map (pr . unArg) args)-               , text "fvars lhs (rel):" <+> sep (map (text . show) relVL)-               , text "fvars lhs (irr):" <+> sep (map (text . show) irrVL)-               ]--      -- Check that the x doesn't occur in the right hand side.-      -- Prune mvars on rhs such that they can only depend on lhs vars.-      -- Herein, distinguish relevant and irrelevant vars,-      -- since when abstracting irrelevant lhs vars, they may only occur-      -- irrelevantly on rhs.-      v <- liftTCM $ occursCheck x (relVL, irrVL) v--      reportSLn "tc.meta.assign" 15 "passed occursCheck"-      verboseS "tc.meta.assign" 30 $ do-        let n = termSize v-        when (n > 200) $ reportSDoc "tc.meta.assign" 30 $-          sep [ text "size" <+> text (show n)---              , nest 2 $ text "type" <+> prettyTCM t-              , nest 2 $ text "term" <+> prettyTCM v-              ]--      -- Check linearity of @ids@-      -- Andreas, 2010-09-24: Herein, ignore the variables which are not-      -- free in v-      -- Ulf, 2011-09-22: we need to respect irrelevant vars as well, otherwise-      -- we'll build solutions where the irrelevant terms are not valid-      let fvs = allFreeVars v-      reportSDoc "tc.meta.assign" 20 $-        text "fvars rhs:" <+> sep (map (text . show) $ Set.toList fvs)--      -- Check that the arguments are variables-      mids <- do-        res <- runExceptT $ inverseSubst args-        case res of-          -- all args are variables-          Right ids -> do-            reportSDoc "tc.meta.assign" 50 $-              text "inverseSubst returns:" <+> sep (map prettyTCM ids)-            return $ Just ids-          -- 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-          -- 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:-          -- same as neutral-          Left ProjectedVar{} -> Just <$> attemptPruning x args fvs--      case mids of-        Nothing  -> patternViolation -- Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v-        Just ids -> do-          -- Check linearity-          ids <- do-            res <- runExceptT $ checkLinearity {- (`Set.member` fvs) -} ids-            case res of-              -- case: linear-              Right ids -> return ids-              -- case: non-linear variables that could possibly be pruned-              Left ()   -> attemptPruning x args fvs--          -- Solve.-          m <- getContextSize-          assignMeta' m x t (length args) ids v-  where-    attemptPruning x args fvs = do-      -- non-linear lhs: we cannot solve, but prune-      killResult <- prune x args $ Set.toList fvs-      reportSDoc "tc.meta.assign" 10 $-        text "pruning" <+> prettyTCM x <+> do-        text $-          if killResult `elem` [PrunedSomething,PrunedEverything] then "succeeded"-           else "failed"-      patternViolation--{- 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---   for instance arguments, where knowing the head D might enable progress.-attemptInertRHSImprovement :: MetaId -> Args -> Term -> TCM ()-attemptInertRHSImprovement m args v = do-  reportSDoc "tc.meta.inert" 30 $ vcat-    [ text "attempting inert rhs improvement"-    , nest 2 $ sep [ prettyTCM (MetaV m $ map Apply args) <+> text "=="-                   , prettyTCM v ] ]-  -- Check that the right-hand side has the form D vs, for some inert constant D.-  -- Returns the type of D and a function to build an application of D.-  (a, mkRHS) <- ensureInert v-  -- Check that all arguments to the meta are neutral and does not have head D.-  -- If there are non-neutral arguments there could be solutions to the meta-  -- that computes over these arguments. If D is an argument to the meta we get-  -- multiple solutions (for instance: _M Nat == Nat can be solved by both-  -- _M := \ x -> x and _M := \ x -> Nat).-  mapM_ (ensureNeutral (mkRHS []) . unArg) args-  tel <- theTel <$> (telView =<< getMetaType m)-  -- When attempting shortcut meta solutions, metas aren't necessarily fully-  -- eta expanded. If this is the case we skip inert improvement.-  when (length args < size tel) $ do-    reportSDoc "tc.meta.inert" 30 $ text "not fully applied"-    patternViolation-  -- Solve the meta with _M := \ xs -> D (_Y1 xs) .. (_Yn xs), for fresh metas-  -- _Yi.-  metaArgs <- inTopContext $ addContext tel $ newArgsMeta a-  let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)-      sol     = mkRHS metaArgs-      argTel  = map ("x" <$) args-  reportSDoc "tc.meta.inert" 30 $ nest 2 $ vcat-    [ text "a       =" <+> prettyTCM a-    , text "tel     =" <+> prettyTCM tel-    , text "metas   =" <+> prettyList (map prettyTCM metaArgs)-    , text "sol     =" <+> prettyTCM sol-    ]-  assignTerm m argTel sol-  patternViolation  -- throwing a pattern violation here lets the constraint-                    -- machinery worry about restarting the comparison.-  where-    ensureInert :: Term -> TCM (Type, Args -> Term)-    ensureInert v = do-      let notInert = do-            reportSDoc "tc.meta.inert" 30 $ nest 2 $ text "not inert:" <+> prettyTCM v-            patternViolation-          toArgs elims =-            case allApplyElims elims of-              Nothing -> do-                reportSDoc "tc.meta.inert" 30 $ nest 2 $ text "can't do projections from inert"-                patternViolation-              Just args -> return args-      case ignoreSharing v of-        Var x elims -> (, Var x . map Apply) <$> typeOfBV x-        Con c ci args  -> notInert -- (, Con c ci) <$> defType <$> getConstInfo (conName c)-        Def f elims -> do-          def <- getConstInfo f-          let good = return (defType def, Def f . map Apply)-          case theDef def of-            Axiom{}       -> good-            Datatype{}    -> good-            Record{}      -> good-            Function{}    -> notInert-            Primitive{}   -> notInert-            Constructor{} -> __IMPOSSIBLE__--        Pi{}       -> notInert -- this is actually inert but improving doesn't buy us anything for Pi-        Lam{}      -> notInert-        Sort{}     -> notInert-        Lit{}      -> notInert-        Level{}    -> notInert-        MetaV{}    -> notInert-        DontCare{} -> notInert-        Shared{}   -> __IMPOSSIBLE__--    ensureNeutral :: Term -> Term -> TCM ()-    ensureNeutral rhs v = do-      b <- reduceB v-      let notNeutral v = do-            reportSDoc "tc.meta.inert" 30 $ nest 2 $ text "not neutral:" <+> prettyTCM v-            patternViolation-          checkRHS arg-            | arg == rhs = do-              reportSDoc "tc.meta.inert" 30 $ nest 2 $ text "argument shares head with RHS:" <+> prettyTCM arg-              patternViolation-            | otherwise  = return ()-      case fmap ignoreSharing b of-        Blocked{}      -> notNeutral v-        NotBlocked r v ->                      -- Andrea(s) 2014-12-06 can r be useful?-          case v of-            Var x _    -> checkRHS (Var x [])-            Def f _    -> checkRHS (Def f [])-            Pi{}       -> return ()-            Sort{}     -> return ()-            Level{}    -> return ()-            Lit{}      -> notNeutral v-            DontCare{} -> notNeutral v-            MetaV{}    -> notNeutral v-            Con{}      -> notNeutral v-            Lam{}      -> notNeutral v-            Shared{}   -> __IMPOSSIBLE__--- END UNUSED -}---- | @assignMeta m x t ids u@ solves @x ids = u@ for meta @x@ of type @t@,---   where term @u@ lives in a context of length @m@.---   Precondition: @ids@ is linear.-assignMeta :: Int -> MetaId -> Type -> [Int] -> Term -> TCM ()-assignMeta m x t ids v = do-  let n    = length ids-      cand = List.sort $ zip ids $ map var $ downFrom n-  assignMeta' m x t n cand v---- | @assignMeta' m x t ids u@ solves @x = [ids]u@ for meta @x@ of type @t@,---   where term @u@ lives in a context of length @m@,---   and @ids@ is a partial substitution.-assignMeta' :: Int -> MetaId -> Type -> Int -> SubstCand -> Term -> TCM ()-assignMeta' m x t n ids v = do-  -- we are linear, so we can solve!-  reportSDoc "tc.meta.assign" 25 $-      text "preparing to instantiate: " <+> prettyTCM v--  -- Rename the variables in v to make it suitable for abstraction over ids.-  v' <- do-    -- Basically, if-    --   Γ   = a b c d e-    --   ids = d b e-    -- then-    --   v' = (λ a b c d e. v) _ 1 _ 2 0-    ---    -- Andreas, 2013-10-25 Solve using substitutions:-    -- Convert assocList @ids@ (which is sorted) into substitution,-    -- filling in __IMPOSSIBLE__ for the missing terms, e.g.-    -- [(0,0),(1,2),(3,1)] --> [0, 2, __IMP__, 1, __IMP__]-    -- ALT 1: O(m * size ids), serves as specification-    -- let ivs = [fromMaybe __IMPOSSIBLE__ $ lookup i ids | i <- [0..m-1]]-    -- ALT 2: O(m)-    let assocToList i l = case l of-          _           | i >= m -> []-          ((j,u) : l) | i == j -> Just u  : assocToList (i+1) l-          _                    -> Nothing : assocToList (i+1) l-        ivs = assocToList 0 ids-        rho = prependS __IMPOSSIBLE__ ivs $ raiseS n-    return $ applySubst rho v--  -- Metas are top-level so we do the assignment at top-level.-  inTopContext $ do-    -- Andreas, 2011-04-18 to work with irrelevant parameters-    -- we need to construct tel' from the type of the meta variable-    -- (no longer from ids which may not be the complete variable list-    -- any more)-    reportSDoc "tc.meta.assign" 15 $ text "type of meta =" <+> prettyTCM t-    reportSDoc "tc.meta.assign" 70 $ text "type of meta =" <+> text (show t)--    TelV tel' _ <- telViewUpTo n t-    reportSDoc "tc.meta.assign" 30 $ text "tel'  =" <+> prettyTCM tel'-    reportSDoc "tc.meta.assign" 30 $ text "#args =" <+> text (show n)-    -- Andreas, 2013-09-17 (AIM XVIII): if t does not provide enough-    -- types for the arguments, it might be blocked by a meta;-    -- then we give up. (Issue 903)-    when (size tel' < n)-       patternViolation -- WAS: __IMPOSSIBLE__--    -- Perform the assignment (and wake constraints).-    reportSDoc "tc.meta.assign" 10 $-      text "solving" <+> prettyTCM x <+> text ":=" <+> prettyTCM (abstract tel' v')-    assignTerm x (telToArgs tel') v'----- | Turn the assignment problem @_X args <= SizeLt u@ into--- @_X args = SizeLt (_Y args)@ and constraint--- @_Y args <= u@.-subtypingForSizeLt-  :: CompareDirection -- ^ @dir@-  -> MetaId           -- ^ The meta variable @x@.-  -> MetaVariable     -- ^ Its associated information @mvar <- lookupMeta x@.-  -> Type             -- ^ Its type @t = jMetaType $ mvJudgement mvar@-  -> Args             -- ^ Its arguments.-  -> Term             -- ^ Its to-be-assigned value @v@, such that @x args `dir` v@.-  -> (Term -> TCM ()) -- ^ Continuation taking its possibly assigned value.-  -> TCM ()-subtypingForSizeLt DirEq x mvar t args v cont = cont v-subtypingForSizeLt dir   x mvar t args v cont = do-  let fallback = cont v-  -- Check whether we have built-ins SIZE and SIZELT-  (mSize, mSizeLt) <- getBuiltinSize-  caseMaybe mSize   fallback $ \ qSize   -> do-    caseMaybe mSizeLt fallback $ \ qSizeLt -> do-      -- Check whether v is a SIZELT-      v <- reduce v-      case ignoreSharing v of-        Def q [Apply (Arg ai u)] | q == qSizeLt -> do-          -- Clone the meta into a new size meta @y@.-          -- To this end, we swap the target of t for Size.-          TelV tel _ <- telView t-          let size = sizeType_ qSize-              t'   = telePi tel size-          y <- newMeta (mvInfo mvar) (mvPriority mvar) (mvPermutation mvar)-                       (HasType __IMPOSSIBLE__ t')-          -- Note: no eta-expansion of new meta possible/necessary.-          -- Add the size constraint @y args `dir` u@.-          let yArgs = MetaV y $ map Apply args-          addConstraint $ dirToCmp (`ValueCmp` size) dir yArgs u-          -- We continue with the new assignment problem, and install-          -- an exception handler, since we created a meta and a constraint,-          -- so we cannot fall back to the original handler.-          let xArgs = MetaV x $ map Apply args-              v'    = Def qSizeLt [Apply $ Arg ai yArgs]-              c     = dirToCmp (`ValueCmp` sizeUniv) dir xArgs v'-          catchConstraint c $ cont v'-        _ -> fallback---- | Eta-expand bound variables like @z@ in @X (fst z)@.-expandProjectedVars :: (Normalise a, TermLike a, Show a, PrettyTCM a, NoProjectedVar a,-                        Subst Term a, PrettyTCM b, Subst Term b) =>-  a -> b -> (a -> b -> TCM c) -> TCM c-expandProjectedVars args v ret = loop (args, v) where-  loop (args, v) = do-    reportSDoc "tc.meta.assign.proj" 45 $ text "meta args: " <+> prettyTCM args-    args <- etaContract =<< normalise args-    reportSDoc "tc.meta.assign.proj" 45 $ text "norm args: " <+> prettyTCM args-    reportSDoc "tc.meta.assign.proj" 85 $ text "norm args: " <+> text (show args)-    let done = ret args v-    case noProjectedVar args of-      Right ()              -> do-        reportSDoc "tc.meta.assign.proj" 40 $-          text "no projected var found in args: " <+> prettyTCM args-        done-      Left (ProjVarExc i _) -> etaExpandProjectedVar i (args, v) done loop---- | Eta-expand a de Bruijn index of record type in context and passed term(s).-etaExpandProjectedVar :: (PrettyTCM a, Subst Term a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c-etaExpandProjectedVar i v fail succeed = do-  reportSDoc "tc.meta.assign.proj" 40 $-    text "trying to expand projected variable" <+> prettyTCM (var i)-  caseMaybeM (etaExpandBoundVar i) fail $ \ (delta, sigma, tau) -> do-    reportSDoc "tc.meta.assign.proj" 25 $-      text "eta-expanding var " <+> prettyTCM (var i) <+>-      text " in terms " <+> prettyTCM v-    inTopContext $ addContext delta $-      succeed $ applySubst tau v---- | Check whether one of the meta args is a projected var.-class NoProjectedVar a where-  noProjectedVar :: a -> Either ProjVarExc ()--data ProjVarExc = ProjVarExc Int [(ProjOrigin, QName)]---- ASR (17 June 2015). Unused Error instance.--- instance Error ProjVarExc where---   noMsg = __IMPOSSIBLE__--instance NoProjectedVar Term where-  noProjectedVar t =-    case ignoreSharing t of-      Var i es-        | qs@(_:_) <- takeWhileJust id $ map isProjElim es -> Left $ ProjVarExc i qs-      -- Andreas, 2015-09-12 Issue 1316:-      -- Also look in inductive record constructors-      Con (ConHead _ Inductive (_:_)) _ vs -> noProjectedVar vs-      _ -> return ()--instance NoProjectedVar a => NoProjectedVar (Arg a) where-  noProjectedVar = Fold.mapM_ noProjectedVar--instance NoProjectedVar a => NoProjectedVar [a] where-  noProjectedVar = Fold.mapM_ noProjectedVar---{- UNUSED, BUT KEEP!--- Wrong attempt at expanding bound variables.--- The following code curries meta instead.---- | @etaExpandProjectedVar mvar x t n qs@------   @mvar@ is the meta var info.---   @x@ is the meta variable we are trying to solve for.---   @t@ is its type.---   @n@ is the number of the meta arg we want to curry (starting at 0).---   @qs@ is the projection path along which we curry.----etaExpandProjectedVar :: MetaVariable -> MetaId -> Type -> Int -> [QName] -> TCM a-etaExpandProjectedVar mvar x t n qs = inTopContext $ do-  (_, uncurry, t') <- curryAt t n-  let TelV tel a = telView' t'-      perm       = idP (size tel)-  y <- newMeta (mvInfo mvar) (mvPriority mvar) perm (HasType __IMPOSSIBLE__ t')-  assignTerm' x (uncurry $ MetaV y [])-  patternViolation--}--{--  -- first, strip the leading n domains (which remain unchanged)-  TelV gamma core <- telViewUpTo n t-  case ignoreSharing $ unEl core of-    -- There should be at least one domain left-    Pi (Dom ai a) b -> do-      -- Eta-expand @dom@ along @qs@ into a telescope @tel@, computing a substitution.-      -- For now, we only eta-expand once.-      -- 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-      unless (recEtaEquality def) __IMPOSSIBLE__-      let tel = recTel def `apply` pars-          m   = size tel-          v   = Con (recConHead def) $ map var $ downFrom m-          b'  = raise m b `absApp` v-          fs  = recFields def-          vs  = zipWith (\ f i -> Var i [Proj f]) fs $ downFrom m-          -- v = c (n-1) ... 1 0-      (tel, u) <- etaExpandAtRecordType a $ var 0-      -- TODO: compose argInfo ai with tel.-      -- Substitute into @b@.-      -- Abstract over @tel@.-      -- Abstract over @gamma@.-      -- Create new meta.-      -- Solve old meta, using substitution.-      patternViolation-    _ -> __IMPOSSIBLE__--}--type FVs = Set.VarSet-type SubstCand = [(Int,Term)] -- ^ a possibly non-deterministic substitution---- | Turn non-det substitution into proper substitution, if possible.---   Otherwise, raise the error.-checkLinearity :: SubstCand -> ExceptT () TCM SubstCand-checkLinearity ids0 = do-  let ids = sortBy (compare `on` fst) ids0  -- see issue 920-  let grps = groupOn fst ids-  concat <$> mapM makeLinear grps-  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) : _) =-      ifM ((Right True ==) <$> do isSingletonTypeModuloRelevance =<< typeOfBV i)-        (return [p])-        (throwError ())---- Intermediate result in the following function-type Res = [(Arg Nat, Term)]---- | Exceptions raised when substitution cannot be inverted.-data InvertExcept-  = CantInvert                -- ^ Cannot recover.-  | NeutralArg                -- ^ A potentially neutral arg: can't invert, but can try pruning.-  | ProjectedVar Int [(ProjOrigin, QName)]  -- ^ Try to eta-expand var to remove projs.--#if !MIN_VERSION_transformers(0,4,1)-instance Error InvertExcept where-  noMsg = CantInvert-#endif---- | Check that arguments @args@ to a metavar are in pattern fragment.---   Assumes all arguments already in whnf and eta-reduced.---   Parameters are represented as @Var@s so @checkArgs@ really---   checks that all args are @Var@s and returns the "substitution"---   to be applied to the rhs of the equation to solve.---   (If @args@ is considered a substitution, its inverse is returned.)------   The returned list might not be ordered.---   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)-  where-    loop  = foldM isVarOrIrrelevant []-    terms = map var (downFrom (size args))-    failure = do-      lift $ reportSDoc "tc.meta.assign" 15 $ vcat-        [ text "not all arguments are variables: " <+> prettyTCM args-        , text "  aborting assignment" ]-      throwError CantInvert-    neutralArg = throwError NeutralArg--    isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res-    isVarOrIrrelevant vars (arg, t) =-      case ignoreSharing <$> arg of-        -- i := x-        Arg info (Var i []) -> return $ (Arg info i, t) `cons` vars--        -- π i := x  try to eta-expand projection π away!-        Arg _ (Var i es) | Just qs <- mapM isProjElim es ->-          throwError $ ProjectedVar i qs--        -- (i, j) := x  becomes  [i := fst x, j := snd x]-        -- Andreas, 2013-09-17 but only if constructor is fully applied-        Arg info (Con c ci vs) -> do-          let fallback-               | isIrrelevant info = return vars-                 -- Andreas, 2016-11-03, issue #2211-                 -- treating UnusedArg as Irrelevant bears trouble-                 -- since the UnusedArg info is not consistently present-                 -- irrelevantOrUnused (getRelevance info) = return vars-               | otherwise                              = failure-          isRC <- lift $ isRecordConstructor $ conName c-          case isRC of-            Just (_, Record{ recFields = fs })-              | length fs == length vs -> do-                let aux (Arg _ v) (Arg info' f) = (Arg ai v,) $ t `applyE` [Proj ProjSystem f] where-                     ai = ArgInfo-                       { argInfoHiding       = min (getHiding info) (getHiding info')-                       , argInfoRelevance    = max (getRelevance info) (getRelevance info')-                       , argInfoOrigin       = min (getOrigin info) (getOrigin info')-                       , argInfoOverlappable = False-                       }-                res <- loop $ zipWith aux vs fs-                return $ res `append` vars-              | otherwise -> fallback-            Just _  -> __IMPOSSIBLE__-            Nothing -> fallback--        -- An irrelevant argument which is not an irrefutable pattern is dropped-        Arg info _ | isIrrelevant info -> return vars-          -- Andreas, 2016-11-03, issue #2211-          -- treating UnusedArg as Irrelevant bears trouble-          -- since the UnusedArg info is not consistently present-          -- irrelevantOrUnused (getRelevance info) -> return vars-        -- Andreas, 2013-10-29-        -- An irrelevant part can also be marked by a DontCare-        -- (coming from an irrelevant projection), see Issue 927:-        Arg _ DontCare{}                                    -> return vars--        -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure-        -- from those that can only put somewhere as a whole ==> neutralArg-        Arg _ Var{}      -> neutralArg-        Arg _ Def{}      -> neutralArg  -- Note that this Def{} is in normal form and might be prunable.-        Arg _ Lam{}      -> failure-        Arg _ Lit{}      -> failure-        Arg _ MetaV{}    -> failure-        Arg _ Pi{}       -> neutralArg-        Arg _ Sort{}     -> neutralArg-        Arg _ Level{}    -> neutralArg--        Arg info (Shared p) -> isVarOrIrrelevant vars (Arg info $ derefPtr p, t)--    -- 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 (ArgInfo _ Irrelevant _ _) i, t) vars    -- TODO? UnusedArg?!-      | any ((i==) . unArg . fst) vars  = vars-      | otherwise                       = a : vars-    -- adding a relevant entry:-    cons a@(Arg info i, t) vars = a :-      -- filter out duplicate irrelevants-      filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars---- UNUSED--- -- | Used in 'Agda.Interaction.BasicOps.giveExpr'.--- updateMeta :: MetaId -> Term -> TCM ()--- updateMeta mI v = do---     mv <- lookupMeta mI---     withMetaInfo' mv $ do---       args <- getContextArgs---       noConstraints $ assignV DirEq mI args v---- | Turn open metas into postulates.------   Preconditions:------   1. We are 'inTopContext'.------   2. 'envCurrentModule' is set to the top-level module.----openMetasToPostulates :: TCM ()-openMetasToPostulates = do-  m <- asks envCurrentModule--  -- Go through all open metas.-  ms <- Map.assocs <$> use stMetaStore-  forM_ ms $ \ (x, mv) -> do-    when (isOpenMeta $ mvInstantiation mv) $ do-      let t = 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." ++ show (metaId x)-      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 x <+> text " into postulate."-        , nest 2 $ vcat-          [ text "Name: " <+> prettyTCM q-          , text "Type: " <+> prettyTCM t-          ]-        ]--      -- Add the new postulate to the signature.-      addConstant q $ defaultDefn defaultArgInfo q t Axiom--      -- Solve the meta.-      let inst = InstV [] $ Def q []-      stMetaStore %= Map.adjust (\ mv0 -> mv0 { mvInstantiation = inst }) x-      return ()+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.MetaVars where++import Prelude hiding (null)++import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT )+import Control.Monad.Trans.Maybe++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++import Agda.Interaction.Options++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+import Agda.Syntax.Position (getRange, killRange)++import Agda.TypeChecking.Monad+-- import Agda.TypeChecking.Monad.Builtin+-- import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Sort+import Agda.TypeChecking.Substitute+import qualified Agda.TypeChecking.SyntacticEquality as SynEq+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Free+import Agda.TypeChecking.Lock+import Agda.TypeChecking.Level (levelType)+import Agda.TypeChecking.Records+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.EtaContract+import Agda.TypeChecking.SizedTypes (boundedSizeMetaHook, isSizeProblem)+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal+import {-# SOURCE #-} Agda.TypeChecking.Conversion++-- import Agda.TypeChecking.CheckInternal+-- 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.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.Impossible++instance MonadMetaSolver TCM where+  newMeta' = newMetaTCM'+  assignV dir x args v t = assignWrapper dir x (map Apply args) v $ assign dir x args v t+  assignTerm' = assignTermTCM'+  etaExpandMeta = etaExpandMetaTCM+  updateMetaVar = updateMetaVarTCM++  -- Right now we roll back the full state when aborting.+  -- TODO: only roll back the metavariables+  speculateMetas fallback m = do+    (a, s) <- localTCStateSaving m+    case a of+      KeepMetas     -> putTC s+      RollBackMetas -> fallback++-- | Find position of a value in a list.+--   Used to change metavar argument indices during assignment.+--+--   @reverse@ is necessary because we are directly abstracting over the list.+--+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 <- 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 <- lookupMetaInstantiation x+    let r = case i of+            BlockedConst{}                 -> True+            PostponedTypeCheckingProblem{} -> True+            InstV{}                        -> False+            OpenMeta{}                     -> False+    reportSLn "tc.meta.blocked" 12 $+      if r then "  yes, because " ++ prettyShow i else "  no"+    return r++isEtaExpandable :: [MetaClass] -> MetaId -> TCM Bool+isEtaExpandable classes x = do+    i <- lookupMetaInstantiation x+    return $ case i of+      OpenMeta UnificationMeta       -> True+      OpenMeta InstanceMeta          -> Records `notElem` classes+      InstV{}                        -> False+      BlockedConst{}                 -> False+      PostponedTypeCheckingProblem{} -> False++-- * Performing the assignment++-- | Performing the meta variable assignment.+--+--   The instantiation should not be an 'InstV' and the 'MetaId'+--   should point to something 'Open' or a 'BlockedConst'.+--   Further, the meta variable may not be 'Frozen'.+assignTerm :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m ()+assignTerm x tel v = do+     -- verify (new) invariants+    whenM (isFrozen x) __IMPOSSIBLE__+    assignTerm' x tel v++-- | Skip frozen check.  Used for eta expanding frozen metas.+assignTermTCM' :: MetaId -> [Arg ArgName] -> Term -> TCM ()+assignTermTCM' x tel v = do+    reportSDoc "tc.meta.assign" 70 $ vcat+      [ "assignTerm" <+> prettyTCM x <+> " := " <+> prettyTCM v+      , nest 2 $ "tel =" <+> prettyList_ (map (text . unArg) tel)+      ]+     -- verify (new) invariants+    whenM (not <$> asksTC envAssignMetas) __IMPOSSIBLE__++    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++-- * Creating meta variables.++-- | Create a sort meta that cannot be instantiated with 'Inf' (Setω).+newSortMetaBelowInf :: TCM Sort+newSortMetaBelowInf = do+  x <- newSortMeta+  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 =+  ifM hasUniversePolymorphism (newSortMetaCtx =<< getContextArgs)+  -- else (no universe polymorphism)+  $ do i   <- createMetaInfo+       let j = IsSort () __DUMMY_TYPE__+       x   <- newMeta Instantiable i normalMetaPriority (idP 0) j+       reportSDoc "tc.meta.new" 50 $+         "new sort meta" <+> prettyTCM x+       return $ MetaS x []++-- | Create a sort meta that may be instantiated with 'Inf' (Setω).+newSortMetaCtx :: MonadMetaSolver m => Args -> m Sort+newSortMetaCtx vs = do+    i   <- createMetaInfo+    tel <- getContextTelescope+    let t = telePi_ tel __DUMMY_TYPE__+    x   <- newMeta Instantiable i normalMetaPriority (idP $ size tel) $ IsSort () t+    reportSDoc "tc.meta.new" 50 $+      "new sort meta" <+> prettyTCM x <+> ":" <+> prettyTCM t+    return $ MetaS x $ map Apply vs++newTypeMeta' :: Comparison -> Sort -> TCM Type+newTypeMeta' cmp s = El s . snd <$> newValueMeta RunMetaOccursCheck cmp (sort s)++newTypeMeta :: Sort -> TCM Type+newTypeMeta = newTypeMeta' CmpLeq++newTypeMeta_ ::  TCM Type+newTypeMeta_  = newTypeMeta' CmpEq =<< (workOnTypes $ newSortMeta)+-- TODO: (this could be made work with new uni-poly)+-- Andreas, 2011-04-27: If a type meta gets solved, than we do not have to check+-- 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+  return $ case v of+    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+  :: MonadMetaSolver m+  => MetaNameSuggestion -> Type -> m (MetaId, Term)+newInstanceMeta s t = do+  vs  <- getContextArgs+  ctx <- getContextTelescope+  newInstanceMetaCtx s (telePi_ ctx t) vs++newInstanceMetaCtx+  :: MonadMetaSolver m+  => MetaNameSuggestion -> Type -> Args -> m (MetaId, Term)+newInstanceMetaCtx s t vs = do+  reportSDoc "tc.meta.new" 50 $ fsep+    [ "new instance meta:"+    , nest 2 $ prettyTCM vs <+> "|-"+    ]+  -- Andreas, 2017-10-04, issue #2753: no metaOccurs check for instance metas+  i0 <- createMetaInfo' DontRunMetaOccursCheck+  let i = i0 { miNameSuggestion = s }+  TelV tel _ <- telView t+  let perm = idP (size tel)+  x <- newMeta' (OpenMeta InstanceMeta) Instantiable i normalMetaPriority perm (HasType () CmpLeq t)+  reportSDoc "tc.meta.new" 50 $ fsep+    [ nest 2 $ pretty x <+> ":" <+> prettyTCM t+    ]+  r <- getMetaRange x+  let c = FindInstance r x Nothing+  addAwakeConstraint alwaysUnblock c+  etaExpandMetaSafe x+  return (x, MetaV x $ map Apply vs)++-- | Create a new value meta with specific dependencies, possibly η-expanding in the process.+newNamedValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta b s cmp t = do+  (x, v) <- newValueMeta b cmp t+  setMetaNameSuggestion x s+  return (x, v)++-- | Create a new value meta with specific dependencies without η-expanding.+newNamedValueMeta' :: MonadMetaSolver m => RunMetaOccursCheck -> MetaNameSuggestion -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta' b s cmp t = do+  (x, v) <- newValueMeta' b cmp t+  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+  vs  <- getContextArgs+  tel <- getContextTelescope+  newValueMetaCtx Instantiable b cmp t tel (idP $ size tel) vs++newValueMetaCtx+  :: MonadMetaSolver m+  => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)+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+  => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)+newValueMeta' b cmp t = do+  vs  <- getContextArgs+  tel <- getContextTelescope+  newValueMetaCtx' Instantiable b cmp t tel (idP $ size tel) vs++newValueMetaCtx'+  :: MonadMetaSolver m+  => Frozen -> RunMetaOccursCheck -> Comparison -> Type -> Telescope -> Permutation -> Args -> m (MetaId, Term)+newValueMetaCtx' frozen b cmp a tel perm vs = do+  i <- createMetaInfo' b+  let t     = telePi_ tel a+  x <- newMeta frozen i normalMetaPriority perm (HasType () cmp t)+  modality <- currentModality+  reportSDoc "tc.meta.new" 50 $ fsep+    [ text $ "new meta (" ++ show (i ^. lensIsAbstract) ++ "):"+    , nest 2 $ prettyTCM vs <+> "|-"+    , nest 2 $ pretty x <+> ":" <+> pretty modality <+> prettyTCM t+    ]+  etaExpandMetaSafe x+  -- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u+  let u = MetaV x $ map Apply vs+  boundedSizeMetaHook u tel a+  return (x, u)++newTelMeta :: MonadMetaSolver m => Telescope -> m Args+newTelMeta tel = newArgsMeta (abstract tel $ __DUMMY_TYPE__)++type Condition = Dom Type -> Abs Type -> Bool++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+  tel  <- getContextTelescope+  newArgsMetaCtx' Instantiable condition t tel (idP $ size tel) args++newArgsMetaCtx :: Type -> Telescope -> Permutation -> Args -> TCM Args+newArgsMetaCtx = newArgsMetaCtx' Instantiable trueCondition++newArgsMetaCtx''+  :: MonadMetaSolver m+  => 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+      let mod  = getModality info+          -- Issue #3031: It's not enough to applyModalityToContext, since most (all?)+          -- of the context lives in tel. Don't forget the arguments in ctx.+          tel' = telFromList $+                 map (mod `inverseApplyModalityButNotQuantity`) $+                 telToList tel+          ctx' = map (mod `inverseApplyModalityButNotQuantity`) ctx+      (m, u) <- applyModalityToContext info $+                 newValueMetaCtx frozen RunMetaOccursCheck CmpLeq a tel' perm ctx'+      -- Jesper, 2021-05-05: When creating a metavariable from a+      -- generalizable variable, we must set the modality at which it+      -- will be generalized.  Don't do this for other metavariables,+      -- as they should keep the defaul modality (see #5363).+      whenM ((== YesGeneralizeVar) <$> viewTC eGeneralizeMetas) $+        setMetaGeneralizableArgInfo m $ hideOrKeepInstance info+      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 mempty Instantiable r pars tel (idP $ size tel) args++newRecordMetaCtx+  :: 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 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+  return $ Con con ConOSystem (map Apply fields)++newQuestionMark :: InteractionId -> Comparison -> Type -> TCM (MetaId, Term)+newQuestionMark ii cmp = newQuestionMark' (newValueMeta' RunMetaOccursCheck) ii cmp+++-- Since we are type-checking some code twice, e.g., record declarations+-- for the sake of the record constructor type and then again for the sake+-- of the record module (issue #434), we may encounter an interaction point+-- for which we already have a meta.  In this case, we want to reuse the meta.+-- Otherwise we get two meta for one interaction point which are not connected,+-- and e.g. Agda might solve one in some way+-- and the user the other in some other way...+--+-- New reference: Andreas, 2021-07-21, issues #5478 and #5463+-- Old reference: Andreas, 2016-07-29, issue 1720-2+-- See also: issue #2257+newQuestionMark'+  :: (Comparison -> Type -> TCM (MetaId, Term))+  -> InteractionId -> Comparison -> Type -> TCM (MetaId, Term)+newQuestionMark' new ii cmp t = lookupInteractionMeta ii >>= \case++  -- Case: new meta.+  Nothing -> do+    -- Do not run check for recursive occurrence of meta in definitions,+    -- because we want to give the recursive solution interactively (Issue 589)+    (x, m) <- new cmp t+    connectInteractionPoint ii x+    return (x, m)++  -- Case: existing meta.+  Just x -> do+    -- Get the context Γ in which the meta was created.+    MetaVar+      { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = TCEnv{ envContext = gamma }}}+      , mvPermutation = p+      } <- 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 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+      , nest 2 $ "reusage  context:" <+> pretty dxs+      ]++    -- When checking a record declaration (e.g. Σ), creation context Γ+    -- might be of the forms Γ₀,Γ₁ or Γ₀,fst,Γ₁ or Γ₀,fst,snd,Γ₁ whereas+    -- Δ is of the form Γ₀,r,Γ₁,{Δ₂} for record variable r.+    -- So first find the record variable in Δ.+    rev_args <- case List.findIndex nameIsRecordName dxs of++      -- Case: no record variable in the context.+      -- Test whether Δ is an extension of Γ.+      Nothing -> do+        unless (gys `List.isSuffixOf` dys) $ do+          reportSDoc "impossible" 10 $ vcat+            [ "expecting meta-creation context"+            , nest 2 $ pretty gxs+            , "to be a suffix of the meta-reuse context"+            , nest 2 $ pretty dxs+            ]+          reportSDoc "impossible" 70 $ vcat+            [ "expecting meta-creation context"+            , nest 2 $ (text . show) gxs+            , "to be a suffix of the meta-reuse context"+            , nest 2 $ (text . show) dxs+            ]+          __IMPOSSIBLE__+        -- Apply the meta to |Γ| arguments from Δ.+        return $ map var [dlen - glen .. dlen - 1]++      -- Case: record variable in the context.+      Just k -> do+        -- Verify that the contexts relate as expected.+        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 in gys and dys.+        -- This is a bit risky... blame goes to #434.+        let (d2len, g1len) = findOverlap (take k dys) gys+        reportSDoc "tc.interaction" 30 $ vcat $ map (nest 2)+          [ "glen  =" <+> pretty glen+          , "g0len =" <+> pretty g0len+          , "g1len =" <+> pretty g1len+          , "d2len =" <+> pretty d2len+          ]+        -- The Γ₀ part should match.+        unless (drop (glen - g0len) gxs == drop (k + 1) dxs) $ do+          reportSDoc "impossible" 10 $ vcat+            [ "expecting meta-creation context (with fields instead of record var)"+            , nest 2 $ pretty gxs+            , "to share ancestry (suffix) with the meta-reuse context (with record var)"+            , nest 2 $ pretty dxs+            ]+          __IMPOSSIBLE__+        -- The Γ₁ part should match.+        unless ( ((==) `on` take g1len) gys (drop d2len dys) ) $ do+          reportSDoc "impossible" 10 $ vcat+            [ "expecting meta-creation context (with fields instead of record var)"+            , nest 2 $ pretty gxs+            , "to be an expansion of the meta-reuse context (with record var)"+            , nest 2 $ pretty dxs+            ]+          __IMPOSSIBLE__+        let (vs1, v : vs0) = splitAt g1len $ map var [d2len..dlen-1]+        -- We need to expand the record var @v@ into the correct number of fields.+        let numFields = glen - g1len - g0len+        if numFields <= 0 then return $ vs1 ++ vs0 else do+          -- Get the record type.+          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.+          let vfs = map ((\ x -> v `applyE` [Proj ProjSystem x]) . unDom) fs+          -- These are the final args to the original meta:+          return $ vs1 ++ reverse (take numFields vfs) ++ vs0++    -- Use ArgInfo from Γ.+    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)+  => Type -> m Term -> m Term+blockTerm t blocker = do+  (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+blockTermOnProblem t v pid = do+  -- Andreas, 2012-09-27 do not block on unsolved size constraints+  solved <- isProblemSolved pid+  ifM (return solved `or2M` isSizeProblem pid)+      (v <$ reportSLn "tc.meta.blocked" 20 ("Not blocking because " ++ show pid ++ " is " +++                                            if solved then "solved" else "a size problem")) $ do+    i   <- createMetaInfo+    es  <- map Apply <$> getContextArgs+    tel <- getContextTelescope+    x   <- newMeta' (BlockedConst $ abstract tel v)+                    Instantiable+                    i+                    lowMetaPriority+                    (idP $ size tel)+                    (HasType () CmpLeq $ telePi_ tel t)+                    -- we don't instantiate blocked terms+    inTopContext $ addConstraint (unblockOnProblem pid) (UnBlock x)+    reportSDoc "tc.meta.blocked" 20 $ vcat+      [ "blocked" <+> prettyTCM x <+> ":=" <+> inTopContext+        (prettyTCM $ abstract tel v)+      , "     by" <+> (prettyTCM =<< getConstraintsForProblem pid)+      ]+    inst <- isInstantiatedMeta x+    if inst+      then instantiate (MetaV x es)+      else do+        -- We don't return the blocked term instead create a fresh metavariable+        -- that we compare against the blocked term once it's unblocked. This way+        -- blocked terms can be instantiated before they are unblocked, thus making+        -- constraint solving a bit more robust against instantiation order.+        -- Andreas, 2015-05-22: DontRunMetaOccursCheck to avoid Issue585-17.+        (m', v) <- newValueMeta DontRunMetaOccursCheck CmpLeq t+        reportSDoc "tc.meta.blocked" 30+          $   "setting twin of"+          <+> prettyTCM m'+          <+> "to be"+          <+> prettyTCM x+        updateMetaVar m' (\mv -> mv { mvTwin = Just x })+        i   <- fresh+        -- This constraint is woken up when unblocking, so it doesn't need a problem id.+        cmp <- buildProblemConstraint_ (unblockOnMeta x) (ValueCmp CmpEq (AsTermsOf t) v (MetaV x es))+        reportSDoc "tc.constr.add" 20 $ "adding constraint" <+> prettyTCM cmp+        listenToMeta (CheckConstraint i cmp) x+        return v++{-# SPECIALIZE blockTypeOnProblem :: Type -> ProblemId -> TCM Type #-}+blockTypeOnProblem+  :: (MonadMetaSolver m, MonadFresh Nat m)+  => Type -> ProblemId -> m Type+blockTypeOnProblem (El s a) pid = El s <$> blockTermOnProblem (sort s) a pid++-- | @unblockedTester t@ returns a 'Blocker' for @t@.+--+--   Auxiliary function used when creating a postponed type checking problem.+unblockedTester :: Type -> TCM Blocker+unblockedTester t = ifBlocked t (\ b _ -> return b) (\ _ _ -> return alwaysUnblock)++-- | Create a postponed type checking problem @e : t@ that waits for type @t@+--   to unblock (become instantiated or its constraints resolved).+postponeTypeCheckingProblem_ :: TypeCheckingProblem -> TCM Term+postponeTypeCheckingProblem_ p = do+  postponeTypeCheckingProblem p =<< unblock p+  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 (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+--   instantiation the postponed type checking problem.  An 'UnBlock' constraint+--   is added for this meta, which links to this meta.+postponeTypeCheckingProblem :: TypeCheckingProblem -> Blocker -> TCM Term+postponeTypeCheckingProblem p unblock | unblock == alwaysUnblock = do+  reportSDoc "impossible" 2 $ "Postponed without blocker:" <?> prettyTCM p+  __IMPOSSIBLE__+postponeTypeCheckingProblem p unblock = do+  i   <- createMetaInfo' DontRunMetaOccursCheck+  tel <- getContextTelescope+  cl  <- buildClosure p+  let t = problemType p+  m   <- newMeta' (PostponedTypeCheckingProblem cl)+                  Instantiable i normalMetaPriority (idP (size tel))+         $ HasType () CmpLeq $ telePi_ tel t+  inTopContext $ reportSDoc "tc.meta.postponed" 20 $ vcat+    [ "new meta" <+> prettyTCM m <+> ":" <+> prettyTCM (telePi_ tel t)+    , "for postponed typechecking problem" <+> prettyTCM p+    ]++  -- Create the meta that we actually return+  -- Andreas, 2012-03-15+  -- This is an alias to the pptc meta, in order to allow pruning (issue 468)+  -- and instantiation.+  -- Since this meta's solution comes from user code, we do not need+  -- to run the extended occurs check (metaOccurs) to exclude+  -- non-terminating solutions.+  es  <- map Apply <$> getContextArgs+  (_, v) <- newValueMeta DontRunMetaOccursCheck CmpLeq t+  cmp <- buildProblemConstraint_ (unblockOnMeta m) (ValueCmp CmpEq (AsTermsOf t) v (MetaV m es))+  reportSDoc "tc.constr.add" 20 $ "adding constraint" <+> prettyTCM cmp+  i   <- liftTCM fresh+  listenToMeta (CheckConstraint i cmp) m+  addConstraint unblock (UnBlock m)+  return v++-- | Type of the term that is produced by solving the 'TypeCheckingProblem'.+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 (CheckLambda _ _ _ t     ) = t+problemType (DoQuoteTerm _ _ t)        = t+problemType (DisambiguateConstructor (ConstructorDisambiguationData _ _ _ t) _) = t++-- | 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+          reportSDoc "tc.meta.eta" 20 $ do+            "postponing eta-expansion of meta variable" <+>+              prettyTCM m <+>+              "which is blocked by" <+> prettyTCM 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 <- lookupLocalMeta m+    case mvJudgement meta of+      IsSort{} -> dontExpand+      HasType _ cmp a -> do++        reportSDoc "tc.meta.eta" 40 $ sep+          [ text "considering eta-expansion at type "+          , prettyTCM a+          , text " raw: "+          , pretty a+          ]++        TelV tel b <- telView a+        reportSDoc "tc.meta.eta" 40 $ sep+          [ text "considering eta-expansion at type"+          , addContext tel (prettyTCM b)+          , text "under telescope"+          , prettyTCM tel+          ]++        -- Eta expanding metas with a domFinite will just make sure+        -- 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 domIsFinite (flattenTel tel) then dontExpand else do++        -- Issue #3774: continue with the right context for b+        addContext tel $ do++        -- if the target type @b@ of @m@ is a meta variable @x@ itself+        -- (@NonBlocked (MetaV{})@),+        -- or it is blocked by a meta-variable @x@ (@Blocked@), we cannot+        -- eta expand now, we have to postpone this.  Once @x@ is+        -- instantiated, we can continue eta-expanding m.  This is realized+        -- by adding @m@ to the listeners of @x@.+        ifBlocked (unEl b) (\ x _ -> waitFor x) $ \ _ t -> case t of+          lvl@(Def r es) ->+            ifM (isEtaRecord r) {- then -} (do+              let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+              let expand = do+                    u <- withMetaInfo' meta $+                      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+                      reportSDoc "tc.meta.eta" 15 $ sep+                          [ "eta expanding: " <+> pretty m <+> " --> "+                          , nest 2 $ prettyTCM u+                          ]+                      -- Andreas, 2012-03-29: No need for occurrence check etc.+                      -- we directly assign the solution for the meta+                      -- 2012-05-23: We also bypass the check for frozen.+                      noConstraints $ assignTerm' m (telToArgs tel) u  -- should never produce any constraints+              if Records `elem` kinds then+                expand+               else if (SingletonRecords `elem` kinds) then+                catchPatternErr (\x -> waitFor x) $ do+                 ifM (isSingletonRecord r ps) expand dontExpand+                else dontExpand+            ) $ {- else -} ifM (andM [ return $ Levels `elem` kinds+                            , typeInType+                            , (Just lvl ==) <$> getBuiltin' builtinLevel+                            ]) (do+              reportSLn "tc.meta.eta" 20 $ "Expanding level meta to 0 (type-in-type)"+              -- Andreas, 2012-03-30: No need for occurrence check etc.+              -- we directly assign the solution for the meta+              noConstraints $ assignTerm m (telToArgs tel) $ Level $ ClosedLevel 0+           ) $ {- else -} dontExpand+          _ -> dontExpand++-- | Eta expand blocking metavariables of record type, and reduce the+-- blocked thing.++etaExpandBlocked :: (MonadReduce m, MonadMetaSolver m, IsMeta t, Reduce t)+                 => Blocked t -> m (Blocked t)+etaExpandBlocked t@NotBlocked{} = return t+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]) $ 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 (":" ++ prettyShow dir) <+> prettyTCM v+    nowSolvingConstraints doAssign `finally` solveAwakeConstraints++  where dontAssign = do+          reportSLn "tc.meta.assign" 10 "don't assign metas"+          patternViolation alwaysUnblock  -- retry again when we are allowed to instantiate metas++-- | Miller pattern unification:+--+--   @assign dir x vs v a@ solves problem @x vs <=(dir) v : a@ for meta @x@+--   if @vs@ are distinct variables (linearity check)+--   and @v@ depends only on these variables+--   and does not contain @x@ itself (occurs check).+--+--   This is the basic story, but we have added some features:+--+--   1. Pruning.+--   2. Benign cases of non-linearity.+--   3. @vs@ may contain record patterns.+--+--   For a reference to some of these extensions, read+--   Andreas Abel and Brigitte Pientka's TLCA 2011 paper.++assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM ()+assign dir x args v target = addOrUnblocker (unblockOnMeta x) $ do++  mvar <- lookupLocalMeta x  -- information associated with meta x+  let t = jMetaType $ mvJudgement mvar++  -- Andreas, 2011-05-20 TODO!+  -- full normalization  (which also happens during occurs check)+  -- is too expensive! (see Issue 415)+  -- need to do something cheaper, especially if+  -- we are dealing with a Miller pattern that can be solved+  -- immediately!+  -- Ulf, 2011-08-25 DONE!+  -- Just instantiating the top-level meta, which is cheaper. The occurs+  -- 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) <+>+    " to " <+> prettyTCM v+  reportSDoc "tc.meta.assign" 45 $+    "MetaVars.assign: type of meta: " <+> prettyTCM t++  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 ()++  -- Jesper, 2019-09-13: When --no-sort-comparison is enabled,+  -- we equate the sort of the solution with the sort of the+  -- metavariable, in order to solve metavariables in sorts.+  -- Jesper, 2020-04-22: We do this before any of the other steps+  -- because comparing the sorts might lead to some metavariables+  -- being solved, which can help with pruning (see #4615).+  -- Jesper, 2020-08-25: --no-sort-comparison is now the default+  -- behaviour.+  --+  -- Under most circumstances, the conversion checker guarantees that+  -- the solution for the meta has the correct type, so there is no+  -- need to check anything. However, there are two circumstances in+  -- which we do need to check the type of the solution:+  --+  -- 1. When comparing two types they are not guaranteed to have the+  --    same sort.+  --+  -- 2. When --cumulativity is enabled the same can happen when+  --    comparing two terms at a sort type.++  cumulativity <- optCumulativity <$> pragmaOptions++  let checkSolutionSort cmp s v = do+        s' <- sortOf v+        reportSDoc "tc.meta.assign" 40 $+          "Instantiating sort" <+> prettyTCM s <+>+          "to sort" <+> prettyTCM s' <+> "of solution" <+> prettyTCM v+        traceCall (CheckMetaSolution (getRange mvar) x (sort s) v) $+          compareSort cmp s' s++  case (target , mvJudgement mvar) of+    -- Case 1 (comparing term to meta as types)+    (AsTypes{}   , HasType _ cmp0 t) -> do+        let cmp   = if cumulativity then cmp0 else CmpEq+            abort = patternViolation =<< updateBlocker (unblockOnAnyMetaIn t) -- TODO: make piApplyM' compute unblocker+        t' <- piApplyM' abort t args+        s <- shouldBeSort t'+        checkSolutionSort cmp s v++    -- Case 2 (comparing term to type-level meta as terms, with --cumulativity)+    (AsTermsOf{} , HasType _ cmp t)+      | cumulativity -> do+          let abort = patternViolation =<< updateBlocker (unblockOnAnyMetaIn t)+          t' <- piApplyM' abort t args+          TelV tel t'' <- telView t'+          addContext tel $ ifNotSort t'' (return ()) $ \s -> do+            let v' = raise (size tel) v `apply` teleArgs tel+            checkSolutionSort cmp s v'++    (AsTypes{}   , IsSort{}       ) -> return ()+    (AsTermsOf{} , _              ) -> return ()+    (AsSizes{}   , _              ) -> return ()  -- TODO: should we do something similar for sizes?++++  -- 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?+  whenM (isBlockedTerm x) $ do+    reportSLn "tc.meta.assign" 25 $ "aborting: meta is a blocked term!"+    patternViolation (unblockOnMeta x)++  -- Andreas, 2010-10-15 I want to see whether rhs is blocked+  reportSLn "tc.meta.assign" 50 $ "MetaVars.assign: I want to see whether rhs is blocked"+  reportSDoc "tc.meta.assign" 25 $ do+    v0 <- reduceB v+    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+        [ "context before projection expansion"+        , nest 2 $ inTopContext $ prettyTCM cxt+        ]++    -- Normalise and eta contract the arguments to the meta. These are+    -- usually small, and simplifying might let us instantiate more metas.+    -- Also, try to expand away projected vars in meta args.++    expandProjectedVars args (v, target) $ \ args (v, target) -> do++      reportSDoc "tc.meta.assign.proj" 45 $ do+        cxt <- getContextTelescope+        vcat+          [ "context after projection expansion"+          , nest 2 $ inTopContext $ prettyTCM cxt+          ]++      -- Andreas, 2019-11-16, issue #4159:+      -- We would like to save the work we put into expanding projected variables.+      -- However, the Conversion checker speculatively tries some assignment+      -- in some places (e.g. shortcut) and relies on an exception to be thrown+      -- to try other alternatives next.+      -- If we catch the exception here, this (brittle) mechanism will be broken.+      -- Maybe one possibility would be to rethrow the exception with the+      -- new constraint.  Then, further up, it could be decided whether+      -- to discard the new constraint and do something different,+      -- or add the new constraint when postponing.++      -- BEGIN attempt #4159+      -- let constraint = case v of+      --       -- Sort s -> dirToCmp SortCmp dir (MetaS x $ map Apply args) s+      --       _      -> dirToCmp (\ cmp -> ValueCmp cmp target) dir (MetaV x $ map Apply args) v+      -- reportSDoc "tc.meta.assign.catch" 40 $ sep+      --   [ "assign: catching constraint:"+      --   , prettyTCM constraint+      --   ]+      -- -- reportSDoc "tc.meta.assign.catch" 60 $ sep+      -- --   [ "assign: catching constraint:"+      -- --   , pretty constraint+      -- --   ]+      -- reportSDoc "tc.meta.assign.catch" 80 $ sep+      --   [ "assign: catching constraint (raw):"+      --   , (text . show) constraint+      --   ]+      -- catchConstraint constraint $ do+      -- END attempt #4159+++      -- Andreas, 2011-04-21 do the occurs check first+      -- e.g. _1 x (suc x) = suc (_2 x y)+      -- even though the lhs is not a pattern, we can prune the y from _2++      let+                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)+            -- Update 2011-03-27: Also irr. vars under record constructors.+            -- Andreas, 2019-06-25:  The reason is that when solving+            -- @X args = v@ we drop all irrelevant arguments that+            -- are not variables (after flattening of record constructors).+            -- (See isVarOrIrrelevant in inverseSubst.)+            -- Thus, the occurs-check needs to ensure only these variables+            -- are mentioned on the rhs.+            -- In the terminology of free variable analysis, the retained+            -- irrelevant variables are exactly the Unguarded ones.+            -- Jesper, 2019-10-15: This is actually wrong since it+            -- will lead to pruning of metas that should not be+            -- pruned, see #4136.++      reportSDoc "tc.meta.assign" 20 $+          let pr (Var n []) = text (show n)+              pr (Def c []) = prettyTCM c+              pr _          = ".."+          in vcat+               [ "mvar args:" <+> sep (map (pr . unArg) args)+               , "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.+      -- Prune mvars on rhs such that they can only depend on lhs vars.+      -- Herein, distinguish relevant and irrelevant vars,+      -- since when abstracting irrelevant lhs vars, they may only occur+      -- irrelevantly on rhs.+      -- 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 $+          sep [ "size" <+> text (show n)+--              , nest 2 $ "type" <+> prettyTCM t+              , nest 2 $ "term" <+> prettyTCM v+              ]++      -- Check linearity of @ids@+      -- Andreas, 2010-09-24: Herein, ignore the variables which are not+      -- free in v+      -- Ulf, 2011-09-22: we need to respect irrelevant vars as well, otherwise+      -- we'll build solutions where the irrelevant terms are not valid+      let fvs = allFreeVars v+      reportSDoc "tc.meta.assign" 20 $+        "fvars rhs:" <+> sep (map (text . show) $ VarSet.toList fvs)++      -- Check that the arguments are variables+      mids <- do+        res <- runExceptT $ inverseSubst' (const False) args+        case res of+          -- all args are variables+          Right ids -> do+            reportSDoc "tc.meta.assign" 60 $+              "inverseSubst returns:" <+> sep (map pretty ids)+            reportSDoc "tc.meta.assign" 50 $+              "inverseSubst returns:" <+> sep (map prettyTCM ids)+            let boundVars = VarSet.fromList $ map fst ids+            if fvs `VarSet.isSubsetOf` boundVars+              then return $ Just ids+              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 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:+          -- same as neutral+          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 =<< updateBlocker (unblockOnAnyMetaIn v)  -- TODO: more precise+        Just ids -> do+          -- Check linearity+          ids <- do+            res <- runExceptT $ checkLinearity {- (`VarSet.member` fvs) -} ids+            case res of+              -- case: linear+              Right ids -> return ids+              -- case: non-linear variables that could possibly be pruned+              -- 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 ()   -> do+                block <- updateBlocker $ unblockOnAnyMetaIn v+                addOrUnblocker block $ attemptPruning x args fvs++          -- Check ids is time respecting.+          () <- do+            let idvars = map (mapSnd allFreeVars) ids+            -- earlierThan α v := v "arrives" before α+            let earlierThan l j = j > l+            TelV tel' _ <- telViewUpToPath (length args) t+            forM_ ids $ \(i,u) -> 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+                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++          -- Check subtyping constraints on the context variables.++          -- Intuition: suppose @_X : (x : A) → B@, then to turn+          --   @+          --     Γ(x : A') ⊢ _X x =?= v : B'@+          --   @+          -- into+          --   @+          --     Γ ⊢ _X =?= λ x → v+          --   @+          -- we need to check that @A <: A'@ (due to contravariance).+          let sigma = parallelS $ reverse $ map unArg args+          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)+            a' <- typeOfBV i+            checkSubtypeIsEqual a' a+              `catchError` \case+                TypeError{} -> patternViolation (unblockOnMeta x) -- If the subtype check hard-fails we need to+                err         -> throwError err                     -- solve this meta in some other way.++          -- Solve.+          m <- getContextSize+          assignMeta' m x t n ids v+  where+    -- Try to remove meta arguments from lhs that mention variables not occurring on rhs.+    attemptPruning+      :: MetaId  -- Meta-variable (lhs)+      -> Args    -- Meta arguments (lhs)+      -> FVs     -- Variables occuring on the rhs+      -> TCM a+    attemptPruning x args fvs = do+      -- non-linear lhs: we cannot solve, but prune+      killResult <- prune x args $ (`VarSet.member` fvs)+      let success = killResult `elem` [PrunedSomething,PrunedEverything]+      reportSDoc "tc.meta.assign" 10 $+        "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed"+      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+--   for instance arguments, where knowing the head D might enable progress.+attemptInertRHSImprovement :: MetaId -> Args -> Term -> TCM ()+attemptInertRHSImprovement m args v = do+  reportSDoc "tc.meta.inert" 30 $ vcat+    [ "attempting inert rhs improvement"+    , nest 2 $ sep [ prettyTCM (MetaV m $ map Apply args) <+> "=="+                   , prettyTCM v ] ]+  -- Check that the right-hand side has the form D vs, for some inert constant D.+  -- Returns the type of D and a function to build an application of D.+  (a, mkRHS) <- ensureInert v+  -- Check that all arguments to the meta are neutral and does not have head D.+  -- If there are non-neutral arguments there could be solutions to the meta+  -- that computes over these arguments. If D is an argument to the meta we get+  -- multiple solutions (for instance: _M Nat == Nat can be solved by both+  -- _M := \ x -> x and _M := \ x -> Nat).+  mapM_ (ensureNeutral (mkRHS []) . unArg) args+  tel <- theTel <$> (telView =<< getMetaType m)+  -- When attempting shortcut meta solutions, metas aren't necessarily fully+  -- eta expanded. If this is the case we skip inert improvement.+  when (length args < size tel) $ do+    reportSDoc "tc.meta.inert" 30 $ "not fully applied"+    patternViolation+  -- Solve the meta with _M := \ xs -> D (_Y1 xs) .. (_Yn xs), for fresh metas+  -- _Yi.+  metaArgs <- inTopContext $ addContext tel $ newArgsMeta a+  let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)+      sol     = mkRHS metaArgs+      argTel  = map ("x" <$) args+  reportSDoc "tc.meta.inert" 30 $ nest 2 $ vcat+    [ "a       =" <+> prettyTCM a+    , "tel     =" <+> prettyTCM tel+    , "metas   =" <+> prettyList (map prettyTCM metaArgs)+    , "sol     =" <+> prettyTCM sol+    ]+  assignTerm m argTel sol+  patternViolation  -- throwing a pattern violation here lets the constraint+                    -- machinery worry about restarting the comparison.+  where+    ensureInert :: Term -> TCM (Type, Args -> Term)+    ensureInert v = do+      let notInert = do+            reportSDoc "tc.meta.inert" 30 $ nest 2 $ "not inert:" <+> prettyTCM v+            patternViolation+          toArgs elims =+            case allApplyElims elims of+              Nothing -> do+                reportSDoc "tc.meta.inert" 30 $ nest 2 $ "can't do projections from inert"+                patternViolation+              Just args -> return args+      case v of+        Var x elims -> (, Var x . map Apply) <$> typeOfBV x+        Con c ci args  -> notInert -- (, Con c ci) <$> defType <$> getConstInfo (conName c)+        Def f elims -> do+          def <- getConstInfo f+          let good = return (defType def, Def f . map Apply)+          case theDef def of+            Axiom{}       -> good+            Datatype{}    -> good+            Record{}      -> good+            Function{}    -> notInert+            Primitive{}   -> notInert+            Constructor{} -> __IMPOSSIBLE__++        Pi{}       -> notInert -- this is actually inert but improving doesn't buy us anything for Pi+        Lam{}      -> notInert+        Sort{}     -> notInert+        Lit{}      -> notInert+        Level{}    -> notInert+        MetaV{}    -> notInert+        DontCare{} -> notInert++    ensureNeutral :: Term -> Term -> TCM ()+    ensureNeutral rhs v = do+      b <- reduceB v+      let notNeutral v = do+            reportSDoc "tc.meta.inert" 30 $ nest 2 $ "not neutral:" <+> prettyTCM v+            patternViolation+          checkRHS arg+            | arg == rhs = do+              reportSDoc "tc.meta.inert" 30 $ nest 2 $ "argument shares head with RHS:" <+> prettyTCM arg+              patternViolation+            | otherwise  = return ()+      case b of+        Blocked{}      -> notNeutral v+        NotBlocked r v ->                      -- Andrea(s) 2014-12-06 can r be useful?+          case v of+            Var x _    -> checkRHS (Var x [])+            Def f _    -> checkRHS (Def f [])+            Pi{}       -> return ()+            Sort{}     -> return ()+            Level{}    -> return ()+            Lit{}      -> notNeutral v+            DontCare{} -> notNeutral v+            Con{}      -> notNeutral v+            Lam{}      -> notNeutral v+            MetaV{}    -> __IMPOSSIBLE__+-- END UNUSED -}++-- | @assignMeta m x t ids u@ solves @x ids = u@ for meta @x@ of type @t@,+--   where term @u@ lives in a context of length @m@.+--   Precondition: @ids@ is linear.+assignMeta :: Int -> MetaId -> Type -> [Int] -> Term -> TCM ()+assignMeta m x t ids v = do+  let n    = length ids+      cand = List.sort $ zip ids $ map var $ downFrom n+  assignMeta' m x t n cand v++-- | @assignMeta' m x t ids u@ solves @x = [ids]u@ for meta @x@ of type @t@,+--   where term @u@ lives in a context of length @m@,+--   and @ids@ is a partial substitution.+assignMeta' :: Int -> MetaId -> Type -> Int -> SubstCand -> Term -> TCM ()+assignMeta' m x t n ids v = do+  -- we are linear, so we can solve!+  reportSDoc "tc.meta.assign" 25 $+      "preparing to instantiate: " <+> prettyTCM v++  -- Rename the variables in v to make it suitable for abstraction over ids.+  -- Basically, if+  --   Γ   = a b c d e+  --   ids = d b e+  -- then+  --   v' = (λ a b c d e. v) _ 1 _ 2 0+  --+  -- Andreas, 2013-10-25 Solve using substitutions:+  -- Convert assocList @ids@ (which is sorted) into substitution,+  -- filling in __IMPOSSIBLE__ for the missing terms, e.g.+  -- [(0,0),(1,2),(3,1)] --> [0, 2, __IMP__, 1, __IMP__]+  -- ALT 1: O(m * size ids), serves as specification+  -- let ivs = [fromMaybe __IMPOSSIBLE__ $ lookup i ids | i <- [0..m-1]]+  -- 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+      ivs = assocToList 0 ids+      rho = prependS impossible ivs $ raiseS n+      v'  = applySubst rho v++  -- Metas are top-level so we do the assignment at top-level.+  inTopContext $ do+    -- Andreas, 2011-04-18 to work with irrelevant parameters+    -- we need to construct tel' from the type of the meta variable+    -- (no longer from ids which may not be the complete variable list+    -- any more)+    reportSDoc "tc.meta.assign" 15 $ "type of meta =" <+> prettyTCM t++    (telv@(TelV tel' a), bs) <- telViewUpToPathBoundary n t+    reportSDoc "tc.meta.assign" 30 $ "tel'  =" <+> prettyTCM tel'+    reportSDoc "tc.meta.assign" 30 $ "#args =" <+> text (show n)+    -- Andreas, 2013-09-17 (AIM XVIII): if t does not provide enough+    -- types for the arguments, it might be blocked by a meta;+    -- then we give up. (Issue 903)+    when (size tel' < n) $ do+      a <- abortIfBlocked a+      reportSDoc "impossible" 10 $ "not enough pis, but not blocked?" <?> pretty a+      __IMPOSSIBLE__   -- If we get here it was _not_ blocked by a meta!++    -- Perform the assignment (and wake constraints).++    let vsol = abstract tel' v'++    -- Andreas, 2013-10-25 double check solution before assigning+    whenM (optDoubleCheck  <$> pragmaOptions) $ do+      m <- lookupLocalMeta x+      reportSDoc "tc.meta.check" 30 $ "double checking solution"+      catchConstraint (CheckMetaInst x) $+        addContext tel' $ checkSolutionForMeta x m v' a++    reportSDoc "tc.meta.assign" 10 $+      "solving" <+> prettyTCM x <+> ":=" <+> prettyTCM vsol++    v' <- blockOnBoundary telv bs v'++    assignTerm x (telToArgs tel') v'+  where+    blockOnBoundary :: TelView -> Boundary -> Term -> TCM Term+    blockOnBoundary telv         (Boundary []) v = return v+    blockOnBoundary (TelV tel t) (Boundary bs) v = addContext tel $+      blockTerm t $ do+        neg <- primINeg+        forM_ bs $ \ (i,(x,y)) -> do+          let r = var i+          equalTermOnFace (neg `apply1` r) t x v+          equalTermOnFace r  t y v+        return v++-- | Check that the instantiation of the given metavariable fits the+--   type of the metavariable. If the metavariable is not yet+--   instantiated, add a constraint to check the instantiation later.+checkMetaInst :: MetaId -> TCM ()+checkMetaInst x = do+  m <- lookupLocalMeta x+  let postpone = addConstraint (unblockOnMeta x) $ CheckMetaInst x+  case mvInstantiation m of+    BlockedConst{} -> postpone+    PostponedTypeCheckingProblem{} -> postpone+    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 (instBody inst) a++-- | Check that the instantiation of the metavariable with the given+--   term is well-typed.+checkSolutionForMeta :: MetaId -> MetaVariable -> Term -> Type -> TCM ()+checkSolutionForMeta x m v a = do+  reportSDoc "tc.meta.check" 30 $ "checking solution for meta" <+> prettyTCM x+  case mvJudgement m of+    HasType{ jComparison = cmp } -> do+      reportSDoc "tc.meta.check" 30 $ nest 2 $+        prettyTCM x <+> " : " <+> prettyTCM a <+> ":=" <+> prettyTCM v+      reportSDoc "tc.meta.check" 50 $ nest 2 $ do+        ctx <- getContext+        inTopContext $ "in context: " <+> prettyTCM (PrettyContext ctx)+      traceCall (CheckMetaSolution (getRange m) x a v) $+        checkInternal v cmp a+    IsSort{}  -> void $ do+      reportSDoc "tc.meta.check" 30 $ nest 2 $+        prettyTCM x <+> ":=" <+> prettyTCM v <+> " is a sort"+      s <- shouldBeSort (El __DUMMY_SORT__ v)+      traceCall (CheckMetaSolution (getRange m) x (sort (univSort s)) (Sort s)) $+        inferInternal s++-- | Given two types @a@ and @b@ with @a <: b@, check that @a == b@.+checkSubtypeIsEqual :: Type -> Type -> TCM ()+checkSubtypeIsEqual a b = do+  reportSDoc "tc.meta.subtype" 30 $+    "checking that subtype" <+> prettyTCM a <+>+    "of" <+> prettyTCM b <+> "is actually equal."+  SynEq.checkSyntacticEquality a b (\_ _ -> return ()) $ \a b -> do+    cumulativity <- optCumulativity <$> pragmaOptions+    abortIfBlocked (unEl b) >>= \case+      Sort sb -> abortIfBlocked (unEl a) >>= \case+        Sort sa | cumulativity -> equalSort sa sb+                             | otherwise    -> return ()+        Dummy{} -> return () -- TODO: this shouldn't happen but+                             -- currently does because of generalized+                             -- metas being created in a dummy context+        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 =<< updateBlocker (unblockOnAnyMetaIn a)+      -- TODO: check subtyping for Size< types+      _ -> return ()+++-- | Turn the assignment problem @_X args <= SizeLt u@ into+-- @_X args = SizeLt (_Y args)@ and constraint+-- @_Y args <= u@.+subtypingForSizeLt+  :: CompareDirection -- ^ @dir@+  -> 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@.+  -> (Term -> TCM ()) -- ^ Continuation taking its possibly assigned value.+  -> TCM ()+subtypingForSizeLt DirEq x mvar t args v cont = cont v+subtypingForSizeLt dir   x mvar t args v cont = do+  let fallback = cont v+  -- Check whether we have built-ins SIZE and SIZELT+  (mSize, mSizeLt) <- getBuiltinSize+  caseMaybe mSize   fallback $ \ qSize   -> do+    caseMaybe mSizeLt fallback $ \ qSizeLt -> do+      -- Check whether v is a SIZELT+      v <- reduce v+      case v of+        Def q [Apply (Arg ai u)] | q == qSizeLt -> do+          -- Clone the meta into a new size meta @y@.+          -- To this end, we swap the target of t for Size.+          TelV tel _ <- telView t+          let size = sizeType_ qSize+              t'   = telePi tel size+          y <- newMeta Instantiable (mvInfo mvar) (mvPriority mvar) (mvPermutation mvar)+                       (HasType __IMPOSSIBLE__ CmpLeq t')+          -- Note: no eta-expansion of new meta possible/necessary.+          -- Add the size constraint @y args `dir` u@.+          let yArgs = MetaV y $ map Apply args+          addConstraint (unblockOnMeta y) $ dirToCmp (`ValueCmp` AsSizes) dir yArgs u+          -- We continue with the new assignment problem, and install+          -- an exception handler, since we created a meta and a constraint,+          -- so we cannot fall back to the original handler.+          let xArgs = MetaV x $ map Apply args+              v'    = Def qSizeLt [Apply $ Arg ai yArgs]+              c     = dirToCmp (`ValueCmp` (AsTermsOf sizeUniv)) dir xArgs v'+          catchConstraint c $ cont v'+        _ -> fallback++-- | Eta-expand bound variables like @z@ in @X (fst z)@.+expandProjectedVars+  :: ( Pretty a, PrettyTCM a, NoProjectedVar a+     -- , Normalise a, TermLike a, Subst Term a+     , ReduceAndEtaContract a+     , PrettyTCM b, TermSubst b+     )+  => a  -- ^ Meta variable arguments.+  -> b  -- ^ Right hand side.+  -> (a -> b -> TCM c)+  -> TCM c+expandProjectedVars args v ret = loop (args, v) where+  loop (args, v) = do+    reportSDoc "tc.meta.assign.proj" 45 $ "meta args: " <+> prettyTCM args+    args <- callByName $ reduceAndEtaContract args+    reportSDoc "tc.meta.assign.proj" 45 $ "norm args: " <+> prettyTCM args+    reportSDoc "tc.meta.assign.proj" 85 $ "norm args: " <+> pretty args+    let done = ret args v+    case noProjectedVar args of+      Right ()              -> do+        reportSDoc "tc.meta.assign.proj" 40 $+          "no projected var found in args: " <+> prettyTCM args+        done+      Left (ProjectedVar i _) -> etaExpandProjectedVar i (args, v) done loop++-- | Eta-expand a de Bruijn index of record type in context and passed term(s).+etaExpandProjectedVar :: (PrettyTCM a, TermSubst a) => Int -> a -> TCM c -> (a -> TCM c) -> TCM c+etaExpandProjectedVar i v fail succeed = do+  reportSDoc "tc.meta.assign.proj" 40 $+    "trying to expand projected variable" <+> prettyTCM (var i)+  caseMaybeM (etaExpandBoundVar i) fail $ \ (delta, sigma, tau) -> do+    reportSDoc "tc.meta.assign.proj" 25 $+      "eta-expanding var " <+> prettyTCM (var i) <+>+      " in terms " <+> prettyTCM v+    unsafeInTopContext $ addContext delta $+      succeed $ applySubst tau v++-- | Check whether one of the meta args is a projected var.+class NoProjectedVar a where+  noProjectedVar :: a -> Either ProjectedVar ()++  default noProjectedVar+    :: (NoProjectedVar b, Foldable t, t b ~ a)+    => a -> Either ProjectedVar ()+  noProjectedVar = Fold.mapM_ noProjectedVar++instance NoProjectedVar a => NoProjectedVar (Arg a)+instance NoProjectedVar a => NoProjectedVar [a]++instance NoProjectedVar Term where+  noProjectedVar = \case+      Var i es+        | qs@(_:_) <- takeWhileJust id $ map isProjElim es+        -> Left $ ProjectedVar i qs+      -- Andreas, 2015-09-12 Issue #1316:+      -- Also look in inductive record constructors+      Con (ConHead _ IsRecord{} Inductive _) _ es+        | Just vs <- allApplyElims es+        -> noProjectedVar vs+      _ -> return ()++-- | Normalize just far enough to be able to eta-contract maximally.+class (TermLike a, TermSubst a, Reduce a) => ReduceAndEtaContract a where+  reduceAndEtaContract :: a -> TCM a++  default reduceAndEtaContract+    :: (Traversable f, TermLike b, Subst b, Reduce b, ReduceAndEtaContract b, f b ~ a)+    => a -> TCM a+  reduceAndEtaContract = Trav.mapM reduceAndEtaContract++instance ReduceAndEtaContract a => ReduceAndEtaContract [a]+instance ReduceAndEtaContract a => ReduceAndEtaContract (Arg a)++instance ReduceAndEtaContract Term where+  reduceAndEtaContract u = do+    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 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+      v -> return v++{- UNUSED, BUT KEEP!+-- Wrong attempt at expanding bound variables.+-- The following code curries meta instead.++-- | @etaExpandProjectedVar mvar x t n qs@+--+--   @mvar@ is the meta var info.+--   @x@ is the meta variable we are trying to solve for.+--   @t@ is its type.+--   @n@ is the number of the meta arg we want to curry (starting at 0).+--   @qs@ is the projection path along which we curry.+--+etaExpandProjectedVar :: MetaVariable -> MetaId -> Type -> Int -> [QName] -> TCM a+etaExpandProjectedVar mvar x t n qs = inTopContext $ do+  (_, uncurry, t') <- curryAt t n+  let TelV tel a = telView' t'+      perm       = idP (size tel)+  y <- newMeta (mvInfo mvar) (mvPriority mvar) perm (HasType __IMPOSSIBLE__ t')+  assignTerm' x (uncurry $ MetaV y [])+  patternViolation+-}++{-+  -- first, strip the leading n domains (which remain unchanged)+  TelV gamma core <- telViewUpTo n t+  case unEl core of+    -- There should be at least one domain left+    Pi (Dom ai a) b -> do+      -- Eta-expand @dom@ along @qs@ into a telescope @tel@, computing a substitution.+      -- For now, we only eta-expand once.+      -- 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+      unless (recEtaEquality def) __IMPOSSIBLE__+      let tel = recTel def `apply` pars+          m   = size tel+          v   = Con (recConHead def) $ map var $ downFrom m+          b'  = raise m b `absApp` v+          fs  = recFields def+          vs  = zipWith (\ f i -> Var i [Proj f]) fs $ downFrom m+          -- v = c (n-1) ... 1 0+      (tel, u) <- etaExpandAtRecordType a $ var 0+      -- TODO: compose argInfo ai with tel.+      -- Substitute into @b@.+      -- Abstract over @tel@.+      -- Abstract over @gamma@.+      -- Create new meta.+      -- Solve old meta, using substitution.+      patternViolation+    _ -> __IMPOSSIBLE__+-}++type FVs = VarSet+type SubstCand = [(Int,Term)] -- ^ a possibly non-deterministic substitution++-- | Turn non-det substitution into proper substitution, if possible.+--   Otherwise, raise the error.+checkLinearity :: SubstCand -> ExceptT () TCM SubstCand+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 :: 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)+        (throwError ())++-- Intermediate result in the following function+type Res = [(Arg Nat, Term)]++-- | Exceptions raised when substitution cannot be inverted.+data InvertExcept+  = 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.++-- | Check that arguments @args@ to a metavar are in pattern fragment.+--   Assumes all arguments already in whnf and eta-reduced.+--   Parameters are represented as @Var@s so @checkArgs@ really+--   checks that all args are @Var@s and returns the "substitution"+--   to be applied to the rhs of the equation to solve.+--   (If @args@ is considered a substitution, its inverse is returned.)+--+--   The returned list might not be ordered.+--   Linearity, i.e., whether the substitution is deterministic,+--   has to be checked separately.+--+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 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+    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, 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++      -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure+      -- from those that can only put somewhere as a whole ==> neutralArg+      Var{}      -> neutralArg++      -- 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++      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:+--+--   1. We are 'inTopContext'.+--+--   2. 'envCurrentModule' is set to the top-level module.+--+openMetasToPostulates :: TCM ()+openMetasToPostulates = do+  m <- asksTC envCurrentModule++  -- Go through all open metas.+  ms <- MapS.assocs <$> useTC stOpenMetaStore+  forM_ ms $ \ (x, mv) -> do+    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." ++ 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 x <+> " into postulate."+      , nest 2 $ vcat+        [ "Name: " <+> prettyTCM q+        , "Type: " <+> prettyTCM t+        ]+      ]++    -- Add the new postulate to the signature.+    addConstant' q defaultArgInfo t defaultAxiom++    -- 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 UType 0)+        _ -> t++-- | Sort metas in dependency order.+dependencySortMetas :: [MetaId] -> TCM (Maybe [MetaId])+dependencySortMetas metas = do+  metaGraph <- concat <$> do+    forM metas $ \ m -> do+      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++  where+    metas' = Set.fromList metas++    -- Sort metas don't have types, but we still want to sort them.+    getType m = do+      j <- lookupMetaJudgement m+      case j of+        IsSort{}                 -> return Nothing+        HasType{ jMetaType = t } -> Just <$> instantiateFull t
src/full/Agda/TypeChecking/MetaVars.hs-boot view
@@ -1,19 +1,27 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.MetaVars where -import Agda.Syntax.Common           ( Arg, Dom )-import Agda.Syntax.Internal         ( MetaId, Term, Type, Args, Abs, Telescope )-import Agda.Syntax.Internal.Generic ( TermLike )-import Agda.TypeChecking.Monad.Base ( TCM, RunMetaOccursCheck(..), CompareDirection(..), Candidate )+import Agda.Syntax.Common           ( Arg )+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-newArgsMeta'      :: Condition -> Type -> TCM Args-newArgsMeta       :: Type -> TCM Args-assignTerm        :: MetaId -> [Arg String] -> Term -> TCM ()-etaExpandMetaSafe :: MetaId -> TCM ()-assignV           :: CompareDirection -> MetaId -> Args -> Term -> TCM ()-assign            :: CompareDirection -> MetaId -> Args -> Term -> TCM ()-newIFSMeta        :: String -> Type -> TCM (MetaId, Term)-newValueMeta      :: RunMetaOccursCheck -> Type -> TCM (MetaId, Term)-newNamedValueMeta :: RunMetaOccursCheck -> String -> Type -> TCM (MetaId, Term)-newNamedValueMeta':: RunMetaOccursCheck -> String -> Type -> TCM (MetaId, Term)-newTelMeta        :: Telescope -> TCM Args+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 ()+assign            :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM ()+newInstanceMeta   :: MonadMetaSolver m => String -> Type -> m (MetaId, Term)+newValueMeta      :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> String -> Comparison -> Type -> m (MetaId, Term)+newNamedValueMeta':: MonadMetaSolver m => RunMetaOccursCheck -> String -> Comparison -> Type -> m (MetaId, Term)+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,15 +1,23 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.MetaVars.Mention where +import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import qualified Data.Set as Set+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad  class MentionsMeta t where-  mentionsMeta :: MetaId -> t -> Bool+  mentionsMetas :: HashSet MetaId -> t -> Bool +mentionsMeta :: MentionsMeta t => MetaId -> t -> Bool+mentionsMeta = mentionsMetas . HashSet.singleton+ instance MentionsMeta Term where-  mentionsMeta x v = case v of+  mentionsMetas xs = \case     Var _ args   -> mm args     Lam _ b      -> mm b     Lit{}        -> False@@ -18,91 +26,114 @@     Pi a b       -> mm (a, b)     Sort s       -> mm s     Level l      -> mm l+    Dummy{}      -> False     DontCare v   -> False   -- we don't have to look inside don't cares when deciding to wake constraints-    MetaV y args -> x == y || mm args   -- TODO: we really only have to look one level deep at meta args-    Shared p     -> mm $ derefPtr p+    MetaV y args -> HashSet.member y xs || mm args   -- TODO: we really only have to look one level deep at meta args     where-      mm v = mentionsMeta x v+      mm :: forall t. MentionsMeta t => t -> Bool+      mm = mentionsMetas xs  instance MentionsMeta Level where-  mentionsMeta x (Max as) = mentionsMeta x as+  mentionsMetas xs (Max _ as) = mentionsMetas xs as  instance MentionsMeta PlusLevel where-  mentionsMeta x ClosedLevel{} = False-  mentionsMeta x (Plus _ a) = mentionsMeta x a+  mentionsMetas xs (Plus _ a) = mentionsMetas xs a -instance MentionsMeta LevelAtom where-  mentionsMeta x l = case l of-    MetaLevel m vs   -> x == m || mentionsMeta x vs-    BlockedLevel m _ -> x == m    -- if it's blocked on a different meta it doesn't matter if it mentions the meta somewhere else-    UnreducedLevel l -> mentionsMeta x l-    NeutralLevel _ l -> mentionsMeta x l+instance MentionsMeta Blocker where+  mentionsMetas xs (UnblockOnAll bs)  = mentionsMetas xs $ Set.toList bs+  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-    mentionsMeta x (El s t) = mentionsMeta x (s, t)+    mentionsMetas xs (El s t) = mentionsMetas xs (s, t)  instance MentionsMeta Sort where-  mentionsMeta x s = case s of-    Type l     -> mentionsMeta x l-    Prop       -> False-    Inf        -> False+  mentionsMetas xs = \case+    Univ _ l   -> mentionsMetas xs l+    Inf _ _    -> False     SizeUniv   -> False-    DLub s1 s2 -> mentionsMeta x (s1, s2)+    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+    MetaS m es -> HashSet.member m xs || mentionsMetas xs es+    DefS d es  -> mentionsMetas xs es+    DummyS{}   -> False  instance MentionsMeta t => MentionsMeta (Abs t) where-  mentionsMeta x = mentionsMeta x . unAbs+  mentionsMetas xs = mentionsMetas xs . unAbs  instance MentionsMeta t => MentionsMeta (Arg t) where-  mentionsMeta x a | isIrrelevant a = False-  -- ^ we don't have to look inside irrelevant arguments when deciding to wake constraints-  mentionsMeta x a = mentionsMeta x (unArg a)+  mentionsMetas xs a | isIrrelevant a = False+  -- we don't have to look inside irrelevant arguments when deciding to wake constraints+  mentionsMetas xs a = mentionsMetas xs (unArg a)  instance MentionsMeta t => MentionsMeta (Dom t) where-  mentionsMeta x = mentionsMeta x . unDom+  mentionsMetas xs = mentionsMetas xs . unDom  instance MentionsMeta t => MentionsMeta [t] where-  mentionsMeta x = any (mentionsMeta x)+  mentionsMetas xs = any (mentionsMetas xs)  instance MentionsMeta t => MentionsMeta (Maybe t) where-  mentionsMeta x = maybe False (mentionsMeta x)+  mentionsMetas xs = maybe False (mentionsMetas xs)  instance (MentionsMeta a, MentionsMeta b) => MentionsMeta (a, b) where-  mentionsMeta x (a, b) = mentionsMeta x a || mentionsMeta x b+  mentionsMetas xs (a, b) = mentionsMetas xs a || mentionsMetas xs b  instance (MentionsMeta a, MentionsMeta b, MentionsMeta c) => MentionsMeta (a, b, c) where-  mentionsMeta x (a, b, c) = mentionsMeta x a || mentionsMeta x b || mentionsMeta x c+  mentionsMetas xs (a, b, c) = mentionsMetas xs a || mentionsMetas xs b || mentionsMetas xs c  instance MentionsMeta a => MentionsMeta (Closure a) where-  mentionsMeta x cl = mentionsMeta x (clValue cl)+  mentionsMetas xs cl = mentionsMetas xs (clValue cl)  instance MentionsMeta Elim where-  mentionsMeta x Proj{} = False-  mentionsMeta x (Apply v) = mentionsMeta x v+  mentionsMetas xs Proj{} = False+  mentionsMetas xs (Apply v) = mentionsMetas xs v+  mentionsMetas xs (IApply y0 y1 v) = mentionsMetas xs (y0,y1,v)  instance MentionsMeta a => MentionsMeta (Tele a) where-  mentionsMeta x EmptyTel = False-  mentionsMeta x (ExtendTel a b) = mentionsMeta x (a, b)+  mentionsMetas xs EmptyTel = False+  mentionsMetas xs (ExtendTel a b) = mentionsMetas xs (a, b)  instance MentionsMeta ProblemConstraint where-  mentionsMeta x = mentionsMeta x . theConstraint+  mentionsMetas xs = mentionsMetas xs . theConstraint  instance MentionsMeta Constraint where-  mentionsMeta x c = case c of+  mentionsMetas xs = \case     ValueCmp _ t u v    -> mm (t, u, v)-    ElimCmp _ t v as bs -> mm ((t, v), (as, bs))+    ValueCmpOnFace _ p t u v    -> mm ((p,t), u, v)+    ElimCmp _ _ t v as bs -> mm ((t, v), (as, bs))     LevelCmp _ u v      -> mm (u, v)-    TypeCmp _ a b       -> mm (a, b)-    TelCmp a b _ u v    -> mm ((a, b), (u, v))     SortCmp _ a b       -> mm (a, b)-    Guarded c _         -> mm c     UnBlock _           -> True   -- this might be a postponed typechecking                                   -- problem and we don't have a handle on                                   -- what metas it depends on-    FindInScope{}       -> True   -- this needs to be woken up for any meta+    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 _ ms mod t -> mm (ms, t)     where-      mm v = mentionsMeta x v+      mm :: forall t. MentionsMeta t => t -> Bool+      mm = mentionsMetas xs++instance MentionsMeta CompareAs where+  mentionsMetas xs = \case+    AsTermsOf a -> mentionsMetas xs a+    AsSizes -> False+    AsTypes -> False  -- instance (Ord k, MentionsMeta e) => MentionsMeta (Map k e) where --   mentionsMeta = traverse mentionsMeta
src/full/Agda/TypeChecking/MetaVars/Occurs.hs view
@@ -1,764 +1,1065 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE UndecidableInstances #-}--{- | The occurs check for unification.  Does pruning on the fly.--  When hitting a meta variable:--  - Compute flex/rigid for its arguments.-  - Compare to allowed variables.-  - Mark arguments with rigid occurrences of disallowed variables for deletion.-  - Attempt to delete marked arguments.-  - We don't need to check for success, we can just continue occurs checking.--}--module Agda.TypeChecking.MetaVars.Occurs where--import Control.Applicative-import Control.Monad-import Control.Monad.Reader--import Data.Foldable (foldMap)-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Traversable (traverse)--import qualified Agda.Benchmarking as Bench--import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.TypeChecking.Monad-import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Free hiding (Occurrence(..))-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Records-import {-# SOURCE #-} Agda.TypeChecking.MetaVars--- import Agda.TypeChecking.MetaVars--import Agda.Utils.Either--import Agda.Utils.Except-  ( ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--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.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible--{- To address issue 585 (meta var occurrences in mutual defs)--data B : Set where-  inn : A -> B--out : B -> A-out (inn a) = a--postulate-  P : (y : A) (z : Unit -> B) → Set-  p : (x : Unit -> B) → P (out (x unit)) x--mutual-  d : Unit -> B-  d unit = inn _           -- Y--  g : P (out (d unit)) d-  g = p _             -- X---- Agda solves  d unit = inn (out (d unit))------ out (X unit) = out (d unit) = out (inn Y) = Y--- X = d--When doing the occurs check on d, we need to look at the definition of-d to discover that it mentions X.--To this end, we extend the state by names of definitions that have to-be checked when they occur.  At the beginning, this is initialized-with the names in the current mutual block.  Each time we encounter a-name in the list during occurs check, we delete it (if check is-successful).  This way, we do not duplicate work.---}--modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()-modifyOccursCheckDefs f = stOccursCheckDefs %= f---- | Set the names of definitions to be looked at---   to the defs in the current mutual block.-initOccursCheck :: MetaVariable -> TCM ()-initOccursCheck mv = modifyOccursCheckDefs . const =<<-  if (miMetaOccursCheck (mvInfo mv) == DontRunMetaOccursCheck)-   then do-     reportSLn "tc.meta.occurs" 20 $-       "initOccursCheck: we do not look into definitions"-     return Set.empty-   else do-     reportSLn "tc.meta.occurs" 20 $-       "initOccursCheck: we look into the following definitions:"-     mb <- asks envMutualBlock-     case mb of-       Nothing -> do-         reportSLn "tc.meta.occurs" 20 $ "(none)"-         return Set.empty-       Just b  -> do-         ds <- mutualNames <$> lookupMutualBlock b-         reportSDoc "tc.meta.occurs" 20 $ sep $ map prettyTCM $ Set.toList ds-         return ds----- | Is a def in the list of stuff to be checked?-defNeedsChecking :: QName -> TCM Bool-defNeedsChecking d = Set.member d <$> use stOccursCheckDefs---- | Remove a def from the list of defs to be looked at.-tallyDef :: QName -> TCM ()-tallyDef d = modifyOccursCheckDefs $ \ s -> Set.delete d s--data OccursCtx-  = Flex          -- ^ We are in arguments of a meta.-  | Rigid         -- ^ We are not in arguments of a meta but a bound var.-  | StronglyRigid -- ^ We are at the start or in the arguments of a constructor.-  | Top           -- ^ We are at the term root (this turns into @StronglyRigid@).-  | Irrel         -- ^ We are in an irrelevant argument.-  deriving (Eq, Show)--data UnfoldStrategy = YesUnfold | NoUnfold-  deriving (Eq, Show)--defArgs :: UnfoldStrategy -> OccursCtx -> OccursCtx-defArgs NoUnfold  _   = Flex-defArgs YesUnfold ctx = weakly ctx--unfold :: UnfoldStrategy -> Term -> TCM (Blocked Term)-unfold NoUnfold  v = notBlocked <$> instantiate v-unfold YesUnfold v = reduceB v---- | Leave the top position.-leaveTop :: OccursCtx -> OccursCtx-leaveTop Top = StronglyRigid-leaveTop ctx = ctx---- | Leave the strongly rigid position.-weakly :: OccursCtx -> OccursCtx-weakly Top           = Rigid-weakly StronglyRigid = Rigid-weakly ctx = ctx--strongly :: OccursCtx -> OccursCtx-strongly Rigid = StronglyRigid-strongly ctx = ctx--patternViolation' :: Int -> String -> TCM a-patternViolation' n err = do-  reportSLn "tc.meta.occurs" n err-  patternViolation--abort :: OccursCtx -> TypeError -> TCM a-abort Top           err = typeError err-abort StronglyRigid err = typeError err -- here, throw an uncatchable error (unsolvable constraint)-abort Flex          err = patternViolation' 70 (show err) -- throws a PatternErr, which leads to delayed constraint-abort Rigid         err = patternViolation' 70 (show err)-abort Irrel         err = patternViolation' 70 (show err)---- | Distinguish relevant and irrelevant variables in occurs check.-type Vars = ([Nat],[Nat])--goIrrelevant :: Vars -> Vars-goIrrelevant (relVs, irrVs) = (irrVs ++ relVs, [])--allowedVar :: Nat -> Vars -> Bool-allowedVar i (relVs, irrVs) = i `elem` relVs--takeRelevant :: Vars -> [Nat]-takeRelevant = fst--liftUnderAbs :: Vars -> Vars-liftUnderAbs (relVs, irrVs) = (0 : map (1+) relVs, map (1+) irrVs)---- | Extended occurs check.-class Occurs t where-  occurs :: UnfoldStrategy -> OccursCtx -> MetaId -> Vars -> t -> TCM t-  metaOccurs :: MetaId -> t -> TCM ()  -- raise exception if meta occurs in t---- | 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 -> Vars -> a -> TCM a-occursCheck m xs v = disableDestructiveUpdate $ Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do-  mv <- lookupMeta m-  initOccursCheck mv-      -- TODO: Can we do this in a better way?-  let redo m = m -- disableDestructiveUpdate m >> m-  -- First try without normalising the term-  redo (occurs NoUnfold  Top m xs v) `catchError` \_ -> do-    initOccursCheck mv-    redo (occurs YesUnfold Top m xs v) `catchError` \err -> case err of-                            -- Produce nicer error messages-      TypeError _ cl -> case clValue cl of-        MetaOccursInItself{} ->-          typeError . GenericError . show =<<-            fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to")-                 , prettyTCM =<< instantiateFull v-                 ]-        MetaCannotDependOn _ _ i ->-          ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism))-          ( typeError . GenericError . show =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to")-                 , prettyTCM v-                 , text "since universe polymorphism is disabled"-                 ]-          ) {- else -}-          ( typeError . GenericError . show =<<-              fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")-                   , prettyTCM v-                   , text "since it contains the variable"-                   , enterClosure cl $ \_ -> prettyTCM (Var i [])-                   , text $ "which is not in scope of the metavariable or irrelevant in the metavariable but relevant in the solution"-                   ]-            )-        _ -> throwError err-      _ -> throwError err--instance Occurs Term where-  occurs red ctx m xs v = do-    v <- unfold red v-    -- occurs' ctx $ ignoreBlocking v  -- fails test/succeed/DontPruneBlocked-    case v of-      -- Don't fail on blocked terms or metas-      NotBlocked _ v      -> occurs' ctx v-      -- Blocked _ v@MetaV{} -> occurs' ctx v  -- does not help with issue 856-      Blocked _ v         -> occurs' Flex v-    where-      occurs' ctx v = do-        reportSDoc "tc.meta.occurs" 45 $-          text ("occursCheck " ++ prettyShow m ++ " (" ++ show ctx ++ ") of ") <+> prettyTCM v-        reportSDoc "tc.meta.occurs" 70 $-          nest 2 $ text $ show v-        case v of-          Var i es   -> do-            if (i `allowedVar` xs) then Var i <$> occ (weakly ctx) es else do-              -- if the offending variable is of singleton type,-              -- eta-expand it away-              isST <- isSingletonType =<< typeOfBV i-              case isST of-                -- cannot decide, blocked by meta-var-                Left mid -> patternViolation' 70 $ "Disallowed var " ++ show i ++ " not obviously singleton"-                -- not a singleton type-                Right Nothing -> -- abort Rigid turns this error into PatternErr-                  abort (strongly ctx) $ MetaCannotDependOn m (takeRelevant xs) i-                -- is a singleton type with unique inhabitant sv-                Right (Just sv) -> return $ sv `applyE` es-          Lam h f     -> Lam h <$> occ (leaveTop ctx) f-          Level l     -> Level <$> occ ctx l  -- stay in Top-          Lit l       -> return v-          DontCare v  -> dontCare <$> occurs red Irrel m (goIrrelevant xs) v-          Def d es    -> Def d <$> occDef d (leaveTop ctx) es-          Con c ci vs -> Con c ci <$> occ (leaveTop ctx) vs  -- if strongly rigid, remain so-          Pi a b      -> uncurry Pi <$> occ (leaveTop ctx) (a,b)-          Sort s      -> Sort <$> occ (leaveTop ctx) s-          v@Shared{}  -> updateSharedTerm (occ ctx) v-          MetaV m' es -> do-              -- Check for loop-              --   don't fail hard on this, since we might still be on the top-level-              --   after some killing (Issue 442)-              ---              -- Andreas, 2013-02-18  Issue 795 demonstrates that a recursive-              -- occurrence of a meta could be solved by the identity.-              --   ? (Q A) = Q (? A)-              -- So, do not throw an error.-              -- I guess the error was there from times when occurrence check-              -- was done after the "lhs=linear variables" check, but now-              -- occurrence check comes first.-              -- WAS:-              -- when (m == m') $ if ctx == Top then patternViolation else-              --   abort ctx $ MetaOccursInItself m'-              when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ prettyShow m--              -- The arguments of a meta are in a flexible position-              (MetaV m' <$> occurs red Flex m xs es) `catchError` \err -> do-                reportSDoc "tc.meta.kill" 25 $ vcat-                  [ text $ "error during flexible occurs check, we are " ++ show ctx-                  , text $ show err-                  ]-                case err of-                  -- On pattern violations try to remove offending-                  -- flexible occurrences (if not already in a flexible context)-                  PatternErr{} | ctx /= Flex -> do-                    reportSLn "tc.meta.kill" 20 $-                      "oops, pattern violation for " ++ prettyShow m'-                    -- Andreas, 2014-03-02, see issue 1070:-                    -- Do not prune when meta is projected!-                    caseMaybe (allApplyElims es) (throwError err) $ \ vs -> do-                      killResult <- prune m' vs (takeRelevant xs)-                      if (killResult == PrunedEverything)-                        -- after successful pruning, restart occurs check-                        then occurs red ctx m xs =<< instantiate (MetaV m' es)-                        else throwError err-                  _ -> throwError err-          where-            occ ctx v = occurs red ctx m xs v-            -- a data or record type constructor propagates strong occurrences-            -- since e.g. x = List x is unsolvable-            occDef d ctx vs = do-              metaOccurs m d-              ifM (isJust <$> isDataOrRecordType d)-                {-then-} (occ ctx vs)-                {-else-} (occ (defArgs red ctx) vs)--  metaOccurs m v = do-    v <- instantiate v-    case v of-      Var i vs   -> metaOccurs m vs-      Lam h f    -> metaOccurs m f-      Level l    -> metaOccurs m l-      Lit l      -> return ()-      DontCare v -> metaOccurs m v-      Def d vs   -> metaOccurs m d >> metaOccurs m vs-      Con c _ vs -> metaOccurs m vs-      Pi a b     -> metaOccurs m (a,b)-      Sort s     -> metaOccurs m s-      Shared p   -> metaOccurs m $ derefPtr p-      MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ prettyShow m-                  | otherwise -> metaOccurs m vs--instance Occurs QName where-  occurs red ctx m xs d = __IMPOSSIBLE__--  metaOccurs m d = whenM (defNeedsChecking d) $ do-    tallyDef d-    reportSLn "tc.meta.occurs" 30 $ "Checking for occurrences in " ++ show d-    metaOccurs m . theDef =<< ignoreAbstractMode (getConstInfo d)--instance Occurs Defn where-  occurs red ctx m xs def = __IMPOSSIBLE__--  metaOccurs m Axiom{}                      = return ()-  metaOccurs m Function{ funClauses = cls } = 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_ mocc cs-    where mocc c = metaOccurs m . defType =<< getConstInfo c-  metaOccurs m Record{ recConHead = c }     = metaOccurs m . defType =<< getConstInfo (conName c)-  metaOccurs m Constructor{}                = return ()-  metaOccurs m Primitive{}                  = return ()-  metaOccurs m AbstractDefn{}               = __IMPOSSIBLE__--instance Occurs Clause where-  occurs red ctx m xs cl = __IMPOSSIBLE__--  metaOccurs m = metaOccurs m . clauseBody--instance Occurs Level where-  occurs red ctx m xs (Max as) = Max <$> occurs red ctx m xs as--  metaOccurs m (Max as) = metaOccurs m as--instance Occurs PlusLevel where-  occurs red ctx m xs l@ClosedLevel{} = return l-  occurs red ctx m xs (Plus n l) = Plus n <$> occurs red ctx' m xs l-    where ctx' | n == 0    = ctx-               | otherwise = leaveTop ctx  -- we leave Top only if we encounter at least one successor-  metaOccurs m ClosedLevel{} = return ()-  metaOccurs m (Plus n l)    = metaOccurs m l--instance Occurs LevelAtom where-  occurs red ctx m xs l = do-    l <- case red of-           YesUnfold -> reduce l-           NoUnfold  -> instantiate l-    case l of-      MetaLevel m' args -> do-        MetaV m' args <- ignoreSharing <$> occurs red ctx m xs (MetaV m' args)-        return $ MetaLevel m' args-      NeutralLevel r v  -> NeutralLevel r  <$> occurs red ctx m xs v-      BlockedLevel m' v -> BlockedLevel m' <$> occurs red Flex m xs v-      UnreducedLevel v  -> UnreducedLevel  <$> occurs red ctx m xs v--  metaOccurs m l = do-    l <- instantiate l-    case l of-      MetaLevel m' args -> metaOccurs m $ MetaV m' args-      NeutralLevel _ v  -> metaOccurs m v-      BlockedLevel _ v  -> metaOccurs m v-      UnreducedLevel v  -> metaOccurs m v---instance Occurs Type where-  occurs red ctx m xs (El s v) = uncurry El <$> occurs red ctx m xs (s,v)--  metaOccurs m (El s v) = metaOccurs m (s,v)--instance Occurs Sort where-  occurs red ctx m xs s = do-    s' <- case red of-            YesUnfold -> reduce s-            NoUnfold  -> instantiate s-    case s' of-      DLub s1 s2 -> uncurry DLub <$> occurs red (weakly ctx) m xs (s1,s2)-      Type a     -> Type <$> occurs red ctx m xs a-      Prop       -> return s'-      Inf        -> return s'-      SizeUniv   -> return s'--  metaOccurs m s = do-    s <- instantiate s-    case s of-      DLub s1 s2 -> metaOccurs m (s1,s2)-      Type a     -> metaOccurs m a-      Prop       -> return ()-      Inf        -> return ()-      SizeUniv   -> return ()--instance Occurs a => Occurs (Elim' a) where-  occurs red ctx m xs e@Proj{}  = return e-  occurs red ctx m xs (Apply a) = Apply <$> occurs red ctx m xs a--  metaOccurs m (Proj{} ) = return ()-  metaOccurs m (Apply a) = metaOccurs m a--instance (Occurs a, Subst t a) => Occurs (Abs a) where-  occurs red ctx m xs b@(Abs   s x) = Abs   s <$> underAbstraction_ b (occurs red ctx m (liftUnderAbs xs))-  occurs red ctx m xs b@(NoAbs s x) = NoAbs s <$> occurs red ctx m xs x--  metaOccurs m (Abs   s x) = metaOccurs m x-  metaOccurs m (NoAbs s x) = metaOccurs m x--instance Occurs a => Occurs (Arg a) where-  occurs red ctx m xs (Arg info x) | isIrrelevant info = Arg info <$>-    occurs red Irrel m (goIrrelevant xs) x-  occurs red ctx m xs (Arg info x) = Arg info <$>-    occurs red ctx m xs x--  metaOccurs m a = metaOccurs m (unArg a)--instance Occurs a => Occurs (Dom a) where-  occurs red ctx m xs (Dom info x) = Dom info <$> occurs red ctx m xs x-  metaOccurs m = metaOccurs m . unDom--instance (Occurs a, Occurs b) => Occurs (a,b) where-  occurs red ctx m xs (x,y) = (,) <$> occurs red ctx m xs x <*> occurs red ctx m xs y--  metaOccurs m (x,y) = metaOccurs m x >> metaOccurs m y--instance Occurs a => Occurs [a] where-  occurs red ctx m xs ys = mapM (occurs red ctx m xs) ys--  metaOccurs m ys = mapM_ (metaOccurs m) ys--instance Occurs a => Occurs (Maybe a) where-  occurs red ctx m mx my = traverse (occurs red ctx m mx) my--  metaOccurs m = maybe (return ()) (metaOccurs m)---- * Getting rid of flexible occurrences---- | @prune m' vs xs@ attempts to remove all arguments from @vs@ whose---   free variables are not contained in @xs@.---   If successful, @m'@ is solved by the new, pruned meta variable and we---   return @True@ else @False@.------   Issue 1147:---   If any of the meta args @vs@ is matchable, e.g., is a constructor term,---   we cannot prune, because the offending variables could be removed by---   reduction for a suitable instantiation of the meta variable.-prune :: MetaId -> Args -> [Nat] -> TCM PruneResult-prune m' vs xs = do-  caseEitherM (runExceptT $ mapM (hasBadRigid xs) $ map unArg vs)-    (const $ return PrunedNothing) $ \ kills -> do-    reportSDoc "tc.meta.kill" 10 $ vcat-      [ text "attempting kills"-      , nest 2 $ vcat-        [ text "m'    =" <+> pretty m'-        -- , text "xs    =" <+> text (show xs)-        , text "xs    =" <+> prettyList (map (prettyTCM . var) xs)-        , text "vs    =" <+> prettyList (map prettyTCM vs)-        , text "kills =" <+> text (show kills)-        ]-      ]-    killArgs kills m'---- | @hasBadRigid xs v = Just True@ iff one of the rigid variables in @v@ is not in @xs@.---   Actually we can only prune if a bad variable is in the head. See issue 458.---   Or in a non-eliminateable position (see succeed/PruningNonMillerPattern).------   @hasBadRigid xs v = Nothing@ means that---   we cannot prune at all as one of the meta args is matchable.---   (See issue 1147.)-hasBadRigid :: [Nat] -> Term -> ExceptT () TCM Bool-hasBadRigid xs t = do-  -- We fail if we encounter a matchable argument.-  let failure = throwError ()-  tb <- liftTCM $ reduceB t-  let t = ignoreBlocking tb-  case ignoreSharing t of-    Var x _      -> return $ notElem x xs-    -- Issue 1153: A lambda has to be considered matchable.-    -- Lam _ v    -> hasBadRigid (0 : map (+1) xs) (absBody v)-    Lam _ v      -> failure-    DontCare v   -> hasBadRigid xs v-    -- The following types of arguments cannot be eliminated by a pattern-    -- match: data, record, Pi, levels, sorts-    -- Thus, their offending rigid variables are bad.-    v@(Def f es) -> ifNotM (isNeutral tb f es) failure $ {- else -} do-      es `rigidVarsNotContainedIn` xs-    -- Andreas, 2012-05-03: There is room for further improvement.-    -- We could also consider a defined f which is not blocked by a meta.-    Pi a b       -> (a,b) `rigidVarsNotContainedIn` xs-    Level v      -> v `rigidVarsNotContainedIn` xs-    Sort s       -> s `rigidVarsNotContainedIn` xs-    -- Since constructors can be eliminated by pattern-matching,-    -- offending variables under a constructor could be removed by-    -- the right instantiation of the meta variable.-    -- Thus, they are not rigid.-    Con c _ args -> do-      ifM (liftTCM $ isEtaCon (conName c))-        -- in case of a record con, we can in principle prune-        -- (but not this argument; the meta could become a projection!)-        (and <$> mapM (hasBadRigid xs . unArg) args)  -- not andM, we need to force the exceptions!-        failure-    Lit{}        -> failure -- matchable-    MetaV{}      -> failure -- potentially matchable-    Shared p     -> __IMPOSSIBLE__---- | Check whether a term @Def f es@ is finally stuck.---   Currently, we give only a crude approximation.-isNeutral :: MonadTCM tcm => Blocked t -> QName -> Elims -> tcm Bool-isNeutral b f es = liftTCM $ do-  let yes = return True-      no  = return False-  def <- getConstInfo f-  if defMatchable def then no else do-  case theDef def of-    AbstractDefn -> yes-    Axiom{}    -> yes-    Datatype{} -> yes-    Record{}   -> yes-    Function{} -> case b of-      NotBlocked StuckOn{}   _ -> yes-      NotBlocked AbsurdMatch _ -> yes-      _                        -> no-    _          -> no---- | Check whether any of the variables (given as de Bruijn indices)---   occurs *definitely* in the term in a rigid position.---   Reduces the term successively to remove variables in dead subterms.---   This fixes issue 1386.-rigidVarsNotContainedIn :: (MonadTCM tcm, FoldRigid a) => a -> [Nat] -> tcm Bool-rigidVarsNotContainedIn v is = liftTCM $ do-  n0 <- getContextSize-  let -- allowed variables as de Bruijn levels-      levels = Set.fromList $ map (n0-1 -) is-      -- test if index is forbidden by converting it to level-      test i = do-        n <- getContextSize-        -- get de Bruijn level for i-        let l = n-1 - i-            -- If l >= n0 then it is a bound variable and can be-            -- ignored.  Otherwise, it has to be in the allowed levels.-            forbidden = l < n0 && not (l `Set.member` levels)-        when forbidden $-          reportSLn "tc.meta.kill" 20 $-            "found forbidden de Bruijn level " ++ show l-        return $ Any forbidden-  getAny <$> foldRigid test v---- | Collect the *definitely* rigid variables in a monoid.---   We need to successively reduce the expression to do this.--class FoldRigid a where---  foldRigid :: (MonadTCM tcm, Monoid (tcm m)) => (Nat -> tcm m) -> a -> tcm m-  foldRigid :: (Monoid (TCM m)) => (Nat -> TCM m) -> a -> TCM m--instance FoldRigid Term where-  foldRigid f t = do-    b <- liftTCM $ reduceB t-    case ignoreSharing $ ignoreBlocking b of-      Var i es   -> f i `mappend` fold es-      Lam _ t    -> fold t-      Lit{}      -> mempty-      Def _ es   -> case b of-        Blocked{}                   -> mempty-        NotBlocked MissingClauses _ -> mempty-        _        -> fold es-      Con _ _ ts -> fold ts-      Pi a b     -> fold (a,b)-      Sort s     -> fold s-      Level l    -> fold l-      MetaV{}    -> mempty-      DontCare{} -> mempty-      Shared{}   -> __IMPOSSIBLE__-    where fold = foldRigid f--instance FoldRigid Type where-  foldRigid f (El s t) = foldRigid f (s,t)--instance FoldRigid Sort where-  foldRigid f s =-    case s of-      Type l     -> fold l-      Prop       -> mempty-      Inf        -> mempty-      SizeUniv   -> mempty-      DLub s1 s2 -> fold (s1, s2)-    where fold = foldRigid f--instance FoldRigid Level where-  foldRigid f (Max ls) = foldRigid f ls--instance FoldRigid PlusLevel where-  foldRigid f ClosedLevel{} = mempty-  foldRigid f (Plus _ l)    = foldRigid f l--instance FoldRigid LevelAtom where-  foldRigid f l =-    case l of-      MetaLevel{} -> mempty-      NeutralLevel MissingClauses _ -> mempty-      NeutralLevel _              l -> fold l-      BlockedLevel _              l -> fold l-      UnreducedLevel              l -> fold l-    where fold = foldRigid f--instance (Subst t a, FoldRigid a) => FoldRigid (Abs a) where-  foldRigid f b = underAbstraction_ b $ foldRigid f--instance FoldRigid a => FoldRigid (Arg a) where-  foldRigid f a =-    case getRelevance a of-      Irrelevant -> mempty-      UnusedArg  -> mempty-      _          -> foldRigid f $ unArg a--instance FoldRigid a => FoldRigid (Dom a) where-  foldRigid f dom = foldRigid f $ unDom dom--instance FoldRigid a => FoldRigid (Elim' a) where-  foldRigid f (Apply a) = foldRigid f a-  foldRigid f Proj{}    = mempty--instance FoldRigid a => FoldRigid [a] where-  foldRigid f = foldMap $ foldRigid f--instance (FoldRigid a, FoldRigid b) => FoldRigid (a,b) where-  foldRigid f (a,b) = foldRigid f a `mappend` foldRigid f b---data PruneResult-  = NothingToPrune   -- ^ the kill list is empty or only @False@s-  | PrunedNothing    -- ^ there is no possible kill (because of type dep.)-  | PrunedSomething  -- ^ managed to kill some args in the list-  | PrunedEverything -- ^ all prescribed kills where performed-    deriving (Eq, Show)---- | @killArgs [k1,...,kn] X@ prunes argument @i@ from metavar @X@ if @ki==True@.---   Pruning is carried out whenever > 0 arguments can be pruned.-killArgs :: [Bool] -> MetaId -> TCM PruneResult-killArgs kills _-  | not (or kills) = return NothingToPrune  -- nothing to kill-killArgs kills m = do-  mv <- lookupMeta m-  allowAssign <- asks envAssignMetas-  if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do-      -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS-      let a = jMetaType $ mvJudgement mv-      TelV tel b <- telView' <$> instantiateFull a-      let args         = zip (telToList tel) (kills ++ repeat False)-          (kills', a') = killedType args b-      dbg kills' a a'-      -- If there is any prunable argument, perform the pruning-      if not (any unArg kills') then return PrunedNothing else do-        performKill kills' m a'-        -- Only successful if all occurrences were killed-        -- Andreas, 2011-05-09 more precisely, check that at least-        -- the in 'kills' prescribed kills were carried out-        return $ if (and $ zipWith implies kills $ map unArg kills')-                   then PrunedEverything-                   else PrunedSomething-  where-    implies :: Bool -> Bool -> Bool-    implies False _ = True-    implies True  x = x-    dbg kills' a a' =-      reportSDoc "tc.meta.kill" 10 $ vcat-        [ text "after kill analysis"-        , nest 2 $ vcat-          [ text "metavar =" <+> prettyTCM m-          , text "kills   =" <+> text (show kills)-          , text "kills'  =" <+> text (show kills')-          , text "oldType =" <+> prettyTCM a-          , text "newType =" <+> prettyTCM a'-          ]-        ]---- | @killedType [((x1,a1),k1)..((xn,an),kn)] b = ([k'1..k'n],t')@---   (ignoring @Dom@).  Let @t' = (xs:as) -> b@.---   Invariant: @k'i == True@ iff @ki == True@ and pruning the @i@th argument from---   type @b@ is possible without creating unbound variables.---   @t'@ is type @t@ after pruning all @k'i==True@.-killedType :: [(Dom (ArgName, Type), Bool)] -> Type -> ([Arg Bool], Type)-killedType [] b = ([], b)-killedType ((arg@(Dom info _), kill) : kills) b-  | dontKill  = (Arg info False : args, mkPi arg b')-  | otherwise = (Arg info True  : args, strengthen __IMPOSSIBLE__ b')-  where-    (args, b') = killedType kills b-    dontKill = not kill || 0 `freeIn` b'---- | Instantiate a meta variable with a new one that only takes---   the arguments which are not pruneable.-performKill-  :: [Arg Bool]    -- ^ Arguments to old meta var in left to right order-                   --   with @Bool@ indicating whether they can be pruned.-  -> MetaId        -- ^ The old meta var to receive pruning.-  -> Type          -- ^ The pruned type of the new meta var.-  -> TCM ()-performKill kills m a = do-  mv <- lookupMeta m-  when (mvFrozen mv == Frozen) __IMPOSSIBLE__-  -- Arity of the old meta.-  let n = size kills-  -- The permutation of the new meta picks the arguments-  -- which are not pruned in left to right order-  -- (de Bruijn level order).-  let perm = Perm n-             [ i | (i, Arg _ False) <- zip [0..] kills ]-  m' <- newMeta (mvInfo mv) (mvPriority mv) perm-                (HasType __IMPOSSIBLE__ a)-  -- Andreas, 2010-10-15 eta expand new meta variable if necessary-  etaExpandMetaSafe m'-  let -- Arguments to new meta (de Bruijn indices)-      -- in left to right order.-      vars = [ Arg info (var i)-             | (i, Arg info False) <- zip (downFrom n) kills ]-      u       = MetaV m' $ map Apply vars-      -- Arguments to the old meta (just arg infos and name hints)-      -- in left to right order.-      tel     = map ("v" <$) kills-  dbg m' u-  assignTerm m tel u  -- m tel := u-  where-    dbg m' u = reportSDoc "tc.meta.kill" 10 $ vcat-      [ text "actual killing"-      , nest 2 $ vcat-        [ text "new meta:" <+> pretty m'-        , text "kills   :" <+> text (show kills)-        , text "inst    :" <+> pretty m <+> text ":=" <+> prettyTCM u+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation  #-}++{- | The occurs check for unification.  Does pruning on the fly.++  When hitting a meta variable:++  - Compute flex/rigid for its arguments.+  - Compare to allowed variables.+  - Mark arguments with rigid occurrences of disallowed variables for deletion.+  - Attempt to delete marked arguments.+  - We don't need to check for success, we can just continue occurs checking.+-}++module Agda.TypeChecking.MetaVars.Occurs where++import Control.Monad.Except ( ExceptT, runExceptT, catchError, throwError )+import Control.Monad.Reader ( ReaderT, runReaderT, ask, asks, local )++import Data.Foldable (traverse_)+import Data.Functor+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap++import qualified Agda.Benchmarking as Bench++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars++import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Pretty+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.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.Size+import Agda.Utils.VarSet (VarSet)+import qualified Agda.Utils.VarSet as VarSet++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * MetaOccursCheck: going into definitions to exclude cyclic solutions++{- To address issue 585 (meta var occurrences in mutual defs)++data B : Set where+  inn : A -> B++out : B -> A+out (inn a) = a++postulate+  P : (y : A) (z : Unit -> B) → Set+  p : (x : Unit -> B) → P (out (x unit)) x++mutual+  d : Unit -> B+  d unit = inn _           -- Y++  g : P (out (d unit)) d+  g = p _             -- X++-- Agda solves  d unit = inn (out (d unit))+--+-- out (X unit) = out (d unit) = out (inn Y) = Y+-- X = d++When doing the occurs check on d, we need to look at the definition of+d to discover that it mentions X.++To this end, we extend the state by names of definitions that have to+be checked when they occur.  At the beginning, this is initialized+with the names in the current mutual block.  Each time we encounter a+name in the list during occurs check, we delete it (if check is+successful).  This way, we do not duplicate work.++-}++modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()+modifyOccursCheckDefs f = stOccursCheckDefs `modifyTCLens` f++-- | Set the names of definitions to be looked at+--   to the defs in the current mutual block.+initOccursCheck :: MetaVariable -> TCM ()+initOccursCheck mv = modifyOccursCheckDefs . const =<<+  if (miMetaOccursCheck (mvInfo mv) == DontRunMetaOccursCheck)+   then do+     reportSLn "tc.meta.occurs" 20 $+       "initOccursCheck: we do not look into definitions"+     return Set.empty+   else do+     reportSLn "tc.meta.occurs" 20 $+       "initOccursCheck: we look into the following definitions:"+     mb <- asksTC envMutualBlock+     case mb of+       Nothing -> do+         reportSLn "tc.meta.occurs" 20 $ "(none)"+         return Set.empty+       Just b  -> do+         ds <- mutualNames <$> lookupMutualBlock b+         reportSDoc "tc.meta.occurs" 20 $ sep $ map prettyTCM $ Set.toList ds+         return ds+++-- | Is a def in the list of stuff to be checked?+defNeedsChecking :: QName -> TCM Bool+defNeedsChecking d = Set.member d <$> useTC stOccursCheckDefs++-- | Remove a def from the list of defs to be looked at.+tallyDef :: QName -> TCM ()+tallyDef d = modifyOccursCheckDefs $ Set.delete d++---------------------------------------------------------------------------+-- * OccursM monad and its services++-- | Extra environment for the occurs check.  (Complements 'FreeEnv'.)+data OccursExtra = OccursExtra+  { occUnfold  :: UnfoldStrategy+  , 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.+  }++type OccursCtx  = FreeEnv' () OccursExtra AllowedVar+type OccursM    = ReaderT OccursCtx TCM++-- ** Modality handling.++-- | The passed modality is the one of the current context.+type AllowedVar = Modality -> All++instance IsVarSet () AllowedVar where+  withVarOcc o f = f . composeModality (getModality o)++-- | Check whether a free variable is allowed in the context as+--   specified by the modality.+variableCheck :: VarMap -> Maybe Variable -> AllowedVar+variableCheck xs mi q = All $+  -- Bound variables are always allowed to occur:+  caseMaybe mi True $ \ i ->+    -- Free variables not listed in @xs@ are forbidden:+    caseMaybe (lookupVarMap i xs) False $ \ o ->+      -- For listed variables it holds:+      -- The ascribed modality @o@ must be submodality of the+      -- modality @q@ of the current context.+      -- E.g. irrelevant variables (ascribed, lhs) can only+      -- be used in irrelevant position (rhs).+      getModality o `moreUsableModality` q++-- | Occurs check fails if a defined name is not available+--   since it was declared in irrelevant or erased context.+definitionCheck :: QName -> OccursM ()+definitionCheck d = do+  cxt <- ask+  let irr = isIrrelevant cxt+      er  = hasQuantity0 cxt+      m   = occMeta $ feExtra cxt+  -- Anything goes if we are both irrelevant and erased.+  -- Otherwise, have to check the modality of the defined name.+  unless (irr && er) $ getConstInfo' d >>= \case+   Left _ -> do+    -- Andreas, 2021-07-29.+    -- The definition is not in scope.+    -- This shouldn't happen, but does so in issue #5492.+    -- Let's bail out...+    patternViolation' alwaysUnblock 35 $+      unwords ["occursCheck: definition", prettyShow d, "not in scope" ]+   Right def -> do+    let dmod = getModality def+    unless (irr || usableRelevance dmod) $ do+      reportSDoc "tc.meta.occurs" 35 $ hsep+        [ "occursCheck: definition"+        , prettyTCM d+        , "has relevance"+        , text . show $ getRelevance dmod+        ]+      abort neverUnblock $ MetaIrrelevantSolution m $ occRHS $ feExtra cxt+    unless (er || usableQuantity dmod) $ do+      reportSDoc "tc.meta.occurs" 35 $ hsep+        [ "occursCheck: definition"+        , prettyTCM d+        , "has quantity"+        , text . show $ getQuantity dmod+        ]+      abort neverUnblock $ MetaErasedSolution m $ occRHS $ feExtra cxt++metaCheck :: MetaId -> OccursM MetaId+metaCheck m = do+  cxt <- ask+  let rel = getRelevance cxt+      qnt = getQuantity cxt+      m0  = occMeta $ feExtra cxt++  -- Check for loop+  --   don't fail hard on this, since we might still be on the top-level+  --   after some killing (Issue 442)+  --+  -- Andreas, 2013-02-18  Issue 795 demonstrates that a recursive+  -- occurrence of a meta could be solved by the identity.+  --   ? (Q A) = Q (? A)+  -- So, do not throw an error.+  -- I guess the error was there from times when occurrence check+  -- was done after the "lhs=linear variables" check, but now+  -- occurrence check comes first.+  -- 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 <- 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"+      , text . show $ getRelevance mmod+      , "and quantity"+      , text . show $ getQuantity mmod+      ]+    allowAssign <- asksTC envAssignMetas+    -- Jesper, 2020-11-10: if we encounter a metavariable that is+    -- unusable because of its modality (e.g. irrelevant or erased) we+    -- try to *promote* the meta to the required modality, by creating+    -- a new meta with that modality and solving the old one with+    -- it. Don't do this if the meta occurs in a flexible or unguarded+    -- position:+    -- - If it is in a flexible position, it could disappear when+    --   another meta is solved, so promotion is maybe not necessary.+    -- - 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"+    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'+    -- 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.+allowedVars :: OccursM (Nat -> Bool)+allowedVars = do+  -- @n@ is the number of binders we have stepped under.+  n  <- liftM2 (-) getContextSize (asks (occCxtSize . feExtra))+  xs <- asks (theVarMap . occVars . feExtra)+  -- Bound variables are allowed, and those mentioned in occVars.+  return $ \ i -> i < n || (i - n) `IntMap.member` xs++-- ** Unfolding during occurs check.++-- | Unfold definitions during occurs check?+--   This effectively runs the occurs check on the normal form.+data UnfoldStrategy = YesUnfold | NoUnfold+  deriving (Eq, Show)++defArgs :: OccursM a -> OccursM a+defArgs m = asks (occUnfold . feExtra) >>= \case+  NoUnfold  -> flexibly m+  YesUnfold -> weakly m++-- | For a path constructor `c : ... -> Path D a b`, we have that e.g. `c es i0` reduces to `a`.+--   So we have to consider its arguments as flexible when we do not actually unfold.+conArgs :: Elims -> OccursM a -> OccursM a+conArgs es m = asks (occUnfold . feExtra) >>= \case+  YesUnfold -> m+  NoUnfold | null [ () | IApply{} <- es ]+            -> m+  NoUnfold  -> flexibly m++unfoldB :: (Instantiate t, Reduce t) => t -> OccursM (Blocked t)+unfoldB v = do+  unfold <- asks $ occUnfold . feExtra+  rel    <- asks feModality+  case unfold of+    YesUnfold | not (isIrrelevant rel) -> reduceB v+    _                                  -> notBlocked <$> instantiate v++unfold :: (Instantiate t, Reduce t) => t -> OccursM t+unfold v = asks (occUnfold . feExtra) >>= \case+  NoUnfold  -> instantiate v+  YesUnfold -> reduce v++-- ** Managing rigidiy during occurs check.++-- | Leave the strongly rigid position.+weakly :: OccursM a -> OccursM a+weakly = local $ over lensFlexRig $ composeFlexRig WeaklyRigid++strongly :: OccursM a -> OccursM a+strongly = local $ over lensFlexRig $ \case+  WeaklyRigid -> StronglyRigid+  Unguarded   -> StronglyRigid+  ctx -> ctx++flexibly :: OccursM a -> OccursM a+flexibly = local $ set lensFlexRig $ Flexible ()++-- ** Error throwing during occurs check.++patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a+patternViolation' unblock n err = liftTCM $ do+  reportSLn "tc.meta.occurs" n err+  patternViolation unblock++abort :: Blocker -> TypeError -> OccursM a+abort unblock err = do+  ctx <- ask+  lift $ do+    if | isIrrelevant ctx                    -> soft+       | StronglyRigid <- ctx ^. lensFlexRig -> hard+       | otherwise -> soft+  where+  hard = typeError err -- here, throw an uncatchable error (unsolvable constraint)+  soft = patternViolation' unblock 70 (show err) -- throws a PatternErr, which leads to delayed constraint++---------------------------------------------------------------------------+-- * Implementation of the occurs check.++-- | Extended occurs check.+class Occurs t where+  occurs :: t -> OccursM t+  metaOccurs :: MetaId -> t -> TCM ()  -- raise exception if meta occurs in t++  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+  :: MetaId -> VarMap -> Term -> TCM Term+occursCheck m xs v = Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do+  mv <- lookupLocalMeta m+  n  <- getContextSize+  reportSDoc "tc.meta.occurs" 65 $ "occursCheck" <+> pretty m <+> text (show xs)+  let initEnv unf = FreeEnv+        { feExtra = OccursExtra+          { occUnfold  = unf+          , occMeta    = m+          , occVars    = xs+          , occRHS     = v+          , occCxtSize = n+          }+        , feFlexRig   = StronglyRigid -- ? Unguarded+        , feModality  = getModality mv+        , feSingleton = variableCheck xs+        }+  initOccursCheck mv+  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 $ getModality mv) -> do+          initOccursCheck mv+          occurs v `runReaderT` initEnv YesUnfold+        _ -> throwError err++instance Occurs Term where+  occurs v = do+    vb  <- unfoldB v+    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} <- vb -> flexibly+          | otherwise -> id+    v <- reduceProjectionLike $ ignoreBlocking vb+    flexIfBlocked $ do+        ctx <- ask+        let m = occMeta . feExtra $ ctx+        reportSDoc "tc.meta.occurs" 45 $+          text ("occursCheck " ++ prettyShow m ++ " (" ++ show (feFlexRig ctx) ++ ") of ") <+> prettyTCM v+        reportSDoc "tc.meta.occurs" 70 $+          nest 2 $ pretty v+        case v of+          Var i es   -> do+            allowed <- getAll . ($ unitModality) <$> variable i+            if allowed then Var i <$> weakly (occurs es) else do+              -- if the offending variable is of singleton type,+              -- eta-expand it away+              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 <- typeLevelReductions $ isSingletonType t+              reportSDoc "tc.meta.occurs" 35 $ nest 2 $ "(after singleton test)"+              case isST of+                -- not a singleton type+                Nothing ->+                  -- #4480: Only hard fail if the variable is not in scope. Wrong modality/relevance+                  -- 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 (occRHS $ feExtra ctx) i)+                -- is a singleton type with unique inhabitant sv+                (Just sv) -> return $ sv `applyE` es+          Lam h f     -> do+            Lam h <$> occurs f+          Level l     -> Level <$> occurs_ l+          Lit l       -> return v+          Dummy{}     -> return 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      -> Pi <$> occurs_ a <*> occurs b+          Sort s      -> Sort <$> do underRelevance shapeIrrelevant $ occurs_ s+          MetaV m' es -> do+            m' <- metaCheck m'+            -- 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)+                  , text $ show err+                  ]+                case err of+                  -- On pattern violations try to remove offending+                  -- flexible occurrences (if not already in a flexible context)+                  PatternErr{} | not (isFlexible ctx) -> do+                    reportSLn "tc.meta.kill" 20 $+                      "oops, pattern violation for " ++ prettyShow m'+                    -- Andreas, 2014-03-02, see issue 1070:+                    -- Do not prune when meta is projected!+                    caseMaybe (allApplyElims es) (throwError err) $ \ vs -> do+                      killResult <- lift . prune m' vs =<< allowedVars+                      if (killResult == PrunedEverything) then do+                        -- after successful pruning, restart occurs check+                        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+            -- since e.g. x = List x is unsolvable+            occDef d vs = do+              m   <- asks (occMeta . feExtra)+              lift $ metaOccurs m d+              ifM (liftTCM $ isJust <$> isDataOrRecordType d)+                {-then-} (occurs vs)+                {-else-} (defArgs $ occurs vs)++  metaOccurs m v = do+    v <- instantiate v+    case v of+      Var i vs   -> metaOccurs m vs+      Lam h f    -> metaOccurs m f+      Level l    -> metaOccurs m l+      Lit l      -> return ()+      Dummy{}    -> return ()+      DontCare v -> metaOccurs m v+      Def d vs   -> metaOccurs2 m d vs+      Con c _ vs -> metaOccurs m vs+      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++instance Occurs QName where+  occurs d = __IMPOSSIBLE__++  metaOccurs m d = whenM (defNeedsChecking d) $ do+    tallyDef d+    reportSDoc "tc.meta.occurs" 30 $ "Checking for occurrences in " <+> prettyTCM d+    metaOccursQName m d++metaOccursQName :: MetaId -> QName -> TCM ()+metaOccursQName m x = metaOccurs m . theDef =<< do+  ignoreAbstractMode $ getConstInfo x+  -- Andreas, 2019-05-03, issue #3742:+  -- ignoreAbstractMode necessary, as abstract+  -- constructors are also called up.++instance Occurs Defn where+  occurs def = __IMPOSSIBLE__++  metaOccurs m Axiom{}                      = return ()+  metaOccurs m DataOrRecSig{}               = return ()+  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+  metaOccurs m Record{ recConHead = c }     = metaOccursQName m $ conName c+  metaOccurs m Constructor{}                = return ()+  metaOccurs m Primitive{}                  = return ()+  metaOccurs m PrimitiveSort{}              = __IMPOSSIBLE__+  metaOccurs m AbstractDefn{}               = __IMPOSSIBLE__+  metaOccurs m GeneralizableVar{}           = __IMPOSSIBLE__++instance Occurs Clause where+  occurs cl = __IMPOSSIBLE__++  metaOccurs m cl = whenJust (clauseBody cl) $ metaOccurs m++instance Occurs Level where+  occurs (Max n as) = Max n <$> traverse occurs_ as++  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) = do+    Plus n <$> occurs l++  metaOccurs m (Plus n l) = metaOccurs m l++instance Occurs Type where+  occurs (El s v) = El <$> occurs_ s <*> occurs 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+        return $ PiSort a' s1' s2'+      FunSort s1 s2 -> FunSort <$> flexibly (occurs_ s1) <*> flexibly (occurs_ s2)+      Univ u a   -> Univ u <$> occurs_ a+      s@Inf{}    -> return s+      s@SizeUniv -> return s+      s@LockUniv -> return 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+      DefS x es -> do+        Def x es <- occurs (Def x es)+        return $ DefS x es+      DummyS{}   -> return s++  metaOccurs m s = do+    s <- instantiate s+    case s of+      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 ()+      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 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 es = forM_ es $ \case+    Proj{} -> return ()+    Apply a -> metaOccurs m a+    IApply x y a -> metaOccurs3 m x y a++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+    applyWhen (isIrrelevant info) onlyReduceTypes $+      underModality info $ occurs v+  metaOccurs m = metaOccurs m . unArg++instance Occurs a => Occurs (Dom a) where+  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.++-- | @prune m' vs xs@ attempts to remove all arguments from @vs@ whose+--   free variables are not contained in @xs@.+--   If successful, @m'@ is solved by the new, pruned meta variable and we+--   return @True@ else @False@.+--+--   Issue 1147:+--   If any of the meta args @vs@ is matchable, e.g., is a constructor term,+--   we cannot prune, because the offending variables could be removed by+--   reduction for a suitable instantiation of the meta variable.+prune+  :: (PureTCM m, MonadMetaSolver m)+  => MetaId         -- ^ Meta to prune.+  -> Args           -- ^ Arguments to meta variable.+  -> (Nat -> Bool)  -- ^ Test for allowed variable (de Bruijn index).+  -> m PruneResult+prune m' vs xs = do+  caseEitherM (runExceptT $ mapM ((hasBadRigid xs) . unArg) vs)+    (const $ return PrunedNothing) $ \ kills -> do+    reportSDoc "tc.meta.kill" 10 $ vcat+      [ "attempting kills"+      , nest 2 $ vcat+        [ "m'    =" <+> pretty m'+        -- , "xs    =" <+> prettyList (map (prettyTCM . var) xs)  -- no longer printable+        , "vs    =" <+> prettyList (map prettyTCM vs)+        , "kills =" <+> text (show kills)+        ]+      ]+    killArgs kills m'++-- | @hasBadRigid xs v = Just True@ iff one of the rigid variables in @v@ is not in @xs@.+--   Actually we can only prune if a bad variable is in the head. See issue 458.+--   Or in a non-eliminateable position (see succeed/PruningNonMillerPattern).+--+--   @hasBadRigid xs v = Nothing@ means that+--   we cannot prune at all as one of the meta args is matchable.+--   (See issue 1147.)+hasBadRigid+  :: PureTCM m+  => (Nat -> Bool)      -- ^ Test for allowed variable (de Bruijn index).+  -> Term               -- ^ Argument of meta variable.+  -> ExceptT () m Bool  -- ^ Exception if argument is matchable.+hasBadRigid xs t = do+  -- We fail if we encounter a matchable argument.+  let failure = throwError ()+  tb <- reduceB t+  let t = ignoreBlocking tb+  case t of+    Var x _      -> return $ not $ xs x+    -- Issue 1153: A lambda has to be considered matchable.+    -- Lam _ v    -> hasBadRigid (0 : map (+1) xs) (absBody v)+    Lam _ v      -> failure+    DontCare v   -> hasBadRigid xs v+    -- The following types of arguments cannot be eliminated by a pattern+    -- match: data, record, Pi, levels, sorts+    -- Thus, their offending rigid variables are bad.+    v@(Def f es) -> ifNotM (isNeutral tb f es) failure $ {- else -} do+      lift $ es `rigidVarsNotContainedIn` xs+    -- Andreas, 2012-05-03: There is room for further improvement.+    -- We could also consider a defined f which is not blocked by a meta.+    Pi a b       -> lift $ (a,b) `rigidVarsNotContainedIn` xs+    Level v      -> lift $ v `rigidVarsNotContainedIn` xs+    Sort s       -> lift $ s `rigidVarsNotContainedIn` xs+    -- Since constructors can be eliminated by pattern-matching,+    -- offending variables under a constructor could be removed by+    -- the right instantiation of the meta variable.+    -- Thus, they are not rigid.+    Con c _ es | Just args <- allApplyElims es -> do+      ifM (isEtaCon (conName c))+        -- in case of a record con, we can in principle prune+        -- (but not this argument; the meta could become a projection!)+        (and <$> mapM (hasBadRigid xs . unArg) args)  -- not andM, we need to force the exceptions!+        failure+    Con c _ es | otherwise -> failure+    Lit{}        -> failure -- matchable+    MetaV{}      -> failure -- potentially matchable+    Dummy{}      -> return False++-- | Check whether a term @Def f es@ is finally stuck.+--   Currently, we give only a crude approximation.+isNeutral :: (HasConstInfo m) => Blocked t -> QName -> Elims -> m Bool+isNeutral b f es = do+  let yes = return True+      no  = return False+  def <- getConstInfo f+  if not (null $ defMatchable def) then no else do+  case theDef def of+    AbstractDefn{} -> yes+    Axiom{}    -> yes+    Datatype{} -> yes+    Record{}   -> yes+    Function{} -> case b of+      NotBlocked StuckOn{}   _ -> yes+      NotBlocked AbsurdMatch _ -> yes+      _                        -> no+    GeneralizableVar{} -> __IMPOSSIBLE__+    _          -> no++-- | Check whether any of the variables (given as de Bruijn indices)+--   occurs *definitely* in the term in a rigid position.+--   Reduces the term successively to remove variables in dead subterms.+--   This fixes issue 1386.+rigidVarsNotContainedIn+  :: (PureTCM m, AnyRigid a)+  => a+  -> (Nat -> Bool)   -- ^ Test for allowed variable (de Bruijn index).+  -> m Bool+rigidVarsNotContainedIn v is = do+  n0 <- getContextSize+  let -- allowed variables as de Bruijn levels+      levels = is . (n0-1 -)+      -- test if index is forbidden by converting it to level+      test i = do+        n <- getContextSize+        -- get de Bruijn level for i+        let l = n-1 - i+            -- If l >= n0 then it is a bound variable and can be+            -- ignored.  Otherwise, it has to be in the allowed levels.+            forbidden = l < n0 && not (levels l)+        when forbidden $+          reportSLn "tc.meta.kill" 20 $+            "found forbidden de Bruijn level " ++ show l+        return forbidden+  anyRigid test v++-- | Collect the *definitely* rigid variables in a monoid.+--   We need to successively reduce the expression to do this.++class AnyRigid a where+  anyRigid :: (PureTCM tcm)+           => (Nat -> tcm Bool) -> a -> tcm Bool++instance AnyRigid Term where+  anyRigid f t = do+    b <- reduceB t+    case ignoreBlocking b of+      -- Upon entry, we are in rigid position, thus,+      -- bound variables are rigid ones.+      Var i es   -> f i `or2M` anyRigid f es+      Lam _ t    -> anyRigid f t+      Lit{}      -> return False+      Def _ es   -> case b of+        -- If the definition is blocked by a meta, its arguments+        -- may be in flexible positions.+        Blocked{}                   -> return False+        -- 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+        -- _        -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern+        _        -> anyRigid f es+      Con _ _ ts -> anyRigid f ts+      Pi a b     -> anyRigid f (a,b)+      Sort s     -> anyRigid f s+      Level l    -> anyRigid f l+      MetaV{}    -> return False+      DontCare{} -> return False+      Dummy{}    -> return False++instance AnyRigid Type where+  anyRigid f (El s t) = anyRigid f (s,t)++instance AnyRigid Sort where+  anyRigid f s =+    case s of+      Univ _ l   -> anyRigid f l+      Inf _ _    -> return False+      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+      MetaS{}    -> return False+      DefS{}     -> return False+      DummyS{}   -> return False++instance AnyRigid Level where+  anyRigid f (Max _ ls) = anyRigid f ls++instance AnyRigid PlusLevel where+  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 =+      -- Irrelevant arguments are definitionally equal to+      -- values, so the variables there are not considered+      -- "definitely rigid".+    if isIrrelevant a then return False else+      anyRigid f $ unArg a++instance AnyRigid a => AnyRigid (Dom a) where+  anyRigid f = anyRigid f . unDom++instance AnyRigid a => AnyRigid (Elim' a) where+  anyRigid f (Apply a)      = anyRigid f a+  anyRigid f (IApply x y a) = anyRigid f (x,(y,a))+  anyRigid f Proj{}         = return False++instance AnyRigid a => AnyRigid [a] where+  anyRigid = anyM . anyRigid++instance (AnyRigid a, AnyRigid b) => AnyRigid (a,b) where+  anyRigid f (a,b) = anyRigid f a `or2M` anyRigid f b+++data PruneResult+  = NothingToPrune   -- ^ the kill list is empty or only @False@s+  | PrunedNothing    -- ^ there is no possible kill (because of type dep.)+  | PrunedSomething  -- ^ managed to kill some args in the list+  | PrunedEverything -- ^ all prescribed kills where performed+    deriving (Eq, Show)++-- | @killArgs [k1,...,kn] X@ prunes argument @i@ from metavar @X@ if @ki==True@.+--   Pruning is carried out whenever > 0 arguments can be pruned.+killArgs :: (MonadMetaSolver m) => [Bool] -> MetaId -> m PruneResult+killArgs kills _+  | not (or kills) = return NothingToPrune  -- nothing to kill+killArgs kills m = do+  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+      let a = jMetaType $ mvJudgement mv+      TelV tel b <- telView' <$> instantiateFull a+      let args         = zip (telToList tel) (kills ++ repeat False)+      (kills', a') <- killedType args b+      dbg kills' a a'+      -- If there is any prunable argument, perform the pruning+      if not (any unArg kills') then return PrunedNothing else do+        addContext tel $ performKill kills' m a'+        -- Only successful if all occurrences were killed+        -- Andreas, 2011-05-09 more precisely, check that at least+        -- the in 'kills' prescribed kills were carried out+        return $ if (and $ zipWith implies kills $ map unArg kills')+                   then PrunedEverything+                   else PrunedSomething+  where+    implies :: Bool -> Bool -> Bool+    implies False _ = True+    implies True  x = x+    dbg kills' a a' =+      reportSDoc "tc.meta.kill" 10 $ vcat+        [ "after kill analysis"+        , nest 2 $ vcat+          [ "metavar =" <+> prettyTCM m+          , "kills   =" <+> text (show kills)+          , "kills'  =" <+> prettyList (map prettyTCM kills')+          , "oldType =" <+> prettyTCM a+          , "newType =" <+> prettyTCM a'+          ]+        ]++-- | @killedType [((x1,a1),k1)..((xn,an),kn)] b = ([k'1..k'n],t')@+--   (ignoring @Dom@).  Let @t' = (xs:as) -> b@.+--   Invariant: @k'i == True@ iff @ki == True@ and pruning the @i@th argument from+--   type @b@ is possible without creating unbound variables.+--   @t'@ is type @t@ after pruning all @k'i==True@.+killedType :: (MonadReduce m) => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Type)+killedType args b = do++  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 = 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++  -- Then recurse over the telescope (right-to-left), building up the final type.+  (killed, b) <- go (reverse $ map fst args) tokill b++  -- 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 = VarSet.mapMonotonic pred+    up   = VarSet.mapMonotonic succ++    -- go Δ xs B+    -- Invariants:+    --   - Δ ⊢ B+    --   - Δ is represented as a list in right-to-left order+    --   - xs are deBruijn indices into Δ+    --   - xs ∩ FV(B) = Ø+    -- Result: (ys, Δ' → B')+    --    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)] -> 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)+      | 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 (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 (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+          -- us from killing variables in xs.+          let xs'       = down xs -- Shift to make relative to Δ ⊢ A+              (name, a) = unDom arg+          (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+          -- Shift back up to make it relative to Δ (x : A) again.+          return (up zs, b)++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    = 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 (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 (VarSet.difference xs rigid) a+      let xs = IntMap.keysSet $ IntMap.filter (== NotFree) fvs+      return (xs, a)++-- | Instantiate a meta variable with a new one that only takes+--   the arguments which are not pruneable.+performKill+  :: MonadMetaSolver m+  => [Arg Bool]    -- ^ Arguments to old meta var in left to right order+                   --   with @Bool@ indicating whether they can be pruned.+  -> MetaId        -- ^ The old meta var to receive pruning.+  -> Type          -- ^ The pruned type of the new meta var.+  -> m ()+performKill kills m a = do+  mv <- lookupLocalMeta m+  when (mvFrozen mv == Frozen) __IMPOSSIBLE__+  -- Arity of the old meta.+  let n = size kills+  -- The permutation of the new meta picks the arguments+  -- which are not pruned in left to right order+  -- (de Bruijn level order).+  let perm = Perm n+             [ i | (i, Arg _ False) <- zip [0..] kills ]+      -- The permutation for the old meta might range over a prefix of the arguments+      oldPerm = liftP (max 0 $ n - m) p+        where p = mvPermutation mv+              m = size p+      judg = case mvJudgement mv of+        HasType{ jComparison = cmp } -> HasType __IMPOSSIBLE__ cmp a+        IsSort{}  -> IsSort  __IMPOSSIBLE__ a+  m' <- newMeta Instantiable (mvInfo mv) (mvPriority mv) (composeP perm oldPerm) judg+  -- Andreas, 2010-10-15 eta expand new meta variable if necessary+  etaExpandMetaSafe m'+  let -- Arguments to new meta (de Bruijn indices)+      -- in left to right order.+      vars = [ Arg info (var i)+             | (i, Arg info False) <- zip (downFrom n) kills ]+      u       = MetaV m' $ map Apply vars+      -- Arguments to the old meta (just arg infos and name hints)+      -- in left to right order.+      tel     = map ("v" <$) kills+  dbg m' u+  assignTerm m tel u  -- m tel := u+  where+    dbg m' u = reportSDoc "tc.meta.kill" 10 $ vcat+      [ "actual killing"+      , nest 2 $ vcat+        [ "new meta:" <+> pretty m'+        , "kills   :" <+> prettyList_ (map (text . show . unArg) kills)+        , "inst    :" <+> pretty m <+> ":=" <+> prettyTCM u         ]       ]
+ 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,16 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Monad     ( module Agda.TypeChecking.Monad.Base+    , module Agda.TypeChecking.Monad.Builtin     , module Agda.TypeChecking.Monad.Closure     , module Agda.TypeChecking.Monad.Constraints     , module Agda.TypeChecking.Monad.Context+    , module Agda.TypeChecking.Monad.Debug     , module Agda.TypeChecking.Monad.Env     , module Agda.TypeChecking.Monad.Imports-    , module Agda.TypeChecking.Monad.Local     , 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-    , module Agda.TypeChecking.Monad.Sharing+    , module Agda.TypeChecking.Monad.Pure     , module Agda.TypeChecking.Monad.Signature     , module Agda.TypeChecking.Monad.SizedTypes     , module Agda.TypeChecking.Monad.State@@ -20,17 +24,19 @@     ) where  import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Constraints import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Imports-import Agda.TypeChecking.Monad.Local 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-import Agda.TypeChecking.Monad.Sharing+import Agda.TypeChecking.Monad.Pure import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Monad.SizedTypes import Agda.TypeChecking.Monad.State
src/full/Agda/TypeChecking/Monad/Base.hs view
@@ -1,3102 +1,6694 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE UndecidableInstances       #-}--module Agda.TypeChecking.Monad.Base where--import Prelude hiding (null)--import qualified Control.Concurrent as C-import qualified Control.Exception as E-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer hiding ((<>))-import Control.Monad.Trans.Maybe-import Control.Applicative hiding (empty)--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.Set (Set)-import qualified Data.Set as Set -- hiding (singleton, null, empty)-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Any(..))-import Data.Typeable (Typeable)-import Data.Foldable (Foldable)-import Data.Traversable-import Data.IORef--import qualified System.Console.Haskeline as Haskeline--import Agda.Benchmarking (Benchmark, Phase)--import Agda.Syntax.Concrete (TopLevelModuleName)-import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Concrete.Definitions as D-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract (AllNames)-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern ()-import Agda.Syntax.Internal.Generic (TermLike(..))-import Agda.Syntax.Parser (PM(..), ParseWarning, runPMIO)-import Agda.Syntax.Treeless (Compiled)-import Agda.Syntax.Fixity-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import qualified Agda.Syntax.Info as Info--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Free.Lazy (Free'(freeVars'), bind', bind)---- import {-# SOURCE #-} Agda.Interaction.FindFile-import Agda.Interaction.Options-import Agda.Interaction.Response-  (InteractionOutputCallback, defaultInteractionOutputCallback)-import Agda.Interaction.Highlighting.Precise-  (CompressedFile, HighlightingInfo)--import qualified Agda.Compiler.UHC.Pragmas.Base as CR--import Agda.Utils.Except-  ( Error(strMsg)-  , ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--import Agda.Utils.Benchmark (MonadBench(..))-import Agda.Utils.FileName-import Agda.Utils.HashMap (HashMap)-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Hash-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty hiding ((<>))-import Agda.Utils.Singleton-import Agda.Utils.Functor--#include "undefined.h"-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.-  }--class Monad m => ReadTCState m where-  getTCState :: m TCState--instance Show TCState where-  show _ = "TCSt{}"--data PreScopeState = PreScopeState-  { stPreTokens             :: !CompressedFile -- from lexer-    -- ^ Highlighting info for tokens (but not those tokens for-    -- which highlighting exists in 'stSyntaxInfo').-  , stPreImports            :: !Signature  -- XX populated by scopec hecker-    -- ^ 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!-  , 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-  , stPreHaskellImports     :: !(Set String)-    -- ^ Imports that should be generated by the compiler / MAlonzo-    -- (this includes imports from imported modules).-  , stPreHaskellImportsUHC  :: !(Set String)-    -- ^ Imports that should be generated by the compiler / UHC backend-    -- (this includes imports from imported modules).-  , stPreHaskellCode        :: ![String]-    -- ^ Inline Haskell code that should be inserted by the GHC backend-  , stPreFreshInteractionId :: !InteractionId-  }--type DisambiguatedNames = IntMap A.QName--data PostScopeState = PostScopeState-  { stPostSyntaxInfo          :: !CompressedFile-    -- ^ 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-  , stPostSolvedInteractionPoints :: !InteractionPoints-    -- ^ Interaction points that have been filled by a give or solve action.-  , 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.-  , stPostModuleParameters    :: !ModuleParamDict-    -- ^ TODO: can these be moved into the @TCEnv@?-  , stPostImportsDisplayForms :: !DisplayForms-    -- ^ Display forms we add for imported identifiers-  , stPostCurrentModule       :: !(Maybe ModuleName)-    -- ^ The current module is available after it has been type-    -- checked.-  , stPostInstanceDefs        :: !TempInstanceTable-  , 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-  , stPostFreshCtxId          :: !CtxId-  , stPostFreshProblemId      :: !ProblemId-  , stPostFreshInt            :: !Int-  , stPostFreshNameId         :: !NameId-  }---- | 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)--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.-  , stLoadedFileCache   :: !(Maybe LoadedFileCache)-    -- ^ Cached typechecking state from the last loaded file.-    --   Should be Nothing when checking imports.-  }--data LoadedFileCache = LoadedFileCache-  { lfcCached  :: !CachedTypeCheckLog-  , lfcCurrent :: !CurrentTypeCheckLog-  }---- | 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 !Info.ModuleInfo !ModuleName ![A.TypedBindings]-  | LeaveSection !ModuleName-  | Decl !A.Declaration-    -- ^ Never a Section or ScopeDecl-  | Pragmas !PragmaOptions---- | Empty persistent state.--initPersistentState :: PersistentTCState-initPersistentState = PersistentTCSt-  { stPersistentOptions         = defaultOptions-  , stDecodedModules            = Map.empty-  , stInteractionOutputCallback = defaultInteractionOutputCallback-  , stBenchmark                 = empty-  , stAccumStatistics           = Map.empty-  , stLoadedFileCache           = Nothing-  }---- | 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-  , stPrePragmaOptions        = defaultInteractionOptions-  , stPreImportedBuiltins     = Map.empty-  , stPreImportedDisplayForms = HMap.empty-  , stPreImportedInstanceDefs = Map.empty-  , stPreHaskellImports       = Set.empty-  , stPreHaskellImportsUHC    = Set.empty-  , stPreHaskellCode          = []-  , stPreFreshInteractionId   = 0-  }--initPostScopeState :: PostScopeState-initPostScopeState = PostScopeState-  { stPostSyntaxInfo           = mempty-  , stPostDisambiguatedNames   = IntMap.empty-  , stPostMetaStore            = Map.empty-  , stPostInteractionPoints    = Map.empty-  , stPostSolvedInteractionPoints = Map.empty-  , stPostAwakeConstraints     = []-  , stPostSleepingConstraints  = []-  , stPostDirty                = False-  , stPostOccursCheckDefs      = Set.empty-  , stPostSignature            = emptySignature-  , stPostModuleParameters     = Map.empty-  , stPostImportsDisplayForms  = HMap.empty-  , stPostCurrentModule        = Nothing-  , stPostInstanceDefs         = (Map.empty , Set.empty)-  , stPostStatistics           = Map.empty-  , stPostTCWarnings           = []-  , stPostMutualBlocks         = Map.empty-  , stPostLocalBuiltins        = Map.empty-  , stPostFreshMetaId          = 0-  , stPostFreshMutualId        = 0-  , stPostFreshCtxId           = 0-  , stPostFreshProblemId       = 1-  , stPostFreshInt             = 0-  , stPostFreshNameId           = NameId 0 0-  }--initState :: TCState-initState = TCSt-  { stPreScopeState   = initPreScopeState-  , stPostScopeState  = initPostScopeState-  , stPersistentState = initPersistentState-  }---- * st-prefixed lenses---------------------------------------------------------------------------stTokens :: Lens' CompressedFile 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}}--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}}--stHaskellImports :: Lens' (Set String) TCState-stHaskellImports f s =-  f (stPreHaskellImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreHaskellImports = x}}--stHaskellImportsUHC :: Lens' (Set String) TCState-stHaskellImportsUHC f s =-  f (stPreHaskellImportsUHC (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreHaskellImportsUHC = x}}--stHaskellCode :: Lens' [String] TCState-stHaskellCode f s =-  f (stPreHaskellCode (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreHaskellCode = x}}--stFreshInteractionId :: Lens' InteractionId TCState-stFreshInteractionId f s =-  f (stPreFreshInteractionId (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}--stFreshNameId :: Lens' NameId TCState-stFreshNameId f s =-  f (stPostFreshNameId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}--stSyntaxInfo :: Lens' CompressedFile 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}}--stSolvedInteractionPoints :: Lens' InteractionPoints TCState-stSolvedInteractionPoints f s =-  f (stPostSolvedInteractionPoints (stPostScopeState s)) <&>-  \ x -> s {stPostScopeState = (stPostScopeState s)-             {stPostSolvedInteractionPoints = 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}}--stModuleParameters :: Lens' (ModuleParamDict) TCState-stModuleParameters f s =-  f (stPostModuleParameters (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleParameters = 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 (stPostCurrentModule (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = 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}}--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}}--stFreshCtxId :: Lens' CtxId TCState-stFreshCtxId f s =-  f (stPostFreshCtxId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCtxId = x}}--stFreshProblemId :: Lens' ProblemId TCState-stFreshProblemId f s =-  f (stPostFreshProblemId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}--stFreshInt :: Lens' Int TCState-stFreshInt f s =-  f (stPostFreshInt (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = 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)--fresh :: (HasFresh i, MonadState TCState m) => m i-fresh =-    do  !s <- get-        let (!c , !s') = nextFresh s-        put 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 CtxId where-  freshLens = stFreshCtxId--instance HasFresh Int where-  freshLens = stFreshInt--newtype ProblemId = ProblemId Nat-  deriving (Typeable, Eq, Ord, Enum, Real, Integral, Num)---- TODO: 'Show' should output Haskell-parseable representations.--- The following instance is deprecated, and Pretty[TCM] should be used--- instead. Later, simply derive Show for this type.---- ASR (28 December 2014). This instance is not used anymore (module--- the test suite) when reporting errors. See Issue 1293.--instance Show ProblemId where-  show (ProblemId n) = show n--instance Pretty ProblemId where-  pretty (ProblemId n) = pretty n--instance HasFresh ProblemId where-  freshLens = stFreshProblemId--freshName :: (MonadState TCState m, HasFresh NameId) => Range -> String -> m Name-freshName r s = do-  i <- fresh-  return $ mkName r i s--freshNoName :: (MonadState TCState m, HasFresh NameId) => Range -> m Name-freshNoName r =-    do  i <- fresh-        return $ Name i (C.NoName noRange i) r noFixity'--freshNoName_ :: (MonadState TCState m, HasFresh NameId) => m Name-freshNoName_ = freshNoName noRange---- | Create a fresh name from @a@.-class FreshName a where-  freshName_ :: (MonadState TCState m, HasFresh NameId) => 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.fromList-     .  List.map (\(m, f) -> (f, m))-     .  Map.toList-    <$> use stModuleToSource---- | Lookup an 'AbsolutePath' in 'sourceToModule'.------   O(n).--lookupModuleFromSource :: AbsolutePath -> TCM (Maybe TopLevelModuleName)-lookupModuleFromSource f =-  fmap fst . List.find ((f ==) . snd) . Map.toList <$> use stModuleToSource-------------------------------------------------------------------------------- ** Interface------------------------------------------------------------------------------data ModuleInfo = ModuleInfo-  { miInterface  :: Interface-  , miWarnings   :: Bool-    -- ^ 'True' if warnings were encountered when the module was type-    -- checked.-  }---- 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 Interface--data Interface = Interface-  { iSourceHash      :: Hash-    -- ^ Hash of the source code.-  , iImportedModules :: [(ModuleName, Hash)]-    -- ^ Imported modules and their hashes.-  , iModuleName      :: ModuleName-    -- ^ Module name of this interface.-  , iScope           :: Map ModuleName Scope-    -- ^ Scope defined by this module.-  , iInsideScope     :: ScopeInfo-    -- ^ Scope after we loaded this interface.-    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'-    --   and     'Agda.Interaction.CommandLine.interactionLoop'.-    ---    --   Andreas, AIM XX: For performance reason, this field is-    --   not serialized, so if you deserialize an interface, @iInsideScope@-    --   will be empty.  You need to type-check the file to get @iInsideScope@.-  , iSignature       :: Signature-  , iDisplayForms    :: DisplayForms-    -- ^ Display forms added for imported identifiers.-  , iBuiltin         :: BuiltinThings (String, QName)-  , iHaskellImports  :: Set String-                        -- ^ Haskell imports listed in-                        -- (transitively) imported modules are-                        -- not included here.-  , iHaskellImportsUHC :: Set String-                        -- ^ Haskell imports listed in-                        -- (transitively) imported modules are-                        -- not included here.-  , iHaskellCode     :: [String] -- ^ Inline Haskell code-  , iHighlighting    :: HighlightingInfo-  , iPragmaOptions   :: [OptionsPragma]-                        -- ^ Pragma options set in the file.-  , iPatternSyns     :: A.PatternSynDefns-  }-  deriving (Typeable, Show)--instance Pretty Interface where-  pretty (Interface sourceH importedM moduleN scope insideS signature display builtin-                    haskellI haskellIUHC haskellCode highlighting pragmaO patternS) =-    hang (text "Interface") 2 $ vcat-      [ text "source hash:"         <+> (pretty . show) sourceH-      , text "imported modules:"    <+> (pretty . show) importedM-      , text "module name:"         <+> pretty moduleN-      , text "scope:"               <+> (pretty . show) scope-      , text "inside scope:"        <+> (pretty . show) insideS-      , text "signature:"           <+> (pretty . show) signature-      , text "display:"             <+> (pretty . show) display-      , text "builtin:"             <+> (pretty . show) builtin-      , text "Haskell imports:"     <+> (pretty . show) haskellI-      , text "Haskell imports UHC:" <+> (pretty . show) haskellIUHC-      , text "Haskell code:"        <+> (vcat $ map (vcat . map text . lines) $ reverse haskellCode)-      , text "highlighting:"        <+> (pretty . show) highlighting-      , text "pragma options:"      <+> (pretty . show) pragmaO-      , text "pattern syns:"        <+> (pretty . show) patternS-      ]---- | 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)-------------------------------------------------------------------------------- ** Closure------------------------------------------------------------------------------data Closure a = Closure-  { clSignature        :: Signature-  , clEnv              :: TCEnv-  , clScope            :: ScopeInfo-  , clModuleParameters :: ModuleParamDict-      -- ^ Since module parameters are currently stored in 'TCState'-      --   not in 'TCEnv', we save them here.-      --   The map contains for each 'ModuleName' @M@ with module telescope @Γ_M@-      --   a substitution @Γ ⊢ ρ_M : Γ_M@ from the current context @Γ = envContext (clEnv)@.-  , clValue            :: a-  }-    deriving (Typeable, Functor, Foldable)--instance Show a => Show (Closure a) where-  show cl = "Closure " ++ show (clValue cl)--instance HasRange a => HasRange (Closure a) where-    getRange = getRange . clValue--buildClosure :: a -> TCM (Closure a)-buildClosure x = do-    env   <- ask-    sig   <- use stSignature-    scope <- use stScope-    pars  <- use stModuleParameters-    return $ Closure sig env scope pars x-------------------------------------------------------------------------------- ** Constraints------------------------------------------------------------------------------type Constraints = [ProblemConstraint]--data ProblemConstraint = PConstr-  { constraintProblems :: [ProblemId]-  , theConstraint      :: Closure Constraint-  }-  deriving (Typeable, Show)--instance HasRange ProblemConstraint where-  getRange = getRange . theConstraint--data Constraint-  = ValueCmp Comparison Type Term Term-  | ElimCmp [Polarity] Type Term [Elim] [Elim]-  | TypeCmp Comparison Type Type-  | TelCmp Type Type Comparison Telescope Telescope -- ^ the two types are for the error message only-  | SortCmp Comparison Sort Sort-  | LevelCmp Comparison Level Level---  | ShortCut MetaId Term Type---    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.-  | UnBlock MetaId-  | Guarded Constraint ProblemId-  | 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.-  | FindInScope MetaId (Maybe MetaId) (Maybe [Candidate])-    -- ^ the first argument is the instance argument, the second one is the meta-    --   on which the constraint may be blocked on and the third one is the list-    --   of candidates (or Nothing if we haven’t determined the list of-    --   candidates yet)-  deriving (Typeable, Show)--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 (TypeCmp cmp a b) = getRange (a,b)-  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 (Guarded c pid) = getRange c-  getRange (FindInScope x cands) = getRange x--}--instance Free' Constraint c where-  freeVars' c =-    case c of-      ValueCmp _ t u v      -> freeVars' (t, (u, v))-      ElimCmp _ t u es es'  -> freeVars' ((t, u), (es, es'))-      TypeCmp _ t t'        -> freeVars' (t, t')-      TelCmp _ _ _ tel tel' -> freeVars' (tel, tel')-      SortCmp _ s s'        -> freeVars' (s, s')-      LevelCmp _ l l'       -> freeVars' (l, l')-      UnBlock _             -> mempty-      Guarded c _           -> freeVars' c-      IsEmpty _ t           -> freeVars' t-      CheckSizeLtSat u      -> freeVars' u-      FindInScope _ _ cs    -> freeVars' cs--instance TermLike Constraint where-  foldTerm f = \case-      ValueCmp _ t u v       -> foldTerm f (t, u, v)-      ElimCmp _ t u es es'   -> foldTerm f (t, u, es, es')-      TypeCmp _ t t'         -> foldTerm f (t, t')-      LevelCmp _ l l'        -> foldTerm f (l, l')-      IsEmpty _ t            -> foldTerm f t-      CheckSizeLtSat u       -> foldTerm f u-      TelCmp _ _ _ tel1 tel2 -> __IMPOSSIBLE__  -- foldTerm f (tel1, tel2) -- Not yet implemented-      SortCmp _ s1 s2        -> __IMPOSSIBLE__  -- foldTerm f (s1, s2) -- Not yet implemented-      UnBlock _              -> __IMPOSSIBLE__  -- mempty     -- Not yet implemented-      Guarded c _            -> __IMPOSSIBLE__  -- foldTerm c -- Not yet implemented-      FindInScope _ _ cs     -> __IMPOSSIBLE__  -- Not yet implemented-  traverseTerm f c  = __IMPOSSIBLE__ -- Not yet implemented-  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented---data Comparison = CmpEq | CmpLeq-  deriving (Eq, Typeable)---- TODO: 'Show' should output Haskell-parseable representations.--- The following instance is deprecated, and Pretty[TCM] should be used--- instead. Later, simply derive Show for this type.---- ASR (27 December 2014). This instance is not used anymore (module--- the test suite) when reporting errors. See Issue 1293.-instance Show Comparison where-  show CmpEq  = "="-  show CmpLeq = "=<"--instance Pretty Comparison where-  pretty CmpEq  = text "="-  pretty CmpLeq = text "=<"---- | An extension of 'Comparison' to @>=@.-data CompareDirection = DirEq | DirLeq | DirGeq-  deriving (Eq, Typeable)--instance Show CompareDirection where-  show DirEq  = "="-  show DirLeq = "=<"-  show 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-------------------------------------------------------------------------------- * Open things-------------------------------------------------------------------------------- | A thing tagged with the context it came from.-data Open a = OpenThing { openThingCtxIds :: [CtxId], openThing :: a }-    deriving (Typeable, Show, Functor)--instance Decoration Open where-  traverseF f (OpenThing cxt x) = OpenThing cxt <$> f x--data Local a = Local ModuleName a   -- ^ Local to a given module, the value-                                    -- should have module parameters as free variables.-             | Global a             -- ^ Global value, should be closed.-    deriving (Typeable, Show, Functor, Foldable, Traversable)--isGlobal :: Local a -> Bool-isGlobal Global{} = True-isGlobal Local{}  = False--instance Decoration Local where-  traverseF f (Local m x) = Local m <$> f x-  traverseF f (Global x)  = Global <$> f 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, jMetaType :: Type }-  | IsSort  { jMetaId :: a, jMetaType :: Type } -- Andreas, 2011-04-26: type needed for higher-order sort metas-  deriving (Typeable)--instance Show a => Show (Judgement a) where-    show (HasType a t) = show a ++ " : " ++ show t-    show (IsSort  a t) = show a ++ " :sort " ++ show t-------------------------------------------------------------------------------- ** 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?-                }-    deriving (Typeable)--data Listener = EtaExpand MetaId-              | CheckConstraint Nat ProblemConstraint-  deriving (Typeable)--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)--data MetaInstantiation-        = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)-        | Open               -- ^ unsolved-        | OpenIFS            -- ^ open, to be instantiated as "implicit from scope"-        | BlockedConst Term  -- ^ solution blocked by unsolved constraints-        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem) (TCM Bool)-    deriving (Typeable)--data TypeCheckingProblem-  = CheckExpr A.Expr Type-  | CheckArgs ExpandHidden Range [NamedArg A.Expr] Type Type (Args -> Type -> TCM Term)-  | CheckLambda (Arg ([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'.-  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type-  deriving (Typeable)--instance Show MetaInstantiation where-  show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"-  show Open      = "Open"-  show OpenIFS   = "OpenIFS"-  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)--data RunMetaOccursCheck-  = RunMetaOccursCheck-  | DontRunMetaOccursCheck-  deriving (Eq, Ord, Show)---- | @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.---  , miRelevance       :: Relevance          -- ^ Created in irrelevant position?-  , 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@.-  }---- | 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 s  x) = text $ "_" ++ s ++ prettyShow x--type MetaStore = Map MetaId 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) }--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 = envRelevance . getMetaEnv-------------------------------------------------------------------------------- ** 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.-  , ipClause:: IPClause-      -- ^ The clause of the interaction point (if any).-      --   Used for case splitting.-  }--instance Eq InteractionPoint where (==) = (==) `on` ipMeta---- | Data structure managing the interaction points.-type InteractionPoints = Map InteractionId InteractionPoint---- | 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.-  , ipcClause   :: A.RHS  -- ^ The original AST clause rhs.-  }-  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.--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 (Typeable, Show)--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]--data Section = Section { _secTelescope :: Telescope }-  deriving (Typeable, Show)--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 @var 0@ is interpreted---   as a hole.  Each occurrence of @var 0@ is a new hole (pattern var).---   For each *occurrence* of @var0@ the rhs @dt@ has a free variable.---   These are instantiated when matching a display form against a---   term @q vs@ succeeds.-data DisplayForm = Display-  { dfFreeVars :: Nat-    -- ^ Number @n@ of free variables in 'dfRHS'.-  , dfPats     :: Elims-    -- ^ Left hand side patterns, where @var 0@ stands for a pattern-    --   variable.  There should be @n@ occurrences of @var0@ in-    --   'dfPats'.-    --   The 'ArgInfo' is ignored in these patterns.-  , dfRHS      :: DisplayTerm-    -- ^ Right hand side, with @n@ free variables.-  }-  deriving (Typeable, Show)--type LocalDisplayForm = Local 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 (Typeable, Show)--instance Free' DisplayForm c where-  freeVars' (Display n ps t) = bind (freeVars' ps) `mappend` bind' n (freeVars' t)--instance Free' DisplayTerm c 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---- | By default, we have no display form.-defaultDisplayForm :: QName -> [LocalDisplayForm]-defaultDisplayForm c = []--defRelevance :: Definition -> Relevance-defRelevance = argInfoRelevance . defArgInfo---- | Non-linear (non-constructor) first-order pattern.-data NLPat-  = PVar (Maybe CtxId) !Int [Arg Int]-    -- ^ Matches anything (modulo non-linearity) that only contains bound-    --   variables that occur in the given arguments.-  | PWild-    -- ^ Matches anything (e.g. irrelevant terms).-  | PDef QName PElims-    -- ^ Matches @f es@-  | PLam ArgInfo (Abs NLPat)-    -- ^ Matches @λ x → t@-  | PPi (Dom NLPType) (Abs NLPType)-    -- ^ Matches @(x : A) → B@-  | PBoundVar {-# UNPACK #-} !Int PElims-    -- ^ Matches @x es@ where x is a lambda-bound variable-  | PTerm Term-    -- ^ Matches the term modulo β (ideally βη).-  deriving (Typeable, Show)-type PElims = [Elim' NLPat]--data NLPType = NLPType-  { nlpTypeLevel :: NLPat  -- always PWild or PVar (with all bound variables in scope)-  , nlpTypeUnEl  :: NLPat-  } deriving (Typeable, Show)--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     -- ^ @Γ ⊢ ps  : t@.-  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.-  , rewType    :: Type       -- ^ @Γ ⊢ t@.-  }-    deriving (Typeable, Show)--data Definition = Defn-  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.-  , defName           :: QName-  , 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--  , 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      :: Bool-    -- ^ Is the def matched against in a rewrite rule?-  , theDef            :: Defn-  }-    deriving (Typeable, 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 -> Defn -> Definition-defaultDefn info x t def = Defn-  { defArgInfo        = info-  , defName           = x-  , defType           = t-  , defPolarity       = []-  , defArgOccurrences = []-  , defDisplay        = defaultDisplayForm x-  , defMutual         = 0-  , defCompiledRep    = noCompiledRep-  , defInstance       = Nothing-  , defCopy           = False-  , defMatchable      = False-  , theDef            = def-  }--type HaskellCode = String-type HaskellType = String-type EpicCode    = String-type JSCode      = String--data HaskellRepresentation-      = HsDefn HaskellType HaskellCode-      | HsType HaskellType-  deriving (Typeable, Show)--data HaskellExport = HsExport HaskellType String deriving (Show, Typeable)--data CoreRepresentation-      = CrDefn CR.CoreExpr -- ^ Core code for functions.-      | CrType CR.CoreType -- ^ Core type for agda type.-      | CrConstr CR.CoreConstr  -- ^ Core constructor for agda constructor.-    deriving (Typeable, Show)---- | Polarity for equality and subtype checking.-data Polarity-  = Covariant      -- ^ monotone-  | Contravariant  -- ^ antitone-  | Invariant      -- ^ no information (mixed variance)-  | Nonvariant     -- ^ constant-  deriving (Typeable, Show, Eq)--data CompiledRepresentation = CompiledRep-  { compiledHaskell :: Maybe HaskellRepresentation-  , exportHaskell   :: Maybe HaskellExport-  , compiledEpic    :: Maybe EpicCode-  , compiledJS      :: Maybe JSCode-  , compiledCore    :: Maybe CoreRepresentation-  }-  deriving (Typeable, Show)--noCompiledRep :: CompiledRepresentation-noCompiledRep = CompiledRep Nothing Nothing Nothing Nothing Nothing---- | Additional information for extended lambdas.-data ExtLamInfo = ExtLamInfo-  { extLamNumHidden :: Int  -- Number of hidden args to be dropped when printing.-  , extLamNumNonHid :: Int  -- Number of visible args to be dropped when printing.-  } deriving (Typeable, Eq, Ord, Show)---- | Additional information for projection 'Function's.-data Projection = Projection-  { projProper    :: Bool-    -- ^ @False@ if only projection-like, @True@ if record projection.-  , projOrig      :: QName-    -- ^ The original projection name-    --   (current name could be from module application).-  , projFromType  :: Arg QName-    -- ^ Type projected from. Record type if @projProper = Just{}@. Also-    -- stores @ArgInfo@ of the principal argument.-  , 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 (Typeable, Show)---- | Abstractions to build projection function (dropping parameters).-newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }-  deriving (Typeable, Show, Null)---- | Building the projection function (which drops the parameters).-projDropPars :: Projection -> ProjOrigin -> Term--- Proper projections:-projDropPars (Projection True 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 False _ _ _ lams) o | null lams = __IMPOSSIBLE__-projDropPars (Projection False d _ _ lams) o =-  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $ init $ 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 !Bool  -- ^ User specifed 'eta-equality' or 'no-eta-equality'-  | Inferred !Bool   -- ^ Positivity checker inferred whether eta is safe/-  deriving (Typeable, Show, Eq)--etaEqualityToBool :: EtaEquality -> Bool-etaEqualityToBool (Specified b) = b-etaEqualityToBool (Inferred b) = b---- | Make sure we do not overwrite a user specification.-setEtaEquality :: EtaEquality -> Bool -> 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 (Typeable, Eq, Ord, Enum, Show)--data Defn = Axiom-            -- ^ Postulate.-          | AbstractDefn-            -- ^ 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.-            , funTreeless       :: Maybe Compiled-              -- ^ Intermediate representation for compiler backends.-            , funInv            :: FunctionInverse-            , funMutual         :: [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does not include this function.-            , 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.-            , funCopatternLHS   :: Bool-              -- ^ Is this a function defined by copatterns?-            }-          | Datatype-            { dataPars           :: Nat            -- ^ Number of parameters.-            , dataSmallPars      :: Permutation    -- ^ Parameters that are maybe small.-            , dataNonLinPars     :: Drop Permutation  -- ^ Parameters that appear in indices.-            , dataIxs            :: Nat            -- ^ Number of indices.-            , dataInduction      :: Induction      -- ^ @data@ or @codata@ (legacy).-            , dataClause         :: (Maybe Clause) -- ^ This might be in an instantiated module.-            , dataCons           :: [QName]        -- ^ Constructor names.-            , dataSort           :: Sort-            , dataMutual         :: [QName]        -- ^ Mutually recursive functions, @data@s and @record@s.  Does not include this data type.-            , dataAbstr          :: IsAbstract-            }-          | Record-            { recPars           :: Nat                  -- ^ Number of parameters.-            , recClause         :: Maybe Clause-            , recConHead        :: ConHead              -- ^ Constructor name and fields.-            , recNamedCon       :: Bool-            , recFields         :: [Arg QName]-            , recTel            :: Telescope            -- ^ The record field telescope. (Includes record parameters.)-                                                        --   Note: @TelV recTel _ == telView' recConType@.-                                                        --   Thus, @recTel@ is redundant.-            , recMutual         :: [QName]              -- ^ Mutually recursive functions, @data@s and @record@s.  Does not include this record.-            , recEtaEquality'    :: EtaEquality          -- ^ Eta-expand at this record type.  @False@ for unguarded recursive records and coinductive records unless the user specifies otherwise.-            , 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.-            , recRecursive      :: Bool                 -- ^ Recursive record.  Infers @recEtaEquality = False@.  Projections are not size-preserving.-            , recAbstr          :: IsAbstract-            }-          | Constructor-            { conPars   :: Nat         -- ^ Number of 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?-            , conErased :: [Bool]      -- ^ Which arguments are erased at runtime (computed during compilation to treeless)-            }-          | Primitive-            { primAbstr :: IsAbstract-            , primName  :: String-            , primClauses :: [Clause]-              -- ^ 'null' for primitive functions, @not null@ for builtin functions.-            , primCompiled :: Maybe CompiledClauses-              -- ^ 'Nothing' for primitive functions,-              --   @'Just' something@ for builtin functions.-            }-            -- ^ Primitive or builtin functions.-    deriving (Typeable, Show)--recEtaEquality :: Defn -> Bool-recEtaEquality = etaEqualityToBool . recEtaEquality'---- | A template for creating 'Function' definitions, with sensible defaults.-emptyFunction :: Defn-emptyFunction = Function-  { funClauses     = []-  , funCompiled    = Nothing-  , funTreeless    = Nothing-  , funInv         = NotInjective-  , funMutual      = []-  , funAbstr       = ConcreteDef-  , funDelayed     = NotDelayed-  , funProjection  = Nothing-  , funFlags       = Set.empty-  , funTerminates  = Nothing-  , funExtLam      = Nothing-  , funWith        = Nothing-  , funCopatternLHS = False-  }--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 <&> const 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--newtype Fields = Fields [(C.Name, Type)]-  deriving (Typeable, 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 (Typeable, Eq, Show)--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 (Typeable, Functor)---- | 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 = case fmap ignoreSharing <$> b of-  NotBlocked _ (Arg _ (MetaV x _)) -> MaybeRed (Reduced $ Blocked x ()) v-  _                                -> MaybeRed (Reduced $ () <$ b)      v-  where-    v = 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       -- ^ Functions which are not projections may be reduced.-  | LevelReductions          -- ^ Reduce @'Level'@ terms.-  | NonTerminatingReductions -- ^ Functions that have not passed termination checking.-  deriving (Show, Eq, Ord, Enum, Bounded)--type AllowedReductions = [AllowedReduction]---- | Not quite all reductions (skip non-terminating reductions)-allReductions :: AllowedReductions-allReductions = [minBound..pred maxBound]--data PrimFun = PrimFun-        { primFunName           :: QName-        , primFunArity          :: Arity-        , primFunImplementation :: [Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)-        }-    deriving (Typeable)--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--defJSDef :: Definition -> Maybe JSCode-defJSDef = compiledJS . defCompiledRep--defEpicDef :: Definition -> Maybe EpicCode-defEpicDef = compiledEpic . defCompiledRep--defCoreDef :: Definition -> Maybe CoreRepresentation-defCoreDef = compiledCore . defCompiledRep---- | 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--defAbstract :: Definition -> IsAbstract-defAbstract d = case theDef d of-    Axiom{}                   -> ConcreteDef-    AbstractDefn{}            -> AbstractDef-    Function{funAbstr = a}    -> a-    Datatype{dataAbstr = a}   -> a-    Record{recAbstr = a}      -> a-    Constructor{conAbstr = a} -> a-    Primitive{primAbstr = a}  -> a-------------------------------------------------------------------------------- ** Injectivity------------------------------------------------------------------------------type FunctionInverse = FunctionInverse' Clause--data FunctionInverse' c-  = NotInjective-  | Inverse (Map TermHead c)-  deriving (Typeable, Show, Functor)--data TermHead = SortHead-              | PiHead-              | ConsHead QName-  deriving (Typeable, Eq, Ord, Show)-------------------------------------------------------------------------------- ** Mutual blocks------------------------------------------------------------------------------newtype MutualId = MutId Int32-  deriving (Typeable, Eq, Ord, Show, Num, Enum)-------------------------------------------------------------------------------- ** Statistics------------------------------------------------------------------------------type Statistics = Map String Integer-------------------------------------------------------------------------------- ** Trace------------------------------------------------------------------------------data Call = CheckClause Type A.SpineClause-          | CheckPattern A.Pattern Telescope Type-          | CheckLetBinding A.LetBinding-          | InferExpr A.Expr-          | CheckExprCall A.Expr Type-          | CheckDotPattern A.Expr Term-          | CheckPatternShadowing A.SpineClause-          | CheckProjection Range QName Type-          | IsTypeCall A.Expr Sort-          | IsType_ A.Expr-          | InferVar Name-          | InferDef QName-          | CheckArguments Range [NamedArg A.Expr] Type Type-          | CheckDataDef Range Name [A.LamBinding] [A.Constructor]-          | CheckRecDef Range Name [A.LamBinding] [A.Constructor]-          | CheckConstructor QName Telescope Sort A.Constructor-          | CheckFunDef Range Name [A.Clause]-          | CheckPragma Range A.Pragma-          | CheckPrimitive Range Name A.Expr-          | CheckIsEmpty Range Type-          | CheckWithFunctionType A.Expr-          | CheckSectionApplication Range ModuleName A.ModuleApplication-          | ScopeCheckExpr C.Expr-          | ScopeCheckDeclaration D.NiceDeclaration-          | ScopeCheckLHS C.QName C.Pattern-          | NoHighlighting-          | ModuleContents  -- ^ Interaction command: show module contents.-          | SetRange Range  -- ^ used by 'setCurrentRange'-    deriving (Typeable)--instance Pretty Call where-    pretty CheckClause{}             = text "CheckClause"-    pretty CheckPattern{}            = text "CheckPattern"-    pretty InferExpr{}               = text "InferExpr"-    pretty CheckExprCall{}           = text "CheckExprCall"-    pretty CheckLetBinding{}         = text "CheckLetBinding"-    pretty CheckProjection{}         = text "CheckProjection"-    pretty IsTypeCall{}              = text "IsTypeCall"-    pretty IsType_{}                 = text "IsType_"-    pretty InferVar{}                = text "InferVar"-    pretty InferDef{}                = text "InferDef"-    pretty CheckArguments{}          = text "CheckArguments"-    pretty CheckDataDef{}            = text "CheckDataDef"-    pretty CheckRecDef{}             = text "CheckRecDef"-    pretty CheckConstructor{}        = text "CheckConstructor"-    pretty CheckFunDef{}             = text "CheckFunDef"-    pretty CheckPragma{}             = text "CheckPragma"-    pretty CheckPrimitive{}          = text "CheckPrimitive"-    pretty CheckWithFunctionType{}   = text "CheckWithFunctionType"-    pretty ScopeCheckExpr{}          = text "ScopeCheckExpr"-    pretty ScopeCheckDeclaration{}   = text "ScopeCheckDeclaration"-    pretty ScopeCheckLHS{}           = text "ScopeCheckLHS"-    pretty CheckDotPattern{}         = text "CheckDotPattern"-    pretty CheckPatternShadowing{}   = text "CheckPatternShadowing"-    pretty SetRange{}                = text "SetRange"-    pretty CheckSectionApplication{} = text "CheckSectionApplication"-    pretty CheckIsEmpty{}            = text "CheckIsEmpty"-    pretty NoHighlighting{}          = text "NoHighlighting"-    pretty ModuleContents{}          = text "ModuleContents"--instance HasRange Call where-    getRange (CheckClause _ c)               = getRange c-    getRange (CheckPattern p _ _)            = getRange p-    getRange (InferExpr e)                   = getRange e-    getRange (CheckExprCall e _)             = getRange e-    getRange (CheckLetBinding b)             = getRange b-    getRange (CheckProjection r _ _)         = r-    getRange (IsTypeCall e s)                = getRange e-    getRange (IsType_ e)                     = getRange e-    getRange (InferVar x)                    = getRange x-    getRange (InferDef f)                    = getRange f-    getRange (CheckArguments r _ _ _)        = r-    getRange (CheckDataDef i _ _ _)          = getRange i-    getRange (CheckRecDef i _ _ _)           = getRange i-    getRange (CheckConstructor _ _ _ c)      = getRange c-    getRange (CheckFunDef i _ _)             = getRange i-    getRange (CheckPragma r _)               = r-    getRange (CheckPrimitive i _ _)          = getRange i-    getRange CheckWithFunctionType{}         = noRange-    getRange (ScopeCheckExpr e)              = getRange e-    getRange (ScopeCheckDeclaration d)       = getRange d-    getRange (ScopeCheckLHS _ p)             = getRange p-    getRange (CheckDotPattern e _)           = getRange e-    getRange (CheckPatternShadowing c)       = getRange c-    getRange (SetRange r)                    = r-    getRange (CheckSectionApplication r _ _) = r-    getRange (CheckIsEmpty r _)              = r-    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 ())-  | 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 (Typeable, Show, Functor, Foldable, Traversable)-------------------------------------------------------------------------------- * 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)---- | 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)---- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're--- type-checking the top-level module and the highlighting level is--- /at least/ @l@.--ifTopLevelAndHighlightingLevelIs ::-  MonadTCM tcm => HighlightingLevel -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIs l m = do-  e <- ask-  when (envModuleNestingLevel e == 0 &&-        envHighlightingLevel e >= l)-       m-------------------------------------------------------------------------------- * Type checking environment------------------------------------------------------------------------------data ModuleParameters = ModuleParams-  { mpSubstitution :: Substitution-      -- ^ @Δ ⊢ σ : Γ@ for a @module M Γ@ where @Δ@ is the current context @envContext@.-  } deriving (Typeable, Show)--defaultModuleParameters :: ModuleParameters-defaultModuleParameters = ModuleParams IdS--type ModuleParamDict = Map ModuleName ModuleParameters-  -- ^ The map contains for each 'ModuleName' @M@ with module telescope @Γ_M@-  --   a substitution @Γ ⊢ ρ_M : Γ_M@ from the current context @Γ = envContext (clEnv)@.--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] -- ^ to detect import cycles-          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block-          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma-          , 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.-          , envAssignMetas         :: Bool-            -- ^ Are we allowed to assign metas?-          , envActiveProblems      :: [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.-          , envRelevance           :: Relevance-                -- ^ Are we checking an irrelevant argument? (=@Irrelevant@)-                -- Then top-level irrelevant declarations are enabled.-                -- Other value: @Relevant@, then only relevant decls. are avail.-          , 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-          , envModuleNestingLevel :: !Int-                -- ^ This number indicates how far away from the-                --   top-level module Agda has come when chasing-                --   modules. 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.-          , envAllowDestructiveUpdate :: Bool-                -- ^ When True, allows destructively shared updating terms-                --   during evaluation or unification. This is disabled when-                --   doing speculative checking, like solve instance metas, or-                --   when updating might break abstraction, as is the case when-                --   checking abstract definitions.-          , 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-          , envCompareBlocked :: Bool-                -- ^ Can we compare blocked things during conversion?-                --   No by default.-                --   Yes for rewriting feature.-          , 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.-          }-    deriving (Typeable)--initEnv :: TCEnv-initEnv = TCEnv { envContext             = []-                , envLetBindings         = Map.empty-                , envCurrentModule       = noModuleName-                , envCurrentPath         = Nothing-                , envAnonymousModules    = []-                , envImportPath          = []-                , envMutualBlock         = Nothing-                , envTerminationCheck    = TerminationCheck-                , envSolvingConstraints  = False-                , envCheckingWhere       = False-                , envActiveProblems      = [0]-                , 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           = Relevant-                , envDisplayFormsEnabled = True-                , envRange                  = noRange-                , envHighlightingRange      = noRange-                , envClause                 = IPNoClause-                , envCall                   = Nothing-                , envHighlightingLevel      = None-                , envHighlightingMethod     = Indirect-                , envModuleNestingLevel     = -1-                , envAllowDestructiveUpdate = True-                , envExpandLast             = ExpandLast-                , envAppDef                 = Nothing-                , envSimplification         = NoSimplification-                , envAllowedReductions      = allReductions-                , envCompareBlocked         = False-                , envPrintDomainFreePi      = False-                , envPrintMetasBare         = False-                , envInsideDotPattern       = False-                , envUnquoteFlags           = defaultUnquoteFlags-                , envInstanceDepth          = 0-                }--disableDestructiveUpdate :: TCM a -> TCM a-disableDestructiveUpdate = local $ \e -> e { envAllowDestructiveUpdate = False }--data UnquoteFlags = UnquoteFlags-  { _unquoteNormalise :: Bool }-  deriving (Typeable)--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 }--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 }--eAssignMetas :: Lens' Bool TCEnv-eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }--eActiveProblems :: Lens' [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 }--eRelevance :: Lens' Relevance TCEnv-eRelevance f e = f (envRelevance e) <&> \ x -> e { envRelevance = 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 }--eModuleNestingLevel :: Lens' Int TCEnv-eModuleNestingLevel f e = f (envModuleNestingLevel e) <&> \ x -> e { envModuleNestingLevel = x }--eAllowDestructiveUpdate :: Lens' Bool TCEnv-eAllowDestructiveUpdate f e = f (envAllowDestructiveUpdate e) <&> \ x -> e { envAllowDestructiveUpdate = 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 }--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 }--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 }-------------------------------------------------------------------------------- ** Context-------------------------------------------------------------------------------- | The @Context@ is a stack of 'ContextEntry's.-type Context      = [ContextEntry]-data ContextEntry = Ctx { ctxId    :: CtxId-                        , ctxEntry :: Dom (Name, Type)-                        }-  deriving (Typeable)--newtype CtxId     = CtxId Nat-  deriving (Typeable, Eq, Ord, Show, Enum, Real, Integral, Num)-------------------------------------------------------------------------------- ** 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 (Typeable, Show, Eq)--aDefToMode :: IsAbstract -> AbstractMode-aDefToMode AbstractDef = AbstractMode-aDefToMode ConcreteDef = ConcreteMode--aModeToDef :: AbstractMode -> IsAbstract-aModeToDef AbstractMode = AbstractDef-aModeToDef ConcreteMode = ConcreteDef-aModeToDef _ = __IMPOSSIBLE__-------------------------------------------------------------------------------- ** 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.-  deriving (Eq)--data ExplicitToInstance-  = ExplicitToInstance    -- ^ Explicit arguments are considered as instance arguments-  | ExplicitStayExplicit-    deriving (Eq, Show)---- | 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 { candidateTerm :: Term-                            , candidateType :: Type-                            , candidateEti  :: ExplicitToInstance-                            , candidateOverlappable :: Bool-                            }-  deriving (Show)--instance Free' Candidate c where-  freeVars' (Candidate t u _ _) = freeVars' (t, u)-------------------------------------------------------------------------------- * 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.---- We keep the state for termination issues, positivity issues and--- unsolved constraints from when we encountered the warning so that--- we can print it later-data Warning =-    TerminationIssue         [TerminationError]-  | NotStrictlyPositive      QName 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'-  | OldBuiltin               String String-    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new-  | EmptyRewritePragma-    -- ^ If the user wrote just @{-# REWRITE #-}@.-  | ParseWarning             ParseWarning-  deriving Show--data TCWarning-  = TCWarning-    { tcWarningState   :: TCState-        -- ^ The state in which the warning was raised.-    , tcWarningClosure :: Closure Warning-        -- ^ The warning and the environment in which it was raised.-    }-  deriving Show--tcWarning :: TCWarning -> Warning-tcWarning = clValue . tcWarningClosure-------------------------------------------------------------------------------- * 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 Typeable---- no Eq, Ord instances: too expensive! (see issues 851, 852)---- | We only 'show' the name of the callee.-instance Show   CallInfo where show   = show . callInfoTarget-instance Pretty CallInfo where pretty = text . show-instance AllNames CallInfo where allNames = singleton . callInfoTarget---- UNUSED, but keep!--- -- | Call pathes are sequences of 'CallInfo's starting from a 'callSource'.--- data CallPath = CallPath---   { callSource :: QName---     -- ^ The originator of the first call.---   , callInfos :: [CallInfo]---     -- ^ The calls, in order from source to final target.---   }---   deriving (Show)---- -- | 'CallPath'es can be connected, but there is no empty callpath.--- --   Thus, they form a semigroup, but we choose to abuse 'Monoid'.--- instance Monoid CallPath where---   mempty = __IMPOSSIBLE__---   mappend (CallPath src cs) (CallPath _ cs') = CallPath src $ cs ++ cs'---- | 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 (Typeable, Show)---- | Error when splitting a pattern variable into possible constructor patterns.-data SplitError-  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.-  | IrrelevantDatatype  (Closure Type)  -- ^ Data type, but in irrelevant position.-  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.-  -- UNUSED, but keep!-  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor-  | CantSplit-    { cantSplitConName  :: QName        -- ^ Constructor.-    , cantSplitTel      :: Telescope    -- ^ Context for indices.-    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).-    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).-    }-  | GenericSplitError String-  deriving (Show)--instance Error SplitError where-  strMsg = GenericSplitError--data UnquoteError-  = BadVisibility String (Arg I.Term)-  | ConInsteadOfDef QName String String-  | DefInsteadOfCon QName String String-  | NonCanonical String I.Term-  | BlockedOnMeta TCState MetaId-  | UnquotePanic String-  deriving (Show)--instance Error UnquoteError where-  strMsg msg = UnquotePanic msg--data TypeError-        = InternalError String-        | NotImplemented String-        | NotSupported String-        | CompilationError String-        | TerminationCheckFailed [TerminationError]-        | 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-        | IndicesNotConstructorApplications [Arg Term] -- ^ Indices.-        | IndexVariablesNotDistinct [Nat] [Arg Term] -- ^ Variables, indices.-        | IndicesFreeInParameters [Nat] [Arg Term] [Arg Term]-          -- ^ Indices (variables), index expressions (with-          -- constructors applied to reconstructed parameters),-          -- parameters.-        | CantResolveOverloadedConstructorsTargetingSameDatatype QName [QName]-          -- ^ Datatype, constructors.-        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type-        | DifferentArities-            -- ^ Varying number of arguments for a function.-        | 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)-            -- ^ A function is applied to a hidden named argument it does not have.-        | WrongIrrelevanceInLambda Type-            -- ^ Expected a relevant function and found an irrelevant lambda.-        | WrongInstanceDeclaration-            -- ^ A term is declared as an instance but it’s not allowed-        | 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.-        | NotInductive Term-          -- ^ The term does not correspond to an inductive data type.-        | UninstantiatedDotPattern A.Expr-        | IlltypedPattern A.Pattern Type-        | IllformedProjectionPattern A.Pattern-        | CannotEliminateWithPattern (NamedArg A.Pattern) Type-        | TooManyArgumentsInLHS 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.-        | ShouldBeRecordType Type-        | ShouldBeRecordPattern DeBruijnPattern-        | NotAProjectionPattern (NamedArg A.Pattern)-        | NotAProperTerm-        | SetOmegaNotValidType-        | 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 A.Pattern (Dom Type)-        | DefinitionIsIrrelevant QName-        | VariableIsIrrelevant Name---        | UnequalLevel Comparison Term Term  -- UNUSED-        | UnequalTerms Comparison Term Term Type-        | UnequalTypes Comparison Type Type---      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED-        | UnequalRelevance Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalHiding Term Term-            -- ^ The two function types have different hiding.-        | UnequalSorts Sort Sort-        | UnequalBecauseOfUniverseConflict Comparison Term Term-        | HeterogeneousEquality Term Type Term Type-            -- ^ We ended up with an equality constraint where the terms-            --   have different types.  This is not supported.-        | NotLeqSort Sort Sort-        | MetaCannotDependOn MetaId [Nat] Nat-            -- ^ The arguments are the meta variable, the parameters it can-            --   depend on and the paratemeter that it wants to depend on.-        | MetaOccursInItself MetaId-        | GenericError String-        | GenericDocError Doc-        | BuiltinMustBeConstructor String A.Expr-        | NoSuchBuiltinName String-        | DuplicateBuiltinBinding String Term Term-        | NoBindingForBuiltin String-        | NoSuchPrimitiveFunction String-        | ShadowedModule C.Name [A.ModuleName]-        | BuiltinInParameterisedModule String-        | IllegalLetInTelescope C.TypedBinding-        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]-        | AbsurdPatternRequiresNoRHS [NamedArg A.Pattern]-        | TooFewFields QName [C.Name]-        | TooManyFields QName [C.Name]-        | DuplicateFields [C.Name]-        | DuplicateConstructors [C.Name]-        | WithOnFreeVariable A.Expr Term-        | UnexpectedWithPatterns [A.Pattern]-        | WithClausePatternMismatch A.Pattern Pattern-        | FieldOutsideRecord-        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]-    -- Coverage errors-    -- TODO: Remove some of the constructors in this section, now that-    -- the SplitError constructor has been added?-        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off-        | CoverageFailure QName [[NamedArg DeBruijnPattern]]-        | UnreachableClauses QName [[NamedArg DeBruijnPattern]]-        | CoverageCantSplitOn QName Telescope Args Args-        | CoverageCantSplitIrrelevantType Type-        | CoverageCantSplitType Type-        | CoverageNoExactSplit QName Clause-        | WithoutKError Type Term Term-        | UnifyConflict ConHead ConHead-        | UnifyCycle Int Term-        | UnifyIndicesNotVars Type Term Term Args-        | UnificationRecursiveEq Type Int Term-        | UnificationStuck Telescope [Term] [Term]-        | SplitError SplitError-    -- Positivity errors-        | TooManyPolarities QName Integer-    -- 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-        | NotInScope [C.QName]-        | NoSuchModule C.QName-        | AmbiguousName C.QName [A.QName]-        | AmbiguousModule C.QName [A.ModuleName]-        | UninstantiatedModule C.QName-        | ClashingDefinition C.QName A.QName-        | ClashingModule A.ModuleName A.ModuleName-        | ClashingImport C.Name A.QName-        | ClashingModuleImport C.Name A.ModuleName-        | PatternShadowsConstructor A.Name A.QName-        | ModuleDoesntExport C.QName [C.ImportedName]-        | DuplicateImports C.QName [C.ImportedName]-        | InvalidPattern C.Pattern-        | RepeatedVariablesInPattern [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 D.NiceDeclaration-        | NotValidBeforeField D.NiceDeclaration-        | NothingAppliedToHiddenArg C.Expr-        | NothingAppliedToInstanceArg C.Expr-    -- Pattern synonym errors-        | BadArgumentsToPatternSynonym A.QName-        | TooFewArgumentsToPatternSynonym A.QName-        | UnusedVariableInPatternSynonym-    -- Operator errors-        | NoParseForApplication [C.Expr]-        | AmbiguousParseForApplication [C.Expr] [C.Expr]-        | NoParseForLHS LHSOrPatSyn C.Pattern-        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]-        | OperatorInformation [NotationSection] TypeError-        | OperatorChangeMessage TypeError-{- UNUSED-        | NoParseForPatternSynonym C.Pattern-        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]--}-    -- Usage errors-    -- Implicit From Scope errors-        | IFSNoCandidateInScope Type-    -- Reflection errors-        | UnquoteFailed UnquoteError-        | DeBruijnIndexOutOfScope Nat Telescope [Name]-    -- Safe flag errors-        | SafeFlagPostulate C.Name-        | SafeFlagPragma [String]-        | SafeFlagNonTerminating-        | SafeFlagTerminating-        | SafeFlagPrimTrustMe-        | SafeFlagNoPositivityCheck-        | SafeFlagPolarity-    -- Language option errors-        | NeedOptionCopatterns-        | NeedOptionRewriting-    -- Failure associated to warnings-        | NonFatalErrors [TCWarning]-    -- Instance search errors-        | InstanceSearchDepthExhausted Term Type Int-          deriving (Typeable, Show)---- | Distinguish error message when parsing lhs or pattern synonym, resp.-data LHSOrPatSyn = IsLHS | IsPatSyn deriving (Eq, Show)---- instance Show TypeError where---   show _ = "<TypeError>" -- TODO: more info?--#if !MIN_VERSION_transformers(0,4,1)-instance Error TypeError where-  strMsg = GenericError-#endif---- | Type-checking errors.--data TCErr-  = TypeError-    { 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 Range E.IOException-  | PatternErr-      -- ^ The exception which is usually caught.-      --   Raised for pattern violations during unification ('assignV')-      --   but also in other situations where we want to backtrack.-  deriving (Typeable)--instance Error TCErr where-  strMsg = Exception noRange . text . strMsg--instance Show TCErr where-    show (TypeError _ e) = show (envRange $ clEnv e) ++ ": " ++ show (clValue e)-    show (Exception r d) = show r ++ ": " ++ render d-    show (IOException r e) = show 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 r _) = r-    getRange PatternErr{}      = noRange--instance E.Exception TCErr---------------------------------------------------------------------------------- * 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)--newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }---  deriving (Functor, Applicative, Monad)--fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b-fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e-{-# INLINE fmapReduce #-}--apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b-apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e -> f e $! x e-{-# INLINE apReduce #-}--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--instance Monad ReduceM where-  return = pure-  (>>=) = bindReduce-  (>>) = (*>)--instance ReadTCState ReduceM where-  getTCState = ReduceM redSt--runReduceM :: ReduceM a -> TCM a-runReduceM m = do-  e <- ask-  s <- get-  return $! unReduceM m (ReduceEnv e s)--runReduceF :: (a -> ReduceM b) -> TCM (a -> b)-runReduceF f = do-  e <- ask-  s <- get-  return $ \x -> unReduceM (f x) (ReduceEnv e s)--instance MonadReader TCEnv ReduceM where-  ask = ReduceM redEnv-  local f (ReduceM m) = ReduceM (m . mapRedEnv f)-------------------------------------------------------------------------------- * Type checking monad transformer------------------------------------------------------------------------------newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }---- TODO: make dedicated MonadTCEnv and MonadTCState service classes--instance MonadIO m => MonadReader TCEnv (TCMT m) where-  ask = TCM $ \s e -> return e-  local f (TCM m) = TCM $ \s e -> m s (f e)--instance MonadIO m => MonadState TCState (TCMT m) where-  get   = TCM $ \s _ -> liftIO (readIORef s)-  put s = TCM $ \r _ -> liftIO (writeIORef r s)--type TCM = TCMT IO--class ( Applicative tcm, MonadIO tcm-      , MonadReader TCEnv tcm-      , MonadState TCState tcm-      ) => MonadTCM tcm where-    liftTCM :: TCM a -> tcm a--instance MonadIO m => ReadTCState (TCMT m) where-  getTCState = get--instance MonadError TCErr (TCMT IO) where-  throwError = liftIO . E.throwIO-  catchError m h = TCM $ \r e -> do-    oldState <- liftIO (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---- | Parse monad--runPM :: PM a -> TCM a-runPM m = do-  (res, ws) <- runPMIO m-  mapM_ (warning . ParseWarning) ws-  case res of-    Left  e -> throwError (Exception (getRange e) (pretty e))-    Right a -> return a---- | Interaction monad.--type IM = TCMT (Haskeline.InputT IO)--runIM :: IM a -> TCM a-runIM = mapTCMT (Haskeline.runInputT Haskeline.defaultSettings)--instance MonadError TCErr IM where-  throwError = liftIO . E.throwIO-  catchError m h = mapTCMT liftIO $ runIM m `catchError` (runIM . h)---- | 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--{-# 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)--{-# RULES "liftTCM/id" liftTCM = id #-}-instance MonadIO m => MonadTCM (TCMT m) where-    liftTCM = mapTCMT liftIO--instance MonadTCM tcm => MonadTCM (MaybeT tcm) where-  liftTCM = lift . liftTCM--instance MonadTCM tcm => MonadTCM (ListT tcm) where-  liftTCM = lift . liftTCM--instance-#if !MIN_VERSION_transformers(0,4,1)-  (Error err, MonadTCM tcm)-#else-  MonadTCM tcm-#endif-  => MonadTCM (ExceptT err tcm) where-  liftTCM = lift . liftTCM--instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm) where-  liftTCM = lift . liftTCM--{- The following is not possible since MonadTCM needs to be a--- MonadState TCState and a MonadReader TCEnv--instance (MonadTCM tcm) => MonadTCM (StateT s tcm) where-  liftTCM = lift . liftTCM--instance (MonadTCM tcm) => MonadTCM (ReaderT r tcm) where-  liftTCM = lift . liftTCM--}--instance MonadTrans TCMT where-    lift m = TCM $ \_ _ -> m---- We want a special monad implementation of fail.-instance MonadIO m => Monad (TCMT m) where-    return = pure-    (>>=)  = bindTCMT-    (>>)   = (*>)-    fail   = internalError---- 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 :: MonadIO m => a -> TCMT m a-returnTCMT = \x -> TCM $ \_ _ -> return x-{-# INLINE returnTCMT #-}--bindTCMT :: MonadIO 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 :: MonadIO 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 MonadIO m => Functor (TCMT m) where-  fmap = fmapTCMT--fmapTCMT :: MonadIO m => (a -> b) -> TCMT m a -> TCMT m b-fmapTCMT = \f (TCM m) -> TCM $ \r e -> liftM f (m r e)-{-# INLINE fmapTCMT #-}--instance MonadIO m => Applicative (TCMT m) where-  pure  = returnTCMT-  (<*>) = apTCMT--apTCMT :: MonadIO m => TCMT m (a -> b) -> TCMT m a -> TCMT m b-apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> ap (mf r e) (m r e)-{-# INLINE apTCMT #-}--instance MonadIO m => MonadIO (TCMT m) where-  liftIO m = TCM $ \s e -> do-               let r = envRange e-               liftIO $ wrap r $ do-                 x <- m-                 x `seq` return x-    where-      wrap r m = E.catch m (handleIOException r)--      handleIOException r e = E.throwIO $ IOException r e---- | We store benchmark statistics in an IORef.---   This enables benchmarking pure computation, see---   "Agda.Benchmarking".-instance MonadBench Phase TCM where-  getBenchmark = liftIO $ getBenchmark-  putBenchmark = liftIO . putBenchmark-  finally = finally_--instance Null (TCM Doc) where-  empty = return empty-  null = __IMPOSSIBLE__---- | Short-cutting disjunction forms a monoid.-instance Semigroup (TCM Any) where-  ma <> mb = Any <$> do (getAny <$> ma) `or2M` (getAny <$> mb)--instance Monoid (TCM Any) where-  mempty = return mempty-  mappend = (<>)--patternViolation :: TCM a-patternViolation = throwError PatternErr--internalError :: MonadTCM tcm => String -> tcm a-internalError s = typeError $ InternalError s--genericError :: MonadTCM tcm => String -> tcm a-genericError = typeError . GenericError--{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}-genericDocError :: MonadTCM tcm => Doc -> tcm a-genericDocError = typeError . GenericDocError--{-# SPECIALIZE typeError :: TypeError -> TCM a #-}-typeError :: MonadTCM tcm => TypeError -> tcm a-typeError err = liftTCM $ throwError =<< typeError_ err--{-# SPECIALIZE typeError_ :: TypeError -> TCM TCErr #-}-typeError_ :: MonadTCM tcm => TypeError -> tcm TCErr-typeError_ err = liftTCM $ TypeError <$> get <*> buildClosure err--{-# SPECIALIZE warning_ :: Warning -> TCM TCWarning #-}-warning_ :: MonadTCM tcm => Warning -> tcm TCWarning-warning_ w = liftTCM $ TCWarning <$> get <*> buildClosure w--{-# SPECIALIZE warning :: Warning -> TCM () #-}-warning :: MonadTCM tcm => Warning -> tcm ()-warning w = do-  tcwarn <- warning_ w-  stTCWarnings %= (tcwarn :)---- | 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)---   in the initial environment.--runSafeTCM :: TCM a -> TCState -> IO (a, TCState)-runSafeTCM m st = runTCM initEnv st m `E.catch` (\ (e :: TCErr) -> __IMPOSSIBLE__)--- runSafeTCM m st = either__IMPOSSIBLE__ return <$> do---     -- Errors must be impossible.---     runTCM $ do---         put st---         a <- m---         st <- get---         return (a, st)---- | 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 <- get-  e <- ask-  liftIO $ void $ C.forkIO $ void $ runTCM e s m----- | Base name for extended lambda patterns-extendedLambdaName :: String-extendedLambdaName = ".extendedlambda"---- | 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-------------------------------------------------------------------------------- * 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 displ mut compiled inst copy ma def) =-    killRange11 Defn ai name t pols occs displ mut compiled inst copy ma def-    -- TODO clarify: Keep the range in the defName field?--instance KillRange CtxId where-  killRange (CtxId x) = killRange1 CtxId x--instance KillRange NLPat where-  killRange (PVar x y z) = killRange3 PVar x y z-  killRange (PWild)    = PWild-  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 (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 RewriteRule where-  killRange (RewriteRule q gamma f es rhs t) =-    killRange6 RewriteRule q gamma f es rhs t--instance KillRange CompiledRepresentation where-  killRange = id---instance KillRange EtaEquality where-  killRange = id--instance KillRange ExtLamInfo where-  killRange = id--instance KillRange FunctionFlag where-  killRange = id--instance KillRange Defn where-  killRange def =-    case def of-      Axiom -> Axiom-      AbstractDefn -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!-      Function cls comp tt inv mut isAbs delayed proj flags term extlam with copat ->-        killRange13 Function cls comp tt inv mut isAbs delayed proj flags term extlam with copat-      Datatype a b c d e f g h i j   -> killRange10 Datatype a b c d e f g h i j-      Record a b c d e f g h i j k   -> killRange11 Record a b c d e f g h i j k-      Constructor a b c d e f        -> killRange6 Constructor a b c d e f-      Primitive a b c d              -> killRange4 Primitive a b c d--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--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 a => KillRange (Local a) where-  killRange (Local a b) = killRange2 Local a b-  killRange (Global a)  = killRange1 Global a--instance KillRange DisplayForm where-  killRange (Display n es dt) = killRange3 Display n es dt--instance KillRange Polarity 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+{-# LANGUAGE CPP #-}+-- {-# LANGUAGE UndecidableInstances #-}  -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT++module Agda.TypeChecking.Monad.Base+  ( module Agda.TypeChecking.Monad.Base+  , 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,22 +0,0 @@-module Agda.TypeChecking.Monad.Base where--import Control.Applicative (Applicative)-import Control.Monad.IO.Class (MonadIO)-import Data.IORef (IORef)-import Data.Map (Map)--import Agda.Syntax.Concrete.Name (TopLevelModuleName)-import Agda.Utils.FileName (AbsolutePath)--data TCEnv-data TCState-newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }--instance MonadIO m => Applicative (TCMT m)-instance MonadIO m => Functor (TCMT m)-instance MonadIO m => Monad (TCMT m)-instance MonadIO m => MonadIO (TCMT m)--type TCM = TCMT IO--type ModuleToSource = Map TopLevelModuleName AbsolutePath
+ 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,8 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Measure CPU time for individual phases of the Agda pipeline.  module Agda.TypeChecking.Monad.Benchmark   ( module Agda.Benchmarking   , B.MonadBench+  , B.BenchPhase   , B.getBenchmark   , updateBenchmarkingStatus   , B.billTo, B.billPureTo, B.billToCPS@@ -15,37 +18,45 @@ import Agda.Benchmarking  import Agda.TypeChecking.Monad.Base-import{-# SOURCE #-} Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.Debug  import qualified Agda.Utils.Benchmark as B  import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)--benchmarkKey :: String-benchmarkKey = "profile"--benchmarkLevel :: Int-benchmarkLevel = 7+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 () updateBenchmarkingStatus =-  B.setBenchmarking =<< hasVerbosity benchmarkKey benchmarkLevel+  B.setBenchmarking =<< benchmarking  -- | Check whether benchmarking is activated.-{-# SPECIALIZE benchmarking :: TCM Bool #-}-benchmarking :: MonadTCM tcm => tcm Bool-benchmarking = liftTCM $ hasVerbosity benchmarkKey benchmarkLevel+{-# SPECIALIZE benchmarking :: TCM (B.BenchmarkOn Phase) #-}+benchmarking :: MonadTCM tcm => tcm (B.BenchmarkOn Phase)+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 7.+--   no benchmark profiling is enabled. print :: MonadTCM tcm => tcm ()-print = liftTCM $ whenM benchmarking $ do+print = liftTCM $ whenM (B.isBenchmarkOn [] <$> benchmarking) $ do   b <- B.getBenchmark-  reportSLn benchmarkKey benchmarkLevel $ prettyShow b+  -- Andreas, 2017-07-29, issue #2602:+  -- The following line messes up the AgdaInfo buffer,+  -- thus, as Fredrik Forsberg suggest, I restore the original+  -- line for release 2.5.3 until a fix is found.+  -- reportSLn "" 0 $ prettyShow b+  -- 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.+  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
@@ -1,555 +1,807 @@-{-# LANGUAGE CPP #-}--module Agda.TypeChecking.Monad.Builtin where--import Control.Applicative-import Control.Monad.State-import Control.Monad.Trans.Maybe--import qualified Data.Map as Map--import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Internal as I-import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Substitute--import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Lens-import Agda.Utils.Monad-import Agda.Utils.Maybe-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible--class (Functor m, Applicative m, Monad m) => HasBuiltins m where-  getBuiltinThing :: String -> m (Maybe (Builtin PrimFun))--instance HasBuiltins m => HasBuiltins (MaybeT m) where-  getBuiltinThing b = lift $ getBuiltinThing b--litType :: Literal -> TCM Type-litType l = case l of-  LitNat _ n    -> do-    _ <- primZero-    when_ (n > 0) $ primSuc-    el <$> primNat-  LitFloat _ _  -> el <$> primFloat-  LitChar _ _   -> el <$> primChar-  LitString _ _ -> el <$> primString-  LitQName _ _  -> el <$> primQName-  LitMeta _ _ _ -> el <$> primAgdaMeta-  where-    el t = El (mkType 0) t--instance MonadIO m => HasBuiltins (TCMT m) where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> use stLocalBuiltins)-                      (Map.lookup b <$> use stImportedBuiltins)--setBuiltinThings :: BuiltinThings PrimFun -> TCM ()-setBuiltinThings b = stLocalBuiltins .= b--bindBuiltinName :: String -> Term -> TCM ()-bindBuiltinName b x = do-        builtin <- getBuiltinThing b-        case builtin of-            Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x-            Just (Prim _)    -> typeError $ NoSuchBuiltinName b-            Nothing          -> stLocalBuiltins %= Map.insert b (Builtin x)--bindPrimitive :: String -> PrimFun -> TCM ()-bindPrimitive b pf = do-  builtin <- use stLocalBuiltins-  setBuiltinThings $ Map.insert b (Prim pf) builtin--getBuiltin :: String -> TCM 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         -- ignore sharing to make sure zero isn't reduced to Lit 0-        Just (Builtin t) -> return $ Just $ ignoreSharing $ killRange t-        _                -> return Nothing--getPrimitive' :: HasBuiltins m => String -> m (Maybe PrimFun)-getPrimitive' x = (getPrim =<<) <$> getBuiltinThing x-  where-    getPrim (Prim pf) = return pf-    getPrim _         = Nothing--getPrimitive :: String -> TCM PrimFun-getPrimitive x =-  fromMaybeM (typeError $ NoSuchPrimitiveFunction x) $ getPrimitive' x---- | Rewrite a literal to constructor form if possible.-constructorForm :: Term -> TCM Term-constructorForm v = constructorForm' primZero primSuc v--constructorForm' :: Applicative m => m Term -> m Term -> Term -> m Term-constructorForm' pZero pSuc v =-  case ignoreSharing v of-    Lit (LitNat r n)-      | n == 0    -> pZero-      | n > 0     -> (`apply1` Lit (LitNat r $ n - 1)) <$> pSuc-      | otherwise -> pure v-    _ -> pure v-------------------------------------------------------------------------------- * The names of built-in things------------------------------------------------------------------------------primInteger, primIntegerPos, primIntegerNegSuc,-    primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse,-    primList, primNil, primCons, primIO, primNat, primSuc, primZero,-    primNatPlus, primNatMinus, primNatTimes, primNatDivSucAux, primNatModSucAux,-    primNatEquality, primNatLess,-    primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax,-    primInf, primSharp, primFlat,-    primEquality, primRefl,-    primRewrite, -- Name of rewrite relation-    primLevel, primLevelZero, primLevelSuc, primLevelMax,-    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,-    primHiding, primHidden, primInstance, primVisible,-    primRelevance, primRelevant, primIrrelevant,-    primAssoc, primAssocLeft, primAssocRight, primAssocNon,-    primPrecedence, primPrecRelated, primPrecUnrelated,-    primFixity, primFixityFixity,-    primAgdaLiteral, primAgdaLitNat, primAgdaLitFloat, primAgdaLitString, primAgdaLitChar, primAgdaLitQName, primAgdaLitMeta,-    primAgdaSort, primAgdaSortSet, primAgdaSortLit, primAgdaSortUnsupported,-    primAgdaDefinition, primAgdaDefinitionFunDef, primAgdaDefinitionDataDef, primAgdaDefinitionRecordDef,-    primAgdaDefinitionPostulate, primAgdaDefinitionPrimitive, primAgdaDefinitionDataConstructor,-    primAgdaClause, primAgdaClauseClause, primAgdaClauseAbsurd,-    primAgdaPattern, primAgdaPatCon, primAgdaPatVar, primAgdaPatDot,-    primAgdaPatLit, primAgdaPatProj,-    primAgdaPatAbsurd,-    primAgdaMeta,-    primAgdaTCM, primAgdaTCMReturn, primAgdaTCMBind, primAgdaTCMUnify,-    primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType,-    primAgdaTCMNormalise, primAgdaTCMReduce,-    primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,-    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDefineFun,-    primAgdaTCMGetType, primAgdaTCMGetDefinition,-    primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm,-    primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro,-    primAgdaTCMWithNormalisation-    :: TCM Term--primInteger      = getBuiltin builtinInteger-primIntegerPos   = getBuiltin builtinIntegerPos-primIntegerNegSuc = getBuiltin builtinIntegerNegSuc-primFloat        = getBuiltin builtinFloat-primChar         = getBuiltin builtinChar-primString       = getBuiltin builtinString-primBool         = getBuiltin builtinBool-primUnit         = getBuiltin builtinUnit-primUnitUnit     = getBuiltin builtinUnitUnit-primTrue         = getBuiltin builtinTrue-primFalse        = getBuiltin builtinFalse-primList         = getBuiltin builtinList-primNil          = getBuiltin builtinNil-primCons         = getBuiltin builtinCons-primIO           = getBuiltin builtinIO-primNat          = getBuiltin builtinNat-primSuc          = getBuiltin builtinSuc-primZero         = getBuiltin builtinZero-primNatPlus      = getBuiltin builtinNatPlus-primNatMinus     = getBuiltin builtinNatMinus-primNatTimes     = getBuiltin builtinNatTimes-primNatDivSucAux = getBuiltin builtinNatDivSucAux-primNatModSucAux = getBuiltin builtinNatModSucAux-primNatEquality  = getBuiltin builtinNatEquals-primNatLess      = getBuiltin builtinNatLess-primSizeUniv     = getBuiltin builtinSizeUniv-primSize         = getBuiltin builtinSize-primSizeLt       = getBuiltin builtinSizeLt-primSizeSuc      = getBuiltin builtinSizeSuc-primSizeInf      = getBuiltin builtinSizeInf-primSizeMax      = getBuiltin builtinSizeMax-primInf          = getBuiltin builtinInf-primSharp        = getBuiltin builtinSharp-primFlat         = getBuiltin builtinFlat-primEquality     = getBuiltin builtinEquality-primRefl         = getBuiltin builtinRefl-primRewrite      = getBuiltin builtinRewrite-primLevel        = getBuiltin builtinLevel-primLevelZero    = getBuiltin builtinLevelZero-primLevelSuc     = getBuiltin builtinLevelSuc-primLevelMax     = getBuiltin builtinLevelMax-primFromNat      = getBuiltin builtinFromNat-primFromNeg      = getBuiltin builtinFromNeg-primFromString   = getBuiltin builtinFromString-primQName        = getBuiltin builtinQName-primArg          = getBuiltin builtinArg-primArgArg       = getBuiltin builtinArgArg-primAbs          = getBuiltin builtinAbs-primAbsAbs       = getBuiltin builtinAbsAbs-primAgdaSort     = getBuiltin builtinAgdaSort-primHiding       = getBuiltin builtinHiding-primHidden       = getBuiltin builtinHidden-primInstance     = getBuiltin builtinInstance-primVisible      = getBuiltin builtinVisible-primRelevance    = getBuiltin builtinRelevance-primRelevant     = getBuiltin builtinRelevant-primIrrelevant   = getBuiltin builtinIrrelevant-primAssoc        = getBuiltin builtinAssoc-primAssocLeft    = getBuiltin builtinAssocLeft-primAssocRight   = getBuiltin builtinAssocRight-primAssocNon     = getBuiltin builtinAssocNon-primPrecedence    = getBuiltin builtinPrecedence-primPrecRelated   = getBuiltin builtinPrecRelated-primPrecUnrelated = getBuiltin builtinPrecUnrelated-primFixity        = getBuiltin builtinFixity-primFixityFixity  = getBuiltin builtinFixityFixity-primArgInfo      = getBuiltin builtinArgInfo-primArgArgInfo   = getBuiltin builtinArgArgInfo-primAgdaSortSet  = getBuiltin builtinAgdaSortSet-primAgdaSortLit  = getBuiltin builtinAgdaSortLit-primAgdaSortUnsupported = getBuiltin builtinAgdaSortUnsupported-primAgdaTerm         = getBuiltin builtinAgdaTerm-primAgdaTermVar      = getBuiltin builtinAgdaTermVar-primAgdaTermLam      = getBuiltin builtinAgdaTermLam-primAgdaTermExtLam   = getBuiltin builtinAgdaTermExtLam-primAgdaTermDef      = getBuiltin builtinAgdaTermDef-primAgdaTermCon      = getBuiltin builtinAgdaTermCon-primAgdaTermPi       = getBuiltin builtinAgdaTermPi-primAgdaTermSort     = getBuiltin builtinAgdaTermSort-primAgdaTermLit      = getBuiltin builtinAgdaTermLit-primAgdaTermUnsupported     = getBuiltin builtinAgdaTermUnsupported-primAgdaTermMeta  = getBuiltin builtinAgdaTermMeta-primAgdaErrorPart       = getBuiltin builtinAgdaErrorPart-primAgdaErrorPartString = getBuiltin builtinAgdaErrorPartString-primAgdaErrorPartTerm   = getBuiltin builtinAgdaErrorPartTerm-primAgdaErrorPartName   = getBuiltin builtinAgdaErrorPartName-primAgdaLiteral   = getBuiltin builtinAgdaLiteral-primAgdaLitNat    = getBuiltin builtinAgdaLitNat-primAgdaLitFloat  = getBuiltin builtinAgdaLitFloat-primAgdaLitChar   = getBuiltin builtinAgdaLitChar-primAgdaLitString = getBuiltin builtinAgdaLitString-primAgdaLitQName  = getBuiltin builtinAgdaLitQName-primAgdaLitMeta   = getBuiltin builtinAgdaLitMeta-primAgdaPattern   = getBuiltin builtinAgdaPattern-primAgdaPatCon    = getBuiltin builtinAgdaPatCon-primAgdaPatVar    = getBuiltin builtinAgdaPatVar-primAgdaPatDot    = getBuiltin builtinAgdaPatDot-primAgdaPatLit    = getBuiltin builtinAgdaPatLit-primAgdaPatProj   = getBuiltin builtinAgdaPatProj-primAgdaPatAbsurd = getBuiltin builtinAgdaPatAbsurd-primAgdaClause    = getBuiltin builtinAgdaClause-primAgdaClauseClause = getBuiltin builtinAgdaClauseClause-primAgdaClauseAbsurd = getBuiltin builtinAgdaClauseAbsurd-primAgdaDefinitionFunDef          = getBuiltin builtinAgdaDefinitionFunDef-primAgdaDefinitionDataDef         = getBuiltin builtinAgdaDefinitionDataDef-primAgdaDefinitionRecordDef       = getBuiltin builtinAgdaDefinitionRecordDef-primAgdaDefinitionDataConstructor = getBuiltin builtinAgdaDefinitionDataConstructor-primAgdaDefinitionPostulate       = getBuiltin builtinAgdaDefinitionPostulate-primAgdaDefinitionPrimitive       = getBuiltin builtinAgdaDefinitionPrimitive-primAgdaDefinition                = getBuiltin builtinAgdaDefinition-primAgdaMeta                      = getBuiltin builtinAgdaMeta-primAgdaTCM           = getBuiltin builtinAgdaTCM-primAgdaTCMReturn     = getBuiltin builtinAgdaTCMReturn-primAgdaTCMBind       = getBuiltin builtinAgdaTCMBind-primAgdaTCMUnify      = getBuiltin builtinAgdaTCMUnify-primAgdaTCMTypeError  = getBuiltin builtinAgdaTCMTypeError-primAgdaTCMInferType  = getBuiltin builtinAgdaTCMInferType-primAgdaTCMCheckType  = getBuiltin builtinAgdaTCMCheckType-primAgdaTCMNormalise  = getBuiltin builtinAgdaTCMNormalise-primAgdaTCMReduce     = getBuiltin builtinAgdaTCMReduce-primAgdaTCMCatchError = getBuiltin builtinAgdaTCMCatchError-primAgdaTCMGetContext = getBuiltin builtinAgdaTCMGetContext-primAgdaTCMExtendContext = getBuiltin builtinAgdaTCMExtendContext-primAgdaTCMInContext     = getBuiltin builtinAgdaTCMInContext-primAgdaTCMFreshName     = getBuiltin builtinAgdaTCMFreshName-primAgdaTCMDeclareDef    = getBuiltin builtinAgdaTCMDeclareDef-primAgdaTCMDefineFun     = getBuiltin builtinAgdaTCMDefineFun-primAgdaTCMGetType            = getBuiltin builtinAgdaTCMGetType-primAgdaTCMGetDefinition      = getBuiltin builtinAgdaTCMGetDefinition-primAgdaTCMQuoteTerm          = getBuiltin builtinAgdaTCMQuoteTerm-primAgdaTCMUnquoteTerm        = getBuiltin builtinAgdaTCMUnquoteTerm-primAgdaTCMBlockOnMeta        = getBuiltin builtinAgdaTCMBlockOnMeta-primAgdaTCMCommit             = getBuiltin builtinAgdaTCMCommit-primAgdaTCMIsMacro            = getBuiltin builtinAgdaTCMIsMacro-primAgdaTCMWithNormalisation  = getBuiltin builtinAgdaTCMWithNormalisation--builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,-  builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,-  builtinNatLess, builtinInteger, builtinIntegerPos, builtinIntegerNegSuc,-  builtinFloat, builtinChar, builtinString, builtinUnit, builtinUnitUnit,-  builtinBool, builtinTrue, builtinFalse,-  builtinList, builtinNil, builtinCons, builtinIO,-  builtinSizeUniv, builtinSize, builtinSizeLt,-  builtinSizeSuc, builtinSizeInf, builtinSizeMax,-  builtinInf, builtinSharp, builtinFlat,-  builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax,-  builtinLevel, builtinLevelZero, builtinLevelSuc,-  builtinFromNat, builtinFromNeg, builtinFromString,-  builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,-  builtinAgdaSortUnsupported,-  builtinHiding, builtinHidden, builtinInstance, builtinVisible,-  builtinRelevance, builtinRelevant, builtinIrrelevant, builtinArg,-  builtinAssoc, builtinAssocLeft, builtinAssocRight, builtinAssocNon,-  builtinPrecedence, builtinPrecRelated, builtinPrecUnrelated,-  builtinFixity, builtinFixityFixity,-  builtinArgInfo, builtinArgArgInfo, builtinArgArg,-  builtinAbs, builtinAbsAbs, builtinAgdaTerm,-  builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,-  builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,-  builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported, builtinAgdaTermMeta,-  builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName,-  builtinAgdaLiteral, builtinAgdaLitNat, 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, builtinAgdaTCMDefineFun,-  builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,-  builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm,-  builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro,-  builtinAgdaTCMWithNormalisation-  :: String--builtinNat                           = "NATURAL"-builtinSuc                           = "SUC"-builtinZero                          = "ZERO"-builtinNatPlus                       = "NATPLUS"-builtinNatMinus                      = "NATMINUS"-builtinNatTimes                      = "NATTIMES"-builtinNatDivSucAux                  = "NATDIVSUCAUX"-builtinNatModSucAux                  = "NATMODSUCAUX"-builtinNatEquals                     = "NATEQUALS"-builtinNatLess                       = "NATLESS"-builtinInteger                       = "INTEGER"-builtinIntegerPos                    = "INTEGERPOS"-builtinIntegerNegSuc                 = "INTEGERNEGSUC"-builtinFloat                         = "FLOAT"-builtinChar                          = "CHAR"-builtinString                        = "STRING"-builtinUnit                          = "UNIT"-builtinUnitUnit                      = "UNITUNIT"-builtinBool                          = "BOOL"-builtinTrue                          = "TRUE"-builtinFalse                         = "FALSE"-builtinList                          = "LIST"-builtinNil                           = "NIL"-builtinCons                          = "CONS"-builtinIO                            = "IO"-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"-builtinFromNat                       = "FROMNAT"-builtinFromNeg                       = "FROMNEG"-builtinFromString                    = "FROMSTRING"-builtinQName                         = "QNAME"-builtinAgdaSort                      = "AGDASORT"-builtinAgdaSortSet                   = "AGDASORTSET"-builtinAgdaSortLit                   = "AGDASORTLIT"-builtinAgdaSortUnsupported           = "AGDASORTUNSUPPORTED"-builtinHiding                        = "HIDING"-builtinHidden                        = "HIDDEN"-builtinInstance                      = "INSTANCE"-builtinVisible                       = "VISIBLE"-builtinRelevance                     = "RELEVANCE"-builtinRelevant                      = "RELEVANT"-builtinIrrelevant                    = "IRRELEVANT"-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"-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"-builtinAgdaTCMDefineFun     = "AGDATCMDEFINEFUN"-builtinAgdaTCMGetType       = "AGDATCMGETTYPE"-builtinAgdaTCMGetDefinition = "AGDATCMGETDEFINITION"-builtinAgdaTCMBlockOnMeta   = "AGDATCMBLOCKONMETA"-builtinAgdaTCMCommit        = "AGDATCMCOMMIT"-builtinAgdaTCMQuoteTerm     = "AGDATCMQUOTETERM"-builtinAgdaTCMUnquoteTerm   = "AGDATCMUNQUOTETERM"-builtinAgdaTCMIsMacro       = "AGDATCMISMACRO"-builtinAgdaTCMWithNormalisation = "AGDATCMWITHNORMALISATION"---- | 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.--builtinsNoDef :: [String]-builtinsNoDef =-  [ builtinSizeUniv-  , builtinSize-  , builtinSizeLt-  , builtinSizeSuc-  , builtinSizeInf-  , builtinSizeMax-  ]---- | The coinductive primitives.--data CoinductionKit = CoinductionKit-  { nameOfInf   :: QName-  , nameOfSharp :: QName-  , nameOfFlat  :: QName-  }---- | Tries to build a 'CoinductionKit'.--coinductionKit' :: TCM CoinductionKit-coinductionKit' = do-  Def inf   _ <- ignoreSharing <$> primInf-  Def sharp _ <- ignoreSharing <$> primSharp-  Def flat  _ <- ignoreSharing <$> primFlat-  return $ CoinductionKit-    { nameOfInf   = inf-    , nameOfSharp = sharp-    , nameOfFlat  = flat-    }--coinductionKit :: TCM (Maybe CoinductionKit)-coinductionKit = tryMaybe coinductionKit'----------------------------------------------------------------------------- * Builtin equality----------------------------------------------------------------------------- | Get the name of the equality type.-primEqualityName :: TCM QName-primEqualityName = do-  eq <- primEquality-  -- Andreas, 2014-05-17 moved this here from TC.Rules.Def-  -- Don't know why up to 2 hidden lambdas need to be stripped,-  -- but I left the code in place.-  -- Maybe it was intended that equality could be declared-  -- in three different ways:-  -- 1. universe and type polymorphic-  -- 2. type polymorphic only-  -- 3. monomorphic.-  let lamV (Lam i b)  = mapFst (getHiding i :) $ lamV (unAbs b)-      lamV (Shared p) = lamV (derefPtr p)-      lamV v          = ([], v)-  return $ case lamV eq of-    ([Hidden, Hidden], Def equality _) -> equality-    ([Hidden],         Def equality _) -> equality-    ([],               Def equality _) -> equality-    _                                  -> __IMPOSSIBLE__---- | Check whether the type is actually an equality (lhs ≡ rhs)---   and extract lhs, rhs, and their type.------   Precondition: type is reduced.--equalityView :: Type -> TCM EqualityView-equalityView t0@(El s t) = do-  equality <- primEqualityName-  case ignoreSharing t of-    Def equality' [ Apply level , Apply typ , Apply lhs , Apply rhs ]-      | equality' == equality -> return $ EqualityType s equality level typ lhs rhs-    _ -> return $ OtherType t0---- | Revert the 'EqualityView'.------   Postcondition: type is reduced.--equalityUnview :: EqualityView -> Type-equalityUnview (OtherType t) = t-equalityUnview (EqualityType s equality l t lhs rhs) =-  El s $ Def equality $ map Apply [l, t, lhs, rhs]++module Agda.TypeChecking.Monad.Builtin+  ( module Agda.TypeChecking.Monad.Builtin+  , module Agda.Syntax.Builtin  -- The names are defined here.+  ) where++import Control.Monad.Except         ( MonadError(..), ExceptT )+import Control.Monad.IO.Class       ( MonadIO(..) )+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         ( WriterT )++import Data.Function ( on )+import qualified Data.Map as Map+import Data.Set (Set)++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Literal+import Agda.Syntax.Builtin+import Agda.Syntax.Internal as I+import Agda.TypeChecking.Monad.Base+-- 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+      , Monad m+      ) => HasBuiltins m where+  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 (ChangeT m)+instance HasBuiltins m => HasBuiltins (ExceptT e m)+instance HasBuiltins m => HasBuiltins (IdentityT m)+instance HasBuiltins m => HasBuiltins (ListT m)+instance HasBuiltins m => HasBuiltins (MaybeT m)+instance HasBuiltins m => HasBuiltins (ReaderT e m)+instance HasBuiltins m => HasBuiltins (StateT s m)+instance (HasBuiltins m, Monoid w) => HasBuiltins (WriterT w m)++deriving instance HasBuiltins m => HasBuiltins (BlockT m)++instance MonadIO m => HasBuiltins (TCMT m) where+  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.++litType+  :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+  => Literal -> m Type+litType = \case+  LitNat n    -> do+    _ <- primZero+    when (n > 0) $ void $ primSuc+    el <$> primNat+  LitWord64 _ -> el <$> primWord64+  LitFloat _  -> el <$> primFloat+  LitChar _   -> el <$> primChar+  LitString _ -> el <$> primString+  LitQName _  -> el <$> primQName+  LitMeta _ _ -> el <$> primAgdaMeta+  where+    el t = El (mkType 0) t++setBuiltinThings :: BuiltinThings -> TCM ()+setBuiltinThings b = stLocalBuiltins `setTCLens` b++bindBuiltinName :: BuiltinId -> Term -> TCM ()+bindBuiltinName b x = do+  builtin <- getBuiltinThing b'+  case builtin of+    Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x+    Just Prim{}      -> typeError $ __IMPOSSIBLE__+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__+    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b' (Builtin x)+  where b' = BuiltinName b++bindPrimitive :: PrimitiveId -> PrimFun -> TCM ()+bindPrimitive b pf = do+  builtin <- getBuiltinThing b'+  case builtin of+    Just (Builtin _) -> typeError $ NoSuchPrimitiveFunction (getBuiltinId b)+    Just (Prim x)    -> typeError $ (DuplicatePrimitiveBinding b `on` primFunName) x pf+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__+    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b' (Prim pf)+  where b' = PrimitiveName b++-- | 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++{-# 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__++{-# 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 = \case+      Prim pf                   -> return pf+      Builtin{}                 -> Nothing+      BuiltinRewriteRelations{} -> __IMPOSSIBLE__++{-# INLINABLE getPrimitive #-}+getPrimitive :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+             => PrimitiveId -> m PrimFun+getPrimitive x =+  fromMaybeM (typeError . NoSuchPrimitiveFunction $ getBuiltinId x) $ getPrimitive' x++getPrimitiveTerm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+                 => PrimitiveId -> m Term+getPrimitiveTerm x = (`Def` []) . primFunName <$> getPrimitive x+++getPrimitiveTerm' :: HasBuiltins m => PrimitiveId -> m (Maybe Term)+getPrimitiveTerm' x = fmap (`Def` []) <$> getPrimitiveName' 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, 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, IsBuiltin a) => String -> a -> m Term+getTerm use name = flip fromMaybeM (getTerm' name) $+  return $! throwImpossible (ImpMissingDefinitions [getBuiltinId name] use)+++-- | Rewrite a literal to constructor form if possible.+constructorForm :: HasBuiltins m => Term -> m Term+constructorForm v = do+  let pZero = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero+      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+    Lit (LitNat n)+      | n == 0    -> pZero+      | n > 0     -> (`apply1` Lit (LitNat $ n - 1)) <$> pSuc+      | otherwise -> pure v+    _ -> pure v++---------------------------------------------------------------------------+-- * The names of built-in things+---------------------------------------------------------------------------++primInteger, primIntegerPos, primIntegerNegSuc,+    primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse,+    primSigma,+    primList, primNil, primCons, primIO, primNat, primSuc, primZero, primMaybe, primNothing, primJust,+    primPath, primPathP, primIntervalUniv, primInterval, primIZero, primIOne, primPartial, primPartialP,+    primIMin, primIMax, primINeg,+    primIsOne, primItIsOne, primIsOne1, primIsOne2, primIsOneEmpty,+    primSub, primSubIn, primSubOut,+    primTrans, primHComp,+    primEquiv, primEquivFun, primEquivProof,+    primTranspProof,+    primGlue, prim_glue, prim_unglue,+    prim_glueU, prim_unglueU,+    primFaceForall,+    primNatPlus, primNatMinus, primNatTimes, primNatDivSucAux, primNatModSucAux,+    primNatEquality, primNatLess,+    -- Machine words+    primWord64,+    primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax,+    primInf, primSharp, primFlat,+    primEquality, primRefl,+    primLevel, primLevelZero, primLevelSuc, primLevelMax,+    primLockUniv,+    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, primAgdaErrorPartPatt, primAgdaErrorPartName,+    primHiding, primHidden, primInstance, primVisible,+    primRelevance, primRelevant, primIrrelevant,+    primQuantity, primQuantity0, primQuantityω,+    primModality, primModalityConstructor,+    primAssoc, primAssocLeft, primAssocRight, primAssocNon,+    primPrecedence, primPrecRelated, primPrecUnrelated,+    primFixity, primFixityFixity,+    primAgdaLiteral, primAgdaLitNat, primAgdaLitWord64, primAgdaLitFloat, primAgdaLitString, primAgdaLitChar, primAgdaLitQName, primAgdaLitMeta,+    primAgdaSort, primAgdaSortSet, primAgdaSortLit, primAgdaSortProp, primAgdaSortPropLit, primAgdaSortInf, primAgdaSortUnsupported,+    primAgdaDefinition, primAgdaDefinitionFunDef, primAgdaDefinitionDataDef, primAgdaDefinitionRecordDef,+    primAgdaDefinitionPostulate, primAgdaDefinitionPrimitive, primAgdaDefinitionDataConstructor,+    primAgdaClause, primAgdaClauseClause, primAgdaClauseAbsurd,+    primAgdaPattern, primAgdaPatCon, primAgdaPatVar, primAgdaPatDot,+    primAgdaPatLit, primAgdaPatProj,+    primAgdaPatAbsurd,+    primAgdaMeta,+    primAgdaBlocker, primAgdaBlockerAny, primAgdaBlockerAll, primAgdaBlockerMeta,+    primAgdaTCM, primAgdaTCMReturn, primAgdaTCMBind, primAgdaTCMUnify,+    primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType,+    primAgdaTCMNormalise, primAgdaTCMReduce,+    primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,+    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDeclareData, primAgdaTCMDefineData, primAgdaTCMDefineFun,+    primAgdaTCMGetType, primAgdaTCMGetDefinition,+    primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm, primAgdaTCMQuoteOmegaTerm,+    primAgdaTCMCommit, primAgdaTCMIsMacro, primAgdaTCMBlock,+    primAgdaTCMFormatErrorParts, primAgdaTCMDebugPrint,+    primAgdaTCMWithNormalisation, primAgdaTCMWithReconstructed,+    primAgdaTCMWithExpandLast, primAgdaTCMWithReduceDefs,+    primAgdaTCMAskNormalisation, primAgdaTCMAskReconstructed,+    primAgdaTCMAskExpandLast, primAgdaTCMAskReduceDefs,+    primAgdaTCMNoConstraints,+    primAgdaTCMWorkOnTypes,+    primAgdaTCMRunSpeculative,+    primAgdaTCMExec,+    primAgdaTCMCheckFromString,+    primAgdaTCMGetInstances,+    primAgdaTCMSolveInstances,+    primAgdaTCMPragmaForeign,+    primAgdaTCMPragmaCompile+    :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term++primInteger                           = getBuiltin builtinInteger+primIntegerPos                        = getBuiltin builtinIntegerPos+primIntegerNegSuc                     = getBuiltin builtinIntegerNegSuc+primFloat                             = getBuiltin builtinFloat+primChar                              = getBuiltin builtinChar+primString                            = getBuiltin builtinString+primBool                              = getBuiltin builtinBool+primSigma                             = getBuiltin builtinSigma+primUnit                              = getBuiltin builtinUnit+primUnitUnit                          = getBuiltin builtinUnitUnit+primTrue                              = getBuiltin builtinTrue+primFalse                             = getBuiltin builtinFalse+primList                              = getBuiltin builtinList+primNil                               = getBuiltin builtinNil+primCons                              = getBuiltin builtinCons+primMaybe                             = getBuiltin builtinMaybe+primNothing                           = getBuiltin builtinNothing+primJust                              = getBuiltin builtinJust+primIO                                = getBuiltin builtinIO+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+primIsOne                             = getBuiltin builtinIsOne+primItIsOne                           = getBuiltin builtinItIsOne+primTrans                             = getPrimitiveTerm builtinTrans+primHComp                             = getPrimitiveTerm builtinHComp+primEquiv                             = getBuiltin builtinEquiv+primEquivFun                          = getBuiltin builtinEquivFun+primEquivProof                        = getBuiltin builtinEquivProof+primTranspProof                       = getBuiltin builtinTranspProof+prim_glueU                            = getPrimitiveTerm builtin_glueU+prim_unglueU                          = getPrimitiveTerm builtin_unglueU+primGlue                              = getPrimitiveTerm builtinGlue+prim_glue                             = getPrimitiveTerm builtin_glue+prim_unglue                           = getPrimitiveTerm builtin_unglue+primFaceForall                        = getPrimitiveTerm builtinFaceForall+primIsOne1                            = getBuiltin builtinIsOne1+primIsOne2                            = getBuiltin builtinIsOne2+primIsOneEmpty                        = getBuiltin builtinIsOneEmpty+primSub                               = getBuiltin builtinSub+primSubIn                             = getBuiltin builtinSubIn+primSubOut                            = getPrimitiveTerm builtinSubOut+primNat                               = getBuiltin builtinNat+primSuc                               = getBuiltin builtinSuc+primZero                              = getBuiltin builtinZero+primNatPlus                           = getBuiltin builtinNatPlus+primNatMinus                          = getBuiltin builtinNatMinus+primNatTimes                          = getBuiltin builtinNatTimes+primNatDivSucAux                      = getBuiltin builtinNatDivSucAux+primNatModSucAux                      = getBuiltin builtinNatModSucAux+primNatEquality                       = getBuiltin builtinNatEquals+primNatLess                           = getBuiltin builtinNatLess+primWord64                            = getBuiltin builtinWord64+primSizeUniv                          = getBuiltin builtinSizeUniv+primSize                              = getBuiltin builtinSize+primSizeLt                            = getBuiltin builtinSizeLt+primSizeSuc                           = getBuiltin builtinSizeSuc+primSizeInf                           = getBuiltin builtinSizeInf+primSizeMax                           = getBuiltin builtinSizeMax+primInf                               = getBuiltin builtinInf+primSharp                             = getBuiltin builtinSharp+primFlat                              = getBuiltin builtinFlat+primEquality                          = getBuiltin builtinEquality+primRefl                              = getBuiltin builtinRefl+primLevel                             = getBuiltin builtinLevel+primLevelZero                         = getBuiltin builtinLevelZero+primLevelSuc                          = getBuiltin builtinLevelSuc+primLevelMax                          = getBuiltin builtinLevelMax+primProp                              = getBuiltin builtinProp+primSet                               = getBuiltin builtinSet+primStrictSet                         = getBuiltin builtinStrictSet+primPropOmega                         = getBuiltin builtinPropOmega+primSetOmega                          = getBuiltin builtinSetOmega+primSSetOmega                         = getBuiltin builtinSSetOmega+primLockUniv                          = getPrimitiveTerm builtinLockUniv+primLevelUniv                         = getBuiltin builtinLevelUniv+primFromNat                           = getBuiltin builtinFromNat+primFromNeg                           = getBuiltin builtinFromNeg+primFromString                        = getBuiltin builtinFromString+primQName                             = getBuiltin builtinQName+primArg                               = getBuiltin builtinArg+primArgArg                            = getBuiltin builtinArgArg+primAbs                               = getBuiltin builtinAbs+primAbsAbs                            = getBuiltin builtinAbsAbs+primAgdaSort                          = getBuiltin builtinAgdaSort+primHiding                            = getBuiltin builtinHiding+primHidden                            = getBuiltin builtinHidden+primInstance                          = getBuiltin builtinInstance+primVisible                           = getBuiltin builtinVisible+primRelevance                         = getBuiltin builtinRelevance+primRelevant                          = getBuiltin builtinRelevant+primIrrelevant                        = getBuiltin builtinIrrelevant+primQuantity                          = getBuiltin builtinQuantity+primQuantity0                         = getBuiltin builtinQuantity0+primQuantityω                         = getBuiltin builtinQuantityω+primModality                          = getBuiltin builtinModality+primModalityConstructor               = getBuiltin builtinModalityConstructor+primAssoc                             = getBuiltin builtinAssoc+primAssocLeft                         = getBuiltin builtinAssocLeft+primAssocRight                        = getBuiltin builtinAssocRight+primAssocNon                          = getBuiltin builtinAssocNon+primPrecedence                        = getBuiltin builtinPrecedence+primPrecRelated                       = getBuiltin builtinPrecRelated+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+primAgdaSortLit                       = getBuiltin builtinAgdaSortLit+primAgdaSortProp                      = getBuiltin builtinAgdaSortProp+primAgdaSortPropLit                   = getBuiltin builtinAgdaSortPropLit+primAgdaSortInf                       = getBuiltin builtinAgdaSortInf+primAgdaSortUnsupported               = getBuiltin builtinAgdaSortUnsupported+primAgdaTerm                          = getBuiltin builtinAgdaTerm+primAgdaTermVar                       = getBuiltin builtinAgdaTermVar+primAgdaTermLam                       = getBuiltin builtinAgdaTermLam+primAgdaTermExtLam                    = getBuiltin builtinAgdaTermExtLam+primAgdaTermDef                       = getBuiltin builtinAgdaTermDef+primAgdaTermCon                       = getBuiltin builtinAgdaTermCon+primAgdaTermPi                        = getBuiltin builtinAgdaTermPi+primAgdaTermSort                      = getBuiltin builtinAgdaTermSort+primAgdaTermLit                       = getBuiltin builtinAgdaTermLit+primAgdaTermUnsupported               = getBuiltin builtinAgdaTermUnsupported+primAgdaTermMeta                      = getBuiltin builtinAgdaTermMeta+primAgdaErrorPart                     = getBuiltin builtinAgdaErrorPart+primAgdaErrorPartString               = getBuiltin builtinAgdaErrorPartString+primAgdaErrorPartTerm                 = getBuiltin builtinAgdaErrorPartTerm+primAgdaErrorPartPatt                 = getBuiltin builtinAgdaErrorPartPatt+primAgdaErrorPartName                 = getBuiltin builtinAgdaErrorPartName+primAgdaLiteral                       = getBuiltin builtinAgdaLiteral+primAgdaLitNat                        = getBuiltin builtinAgdaLitNat+primAgdaLitWord64                     = getBuiltin builtinAgdaLitWord64+primAgdaLitFloat                      = getBuiltin builtinAgdaLitFloat+primAgdaLitChar                       = getBuiltin builtinAgdaLitChar+primAgdaLitString                     = getBuiltin builtinAgdaLitString+primAgdaLitQName                      = getBuiltin builtinAgdaLitQName+primAgdaLitMeta                       = getBuiltin builtinAgdaLitMeta+primAgdaPattern                       = getBuiltin builtinAgdaPattern+primAgdaPatCon                        = getBuiltin builtinAgdaPatCon+primAgdaPatVar                        = getBuiltin builtinAgdaPatVar+primAgdaPatDot                        = getBuiltin builtinAgdaPatDot+primAgdaPatLit                        = getBuiltin builtinAgdaPatLit+primAgdaPatProj                       = getBuiltin builtinAgdaPatProj+primAgdaPatAbsurd                     = getBuiltin builtinAgdaPatAbsurd+primAgdaClause                        = getBuiltin builtinAgdaClause+primAgdaClauseClause                  = getBuiltin builtinAgdaClauseClause+primAgdaClauseAbsurd                  = getBuiltin builtinAgdaClauseAbsurd+primAgdaDefinitionFunDef              = getBuiltin builtinAgdaDefinitionFunDef+primAgdaDefinitionDataDef             = getBuiltin builtinAgdaDefinitionDataDef+primAgdaDefinitionRecordDef           = getBuiltin builtinAgdaDefinitionRecordDef+primAgdaDefinitionDataConstructor     = getBuiltin builtinAgdaDefinitionDataConstructor+primAgdaDefinitionPostulate           = getBuiltin builtinAgdaDefinitionPostulate+primAgdaDefinitionPrimitive           = getBuiltin builtinAgdaDefinitionPrimitive+primAgdaDefinition                    = getBuiltin builtinAgdaDefinition+primAgdaMeta                          = getBuiltin builtinAgdaMeta+primAgdaTCM                           = getBuiltin builtinAgdaTCM+primAgdaTCMReturn                     = getBuiltin builtinAgdaTCMReturn+primAgdaTCMBind                       = getBuiltin builtinAgdaTCMBind+primAgdaTCMUnify                      = getBuiltin builtinAgdaTCMUnify+primAgdaTCMTypeError                  = getBuiltin builtinAgdaTCMTypeError+primAgdaTCMInferType                  = getBuiltin builtinAgdaTCMInferType+primAgdaTCMCheckType                  = getBuiltin builtinAgdaTCMCheckType+primAgdaTCMNormalise                  = getBuiltin builtinAgdaTCMNormalise+primAgdaTCMReduce                     = getBuiltin builtinAgdaTCMReduce+primAgdaTCMCatchError                 = getBuiltin builtinAgdaTCMCatchError+primAgdaTCMGetContext                 = getBuiltin builtinAgdaTCMGetContext+primAgdaTCMExtendContext              = getBuiltin builtinAgdaTCMExtendContext+primAgdaTCMInContext                  = getBuiltin builtinAgdaTCMInContext+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+primAgdaTCMBlock                      = getBuiltin builtinAgdaTCMBlock+primAgdaTCMCommit                     = getBuiltin builtinAgdaTCMCommit+primAgdaTCMIsMacro                    = getBuiltin builtinAgdaTCMIsMacro+primAgdaTCMWithNormalisation          = getBuiltin builtinAgdaTCMWithNormalisation+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+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.++data CoinductionKit = CoinductionKit+  { nameOfInf   :: QName+  , nameOfSharp :: QName+  , nameOfFlat  :: QName+  }++-- | Tries to build a 'CoinductionKit'.++coinductionKit' :: TCM CoinductionKit+coinductionKit' = do+  inf   <- getBuiltinName_ builtinInf+  sharp <- getBuiltinName_ builtinSharp+  flat  <- getBuiltinName_ builtinFlat+  return $ CoinductionKit+    { nameOfInf   = inf+    , nameOfSharp = sharp+    , nameOfFlat  = flat+    }++coinductionKit :: TCM (Maybe CoinductionKit)+coinductionKit = tryMaybe coinductionKit'++-- | Sort primitives.++data SortKit = SortKit+  { nameOfUniv   :: UnivSize -> Univ -> QName+  , isNameOfUniv :: QName -> Maybe (UnivSize, Univ)+  }++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+  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+------------------------------------------------------------------------++getPrimName :: Term -> QName+getPrimName ty = do+  let lamV (Lam i b)  = mapFst (getHiding i :) $ lamV (unAbs b)+      lamV (Pi _ b)   = lamV (unEl $ unAbs b)+      lamV v          = ([], v)+  case lamV ty of+            (_, Def path _) -> path+            (_, Con nm _ _)   -> conName nm+            (_, Var 0 [Proj _ l]) -> l+            (_, t)          -> __IMPOSSIBLE__++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 => 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' builtinIMax+  imin <- getPrimitiveName' builtinIMin+  ineg <- getPrimitiveName' builtinINeg+  return $ \ t ->+    case t of+      Def q es ->+        case es of+          [Apply x,Apply y] | Just q == imin -> IMin x y+          [Apply x,Apply y] | Just q == imax -> IMax x y+          [Apply x]         | Just q == ineg -> INeg x+          _                 -> OTerm t+      Con q _ [] | Just (conName q) == iz -> IZero+                 | Just (conName q) == io -> IOne+      _ -> OTerm t++{-# INLINE intervalView #-}+intervalView :: HasBuiltins m => Term -> m IntervalView+intervalView t = do+  f <- intervalView'+  return (f t)++intervalUnview :: HasBuiltins m => IntervalView -> m Term+intervalUnview t = do+  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' builtinIMin+  imax <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinIMax+  ineg <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinINeg+  return $ \ v -> case v of+             IZero -> iz+             IOne  -> io+             IMin x y -> apply imin [x,y]+             IMax x y -> apply imax [x,y]+             INeg x   -> apply ineg [x]+             OTerm t -> t++------------------------------------------------------------------------+-- * Path equality+------------------------------------------------------------------------++-- | Check whether the type is actually an path (lhs ≡ rhs)+--   and extract lhs, rhs, and their type.+--+--   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+ mpathp <- getBuiltinName' builtinPathP+ return $ \ t0@(El s t) ->+  case t of+    Def path' [ Apply level , Apply typ , Apply lhs , Apply rhs ]+      | Just path' == mpath, Just path <- mpathp -> PathType s path level (lam_i <$> typ) lhs rhs+      where lam_i = Lam defaultArgInfo . NoAbs "_"+    Def path' [ Apply level , Apply typ , Apply lhs , Apply rhs ]+      | Just path' == mpathp, Just path <- mpathp -> PathType s path level typ lhs rhs+    _ -> OType t0++boldPathView :: Type -> PathView+boldPathView t0@(El s t) = do+  case t of+    Def path' [ Apply level , Apply typ , Apply lhs , Apply rhs ]+      -> PathType s path' level typ lhs rhs+    _ -> OType t0++-- | Revert the 'PathView'.+--+--   Postcondition: type is reduced.++pathUnview :: PathView -> Type+pathUnview (OType t) = t+pathUnview (PathType s path l t lhs rhs) =+  El s $ Def path $ map Apply [l, t, lhs, rhs]++------------------------------------------------------------------------+-- * Builtin equality+------------------------------------------------------------------------++-- | Get the name of the equality type.+primEqualityName :: TCM QName+primEqualityName = do+  eq <- primEquality+  -- Andreas, 2014-05-17 moved this here from TC.Rules.Def+  -- Don't know why up to 2 hidden lambdas need to be stripped,+  -- but I left the code in place.+  -- Maybe it was intended that equality could be declared+  -- in three different ways:+  -- 1. universe and type polymorphic+  -- 2. type polymorphic only+  -- 3. monomorphic.+  let lamV (Lam i b)  = mapFst (getHiding i :) $ lamV (unAbs b)+      lamV v          = ([], v)+  return $ case lamV eq of+    (_, Def equality _) -> equality+    _                   -> __IMPOSSIBLE__++-- | Check whether the type is actually an equality (lhs ≡ rhs)+--   and extract lhs, rhs, and their type.+--+--   Precondition: type is reduced.++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+      let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+      let n = length vs+      unless (n >= 3) __IMPOSSIBLE__+      let (pars, [ typ , lhs, rhs ]) = splitAt (n-3) vs+      return $ EqualityType r s equality pars typ lhs rhs+    _ -> return $ OtherType t0++-- | Revert the 'EqualityView'.+--+--   Postcondition: type is reduced.++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 :: [PrimitiveId]+constrainedPrims =+  [ builtinPOr+  , builtinComp+  , builtinHComp+  , builtinTrans+  , builtin_glue+  , builtin_glueU+  ]++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
@@ -0,0 +1,25 @@++module Agda.TypeChecking.Monad.Builtin where++import Control.Monad.IO.Class       ( MonadIO )+import Control.Monad.Reader         ( ReaderT )+import Control.Monad.State          ( StateT )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans          ( MonadTrans, lift )++import Agda.TypeChecking.Monad.Base (TCMT, Builtin, PrimFun)+import Agda.Syntax.Builtin (SomeBuiltin)++class ( Functor m+      , Applicative m+      , Monad m+      ) => HasBuiltins m where+  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)+instance HasBuiltins m => HasBuiltins (ReaderT e m)+instance HasBuiltins m => HasBuiltins (StateT s m)++instance MonadIO m => HasBuiltins (TCMT m)
src/full/Agda/TypeChecking/Monad/Caching.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Caching   ( -- * Log reading/writing operations@@ -8,74 +7,118 @@   , cleanCachedLog   , cacheCurrentLog -    -- * Activating+    -- * Activating/deactivating   , activateLoadedFileCache   , cachingStarts+  , areWeCaching+  , localCache, withoutCache      -- * Restoring the 'PostScopeState'   , restorePostScopeState   ) where -import Control.Monad.State-import qualified Data.Map as Map+import qualified Data.Set as Set  import Agda.Syntax.Common +import Agda.Interaction.Options+ import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.Debug +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Lens+import Agda.Utils.Monad+import Agda.Utils.Null (empty) -#include "undefined.h" import Agda.Utils.Impossible  -- | To be called before any write or restore calls.-cachingStarts :: TCM ()+{-# SPECIALIZE cachingStarts :: TCM () #-}+cachingStarts :: (MonadDebug m, MonadTCState m, ReadTCState m) => m () cachingStarts = do-    NameId _ m <- use stFreshNameId-    stFreshNameId .= NameId 1 m+    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+            OpaqueId _ m'' = stPostFreshOpaqueId s+            stale = or [ m' /= m, m'' /= m ]+          when stale cleanCachedLog+        _ -> return () +areWeCaching :: (ReadTCState m) => m Bool+areWeCaching = useR stAreWeCaching+ -- | Writes a 'TypeCheckAction' to the current log, using the current -- 'PostScopeState'-writeToCurrentLog :: TypeCheckAction -> TCM ()+{-# SPECIALIZE writeToCurrentLog :: TypeCheckAction -> TCM () #-}+writeToCurrentLog :: (MonadDebug m, MonadTCState m, ReadTCState m) => TypeCheckAction -> m () writeToCurrentLog !d = do   reportSLn "cache" 10 $ "cachePostScopeState"-  !l <- gets stPostScopeState+  !l <- getsTC stPostScopeState   modifyCache $ fmap $ \lfc -> lfc{ lfcCurrent = (d, l) : lfcCurrent lfc} -restorePostScopeState :: PostScopeState -> TCM ()+{-# SPECIALIZE restorePostScopeState :: PostScopeState -> TCM () #-}+restorePostScopeState :: (MonadDebug m, MonadTCState m) => PostScopeState -> m () restorePostScopeState pss = do   reportSLn "cache" 10 $ "restorePostScopeState"-  modify $ \s ->-    let ipoints = s^.stInteractionPoints-        pss' = pss{stPostInteractionPoints = stPostInteractionPoints pss `mergeIPMap` ipoints}+  modifyTC $ \s ->+    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-    mergeIPMap lm sm = Map.mapWithKey (\k v -> maybe v (`mergeIP` v) (Map.lookup k lm)) sm-    mergeIP li si = si {ipMeta = ipMeta li}+    mergeIPMap lm sm = BiMap.mapWithKey (\k v -> maybe v (`mergeIP` v) (BiMap.lookup k lm)) sm+    -- see #1338 on why we need to use the new ranges.+    mergeIP li si = li { ipRange = ipRange si } +    mergeWarnings loading current = Set.filter (not . tcWarningCached) current+                        `Set.union` Set.filter (      tcWarningCached) loading++{-# SPECIALIZE modifyCache :: (Maybe LoadedFileCache -> Maybe LoadedFileCache) -> TCM () #-} modifyCache-  :: (Maybe LoadedFileCache -> Maybe LoadedFileCache)-  -> TCM ()-modifyCache f = do-  modify $ \s -> let !p = stPersistentState s in s-    { stPersistentState =-                          p { stLoadedFileCache = f (stLoadedFileCache p)}-    }+  :: MonadTCState m+  => (Maybe LoadedFileCache -> Maybe LoadedFileCache)+  -> m ()+modifyCache = modifyTCLens stLoadedFileCache -getCache :: TCM (Maybe LoadedFileCache)-getCache = do-  gets (stLoadedFileCache . stPersistentState)+{-# SPECIALIZE getCache :: TCM (Maybe LoadedFileCache) #-}+getCache :: ReadTCState m => m (Maybe LoadedFileCache)+getCache = useTC stLoadedFileCache -putCache :: Maybe LoadedFileCache -> TCM ()-putCache cs = modifyCache $ const cs+{-# SPECIALIZE putCache :: Maybe LoadedFileCache -> TCM () #-}+putCache :: MonadTCState m => Maybe LoadedFileCache -> m ()+putCache = setTCLens stLoadedFileCache +-- | Runs the action and restores the current cache at the end of it.+{-# SPECIALIZE localCache :: TCM a -> TCM a #-}+localCache :: (MonadTCState m, ReadTCState m) => m a -> m a+localCache = bracket_ getCache putCache++-- | Runs the action without cache and restores the current cache at+-- the end of it.+{-# SPECIALIZE withoutCache :: TCM a -> TCM a #-}+withoutCache :: (MonadTCState m, ReadTCState m) => m a -> m a+withoutCache m = localCache $ do+    putCache empty+    m+ -- | Reads the next entry in the cached type check log, if present.-readFromCachedLog :: TCM (Maybe (TypeCheckAction, PostScopeState))+{-# SPECIALIZE readFromCachedLog :: TCM (Maybe (TypeCheckAction, PostScopeState)) #-}+readFromCachedLog :: (MonadDebug m, MonadTCState m, ReadTCState m) => m (Maybe (TypeCheckAction, PostScopeState)) readFromCachedLog = do   reportSLn "cache" 10 $ "getCachedTypeCheckAction"-  mbCache <- getCache-  case mbCache of+  getCache >>= \case     Just lfc | (entry : entries) <- lfcCached lfc -> do       putCache $ Just lfc{lfcCached = entries}       return (Just entry)@@ -83,7 +126,8 @@       return Nothing  -- | Empties the "to read" CachedState. To be used when it gets invalid.-cleanCachedLog :: TCM ()+{-# SPECIALIZE cleanCachedLog :: TCM () #-}+cleanCachedLog :: (MonadDebug m, MonadTCState m) => m () cleanCachedLog = do   reportSLn "cache" 10 $ "cleanCachedLog"   modifyCache $ fmap $ \lfc -> lfc{lfcCached = []}@@ -92,20 +136,22 @@ -- current log. Crashes is 'stLoadedFileCache' is already active with a -- dirty log.  Should be called when we start typechecking the current -- file.-activateLoadedFileCache :: TCM ()+{-# SPECIALIZE activateLoadedFileCache :: TCM () #-}+activateLoadedFileCache :: (HasOptions m, MonadDebug m, MonadTCState m) => m () activateLoadedFileCache = do   reportSLn "cache" 10 $ "activateLoadedFileCache"-  b <- enableCaching-  if not b then return ()-     else do-       modifyCache $ \mbLfc -> case mbLfc of++  whenM (optGHCiInteraction <$> commandLineOptions) $+    whenM enableCaching $ do+      modifyCache $ \case          Nothing                          -> Just $ LoadedFileCache [] []          Just lfc | null (lfcCurrent lfc) -> Just lfc          _                                -> __IMPOSSIBLE__  -- | Caches the current type check log.  Discardes the old cache.  Does -- nothing if caching is inactive.-cacheCurrentLog :: TCM ()+{-# SPECIALIZE cacheCurrentLog :: TCM () #-}+cacheCurrentLog :: (MonadDebug m, MonadTCState m) => m () cacheCurrentLog = do   reportSLn "cache" 10 $ "cacheCurrentTypeCheckLog"   modifyCache $ fmap $ \lfc ->
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@@ -5,17 +7,23 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Monad.Context -enterClosure :: Closure a -> (a -> TCM b) -> TCM b-enterClosure (Closure sig env scope pars x) k =-    withScope_ scope-    $ withEnv env-    $ withModuleParameters pars+import Agda.Utils.Lens++{-# 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+  withScope_ scope+    $ locallyTCState stModuleCheckpoints (const cps)+    $ withEnv env{ envIsDebugPrinting = isDbg }     $ k x -withClosure :: Closure a -> (a -> TCM b) -> TCM (Closure b)+{-# INLINE withClosure  #-}+withClosure :: (MonadTCEnv m, ReadTCState m) => Closure a -> (a -> m b) -> m (Closure b) withClosure cl k = enterClosure cl $ k >=> buildClosure -mapClosure :: (a -> TCM b) -> Closure a -> TCM (Closure b)-mapClosure k cl = 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
@@ -1,98 +1,88 @@-{-# LANGUAGE CPP #-}  module Agda.TypeChecking.Monad.Constraints where  import Control.Arrow ((&&&))-import Control.Applicative-import Control.Monad.State+import Control.Monad.Except import Control.Monad.Reader -import Data.List as List+import qualified Data.Foldable as Fold+import qualified Data.List as List+import Data.Set (Set)+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-import Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.Debug  import Agda.Utils.Lens-import Agda.Utils.List import Agda.Utils.Monad-import Agda.Utils.Except -#include "undefined.h"-import Agda.Utils.Impossible---- | Get the current problem-currentProblem :: TCM ProblemId-currentProblem = headWithDefault 0 <$> asks envActiveProblems---- | Steal all constraints belonging to the given problem and add them to the current problem.-stealConstraints :: ProblemId -> TCM ()-stealConstraints pid = do-  current <- currentProblem-  reportSLn "tc.constr.steal" 50 $ "problem " ++ show current ++ " is stealing problem " ++ show pid ++ "'s constraints!"-  -- Rename @pid@ to @current@ in all constraints.-  let rename pc@(PConstr pids c) | elem pid pids = PConstr (current : pids) c-                                 | otherwise     = pc-  -- We should never steal from an active problem.-  whenM (elem pid <$> asks envActiveProblems) __IMPOSSIBLE__-  modifyAwakeConstraints    $ List.map rename-  modifySleepingConstraints $ List.map rename--solvingProblem :: ProblemId -> TCM a -> TCM a-solvingProblem pid = solvingProblems [pid]+solvingProblem :: MonadConstraint m => ProblemId -> m a -> m a+solvingProblem pid = solvingProblems (Set.singleton pid) -solvingProblems :: [ProblemId] -> TCM a -> TCM a-solvingProblems pids m = verboseBracket "tc.constr.solve" 50 ("working on problems " ++ show pids) $ do-  x <- local (\e -> e { envActiveProblems = pids ++ envActiveProblems e }) m-  sequence_-    [ ifNotM (isProblemSolved pid)+solvingProblems :: MonadConstraint m => Set ProblemId -> m a -> m a+solvingProblems pids m = verboseBracket "tc.constr.solve" 50 ("working on problems " ++ show (Set.toList pids)) $ do+  x <- localTC (\e -> e { envActiveProblems = pids `Set.union` envActiveProblems e }) m+  Fold.forM_ pids $ \ pid -> do+    ifNotM (isProblemSolved pid)         (reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was not solved.")       $ {- else -} do         reportSLn "tc.constr.solve" 50 $ "problem " ++ show pid ++ " was solved!"-        wakeConstraints (return . blockedOn pid . clValue . theConstraint)-    | pid <- pids ]+        wakeConstraints (wakeIfBlockedOnProblem pid . constraintUnblocker)   return x-  where-    blockedOn pid (Guarded _ pid') = pid == pid'-    blockedOn _ _ = False -isProblemSolved :: ProblemId -> TCM Bool-isProblemSolved pid =-  and2M (notElem pid <$> asks envActiveProblems)-        (all (notElem pid . constraintProblems) <$> getAllConstraints)+isProblemSolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool+isProblemSolved = isProblemSolved' False -getConstraintsForProblem :: ProblemId -> TCM Constraints-getConstraintsForProblem pid = List.filter (elem pid . constraintProblems) <$> getAllConstraints+isProblemCompletelySolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool+isProblemCompletelySolved = isProblemSolved' True --- | Get the awake constraints-getAwakeConstraints :: TCM Constraints-getAwakeConstraints = use stAwakeConstraints+isProblemSolved' :: (MonadTCEnv m, ReadTCState m) => Bool -> ProblemId -> m Bool+isProblemSolved' completely pid =+  and2M (not . Set.member pid <$> asksTC envActiveProblems)+        (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` -wakeConstraints :: (ProblemConstraint-> TCM Bool) -> TCM ()-wakeConstraints wake = do-  c <- use stSleepingConstraints-  (wakeup, sleepin) <- partitionM wake c-  reportSLn "tc.constr.wake" 50 $-    "waking up         " ++ show (List.map constraintProblems wakeup) ++ "\n" ++-    "  still sleeping: " ++ show (List.map constraintProblems sleepin)-  modifySleepingConstraints $ const sleepin-  modifyAwakeConstraints (++ wakeup)+{-# SPECIALIZE getConstraintsForProblem :: ProblemId -> TCM Constraints #-}+getConstraintsForProblem :: ReadTCState m => ProblemId -> m Constraints+getConstraintsForProblem pid = List.filter (Set.member pid . constraintProblems) <$> getAllConstraints +-- | Get the awake constraints+getAwakeConstraints :: ReadTCState m => m Constraints+getAwakeConstraints = useR stAwakeConstraints+ -- danger...-dropConstraints :: (ProblemConstraint -> Bool) -> TCM ()+dropConstraints :: MonadConstraint m => (ProblemConstraint -> Bool) -> m () dropConstraints crit = do   let filt = List.filter $ not . crit   modifySleepingConstraints filt   modifyAwakeConstraints    filt -putConstraintsToSleep :: (ProblemConstraint -> Bool) -> TCM ()+-- | Takes out all constraints matching given filter.+--   Danger!  The taken constraints need to be solved or put back at some point.+takeConstraints :: MonadConstraint m => (ProblemConstraint -> Bool) -> m Constraints+takeConstraints f = do+  (takeAwake , keepAwake ) <- List.partition f <$> useTC stAwakeConstraints+  (takeAsleep, keepAsleep) <- List.partition f <$> useTC stSleepingConstraints+  modifyAwakeConstraints    $ const keepAwake+  modifySleepingConstraints $ const keepAsleep+  return $ takeAwake ++ takeAsleep++putConstraintsToSleep :: MonadConstraint m => (ProblemConstraint -> Bool) -> m () putConstraintsToSleep sleepy = do-  awakeOnes <- use stAwakeConstraints-  let (gotoSleep, stayAwake) = partition sleepy awakeOnes+  awakeOnes <- useR stAwakeConstraints+  let (gotoSleep, stayAwake) = List.partition sleepy awakeOnes   modifySleepingConstraints $ (++ gotoSleep)   modifyAwakeConstraints    $ const stayAwake -putAllConstraintsToSleep :: TCM ()+putAllConstraintsToSleep :: MonadConstraint m => m () putAllConstraintsToSleep = putConstraintsToSleep (const True)  data ConstraintStatus = AwakeConstraint | SleepingConstraint@@ -103,76 +93,168 @@ --   by events that would normally trigger a wakeup call. holdConstraints :: (ConstraintStatus -> ProblemConstraint -> Bool) -> TCM a -> TCM a holdConstraints p m = do-  (holdAwake, stillAwake)   <- partition (p AwakeConstraint)    <$> use stAwakeConstraints-  (holdAsleep, stillAsleep) <- partition (p SleepingConstraint) <$> use stSleepingConstraints-  stAwakeConstraints    .= stillAwake-  stSleepingConstraints .= stillAsleep+  (holdAwake, stillAwake)   <- List.partition (p AwakeConstraint)    <$> useTC stAwakeConstraints+  (holdAsleep, stillAsleep) <- List.partition (p SleepingConstraint) <$> useTC stSleepingConstraints+  stAwakeConstraints    `setTCLens` stillAwake+  stSleepingConstraints `setTCLens` stillAsleep   let restore = do-        stAwakeConstraints    %= (holdAwake ++)-        stSleepingConstraints %= (holdAsleep ++)+        stAwakeConstraints    `modifyTCLens` (holdAwake ++)+        stSleepingConstraints `modifyTCLens` (holdAsleep ++)   catchError (m <* restore) (\ err -> restore *> throwError err) -takeAwakeConstraint :: TCM (Maybe ProblemConstraint)-takeAwakeConstraint = do+takeAwakeConstraint :: MonadConstraint m => m (Maybe ProblemConstraint)+takeAwakeConstraint = takeAwakeConstraint' (const True)++takeAwakeConstraint'+  :: MonadConstraint m+  => (ProblemConstraint -> Bool) -> m (Maybe ProblemConstraint)+takeAwakeConstraint' p = do   cs <- getAwakeConstraints-  case cs of-    []     -> return Nothing-    c : cs -> do-      modifyAwakeConstraints $ const cs+  case break p cs of+    (_, [])       -> return Nothing+    (cs0, c : cs) -> do+      modifyAwakeConstraints $ const (cs0 ++ cs)       return $ Just c -getAllConstraints :: TCM Constraints-getAllConstraints = gets $ \s -> s^.stAwakeConstraints ++ s^.stSleepingConstraints+getAllConstraints :: ReadTCState m => m Constraints+getAllConstraints = do+  s <- getTCState+  return $ s ^. stAwakeConstraints ++ s ^. stSleepingConstraints -withConstraint :: (Constraint -> TCM a) -> ProblemConstraint -> TCM a-withConstraint f (PConstr pids c) = do+withConstraint :: MonadConstraint m => (Constraint -> m a) -> ProblemConstraint -> m a+withConstraint f (PConstr pids _ c) = do   -- We should preserve the problem stack and the isSolvingConstraint flag-  (pids', isSolving) <- asks $ envActiveProblems &&& envSolvingConstraints+  (pids', isSolving) <- asksTC $ envActiveProblems &&& envSolvingConstraints   enterClosure c $ \c ->-    local (\e -> e { envActiveProblems = pids', envSolvingConstraints = isSolving }) $+    localTC (\e -> e { envActiveProblems = pids', envSolvingConstraints = isSolving }) $     solvingProblems pids (f c) -buildProblemConstraint :: [ProblemId] -> Constraint -> TCM ProblemConstraint-buildProblemConstraint pids c = PConstr pids <$> buildClosure c+buildProblemConstraint+  :: (MonadTCEnv m, ReadTCState m)+  => Set ProblemId -> Blocker -> Constraint -> m ProblemConstraint+buildProblemConstraint pids unblock c = PConstr pids unblock <$> buildClosure c -buildProblemConstraint_ :: Constraint -> TCM ProblemConstraint-buildProblemConstraint_ = buildProblemConstraint []+buildProblemConstraint_+  :: (MonadTCEnv m, ReadTCState m)+  => Blocker -> Constraint -> m ProblemConstraint+buildProblemConstraint_ = buildProblemConstraint Set.empty -buildConstraint :: Constraint -> TCM ProblemConstraint-buildConstraint c = flip buildProblemConstraint c . nub . filter (> 0) =<< asks envActiveProblems+buildConstraint :: Blocker -> Constraint -> TCM ProblemConstraint+buildConstraint unblock c = do+  pids <- asksTC envActiveProblems+  buildProblemConstraint pids unblock c +-- | Monad service class containing methods for adding and solving+--   constraints+class ( MonadTCEnv m+      , ReadTCState m+      , MonadError TCErr m+      , MonadBlock m+      , HasOptions m+      , MonadDebug m+      ) => MonadConstraint m where+  -- | Unconditionally add the constraint.+  addConstraint :: Blocker -> Constraint -> m ()++  -- | Add constraint as awake constraint.+  addAwakeConstraint :: Blocker -> Constraint -> m ()++  solveConstraint :: Constraint -> m ()++  -- | Solve awake constraints matching the predicate. If the second argument is+  --   True solve constraints even if already 'isSolvingConstraints'.+  solveSomeAwakeConstraints :: (ProblemConstraint -> Bool) -> Bool -> m ()++  wakeConstraints :: (ProblemConstraint-> WakeUp) -> m ()++  stealConstraints :: ProblemId -> m ()++  modifyAwakeConstraints :: (Constraints -> Constraints) -> m ()++  modifySleepingConstraints  :: (Constraints -> Constraints) -> m ()++instance MonadConstraint m => MonadConstraint (ReaderT e m) where+  addConstraint             = (lift .) . addConstraint+  addAwakeConstraint        = (lift .) . addAwakeConstraint+  solveConstraint           = lift . solveConstraint+  solveSomeAwakeConstraints = (lift .) . solveSomeAwakeConstraints+  stealConstraints          = lift . stealConstraints+  modifyAwakeConstraints    = lift . modifyAwakeConstraints+  modifySleepingConstraints = lift . modifySleepingConstraints+  wakeConstraints = lift . wakeConstraints+ -- | Add new a constraint-addConstraint' :: Constraint -> TCM ()-addConstraint' c = do-    pc <- build-    stDirty .= True-    stSleepingConstraints %= (pc :)-  where-    build | isBlocking c = buildConstraint c-          | otherwise    = buildProblemConstraint_ c-    isBlocking SortCmp{}     = False-    isBlocking LevelCmp{}    = False-    isBlocking ValueCmp{}    = True-    isBlocking ElimCmp{}     = True-    isBlocking TypeCmp{}     = True-    isBlocking TelCmp{}      = True-    isBlocking (Guarded c _) = isBlocking c-    isBlocking UnBlock{}     = True-    isBlocking FindInScope{} = False-    isBlocking IsEmpty{}     = True-    isBlocking CheckSizeLtSat{} = True+addConstraint' :: Blocker -> Constraint -> TCM ()+addConstraint' = addConstraintTo stSleepingConstraints --- | Add already awake constraints-addAwakeConstraints :: Constraints -> TCM ()-addAwakeConstraints cs = modifyAwakeConstraints (cs ++)+addAwakeConstraint' :: Blocker -> Constraint -> TCM ()+addAwakeConstraint' = addConstraintTo stAwakeConstraints +addConstraintTo :: Lens' TCState Constraints -> Blocker -> Constraint -> TCM ()+addConstraintTo bucket unblock c = do+    pc <- buildConstraint unblock c+    stDirty `setTCLens` True+    bucket `modifyTCLens` (pc :)++-- | 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 :: TCM a -> TCM a-nowSolvingConstraints = local $ \e -> e { envSolvingConstraints = True }+nowSolvingConstraints :: MonadTCEnv m => m a -> m a+nowSolvingConstraints = localTC $ \e -> e { envSolvingConstraints = True } -isSolvingConstraints :: TCM Bool-isSolvingConstraints = asks envSolvingConstraints+isSolvingConstraints :: MonadTCEnv m => m Bool+isSolvingConstraints = asksTC envSolvingConstraints +-- | 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 ---------------------------------------------------------------------------@@ -182,9 +264,3 @@  mapSleepingConstraints :: (Constraints -> Constraints) -> TCState -> TCState mapSleepingConstraints = over stSleepingConstraints--modifyAwakeConstraints  :: (Constraints -> Constraints) -> TCM ()-modifyAwakeConstraints = modify . mapAwakeConstraints--modifySleepingConstraints  :: (Constraints -> Constraints) -> TCM ()-modifySleepingConstraints = modify . mapSleepingConstraints
src/full/Agda/TypeChecking/Monad/Context.hs view
@@ -1,340 +1,594 @@-{-# LANGUAGE CPP               #-} -#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif- module Agda.TypeChecking.Monad.Context where -import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as T++import Control.Monad                ( (<=<), forM, when )+import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe+import Control.Monad.Writer         ( WriterT ) -import Data.List hiding (sort)-import Data.Map (Map)+import Data.Foldable+import qualified Data.List as List import qualified Data.Map as Map-import Data.Monoid  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.Scope.Monad (getLocalVars, setLocalVars)+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base  import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad.Open-import Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.State -import Agda.Utils.Except ( MonadError(catchError) )+import Agda.Utils.Function import Agda.Utils.Functor+import Agda.Utils.Lens import Agda.Utils.List ((!!!), downFrom)+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.Size-import Agda.Utils.Lens---- * Modifying the context+import Agda.Utils.Tuple+import Agda.Utils.Update --- | Modify the 'ctxEntry' field of a 'ContextEntry'.-modifyContextEntry :: (Dom (Name, Type) -> Dom (Name, Type)) -> ContextEntry -> ContextEntry-modifyContextEntry f ce = ce { ctxEntry = f (ctxEntry ce) }+import Agda.Utils.Impossible --- | Modify all 'ContextEntry's.-modifyContextEntries :: (Dom (Name, Type) -> Dom (Name, Type)) -> Context -> Context-modifyContextEntries f = map (modifyContextEntry f)+-- * Modifying the context --- | Modify a 'Context' in a computation.-{-# SPECIALIZE modifyContext :: (Context -> Context) -> TCM a -> TCM a #-}-modifyContext :: MonadTCM tcm => (Context -> Context) -> tcm a -> tcm a-modifyContext f = local $ \e -> e { envContext = f $ envContext e }+-- | Modify a 'Context' in a computation.  Warning: does not update+--   the checkpoints. Use @updateContext@ instead.+{-# INLINE unsafeModifyContext #-}+unsafeModifyContext :: MonadTCEnv tcm => (Context -> Context) -> tcm a -> tcm a+unsafeModifyContext f = localTC $ \e -> e { envContext = f $ envContext e } -{-# SPECIALIZE mkContextEntry :: Dom (Name, Type) -> TCM ContextEntry #-}-mkContextEntry :: MonadTCM tcm => Dom (Name, Type) -> tcm ContextEntry-mkContextEntry x = do-  i <- fresh-  return $ Ctx i x+{-# 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 $ \case+    (CtxVar x a)   -> CtxVar x (f a) --- | Change to top (=empty) context.------   TODO: currently, this makes the @ModuleParamDict@ ill-formed!+-- | Change to top (=empty) context. Resets the checkpoints. {-# SPECIALIZE inTopContext :: TCM a -> TCM a #-}-inTopContext :: MonadTCM tcm => tcm a -> tcm a-inTopContext cont = do-  locals <- liftTCM $ getLocalVars-  liftTCM $ setLocalVars []-  a <- modifyContext (const []) cont-  liftTCM $ setLocalVars locals-  return a+inTopContext :: (MonadTCEnv tcm, ReadTCState tcm) => tcm a -> tcm a+inTopContext cont =+  unsafeModifyContext (const [])+        $ locallyTC eCurrentCheckpoint (const 0)+        $ locallyTC eCheckpoints (const $ Map.singleton 0 IdS)+        $ locallyTCState stModuleCheckpoints (const Map.empty)+        $ locallyScope scopeLocals (const [])+        $ locallyTC eLetBindings (const Map.empty)+        $ cont +-- | Change to top (=empty) context, but don't update the checkpoints. Totally+--   not safe!+{-# SPECIALIZE unsafeInTopContext :: TCM a -> TCM a #-}+unsafeInTopContext :: (MonadTCEnv m, ReadTCState m) => m a -> m a+unsafeInTopContext cont =+  locallyScope scopeLocals (const []) $+    unsafeModifyContext (const []) cont+ -- | Delete the last @n@ bindings from the context. -----   TODO: currently, this makes the @ModuleParamDict@ ill-formed!-{-# SPECIALIZE escapeContext :: Int -> TCM a -> TCM a #-}-escapeContext :: MonadTCM tcm => Int -> tcm a -> tcm a-escapeContext n = modifyContext $ drop n+--   Doesn't update checkpoints! Use `escapeContext` or `updateContext+--   rho (drop n)` instead, for an appropriate substitution `rho`.+{-# SPECIALIZE unsafeEscapeContext :: Int -> TCM a -> TCM a #-}+unsafeEscapeContext :: MonadTCM tcm => Int -> tcm a -> tcm a+unsafeEscapeContext n = unsafeModifyContext $ drop n --- * Manipulating module parameters --+{-# 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+escapeContext err n = updateContext (strengthenS err n) $ drop n --- | Locally set module parameters for a computation.+-- * Manipulating checkpoints -- -withModuleParameters :: ModuleParamDict -> TCM a -> TCM a-withModuleParameters mp ret = do-  old <- use stModuleParameters-  stModuleParameters .= mp-  x <- ret-  stModuleParameters .= old+{-# 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)+  => Substitution -> tcm a -> tcm a+checkpoint sub k = do+  unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 $ "New checkpoint {"+  old     <- viewTC eCurrentCheckpoint+  oldMods <- useTC  stModuleCheckpoints+  chkpt <- fresh+  unlessDebugPrinting $ verboseS "tc.cxt.checkpoint" 105 $ do+    cxt <- getContextTelescope+    cps <- viewTC eCheckpoints+    let cps' = Map.insert chkpt IdS $ fmap (applySubst sub) cps+        prCps cps = vcat [ pshow c <+> ": " <+> pretty s | (c, s) <- Map.toList cps ]+    reportSDoc "tc.cxt.checkpoint" 105 $ return $ nest 2 $ vcat+      [ "old =" <+> pshow old+      , "new =" <+> pshow chkpt+      , "sub =" <+> pretty sub+      , "cxt =" <+> pretty cxt+      , "old substs =" <+> prCps cps+      , "new substs =" <?> prCps cps'+      ]+  x <- flip localTC k $ \ env -> env+    { envCurrentCheckpoint = chkpt+    , envCheckpoints       = Map.insert chkpt IdS $+                              fmap (applySubst sub) (envCheckpoints env)+    }+  newMods <- useTC stModuleCheckpoints+  -- Set the checkpoint for introduced modules to the old checkpoint when the+  -- new one goes out of scope. #2897: This isn't actually sound for modules+  -- 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 <$ newMods)+  unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 "}"   return x --- | Apply a substitution to all module parameters.--updateModuleParameters :: MonadTCM tcm => Substitution -> tcm a -> tcm a-updateModuleParameters sub ret = do-  pm <- use stModuleParameters-  let showMP pref mps = intercalate "\n" $-        [ p ++ show m ++ " : " ++ show (mpSubstitution mp)-        | (p, (m, mp)) <- zip (pref : repeat (map (const ' ') pref))-                              (Map.toList mps)-        ]-  cxt <- reverse <$> getContext-  reportSLn "tc.cxt.param" 90 $ unlines $-    [ "updatingModuleParameters"-    , "  sub = " ++ show sub-    , "  cxt = " ++ unwords (map (show . fst . unDom) cxt)-    , showMP "  old = " pm-    ]-  let pm' = applySubst sub pm-  reportSLn "tc.cxt.param" 90 $ showMP "  new = " pm'-  stModuleParameters .= pm'-  x <- ret              -- We need to keep introduced modules around-  pm1 <- use stModuleParameters-  let pm'' = Map.union pm (defaultModuleParameters <$ Map.difference pm1 pm)-  stModuleParameters .= pm''-  reportSLn "tc.cxt.param" 90 $ showMP "  restored = " pm''-  return x+-- | Get the substitution from the context at a given checkpoint to the current context.+checkpointSubstitution :: MonadTCEnv tcm => CheckpointId -> tcm Substitution+checkpointSubstitution = maybe __IMPOSSIBLE__ return <=< checkpointSubstitution' --- | Since the @ModuleParamDict@ is relative to the current context,---   this function should be called everytime the context is extended.----weakenModuleParameters :: MonadTCM tcm => Nat -> tcm a -> tcm a-weakenModuleParameters n = updateModuleParameters (raiseS n)+-- | Get the substitution from the context at a given checkpoint to the current context.+checkpointSubstitution' :: MonadTCEnv tcm => CheckpointId -> tcm (Maybe Substitution)+checkpointSubstitution' chkpt = viewTC (eCheckpoints . key chkpt)  -- | Get substitution @Γ ⊢ ρ : Γm@ where @Γ@ is the current context --   and @Γm@ is the module parameter telescope of module @m@. -----   In case the current 'ModuleParamDict' does not know @m@,---   we return the identity substitution.---   This is ok for instance if we are outside module @m@---   (in which case we have to supply all module parameters to any---   symbol defined within @m@ we want to refer).-getModuleParameterSub :: MonadTCM tcm => ModuleName -> tcm Substitution+--   Returns @Nothing@ in case the we don't have a checkpoint for @m@.+getModuleParameterSub :: (MonadTCEnv m, ReadTCState m) => ModuleName -> m (Maybe Substitution) getModuleParameterSub m = do-  r <- use stModuleParameters-  case Map.lookup m r of-    Nothing -> return IdS-    Just mp -> return $ mpSubstitution mp+  mcp <- (^. stModuleCheckpoints . key m) <$> getTCState+  traverse checkpointSubstitution mcp   -- * Adding to the context --- | @addCtx x arg cont@ add a variable to the context.------   Chooses an unused 'Name'.------   Warning: Does not update module parameter substitution!-{-# SPECIALIZE addCtx :: Name -> Dom Type -> TCM a -> TCM a #-}-addCtx :: MonadTCM tcm => Name -> Dom Type -> tcm a -> tcm a-addCtx x a ret = do-  ce <- mkContextEntry $ (x,) <$> a-  modifyContext (ce :) ret-      -- let-bindings keep track of own their context+class MonadTCEnv m => MonadAddContext m where+  -- | @addCtx x arg cont@ add a variable to the context.+  --+  --   Chooses an unused 'Name'.+  --+  --   Warning: Does not update module parameter substitution!+  addCtx :: Name -> Dom Type -> m a -> m a --- | Pick a concrete name that doesn't shadow anything in the context.-unshadowName :: MonadTCM tcm => Name -> tcm Name-unshadowName x = do-  ctx <- map (nameConcrete . fst . unDom) <$> getContext-  return $ head $ filter (notTaken ctx) $ iterate nextName x-  where-    notTaken xs x = isNoName x || nameConcrete x `notElem` xs+  -- | Add a let bound variable to the context+  addLetBinding' :: Origin -> Name -> Term -> Dom Type -> m a -> m a +  -- | Update the context.+  --   Requires a substitution that transports things living in the old context+  --   to the new.+  updateContext :: Substitution -> (Context -> Context) -> m a -> m a++  withFreshName :: Range -> ArgName -> (Name -> m a) -> m a++  default addCtx+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Dom Type -> m a -> m a+  addCtx x a = liftThrough $ addCtx x a++  default addLetBinding'+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => 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)+    => Substitution -> (Context -> Context) -> m a -> m a+  updateContext sub f = liftThrough $ updateContext sub f++  default withFreshName+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Range -> ArgName -> (Name -> m a) -> m a+  withFreshName r x cont = do+    st <- liftWith $ \ run -> do+      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) (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)+instance MonadAddContext m => MonadAddContext (ReaderT r m)+instance MonadAddContext m => MonadAddContext (StateT r m)+instance (Monoid w, MonadAddContext m) => MonadAddContext (WriterT w m)+deriving instance MonadAddContext m => MonadAddContext (BlockT m)++instance MonadAddContext m => MonadAddContext (ListT m) where+  addCtx x a             = liftListT $ addCtx x 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++-- | Run the given TCM action, and register the given variable as+--   being shadowed by all the names with the same root that are added+--   to the context during this TCM action.+withShadowingNameTCM :: Name -> TCM b -> TCM b+withShadowingNameTCM x f = do+  reportSDoc "tc.cxt.shadowing" 80 $ pure $ "registered" <+> pretty x <+> "for shadowing"+  when (isInScope x == InScope) $ tellUsedName x+  (result , useds) <- listenUsedNames f+  reportSDoc "tc.cxt.shadowing" 90 $ pure $ "all used names: " <+> text (show useds)+  tellShadowing x useds+  return result++    where+      listenUsedNames f = do+        origUsedNames <- useTC stUsedNames+        setTCLens stUsedNames Map.empty+        result <- f+        newUsedNames <- useTC stUsedNames+        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 . (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 $ 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' o x u a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $+    defaultAddLetBinding' o x u a ret++  updateContext sub f = unsafeModifyContext f . checkpoint sub++  withFreshName r x m = freshName r x >>= m++addRecordNameContext+  :: (MonadAddContext m, MonadFresh NameId m)+  => Dom Type -> m b -> m b+addRecordNameContext dom ret = do+  x <- setNotInScope <$> freshRecordName+  addCtx x dom ret+ -- | Various specializations of @addCtx@.-{-# SPECIALIZE addContext :: b -> TCM a -> TCM a #-} class AddContext b where-  addContext  :: MonadTCM tcm => b -> tcm a -> tcm a+  addContext :: (MonadAddContext m) => b -> m a -> m a   contextSize :: b -> Nat --- | Since the module parameter substitution is relative to---   the current context, we need to weaken it when we---   extend the context.  This function takes care of that.----addContext' :: (MonadTCM tcm, AddContext b) => b -> tcm a -> tcm a-addContext' cxt = addContext cxt . weakenModuleParameters (contextSize cxt)+-- | Wrapper to tell 'addContext' not to mark names as+--   'NotInScope'. Used when adding a user-provided, but already type+--   checked, telescope to the context.+newtype KeepNames a = KeepNames a -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where-#else-instance AddContext a => AddContext [a] where-#endif-  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-  -- addContext dom = addCtx (fst $ unDom dom) (snd <$> dom)   contextSize _ = 1 +instance AddContext (Dom (String, Type)) where+  addContext = addContext . distributeF+  contextSize _ = 1+ instance AddContext ([Name], Dom Type) where   addContext (xs, dom) = addContext (bindsToTel' id xs dom)   contextSize (xs, _) = length xs +instance AddContext (List1 Name, Dom Type) where+  addContext (xs, dom) = addContext (bindsToTel'1 id xs dom)+  contextSize (xs, _) = length xs+ instance AddContext ([WithHiding Name], Dom Type) where-  addContext ([]                 , dom) = id-  addContext (WithHiding h x : xs, dom) =+  addContext ([]    , dom) = id+  addContext (x : xs, dom) = addContext (x :| xs, dom)+  contextSize (xs, _) = length xs++instance AddContext (List1 (WithHiding Name), Dom Type) where+  addContext (WithHiding h x :| xs, dom) =     addContext (x , mapHiding (mappend h) dom) .     addContext (xs, raise 1 dom)   contextSize (xs, _) = length xs +instance AddContext ([Arg Name], Type) where+  addContext (xs, t) = addContext ((map . fmap) unnamed xs :: [NamedArg Name], t)+  contextSize (xs, _) = length xs++instance AddContext (List1 (Arg Name), Type) where+  addContext (xs, t) = addContext ((fmap . fmap) unnamed xs :: List1 (NamedArg Name), t)+  contextSize (xs, _) = length xs++instance AddContext ([NamedArg Name], Type) where+  addContext ([], _)     = id+  addContext (x : xs, t) = addContext (x :| xs, t)+  contextSize (xs, _) = length xs++instance AddContext (List1 (NamedArg Name), Type) where+  addContext (x :| xs, t) =+    addContext (namedArg x, t <$ domFromNamedArgName x) .+    addContext (xs, raise 1 t)+  contextSize (xs, _) = length xs+ instance AddContext (String, Dom Type) where-  addContext (s, dom) ret = do-    x <- unshadowName =<< freshName_ s-    addCtx x dom ret+  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 (Dom (String, Type)) where-  addContext = addContext . distributeF-  -- addContext dom = addContext (fst $ unDom dom, snd <$> dom)+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 ("_", dom)+  addContext dom = addContext ("_" :: String, dom)   contextSize _ = 1  instance AddContext Name where-  addContext x = addContext (x, dummyDom)+  addContext x = addContext (x, __DUMMY_DOM__)   contextSize _ = 1 -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} AddContext String where-#else-instance AddContext String where-#endif-  addContext s = addContext (s, dummyDom)+  addContext s = addContext (s, __DUMMY_DOM__)   contextSize _ = 1 +instance AddContext (KeepNames Telescope) where+  addContext (KeepNames tel) ret = loop tel where+    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 t tel loop+    loop (ExtendTel t tel) = underAbstraction' id t tel loop   contextSize = size+{-# SPECIALIZE addContext :: Telescope -> TCM a -> TCM a #-} --- | Context entries without a type have this dummy type.-dummyDom :: Dom Type-dummyDom = defaultDom typeDontCare+-- | 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 #-}+underAbstraction :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b+underAbstraction = underAbstraction' id --- | Go under an abstraction.-{-# SPECIALIZE underAbstraction :: Subst t a => Dom Type -> Abs a -> (a -> TCM b) -> TCM b #-}-underAbstraction :: (Subst t a, MonadTCM tcm) => Dom Type -> Abs a -> (a -> tcm b) -> tcm b-underAbstraction _ (NoAbs _ v) k = k v-underAbstraction t a           k = do-    x <- unshadowName =<< freshName_ (realName $ absName a)-    addContext (x, t) $ k $ absBody a+underAbstraction' :: (Subst a, MonadAddContext m, AddContext (name, Dom Type)) =>+                     (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b+underAbstraction' _ _ (NoAbs _ v) k = k v+underAbstraction' wrap t a k = underAbstractionAbs' wrap t a k++-- | Go under an abstraction, treating 'NoAbs' as 'Abs'.+underAbstractionAbs :: (Subst a, MonadAddContext m) => Dom Type -> Abs a -> (a -> m b) -> m b+underAbstractionAbs = underAbstractionAbs' id++underAbstractionAbs'+  :: (Subst a, MonadAddContext m, AddContext (name, Dom Type))+  => (String -> name) -> Dom Type -> Abs a -> (a -> m b) -> m b+underAbstractionAbs' wrap t a k = addContext (wrap $ realName $ absName a, t) $ k $ absBody a   where     realName s = if isNoName s then "x" else argNameToString s  -- | Go under an abstract without worrying about the type to add to the context.-{-# SPECIALIZE underAbstraction_ :: Subst t a => Abs a -> (a -> TCM b) -> TCM b #-}-underAbstraction_ :: (Subst t a, MonadTCM tcm) => Abs a -> (a -> tcm b) -> tcm b-underAbstraction_ = underAbstraction dummyDom+{-# SPECIALIZE underAbstraction_ :: Subst a => Abs a -> (a -> TCM b) -> TCM b #-}+underAbstraction_ :: (Subst a, MonadAddContext m) => Abs a -> (a -> m b) -> m b+underAbstraction_ = underAbstraction __DUMMY_DOM__ --- | Add a let bound variable.-{-# SPECIALIZE addLetBinding :: ArgInfo -> Name -> Term -> Type -> TCM a -> TCM a #-}-addLetBinding :: MonadTCM tcm => ArgInfo -> Name -> Term -> Type -> tcm a -> tcm a-addLetBinding info x v t0 ret = do-    let t = Dom info t0-    vt <- liftTCM $ makeOpen (v, t)-    flip local ret $ \e -> e { envLetBindings = Map.insert x vt $ envLetBindings e }+-- | Map a monadic function on the thing under the abstraction, adding+--   the abstracted variable to the context.+mapAbstraction+  :: (Subst a, Subst b, MonadAddContext m)+  => Dom Type -> (a -> m b) -> Abs a -> m (Abs b)+mapAbstraction dom f x = (x $>) <$> underAbstraction dom x f +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++-- | Add a let bound variable+{-# 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 -> 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 :: MonadReader TCEnv m => m [Dom (Name, Type)]-getContext = asks $ map ctxEntry . envContext+{-# 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, MonadReader TCEnv m) => m Nat-getContextSize = genericLength <$> asks 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, MonadReader TCEnv m) => m Args-getContextArgs = reverse . zipWith mkArg [0..] <$> getContext-  where mkArg i (Dom info _) = Arg info $ var i+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, MonadReader TCEnv 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, MonadReader TCEnv m) => m Telescope-getContextTelescope = telFromList' nameToArgName . reverse <$> getContext+getContextTelescope :: (MonadTCEnv m) => m Telescope+getContextTelescope = contextToTel <$> getContext --- | Check if we are in a compatible context, i.e. an extension of the given context.-{-# SPECIALIZE getContextId :: TCM [CtxId] #-}-getContextId :: MonadReader TCEnv m => m [CtxId]-getContextId = asks $ map ctxId . envContext+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, MonadReader TCEnv 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 (Dom (Name, Type)) #-}-lookupBV :: MonadReader TCEnv m => Nat -> m (Dom (Name, Type))+lookupBV_ :: Nat -> Context -> Maybe ContextEntry+lookupBV_ n ctx = raise (n + 1) <$> ctx !!! n++{-# 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-  ctx <- getContext-  let failure = fail $ "de Bruijn index out of scope: " ++ show n ++-                       " in context " ++ show (map (fst . unDom) ctx)-  maybe failure (return . fmap (raise $ n + 1)) $ ctx !!! n+  let failure = do+        ctx <- getContext+        __IMPOSSIBLE_VERBOSE__ $ unwords+          [ "de Bruijn index out of scope:", show n+          , "in context", prettyShow $ map ctxEntryName ctx+          ]+  caseMaybeM (lookupBV' n) failure return -{-# SPECIALIZE typeOfBV' :: Nat -> TCM (Dom Type) #-}-typeOfBV' :: (Applicative m, MonadReader TCEnv m) => Nat -> m (Dom Type)-typeOfBV' n = fmap snd <$> lookupBV n+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 :: (MonadDebug m, MonadTCEnv m) => Nat -> m (Dom Type)+domOfBV n = ctxEntryDom <$> lookupBV n+ {-# SPECIALIZE typeOfBV :: Nat -> TCM Type #-}-typeOfBV :: (Applicative m, MonadReader TCEnv m) => Nat -> m Type-typeOfBV i = unDom <$> typeOfBV' i+typeOfBV :: (MonadDebug m, MonadTCEnv m) => Nat -> m Type+typeOfBV i = unDom <$> domOfBV i +{-# SPECIALIZE nameOfBV' :: Nat -> TCM (Maybe Name) #-}+nameOfBV' :: (MonadTCEnv m) => Nat -> m (Maybe Name)+nameOfBV' n = fmap ctxEntryName <$> lookupBV' n+ {-# SPECIALIZE nameOfBV :: Nat -> TCM Name #-}-nameOfBV :: (Applicative m, MonadReader TCEnv 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-#if __GLASGOW_HASKELL__ <= 708-  :: (Applicative m, MonadReader TCEnv m)-#else-  :: MonadReader TCEnv m-#endif-  => Name -> m (Term, Dom Type)+getVarInfo :: (MonadDebug m, MonadTCEnv m) => Name -> m (Term, Dom Type) getVarInfo x =-    do  ctx <- getContext-        def <- asks envLetBindings-        case findIndex ((==x) . fst . unDom) ctx of+    do  ctx <- getContextVars'+        def <- asksTC envLetBindings+        case List.findIndex ((== x) . unDom . snd) ctx of             Just n -> do-                t <- typeOfBV' n+                t <- domOfBV n                 return (var n, t)             _       ->                 case Map.lookup x def of-                    Just vt -> getOpen vt-                    _       -> fail $ "unbound variable " ++ show (nameConcrete 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,12 +1,50 @@-{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Context where  import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT ) -import Agda.Syntax.Common (Dom)+import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base -getContext   :: MonadReader TCEnv m => m [Dom (Name, Type)]-getContextId :: MonadReader TCEnv m => m [CtxId]+checkpointSubstitution :: MonadTCEnv tcm => CheckpointId -> tcm Substitution++class MonadTCEnv m => MonadAddContext m where+  addCtx :: Name -> 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++  default addCtx+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Name -> Dom Type -> m a -> m a+  addCtx x a = liftThrough $ addCtx x a++  default addLetBinding'+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => 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)+    => Substitution -> (Context -> Context) -> m a -> m a+  updateContext sub f = liftThrough $ updateContext sub f++  default withFreshName+    :: (MonadAddContext n, MonadTransControl t, t n ~ m)+    => Range -> ArgName -> (Name -> m a) -> m a+  withFreshName r x cont = do+    st <- liftWith $ \ run -> do+      withFreshName r x $ run . cont+    restoreT $ return st++instance MonadAddContext m => MonadAddContext (IdentityT m) where+instance MonadAddContext m => MonadAddContext (ReaderT r m) where+instance MonadAddContext m => MonadAddContext (StateT r m) where++instance MonadAddContext TCM
+ src/full/Agda/TypeChecking/Monad/Debug.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE CPP #-}++module Agda.TypeChecking.Monad.Debug+  ( module Agda.TypeChecking.Monad.Debug+  , Verbosity, VerboseKey, VerboseLevel+  ) where++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+import Control.Monad.State+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Identity+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 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.Syntax.Common.Pretty+import Agda.Utils.ProfileOptions+import Agda.Utils.Update+import qualified Agda.Utils.Trie as Trie++import Agda.Utils.Impossible++class (Functor m, Applicative m, Monad m) => MonadDebug m where++  formatDebugMessage :: VerboseKey -> VerboseLevel -> TCM Doc -> m String+  traceDebugMessage  :: VerboseKey -> VerboseLevel -> String -> m a -> m a++  -- | Print brackets around debug messages issued by a computation.+  verboseBracket     :: VerboseKey -> VerboseLevel -> String -> m a -> m a++  getVerbosity       :: m Verbosity+  getProfileOptions  :: m ProfileOptions++  -- | Check whether we are currently debug printing.+  isDebugPrinting    :: m Bool++  -- | Flag in a computation that we are currently debug printing.+  nowDebugPrinting   :: m a -> m a++  -- default implementation of transformed debug monad++  default formatDebugMessage+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => VerboseKey -> VerboseLevel -> TCM Doc -> m String+  formatDebugMessage k n d = lift $ formatDebugMessage k n d++  default traceDebugMessage+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => 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+  isDebugPrinting = lift isDebugPrinting++  default nowDebugPrinting+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => m a -> m a+  nowDebugPrinting = liftThrough nowDebugPrinting++-- Default implementations (working around the restriction to only+-- have one default signature).++defaultGetVerbosity :: HasOptions m => m Verbosity+defaultGetVerbosity = optVerbose <$> pragmaOptions++defaultGetProfileOptions :: HasOptions m => m ProfileOptions+defaultGetProfileOptions = optProfiling <$> pragmaOptions++defaultIsDebugPrinting :: MonadTCEnv m => m Bool+defaultIsDebugPrinting = asksTC envIsDebugPrinting++defaultNowDebugPrinting :: MonadTCEnv m => m a -> m a+defaultNowDebugPrinting = locallyTC eIsDebugPrinting $ const True++-- | Print a debug message if switched on.+displayDebugMessage :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()+displayDebugMessage k n s = traceDebugMessage k n s $ return ()++-- | During printing, catch internal errors of kind 'Impossible' and print them.+catchAndPrintImpossible+  :: (CatchImpossible m, Monad m)+  => VerboseKey -> VerboseLevel -> m String -> m String+catchAndPrintImpossible k n m = catchImpossibleJust catchMe m $ \ imposs -> do+  return $ render $ vcat+    [ text $ "Debug printing " ++ k ++ ":" ++ show n ++ " failed due to exception:"+    , vcat $ map (nest 2 . text) $ lines $ show imposs+    ]+  where+  -- Exception filter: Catch only the 'Impossible' exception during debug printing.+  catchMe :: Impossible -> Maybe Impossible+  catchMe = filterMaybe $ \case+    Impossible{}            -> True+    Unreachable{}           -> False+    ImpMissingDefinitions{} -> False++instance MonadDebug TCM where++  traceDebugMessage k n s cont = do+    -- Andreas, 2019-08-20, issue #4016:+    -- 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++    -- 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+      renderError err <&> \ s -> vcat+        [ sep $ map text+          [ "Printing debug message"+          , k  ++ ":" ++ show n+          , "failed due to error:"+          ]+        , 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+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting++-- MonadTrans default instances++deriving instance MonadDebug m => MonadDebug (BlockT m)  -- ghc <= 8.0, GeneralizedNewtypeDeriving+instance MonadDebug m => MonadDebug (ChangeT m)+instance MonadDebug m => MonadDebug (ExceptT e m)+instance MonadDebug m => MonadDebug (MaybeT m)+instance MonadDebug m => MonadDebug (ReaderT r m)+instance MonadDebug m => MonadDebug (StateT s m)+instance (MonadDebug m, Monoid w) => MonadDebug (WriterT w m)+instance MonadDebug m => MonadDebug (IdentityT m)++-- We are lacking MonadTransControl ListT++instance MonadDebug m => MonadDebug (ListT m) where+  traceDebugMessage k n s = liftListT $ traceDebugMessage k n s+  verboseBracket    k n s = liftListT $ verboseBracket k n s+  nowDebugPrinting        = liftListT nowDebugPrinting++-- | Debug print some lines if the verbosity level for the given+--   'VerboseKey' is at least 'VerboseLevel'.+--+-- Note: In the presence of @OverloadedStrings@, just+-- @@+--   reportS key level "Literate string"+-- @@+-- gives an @Ambiguous type variable@ error in @GHC@.+-- Use the legacy functions 'reportSLn' and 'reportSDoc' instead then.+--+class ReportS a where+  reportS :: MonadDebug m => VerboseKey -> VerboseLevel -> a -> m ()++instance ReportS (TCM Doc) where reportS = reportSDoc+instance ReportS String    where reportS = reportSLn++instance ReportS [TCM Doc] where reportS k n = reportSDoc k n . fmap vcat . sequence+instance ReportS [String]  where reportS k n = reportSLn  k n . unlines+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+  -- 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 ()+reportSDoc k n d = verboseS k n $ do+  displayDebugMessage k n . (++ "\n") =<< formatDebugMessage k n (locallyTC eIsDebugPrinting (const True) d)++-- | Debug print the result of a computation.+reportResult :: MonadDebug m => VerboseKey -> VerboseLevel -> (a -> TCM Doc) -> m a -> m a+reportResult k n debug action = do+  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++-- | Debug print some lines if the verbosity level for the given+--   'VerboseKey' is at least 'VerboseLevel'.+--+-- Note: In the presence of @OverloadedStrings@, just+-- @@+--   traceS key level "Literate string"+-- @@+-- gives an @Ambiguous type variable@ error in @GHC@.+-- Use the legacy functions 'traceSLn' and 'traceSDoc' instead then.+--+class TraceS a where+  traceS :: MonadDebug m => VerboseKey -> VerboseLevel -> a -> m c -> m c++instance TraceS (TCM Doc) where traceS = traceSDoc+instance TraceS String    where traceS = traceSLn++instance TraceS [TCM Doc] where traceS k n = traceSDoc k n . fmap vcat . sequence+instance TraceS [String]  where traceS k n = traceSLn  k n . unlines+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"++-- | Conditionally render debug 'Doc', print it, and then continue.+traceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a+traceSDoc k n d = applyWhenVerboseS k n $ \cont -> do+  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"++closeVerboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()+closeVerboseBracket k n = displayDebugMessage k n "}\n"++closeVerboseBracketException :: MonadDebug m => VerboseKey -> VerboseLevel -> m ()+closeVerboseBracketException k n = displayDebugMessage k n "} (exception)\n"+++------------------------------------------------------------------------+-- Verbosity++-- Invariant (which we may or may not currently break): Debug+-- printouts use one of the following functions:+--+--   reportS+--   reportSLn+--   reportSDoc++-- | 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 = 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 = 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).++{-# SPECIALIZE whenExactVerbosity :: VerboseKey -> VerboseLevel -> TCM () -> TCM () #-}+whenExactVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m () -> m ()+whenExactVerbosity k n = whenM $ hasExactVerbosity k n++__CRASH_WHEN__ :: (HasCallStack, MonadTCM m, MonadDebug m) => VerboseKey -> VerboseLevel -> m ()+__CRASH_WHEN__ k n = whenExactVerbosity k n (throwImpossible err)+  where+    -- Create the "Unreachable" error using *our* caller as the call site.+    err = withCallerCallStack Unreachable++-- | Run a computation if a certain verbosity level is activated.+--+--   Precondition: The level must be non-negative.+{-# SPECIALIZE verboseS :: VerboseKey -> VerboseLevel -> TCM () -> TCM () #-}+-- {-# SPECIALIZE verboseS :: MonadIO m => VerboseKey -> VerboseLevel -> TCMT m () -> TCMT m () #-} -- RULE left-hand side too complicated to desugar+-- {-# SPECIALIZE verboseS :: MonadTCM tcm => VerboseKey -> VerboseLevel -> tcm () -> tcm () #-}+verboseS :: MonadDebug m => VerboseKey -> VerboseLevel -> m () -> m ()+verboseS k n action = whenM (hasVerbosity k n) $ nowDebugPrinting action++-- | Apply a function if a certain verbosity level is activated.+--+--   Precondition: The level must be non-negative.+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++-- | Check whether a certain profile option is activated.+{-# SPECIALIZE hasProfileOption :: ProfileOption -> TCM Bool #-}+hasProfileOption :: MonadDebug m => ProfileOption -> m Bool+hasProfileOption opt = containsProfileOption opt <$> getProfileOptions++-- | 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
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Monad.Debug where++import Data.Kind (Type)++class MonadDebug (m :: Type -> Type)
src/full/Agda/TypeChecking/Monad/Env.hs view
@@ -1,82 +1,90 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Env where -import Control.Monad.Reader-import Data.List-import Data.Monoid+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 qualified Agda.Utils.SmallSet as SmallSet++import Agda.Utils.Impossible+ -- | Get the name of the current module, if any. {-# SPECIALIZE currentModule :: TCM ModuleName #-} {-# SPECIALIZE currentModule :: ReduceM ModuleName #-}-currentModule :: MonadReader TCEnv m => m ModuleName-currentModule = asks envCurrentModule+currentModule :: MonadTCEnv m => m ModuleName+currentModule = asksTC envCurrentModule  -- | Set the name of the current module.-withCurrentModule :: ModuleName -> TCM a -> TCM a+withCurrentModule :: (MonadTCEnv m) => ModuleName -> m a -> m a withCurrentModule m =-    local $ \e -> e { envCurrentModule = m }+    localTC $ \ e -> e { envCurrentModule = m } +-- | Get the path of the currently checked file+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 #-} {-# SPECIALIZE getAnonymousVariables :: ModuleName -> ReduceM Nat #-}-getAnonymousVariables :: MonadReader TCEnv m => ModuleName -> m Nat+getAnonymousVariables :: MonadTCEnv m => ModuleName -> m Nat getAnonymousVariables m = do-  ms <- asks envAnonymousModules-  return $ sum [ n | (m', n) <- ms, mnameToList m' `isPrefixOf` mnameToList m ]+  ms <- asksTC envAnonymousModules+  return $ sum [ n | (m', n) <- ms, mnameToList m' `List.isPrefixOf` mnameToList m ]  -- | Add variables bound by an anonymous module. withAnonymousModule :: ModuleName -> Nat -> TCM a -> TCM a withAnonymousModule m n =-  local $ \e -> e { envAnonymousModules   = (m, n) : envAnonymousModules e-                  }+  localTC $ \ e -> e { envAnonymousModules = (m, n) : envAnonymousModules e }  -- | Set the current environment to the given-withEnv :: TCEnv -> TCM a -> TCM a-withEnv env = local $ \ env0 -> env+withEnv :: MonadTCEnv m => TCEnv -> m a -> m a+withEnv env = localTC $ \ env0 -> env   -- Keep persistent settings-  { envAllowDestructiveUpdate = envAllowDestructiveUpdate env0-  , envPrintMetasBare         = envPrintMetasBare env0+  { envPrintMetasBare         = envPrintMetasBare env0   }  -- | Get the current environment getEnv :: TCM TCEnv-getEnv = ask---- | Increases the module nesting level by one in the given--- computation.-withIncreasedModuleNestingLevel :: TCM a -> TCM a-withIncreasedModuleNestingLevel =-  local (\e -> e { envModuleNestingLevel =-                     envModuleNestingLevel e + 1 })+getEnv = askTC  -- | Set highlighting level withHighlightingLevel :: HighlightingLevel -> TCM a -> TCM a-withHighlightingLevel h = local $ \e -> e { envHighlightingLevel = h }+withHighlightingLevel h = localTC $ \ e -> e { envHighlightingLevel = h }  -- | Restore setting for 'ExpandLast' to default. doExpandLast :: TCM a -> TCM a-doExpandLast = local $ \ e -> e { envExpandLast = ExpandLast }+doExpandLast = localTC $ \ e -> e { envExpandLast = setExpand (envExpandLast e) }+  where+    setExpand ReallyDontExpandLast = ReallyDontExpandLast+    setExpand _                    = ExpandLast  dontExpandLast :: TCM a -> TCM a-dontExpandLast = local $ \ e -> e { envExpandLast = DontExpandLast }+dontExpandLast = localTC $ \ e -> e { envExpandLast = DontExpandLast } +reallyDontExpandLast :: TCM a -> TCM a+reallyDontExpandLast = localTC $ \ e -> e { envExpandLast = ReallyDontExpandLast }+ -- | If the reduced did a proper match (constructor or literal pattern), --   then record this as simplification step. {-# SPECIALIZE performedSimplification :: TCM a -> TCM a #-}-performedSimplification :: MonadReader TCEnv m => m a -> m a-performedSimplification = local $ \ e -> e { envSimplification = YesSimplification }+performedSimplification :: MonadTCEnv m => m a -> m a+performedSimplification = localTC $ \ e -> e { envSimplification = YesSimplification }  {-# SPECIALIZE performedSimplification' :: Simplification -> TCM a -> TCM a #-}-performedSimplification' :: MonadReader TCEnv m => Simplification -> m a -> m a-performedSimplification' simpl = local $ \ e -> e { envSimplification = simpl `mappend` envSimplification e }+performedSimplification' :: MonadTCEnv m => Simplification -> m a -> m a+performedSimplification' simpl = localTC $ \ e -> e { envSimplification = simpl `mappend` envSimplification e } -getSimplification :: MonadReader TCEnv m => m Simplification-getSimplification = asks envSimplification+getSimplification :: MonadTCEnv m => m Simplification+getSimplification = asksTC envSimplification  -- * Controlling reduction. @@ -84,26 +92,54 @@ updateAllowedReductions :: (AllowedReductions -> AllowedReductions) -> TCEnv -> TCEnv updateAllowedReductions f e = e { envAllowedReductions = f (envAllowedReductions e) } -modifyAllowedReductions :: (AllowedReductions -> AllowedReductions) -> TCM a -> TCM a-modifyAllowedReductions = local . updateAllowedReductions+modifyAllowedReductions :: MonadTCEnv m => (AllowedReductions -> AllowedReductions) -> m a -> m a+modifyAllowedReductions = localTC . updateAllowedReductions -putAllowedReductions :: AllowedReductions -> TCM a -> TCM a+putAllowedReductions :: MonadTCEnv m => AllowedReductions -> m a -> m a putAllowedReductions = modifyAllowedReductions . const  -- | Reduce @Def f vs@ only if @f@ is a projection.-onlyReduceProjections :: TCM a -> TCM a-onlyReduceProjections = putAllowedReductions [ProjectionReductions]+onlyReduceProjections :: MonadTCEnv m => m a -> m a+onlyReduceProjections = modifyAllowedReductions $ SmallSet.intersection $+  SmallSet.singleton ProjectionReductions  -- | Allow all reductions except for non-terminating functions (default).-allowAllReductions :: TCM a -> TCM a+allowAllReductions :: MonadTCEnv m => m a -> m a allowAllReductions = putAllowedReductions allReductions  -- | Allow all reductions including non-terminating functions.-allowNonTerminatingReductions :: TCM a -> TCM a-allowNonTerminatingReductions = putAllowedReductions $ [NonTerminatingReductions] ++ allReductions+allowNonTerminatingReductions :: MonadTCEnv m => m a -> m a+allowNonTerminatingReductions = putAllowedReductions reallyAllReductions +-- | Allow all reductions when reducing types. Otherwise only allow+--   inlined functions to be unfolded.+onlyReduceTypes :: MonadTCEnv m => m a -> m a+onlyReduceTypes = modifyAllowedReductions $ SmallSet.intersection $+  SmallSet.fromList [TypeLevelReductions, InlineReductions]++-- | Update allowed reductions when working on types+typeLevelReductions :: MonadTCEnv m => m a -> m a+typeLevelReductions = modifyAllowedReductions $ \reds -> if+  | TypeLevelReductions `SmallSet.member` reds ->+      if NonTerminatingReductions `SmallSet.member` reds+       then reallyAllReductions+       else allReductions+  | otherwise -> reds++-- * Concerning 'envInsideDotPattern'+ insideDotPattern :: TCM a -> TCM a-insideDotPattern = local $ \e -> e { envInsideDotPattern = True }+insideDotPattern = localTC $ \ e -> e { envInsideDotPattern = True }  isInsideDotPattern :: TCM Bool-isInsideDotPattern = asks envInsideDotPattern+isInsideDotPattern = asksTC envInsideDotPattern++-- | 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/Exception.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE UndecidableInstances   #-}---- | Basically a copy of the ErrorT monad transformer. It's handy to slap---   onto TCM and still be a MonadTCM (which isn't possible with ErrorT).---- Andreas, 2012-03-30: the following command seems to be STALE.---   Also, it does not require the silly Error instance for the err type.--- The silly Error instance is back. ;-)--module Agda.TypeChecking.Monad.Exception where--import Control.Applicative-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer--import Agda.TypeChecking.Monad.Base-import Agda.Utils.Except ( Error(strMsg), MonadError(catchError, throwError) )--newtype ExceptionT err m a = ExceptionT { runExceptionT :: m (Either err a) }--class Error err => MonadException err m | m -> err where-  throwException :: err -> m a-  catchException :: m a -> (err -> m a) -> m a--instance-#if __GLASGOW_HASKELL__ <= 708-  (Applicative m, Monad m, Error err)-#else-  (Monad m, Error err)-#endif-  => Monad (ExceptionT err m) where-  return = pure-  ExceptionT m >>= k = ExceptionT $ do-    r <- m-    case r of-      Left err -> return $ Left err-      Right x  -> runExceptionT $ k x-  fail = ExceptionT . return . Left . strMsg--instance (Monad m, Error err) => MonadException err (ExceptionT err m) where-  throwException = ExceptionT . return . Left-  catchException m h = ExceptionT $ do-    r <- runExceptionT m-    case r of-      Left err  -> runExceptionT $ h err-      Right x   -> return $ Right x--instance (Monad m, MonadException err m) => MonadException err (ReaderT r m) where-  throwException = lift . throwException-  catchException m h = ReaderT $ \ r ->-    catchException (m `runReaderT` r) (\ err -> h err `runReaderT` r)--instance (Monad m, MonadException err m, Monoid w) => MonadException err (WriterT w m) where-  throwException = lift . throwException-  catchException m h = WriterT $-    catchException (runWriterT m) (\ err -> runWriterT $ h err)--instance (Monad m, MonadException err m) => MonadException err (StateT s m) where-  throwException = lift . throwException-  catchException m h = StateT $ \ s ->-    catchException (runStateT m s) (\ err -> runStateT (h err) s)--instance MonadTrans (ExceptionT err) where-  lift = ExceptionT . liftM Right--instance Functor f => Functor (ExceptionT err f) where-  fmap f = ExceptionT . fmap (fmap f) . runExceptionT--instance (Error err, Applicative m, Monad m) => Applicative (ExceptionT err m) where-  pure  = ExceptionT . return . Right-  (<*>) = ap--instance-#if __GLASGOW_HASKELL__ <= 708-  (Error err, Applicative m, MonadState s m)-#else-  (Error err, MonadState s m)-#endif-  => MonadState s (ExceptionT err m) where-  get   = ExceptionT $ Right `liftM` get-  put x = ExceptionT $ Right `liftM` put x--instance-#if __GLASGOW_HASKELL__ <= 708-  (Error err, Applicative m, MonadReader r m)-#else-  (Error err, MonadReader r m)-#endif-  => MonadReader r (ExceptionT err m) where-  ask     = ExceptionT $ Right `liftM` ask-  local f = ExceptionT . local f . runExceptionT--instance-#if __GLASGOW_HASKELL__ <= 708-  (Error err, Applicative m, MonadError err' m)-#else-  (Error err, MonadError err' m)-#endif-  => MonadError err' (ExceptionT err m) where-  throwError err = ExceptionT $ Right `liftM` throwError err-  catchError m h = ExceptionT $ runExceptionT m `catchError` (runExceptionT . h)--instance-#if __GLASGOW_HASKELL__ <= 708-  (Error err, Applicative m, MonadIO m)-#else-  (Error err, MonadIO m)-#endif-  => MonadIO (ExceptionT err m) where-  liftIO m = ExceptionT $ Right `liftM` liftIO m--instance (Error err, MonadTCM tcm) => MonadTCM (ExceptionT err tcm) where-  liftTCM m = ExceptionT $ Right `liftM` liftTCM m
src/full/Agda/TypeChecking/Monad/Imports.hs view
@@ -1,87 +1,134 @@-module Agda.TypeChecking.Monad.Imports where+{-# OPTIONS_GHC -Wunused-imports #-} -import Control.Monad.State-import Control.Monad.Reader+module Agda.TypeChecking.Monad.Imports+  ( addImport+  , addImportCycleCheck+  , checkForImportCycle+  , dropDecodedModule+  , getDecodedModule+  , getDecodedModules+  , getImportPath+  , getPrettyVisitedModules+  , getVisitedModule+  , getVisitedModules+  , setDecodedModules+  , setVisitedModules+  , storeDecodedModule+  , visitModule+  , withImportPath+  ) where -import Data.Set (Set)+import Control.Arrow   ( (***) )+import Control.Monad   ( when )++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.Lens-import Agda.Utils.Monad -addImport :: ModuleName -> TCM ()-addImport m =-    stImportedModules %= Set.insert m+import Agda.Utils.List ( caseListM )+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2+import Agda.Utils.Singleton (singleton) -addImportCycleCheck :: C.TopLevelModuleName -> TCM a -> TCM a-addImportCycleCheck m =-    local $ \e -> e { envImportPath = m : envImportPath e }+import Agda.Utils.Impossible -getImports :: TCM (Set ModuleName)-getImports = use stImportedModules+-- | 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 -isImported :: ModuleName -> TCM Bool-isImported m = Set.member m <$> getImports+-- | @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 -getImportPath :: TCM [C.TopLevelModuleName]-getImportPath = asks envImportPath+  -- Add the given imports to the current set.+  let next = old `Set.union` ms +  -- The interfaces for the modules we added to the transitive imports.+  is <- catMaybes <$> mapM getVisitedModule (Set.toList ms)++  -- 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 =-  stVisitedModules %=-    Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi+  modifyTCLens stVisitedModules $+    Map.insert (iTopLevelModuleName $ miInterface mi) mi  setVisitedModules :: VisitedModules -> TCM ()-setVisitedModules ms = stVisitedModules .= ms+setVisitedModules ms = setTCLens stVisitedModules ms -getVisitedModules :: TCM VisitedModules-getVisitedModules = use stVisitedModules+getVisitedModules :: ReadTCState m => m VisitedModules+getVisitedModules = useTC stVisitedModules -isVisited :: C.TopLevelModuleName -> TCM Bool-isVisited x = Map.member x <$> use stVisitedModules+getPrettyVisitedModules :: ReadTCState m => m Doc+getPrettyVisitedModules = do+  visited <-  fmap (uncurry (<>) . (pretty *** (prettyCheckMode . miMode))) . Map.toList+          <$> getVisitedModules+  return $ hcat $ punctuate ", " visited+  where+  prettyCheckMode :: ModuleCheckMode -> Doc+  prettyCheckMode ModuleTypeChecked                  = ""+  prettyCheckMode ModuleScopeChecked                 = " (scope only)" -getVisitedModule :: C.TopLevelModuleName-                 -> TCM (Maybe ModuleInfo)-getVisitedModule x = Map.lookup x <$> use stVisitedModules+getVisitedModule :: ReadTCState m+                 => TopLevelModuleName+                 -> m (Maybe ModuleInfo)+getVisitedModule x = Map.lookup x <$> useTC stVisitedModules  getDecodedModules :: TCM DecodedModules-getDecodedModules = stDecodedModules . stPersistentState <$> get+getDecodedModules = stDecodedModules . stPersistentState <$> getTC  setDecodedModules :: DecodedModules -> TCM ()-setDecodedModules ms = modify $ \s ->+setDecodedModules ms = modifyTC $ \s ->   s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } -getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe Interface)-getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> get+getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo)+getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> getTC -storeDecodedModule :: Interface -> TCM ()-storeDecodedModule i = modify $ \s ->+storeDecodedModule :: ModuleInfo -> TCM ()+storeDecodedModule mi = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =-          Map.insert (toTopLevelModuleName $ iModuleName i) i $-            (stDecodedModules $ stPersistentState s)+          Map.insert (iTopLevelModuleName $ miInterface mi) mi $+            stDecodedModules (stPersistentState s)         }   } -dropDecodedModule :: C.TopLevelModuleName -> TCM ()-dropDecodedModule x = modify $ \s ->+dropDecodedModule :: TopLevelModuleName -> TCM ()+dropDecodedModule x = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =                                   Map.delete x $ stDecodedModules $ stPersistentState s                               }   } -withImportPath :: [C.TopLevelModuleName] -> TCM a -> TCM a-withImportPath path = local $ \e -> e { envImportPath = path }+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 --   worried about. checkForImportCycle :: TCM () checkForImportCycle = do-    m:ms <- getImportPath-    when (m `elem` ms) $ typeError $ CyclicModuleDependency-                                   $ dropWhile (/= m) $ reverse (m:ms)+  caseListM getImportPath __IMPOSSIBLE__ $ \ m ms -> do+    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/Local.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE CPP #-}-module Agda.TypeChecking.Monad.Local where--import Control.Applicative-import Control.Monad-import Data.Monoid--import Agda.Syntax.Internal-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Context-import Agda.TypeChecking.Monad.Env-import Agda.TypeChecking.Monad.Options-import Agda.TypeChecking.Free-import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (inFreshModuleIfFreeParams, lookupSection)--import Agda.Utils.Size-import Agda.Utils.Impossible-#include "undefined.h"---- | Precondition: must not be called if the module parameter of the current---   module have been refined or (touched at all).-makeLocal :: Free' a All => a -> TCM (Local a)-makeLocal x | closed x = return $ Global x-            | otherwise = inFreshModuleIfFreeParams $ do-  m <- currentModule-  return (Local m x)--makeGlobal :: Free' a All => a -> TCM (Local a)-makeGlobal x | closed x  = return $ Global x-             | otherwise = __IMPOSSIBLE__--getLocal :: Subst Term a => Local a -> TCM (Maybe a)-getLocal (Global x) = return (Just x)-getLocal l@(Local m x) = do-  m' <- currentModule-  if m' == m || isSubModuleOf m' m-    then Just . (`applySubst` x) <$> getModuleParameterSub m-    else return Nothing-
src/full/Agda/TypeChecking/Monad/MetaVars.hs view
@@ -1,140 +1,384 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Monad.MetaVars where  import Prelude hiding (null) -import Control.Applicative hiding (empty)-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Writer+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.Trans.Maybe    ( MaybeT )+import Control.Monad.Reader         ( ReaderT(ReaderT), runReaderT )+import Control.Monad.Writer         ( WriterT, execWriterT, tell ) -import Data.Map (Map)-import qualified Data.Map as Map+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.Generic+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.Options (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+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 Agda.Utils.Size import qualified Agda.Utils.Maybe.Strict as Strict -#include "undefined.h" import Agda.Utils.Impossible +-- | Various classes of metavariables.++data MetaClass =+    Records+    -- ^ Meta variables of record type.+  | SingletonRecords+    -- ^ Meta variables of \"hereditarily singleton\" record type.+  | Levels+    -- ^ Meta variables of level type, if type-in-type is activated.+  deriving (Eq, Enum, Bounded, Show)++-- | All possible metavariable classes.++allMetaClasses :: [MetaClass]+allMetaClasses = [minBound .. maxBound]++data KeepMetas = KeepMetas | RollBackMetas++-- | Monad service class for creating, solving and eta-expanding of+--   metavariables.+class ( MonadConstraint m+      , MonadReduce m+      , MonadAddContext m+      , MonadTCEnv m+      , ReadTCState m+      , HasBuiltins m+      , HasConstInfo m+      , MonadDebug m+      ) => MonadMetaSolver m where+  -- | Generate a new meta variable with some instantiation given.+  --   For instance, the instantiation could be a 'PostponedTypeCheckingProblem'.+  newMeta' :: MetaInstantiation -> Frozen -> MetaInfo -> MetaPriority -> Permutation ->+              Judgement a -> m MetaId++  -- * Solve constraint @x vs = v@.++  -- | Assign to an open metavar which may not be frozen.+  --   First check that metavar args are in pattern fragment.+  --     Then do extended occurs check on given thing.+  --+  --   Assignment is aborted by throwing a @PatternErr@ via a call to+  --   @patternViolation@.  This error is caught by @catchConstraint@+  --   during equality checking (@compareAtom@) and leads to+  --   restoration of the original constraints.+  assignV :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> m ()++  -- | Directly instantiate the metavariable. Skip pattern check,+  -- occurs check and frozen check. Used for eta expanding frozen+  -- metas.+  assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> 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 ()++  -- | 'speculateMetas fallback m' speculatively runs 'm', but if the+  --    result is 'RollBackMetas' any changes to metavariables are+  --    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 :: TCM a -> TCM a-dontAssignMetas = local $ \ env -> env { envAssignMetas = False }+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 :: TCM MetaStore-getMetaStore = use stMetaStore+-- | Is the meta-variable from another top-level module? -modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()-modifyMetaStore f = stMetaStore %= 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 :: TCM a -> TCM (a, Set MetaId)+metasCreatedBy ::+  forall m a. ReadTCState m => m a -> m (a, LocalMetaStores) metasCreatedBy m = do-  before <- Map.keysSet <$> use stMetaStore-  a <- m-  after  <- Map.keysSet <$> use stMetaStore-  return (a, after Set.\\ before)+  !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 :: MetaId -> TCM MetaVariable-lookupMeta m = fromMaybeM failure $ Map.lookup m <$> getMetaStore-  where failure = fail $ "no such meta variable " ++ prettyShow m+-- | Find information about the given local meta-variable, if any. -updateMetaVar :: MetaId -> (MetaVariable -> MetaVariable) -> TCM ()-updateMetaVar m f = modifyMetaStore $ Map.adjust f 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 -getMetaPriority :: MetaId -> TCM MetaPriority-getMetaPriority = mvPriority <.> lookupMeta+-- | Find information about the given local meta-variable. -{- UNUSED-getMetaRelevance :: MetaId -> TCM Relevance-getMetaRelevance x = miRelevance . mvInfo <$> lookupMeta x--}+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 -isSortMeta :: MetaId -> TCM Bool-isSortMeta m = isSortMeta_ <$> lookupMeta m+-- | 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+  | isOpenMeta (mvInstantiation mv) = insert stOpenMetaStore+  | otherwise                       = insert stSolvedMetaStore+  where+  insert = (`modifyTCLens` MapS.insert m mv)++{-# INLINE getMetaPriority #-}+-- | Returns the 'MetaPriority' of the given local meta-variable.+getMetaPriority ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaPriority+getMetaPriority = mvPriority <.> lookupLocalMeta++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 :: MetaId -> TCM 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__ --- | Given a meta, return the type applied to the current context.-getMetaTypeInContext :: MetaId -> TCM Type+{-# 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++{-# 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-  MetaVar{ mvJudgement = j, mvPermutation = p } <- lookupMeta m+  mv@MetaVar{ mvJudgement = j } <- lookupLocalMeta m   case j of-    HasType{ jMetaType = t } -> do-      vs <- getContextArgs-      piApplyM t $ permute (takeP (size vs) p) vs+    HasType{ jMetaType = t } -> piApplyM t =<< getMetaContextArgs mv     IsSort{}                 -> __IMPOSSIBLE__ +{-# 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 :: a -> TCM 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  instance IsInstantiatedMeta Term where   isInstantiatedMeta = loop where    loop v =-    case ignoreSharing v of+    case v of       MetaV x _  -> isInstantiatedMeta x       DontCare v -> loop v       Level l    -> isInstantiatedMeta l       Lam _ b    -> isInstantiatedMeta b-      Con _ _ vs -> isInstantiatedMeta vs+      Con _ _ es | Just vs <- allApplyElims es -> isInstantiatedMeta vs       _          -> __IMPOSSIBLE__  instance IsInstantiatedMeta Level where-  isInstantiatedMeta (Max ls) = isInstantiatedMeta ls+  isInstantiatedMeta (Max n ls) | n == 0 = isInstantiatedMeta ls+  isInstantiatedMeta _ = __IMPOSSIBLE__  instance IsInstantiatedMeta PlusLevel where   isInstantiatedMeta (Plus n l) | n == 0 = isInstantiatedMeta l   isInstantiatedMeta _ = __IMPOSSIBLE__ -instance IsInstantiatedMeta LevelAtom where-  isInstantiatedMeta (MetaLevel x es) = isInstantiatedMeta x-  isInstantiatedMeta _ = __IMPOSSIBLE__- instance IsInstantiatedMeta a => IsInstantiatedMeta [a] where   isInstantiatedMeta = andM . map isInstantiatedMeta @@ -148,92 +392,165 @@ instance IsInstantiatedMeta a => IsInstantiatedMeta (Abs a) where   isInstantiatedMeta = isInstantiatedMeta . unAbs -isInstantiatedMeta' :: MetaId -> TCM (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 every meta-variable occurrence in the given type, except--- for those in 'Sort's.-allMetas :: TermLike a => a -> [MetaId]-allMetas = foldTerm metas+-- | Returns all metavariables in a constraint. Slightly complicated by the+--   fact that blocked terms are represented by two meta variables. To find the+--   second one we need to look up the meta listeners for the one in the+--   UnBlock constraint.+--   This is used for the purpose of deciding if a metavariable is constrained or if it can be+--   generalized over (see Agda.TypeChecking.Generalize).+constraintMetas :: Constraint -> TCM (Set MetaId)+constraintMetas = \case+    -- We don't use allMetas here since some constraints should not stop us from generalizing. For+    -- instance CheckSizeLtSat (see #3694). We also have to check meta listeners to get metas of+    -- UnBlock constraints.+    -- #5147: Don't count metas in the type of a constraint. For instance the constraint u = v : t+    -- should not stop us from generalize metas in t, since we could never solve those metas based+    -- on that constraint alone.+      ValueCmp _ _ u v         -> return $ allMetas Set.singleton (u, v)+      ValueCmpOnFace _ p _ u v -> return $ allMetas Set.singleton (p, u, v)+      ElimCmp _ _ _ _ es es'   -> return $ allMetas Set.singleton (es, es')+      LevelCmp _ l l'          -> return $ allMetas Set.singleton (Level l, Level l')+      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 _       ->+        -- #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)+      UsableAtModality{}       -> return mempty   where-  metas (MetaV m _) = [m]-  metas (Level l)   = levelMetas l-  metas _           = []--  levelMetas (Max as) = concatMap plusLevelMetas as--  plusLevelMetas ClosedLevel{} = []-  plusLevelMetas (Plus _ l)    = levelAtomMetas l--  levelAtomMetas (MetaLevel m _) = [m]-  levelAtomMetas _               = []+    -- For blocked constant twin variables+    listenerMetas EtaExpand{}           = return Set.empty+    listenerMetas (CheckConstraint _ c) = constraintMetas (clValue $ theConstraint c)  -- | Create 'MetaInfo' in the current environment.-createMetaInfo :: TCM MetaInfo+createMetaInfo :: (MonadTCEnv m, ReadTCState m) => m MetaInfo createMetaInfo = createMetaInfo' RunMetaOccursCheck -createMetaInfo' :: RunMetaOccursCheck -> TCM MetaInfo+createMetaInfo'+  :: (MonadTCEnv m, ReadTCState m)+  => RunMetaOccursCheck -> m MetaInfo createMetaInfo' b = do-  r   <- getCurrentRange-  cl  <- buildClosure r+  r        <- getCurrentRange+  cl       <- buildClosure r+  gen      <- viewTC eGeneralizeMetas+  modality <- currentModality   return MetaInfo     { miClosRange       = cl+    , miModality        = modality     , miMetaOccursCheck = b     , miNameSuggestion  = ""+    , miGeneralizable   = defaultArg gen+                          -- The ArgInfo is set to the right value in+                          -- the newArgsMetaCtx' function.     } -setValueMetaName :: Term -> MetaNameSuggestion -> TCM ()+setValueMetaName :: MonadMetaSolver m => Term -> MetaNameSuggestion -> m () setValueMetaName v s = do-  case ignoreSharing v of+  case v of     MetaV mi _ -> setMetaNameSuggestion mi s     u          -> do       reportSLn "tc.meta.name" 70 $         "cannot set meta name; newMeta returns " ++ show u       return () -getMetaNameSuggestion :: MetaId -> TCM MetaNameSuggestion-getMetaNameSuggestion mi = miNameSuggestion . mvInfo <$> lookupMeta mi+getMetaNameSuggestion ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaNameSuggestion+getMetaNameSuggestion mi =+  miNameSuggestion . mvInfo <$> lookupLocalMeta mi -setMetaNameSuggestion :: MetaId -> MetaNameSuggestion -> TCM ()+setMetaNameSuggestion :: MonadMetaSolver m => MetaId -> MetaNameSuggestion -> m () setMetaNameSuggestion mi s = unless (null s || isUnderscore s) $ do   reportSLn "tc.meta.name" 20 $     "setting name of meta " ++ prettyShow mi ++ " to " ++ s   updateMetaVar mi $ \ mvar ->     mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} -updateMetaVarRange :: MetaId -> Range -> TCM ()+-- | 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)+        { miGeneralizable = setArgInfo i (miGeneralizable (mvInfo mv)) } }++updateMetaVarRange :: MonadMetaSolver m => MetaId -> Range -> m () updateMetaVarRange mi r = updateMetaVar mi (setRange r) +setMetaOccursCheck :: MonadMetaSolver m => MetaId -> RunMetaOccursCheck -> m ()+setMetaOccursCheck mi b = updateMetaVar mi $ \ mvar ->+  mvar { mvInfo = (mvInfo mvar) { miMetaOccursCheck = b } }+ -- * Query and manipulate interaction points. -modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> TCM ()-modifyInteractionPoints f =-  stInteractionPoints %= f+class (MonadTCEnv m, ReadTCState m) => MonadInteractionPoints m where+  freshInteractionId :: m InteractionId+  default freshInteractionId+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => m InteractionId+  freshInteractionId = lift freshInteractionId +  modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> m ()+  default modifyInteractionPoints+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => (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+  modifyInteractionPoints f = stInteractionPoints `modifyTCLens` f+ -- | Register an interaction point during scope checking. --   If there is no interaction id yet, create one.-registerInteractionPoint :: Bool -> Range -> Maybe Nat -> TCM InteractionId+registerInteractionPoint+  :: forall m. MonadInteractionPoints m+  => Bool -> Range -> Maybe Nat -> m InteractionId registerInteractionPoint preciseRange r maybeId = do-  m <- use stInteractionPoints-  if not preciseRange then continue m else do+  m <- useR stInteractionPoints+  -- If we're given an interaction id we shouldn't look up by range.+  -- This is important when doing 'refine', since all interaction points+  -- created by the refine gets the same range.+  if not preciseRange || isJust maybeId then continue m else do     -- If the range does not come from a file, it is not     -- precise, so ignore it.     Strict.caseMaybe (rangeFile r) (continue m) $ \ _ -> do     -- First, try to find the interaction point by Range.     caseMaybe (findInteractionPoint_ r m) (continue m) {-else-} return  where+ continue :: InteractionPoints -> m InteractionId  continue m = do   -- We did not find an interaction id with the same Range, so let's create one!   ii <- case maybeId of     Just i  -> return $ InteractionId i-    Nothing -> fresh-  let ip = InteractionPoint { ipRange = r, ipMeta = Nothing, ipClause = IPNoClause }-  case Map.insertLookupWithKey (\ key new old -> old) ii ip m of+    Nothing -> freshInteractionId+  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.     (Just ip0, _)@@ -244,214 +561,288 @@       return ii  -- | Find an interaction point by 'Range' by searching the whole map.+--   Issue 3000: Don't consider solved interaction points. -- --   O(n): linear in the number of registered interaction points.  findInteractionPoint_ :: Range -> InteractionPoints -> Maybe InteractionId findInteractionPoint_ r m = do   guard $ not $ null r-  headMaybe $ mapMaybe sameRange $ Map.toList m+  listToMaybe $ mapMaybe sameRange $ BiMap.toList m   where     sameRange :: (InteractionId, InteractionPoint) -> Maybe InteractionId-    sameRange (ii, InteractionPoint r' _ _) | r == r' = Just ii+    sameRange (ii, InteractionPoint r' _ False _ _) | r == r' = Just ii     sameRange _ = Nothing --- | Hook up meta variable to interaction point.-connectInteractionPoint :: InteractionId -> MetaId -> TCM ()+{-# INLINABLE connectInteractionPoint #-}+-- | Hook up a local meta-variable to an interaction point.+connectInteractionPoint+  :: MonadInteractionPoints m+  => InteractionId -> MetaId -> m () connectInteractionPoint ii mi = do-  ipCl <- asks envClause-  m <- use stInteractionPoints-  let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipClause = ipCl }+  ipCl <- asksTC envClause+  m <- useR stInteractionPoints+  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 Map.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of+  case BiMap.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of     (Nothing, _) -> __IMPOSSIBLE__     (Just _, m') -> modifyInteractionPoints $ const m' --- | Move an interaction point from the current ones to the old ones.-removeInteractionPoint :: InteractionId -> TCM ()-removeInteractionPoint ii = do-  ip <- stInteractionPoints %%= \ m -> do-    let (mip, m') = Map.updateLookupWithKey (\ _ _ -> Nothing) ii m-    return (m',-      fromMaybe __IMPOSSIBLE__ mip)-  stSolvedInteractionPoints %= Map.insert ii ip+-- | Mark an interaction point as solved.+removeInteractionPoint :: MonadInteractionPoints m => InteractionId -> m ()+removeInteractionPoint ii =+  modifyInteractionPoints $ BiMap.update (\ ip -> Just ip{ ipSolved = True }) ii  -- | Get a list of interaction ids.-getInteractionPoints :: TCM [InteractionId]-getInteractionPoints = Map.keys <$> use stInteractionPoints+{-# SPECIALIZE getInteractionPoints :: TCM [InteractionId] #-}+getInteractionPoints :: ReadTCState m => m [InteractionId]+getInteractionPoints = BiMap.keys <$> useR stInteractionPoints --- | Get all metas that correspond to interaction ids.-getInteractionMetas :: TCM [MetaId]-getInteractionMetas = mapMaybe ipMeta . Map.elems <$> use stInteractionPoints+-- | Get all metas that correspond to unsolved interaction ids.+getInteractionMetas :: ReadTCState m => m [MetaId]+getInteractionMetas =+  mapMaybe ipMeta . filter (not . ipSolved) . BiMap.elems <$> useR stInteractionPoints --- | Get all metas that correspond to interaction ids.-getInteractionIdsAndMetas :: TCM [(InteractionId,MetaId)]-getInteractionIdsAndMetas = mapMaybe f . Map.toList <$> use stInteractionPoints+getUniqueMetasRanges ::+  (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range]+getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange++getUnsolvedMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]+getUnsolvedMetas = do+  openMetas            <- getOpenMetas+  interactionMetas     <- getInteractionMetas+  getUniqueMetasRanges (openMetas List.\\ interactionMetas)++getUnsolvedInteractionMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]+getUnsolvedInteractionMetas = getUniqueMetasRanges =<< getInteractionMetas++-- | Get all metas that correspond to unsolved interaction ids.+getInteractionIdsAndMetas :: ReadTCState m => m [(InteractionId,MetaId)]+getInteractionIdsAndMetas =+  mapMaybe f . filter (not . ipSolved . snd) . BiMap.toList <$> useR stInteractionPoints   where f (ii, ip) = (ii,) <$> ipMeta ip  -- | Does the meta variable correspond to an interaction point? -----   Time: @O(n)@ where @n@ is the number of interaction metas.-isInteractionMeta :: MetaId -> TCM (Maybe InteractionId)-isInteractionMeta x = lookup x . map swap <$> getInteractionIdsAndMetas+--   Time: @O(log n)@ where @n@ is the number of interaction metas.+isInteractionMeta :: ReadTCState m => MetaId -> m (Maybe InteractionId)+isInteractionMeta x = BiMap.invLookup x <$> useR stInteractionPoints  -- | Get the information associated to an interaction point.-lookupInteractionPoint :: InteractionId -> TCM InteractionPoint+{-# SPECIALIZE lookupInteractionPoint :: InteractionId -> TCM InteractionPoint #-}+lookupInteractionPoint+  :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m)+  => InteractionId -> m InteractionPoint lookupInteractionPoint ii =-  fromMaybeM err $ Map.lookup ii <$> use 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 :: InteractionId -> TCM MetaId-lookupInteractionId ii = fromMaybeM err2 $ ipMeta <$> lookupInteractionPoint ii-  where-    err2 = typeError $ GenericError $ "No type nor action available for hole " ++ show ii ++ ". Possible cause: the hole has not been reached during type checking (do you see yellow?)"+lookupInteractionId+  :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m)+  => InteractionId -> m MetaId+lookupInteractionId ii =+  fromMaybeM (interactionError $ NoActionForInteractionPoint ii) $+    ipMeta <$> lookupInteractionPoint ii  -- | Check whether an interaction id is already associated with a meta variable.-lookupInteractionMeta :: InteractionId -> TCM (Maybe MetaId)-lookupInteractionMeta ii = lookupInteractionMeta_ ii <$> use stInteractionPoints+lookupInteractionMeta :: ReadTCState m => InteractionId -> m (Maybe MetaId)+lookupInteractionMeta ii = lookupInteractionMeta_ ii <$> useR stInteractionPoints  lookupInteractionMeta_ :: InteractionId -> InteractionPoints -> Maybe MetaId-lookupInteractionMeta_ ii m = ipMeta =<< Map.lookup ii m+lookupInteractionMeta_ ii m = ipMeta =<< BiMap.lookup ii m  -- | Generate new meta variable.-newMeta :: MetaInfo -> MetaPriority -> Permutation -> Judgement a -> TCM MetaId-newMeta = newMeta' Open+newMeta :: MonadMetaSolver m => Frozen -> MetaInfo -> MetaPriority -> Permutation -> Judgement a -> m MetaId+newMeta = newMeta' (OpenMeta UnificationMeta)  -- | Generate a new meta variable with some instantiation given. --   For instance, the instantiation could be a 'PostponedTypeCheckingProblem'.-newMeta' :: MetaInstantiation -> MetaInfo -> MetaPriority -> Permutation ->-            Judgement a -> TCM MetaId-newMeta' inst mi p perm j = do+newMetaTCM' :: MetaInstantiation -> Frozen -> MetaInfo -> MetaPriority -> Permutation ->+               Judgement a -> TCM MetaId+newMetaTCM' inst frozen mi p perm j = do   x <- fresh   let j' = j { jMetaId = x }  -- fill the identifier part of the judgement-      mv = MetaVar mi p perm j' inst Set.empty Instantiable+      mv = MetaVar{ mvInfo             = mi+                  , mvPriority         = p+                  , mvPermutation      = perm+                  , mvJudgement        = j'+                  , mvInstantiation    = inst+                  , mvListeners        = Set.empty+                  , mvFrozen           = frozen+                  , mvTwin             = Nothing+                  }   -- printing not available (import cycle)-  -- reportSDoc "tc.meta.new" 50 $ text "new meta" <+> prettyTCM j'-  stMetaStore %= Map.insert x mv+  -- reportSDoc "tc.meta.new" 50 $ "new meta" <+> prettyTCM j'+  insertMetaVar x mv   return x  -- | Get the 'Range' for an interaction point.-getInteractionRange :: InteractionId -> TCM Range+{-# SPECIALIZE getInteractionRange :: InteractionId -> TCM Range #-}+getInteractionRange+  :: (MonadInteractionPoints m, MonadDebug m, MonadError TCErr m)+  => InteractionId -> m Range getInteractionRange = ipRange <.> lookupInteractionPoint --- | Get the 'Range' for a meta variable.-getMetaRange :: MetaId -> TCM 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 :: InteractionId -> TCM ScopeInfo-getInteractionScope = getMetaScope <.> lookupMeta <=< lookupInteractionId+getInteractionScope ::+  (MonadDebug m, ReadTCState m, MonadError TCErr m,+   MonadTCEnv m) =>+  InteractionId -> m ScopeInfo+getInteractionScope =+  getMetaScope <.> lookupLocalMeta <=< lookupInteractionId -withMetaInfo' :: MetaVariable -> TCM a -> TCM a+withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a withMetaInfo' mv = withMetaInfo (miClosRange $ mvInfo mv) -withMetaInfo :: Closure Range -> TCM a -> TCM a+withMetaInfo :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => Closure Range -> m a -> m a withMetaInfo mI cont = enterClosure mI $ \ r ->   setCurrentRange r cont -getInstantiatedMetas :: TCM [MetaId]-getInstantiatedMetas = do-    store <- getMetaStore-    return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isInst mi ]-    where-        isInst Open                           = False-        isInst OpenIFS                        = False-        isInst BlockedConst{}                 = False-        isInst PostponedTypeCheckingProblem{} = False-        isInst InstV{}                        = True+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 -getOpenMetas :: TCM [MetaId]-getOpenMetas = do-    store <- getMetaStore-    return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isOpenMeta mi ]+withMetaId ::+  (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m,+   ReadTCState m) =>+  MetaId -> m a -> m a+withMetaId m ret = do+  mv <- lookupLocalMeta m+  withMetaInfo' mv ret +getOpenMetas :: ReadTCState m => m [MetaId]+getOpenMetas = MapS.keys <$> useR stOpenMetaStore+ isOpenMeta :: MetaInstantiation -> Bool-isOpenMeta Open                           = True-isOpenMeta OpenIFS                        = True+isOpenMeta OpenMeta{}                     = True isOpenMeta BlockedConst{}                 = True isOpenMeta PostponedTypeCheckingProblem{} = True isOpenMeta InstV{}                        = False  -- | @listenToMeta l m@: register @l@ as a listener to @m@. This is done --   when the type of l is blocked by @m@.-listenToMeta :: Listener -> MetaId -> TCM ()+listenToMeta :: MonadMetaSolver m => Listener -> MetaId -> m () listenToMeta l m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.insert l $ mvListeners mv }  -- | Unregister a listener.-unlistenToMeta :: Listener -> MetaId -> TCM ()+unlistenToMeta :: MonadMetaSolver m => Listener -> MetaId -> m () unlistenToMeta l m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.delete l $ mvListeners mv } --- | Get the listeners to a meta.-getMetaListeners :: MetaId -> TCM [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 :: MetaId -> TCM ()+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 all so far unfrozen metas for the duration of the given computation.-withFreezeMetas :: TCM a -> TCM a-withFreezeMetas cont = do-  ms <- Set.fromList <$> freezeMetas-  x  <- cont-  unfreezeMetas' (`Set.member` ms)-  return x---- | Freeze all meta variables and return the list of metas that got frozen.-freezeMetas :: TCM [MetaId]-freezeMetas = freezeMetas' $ const True---- | Freeze some meta variables and return the list of metas that got frozen.-freezeMetas' :: (MetaId -> Bool) -> TCM [MetaId]-freezeMetas' p = execWriterT $ stMetaStore %== Map.traverseWithKey freeze+{-# 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 stOpenMetaStore $+  execStateT (mapM_ freeze $ MapS.keys ms)   where-  freeze :: Monad m => MetaId -> MetaVariable -> WriterT [MetaId] m MetaVariable-  freeze m mvar-    | p m && mvFrozen mvar /= Frozen = do-        tell [m]-        return $ mvar { mvFrozen = Frozen }-    | otherwise = return mvar+  freeze :: MetaId -> StateT LocalMetaStore (WriterT (Set MetaId) m) ()+  freeze m = do+    store <- get+    case MapS.lookup m store of+      Just mvar+        | mvFrozen mvar /= Frozen -> do+          lift $ tell (Set.singleton m)+          put $ MapS.insert m (mvar { mvFrozen = Frozen }) store+        | otherwise -> return ()+      Nothing -> return () --- | Thaw all meta variables.+-- | Thaw all open meta variables. unfreezeMetas :: TCM ()-unfreezeMetas = unfreezeMetas' $ const True---- | Thaw some metas, as indicated by the passed condition.-unfreezeMetas' :: (MetaId -> Bool) -> TCM ()-unfreezeMetas' cond = modifyMetaStore $ Map.mapWithKey unfreeze where-  unfreeze :: MetaId -> MetaVariable -> MetaVariable-  unfreeze m mvar-    | cond m    = mvar { mvFrozen = Instantiable }-    | otherwise = mvar+unfreezeMetas = stOpenMetaStore `modifyTCLens` MapS.map unfreeze+  where+  unfreeze :: MetaVariable -> MetaVariable+  unfreeze mvar = mvar { mvFrozen = Instantiable } -isFrozen :: MetaId -> TCM 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 :: a -> TCM ()+  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 =<< do jMetaType . mvJudgement <$> lookupMeta x+    unfreezeMeta =<< metaType x+{-# SPECIALIZE unfreezeMeta :: MetaId -> TCM () #-}  instance UnFreezeMeta Type where   unfreezeMeta (El s t) = unfreezeMeta s >> unfreezeMeta t  instance UnFreezeMeta Term where-  unfreezeMeta (Shared p)    = unfreezeMeta $ derefPtr p   unfreezeMeta (MetaV x _)   = unfreezeMeta x   unfreezeMeta (Sort s)      = unfreezeMeta s   unfreezeMeta (Level l)     = unfreezeMeta l@@ -460,21 +851,14 @@   unfreezeMeta _             = return ()  instance UnFreezeMeta Sort where-  unfreezeMeta (Type l)      = unfreezeMeta l+  unfreezeMeta (MetaS x _)   = unfreezeMeta x   unfreezeMeta _             = return ()  instance UnFreezeMeta Level where-  unfreezeMeta (Max ls)      = unfreezeMeta ls+  unfreezeMeta (Max _ ls)      = unfreezeMeta ls  instance UnFreezeMeta PlusLevel where   unfreezeMeta (Plus _ a)    = unfreezeMeta a-  unfreezeMeta ClosedLevel{} = return ()--instance UnFreezeMeta LevelAtom where-  unfreezeMeta (MetaLevel x _)    = unfreezeMeta x-  unfreezeMeta (BlockedLevel _ t) = unfreezeMeta t-  unfreezeMeta (NeutralLevel _ t) = unfreezeMeta t-  unfreezeMeta (UnreducedLevel t) = unfreezeMeta t  instance UnFreezeMeta a => UnFreezeMeta [a] where   unfreezeMeta = mapM_ unfreezeMeta
+ src/full/Agda/TypeChecking/Monad/MetaVars.hs-boot view
@@ -0,0 +1,36 @@+{-# 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, MetaId)+import Agda.TypeChecking.Monad.Base++class (MonadTCEnv m, ReadTCState m) => MonadInteractionPoints m where+  freshInteractionId :: m InteractionId+  modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> m ()++  default freshInteractionId+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => m InteractionId+  freshInteractionId = lift freshInteractionId++  default modifyInteractionPoints+    :: (MonadTrans t, MonadInteractionPoints n, t n ~ m)+    => (InteractionPoints -> InteractionPoints) -> m ()+  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,52 +1,39 @@--- {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Mutual where  import Prelude hiding (null) -import Control.Monad.Reader--import Data.Functor ((<$>))-import Data.Set (Set) 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 import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.State -import Agda.Utils.Lens import Agda.Utils.Null  noMutualBlock :: TCM a -> TCM a-noMutualBlock = local $ \e -> e { envMutualBlock = Nothing }+noMutualBlock = localTC $ \e -> e { envMutualBlock = Nothing }  -- | Pass the current mutual block id --   or create a new mutual block if we are not already inside on. inMutualBlock :: (MutualId -> TCM a) -> TCM a inMutualBlock m = do-  mi <- asks envMutualBlock+  mi <- asksTC envMutualBlock   case mi of     Nothing -> do       i <- fresh-      local (\ e -> e { envMutualBlock = Just i }) $ m i+      localTC (\ e -> e { envMutualBlock = Just i }) $ m i     -- 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 %= 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 %= 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))@@ -56,9 +43,9 @@ -- | Set the mutual block for a definition.  setMutualBlock :: MutualId -> QName -> TCM ()-setMutualBlock i x = do-  stMutualBlocks %= Map.alter f i-  stSignature    %= 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,19 +53,9 @@ -- | Get the current mutual block, if any, otherwise a fresh mutual -- block is returned. currentOrFreshMutualBlock :: TCM MutualId-currentOrFreshMutualBlock = maybe fresh return =<< asks envMutualBlock--lookupMutualBlock :: MutualId -> TCM MutualBlock-lookupMutualBlock mi = do-  mbs <- use 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+currentOrFreshMutualBlock = maybe fresh return =<< asksTC envMutualBlock --- | Reverse lookup of a mutual block id for a names.-mutualBlockOf :: QName -> TCM MutualId-mutualBlockOf x = do-  mb <- Map.toList <$> use stMutualBlocks-  case filter (Set.member x . mutualNames . snd) mb of-    (i, _) : _ -> return i-    _          -> fail $ "No mutual block for " ++ show 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
@@ -1,54 +1,69 @@--- {-# LANGUAGE CPP #-}  module Agda.TypeChecking.Monad.Open         ( makeOpen-        , makeClosed, isClosed         , getOpen-        , tryOpen+        , tryGetOpen+        , isClosed         ) where  import Control.Applicative-import Control.Monad-import Control.Monad.Reader-import Data.List+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set +import Agda.Syntax.Internal import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.State (currentModuleNameHash)  import {-# SOURCE #-} Agda.TypeChecking.Monad.Context -import Agda.Utils.Except ( MonadError(catchError) )+import Agda.Utils.Lens+import Agda.Utils.Maybe  -- | Create an open term in the current context.-makeOpen :: a -> TCM (Open a)+makeOpen :: (ReadTCState m, MonadTCEnv m) => a -> m (Open a) makeOpen x = do-    ctx <- getContextId-    return $ OpenThing ctx x+    cp  <- viewTC eCurrentCheckpoint+    env <- viewTC eCheckpoints+    m   <- currentModuleNameHash+    return $ OpenThing cp env m x --- | Create an open term which is closed.-makeClosed :: a -> Open a-makeClosed = OpenThing []+-- | Extract the value from an open term. The checkpoint at which it was+--   created must be in scope.+getOpen :: (TermSubst a, MonadTCEnv m) => Open a -> m a+getOpen (OpenThing cp _ _ x) = do+  sub <- checkpointSubstitution cp+  return $ applySubst sub x --- | Check if an 'Open' is closed.-isClosed :: Open a -> Bool-isClosed (OpenThing cxt _) = null cxt+-- | Extract the value from an open term. If the checkpoint is no longer in scope use the provided+--   function to pull the object to the most recent common checkpoint. The function is given the+--   substitution from the common ancestor to the checkpoint of the thing.+tryGetOpen :: (TermSubst a, ReadTCState m, MonadTCEnv m) => (Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)+tryGetOpen extract open = do+  OpenThing cp env _ x <- restrict open -- Strip the env if from another module+  runMaybeT $ do+      (`applySubst` x) <$> (liftMaybe =<< viewTC (eCheckpoints . key cp))+    <|> do  -- Checkpoint no longer in scope+      curEnv <- lift $ viewTC eCheckpoints+      parent <- findParent env curEnv+      let Just subToOld = Map.lookup parent env+          Just subToCur = Map.lookup parent curEnv+      (applySubst subToCur) <$> liftMaybe (extract subToOld x)+  where+    -- If this comes from a different file, the checkpoints refer to checkpoints in that file and+    -- not in the current file. To avoid confusing them we set the checkpoint to -1 and only keep+    -- checkpoint 0 (which is shared between files) in the environment.+    restrict o@(OpenThing cp env m x) = do+      cur <- currentModuleNameHash+      if m == cur then return o+                  else return $ OpenThing (-1) (Map.filterWithKey (\ k _ -> k == 0) env) m x --- | Extract the value from an open term. Must be done in an extension of the---   context in which the term was created.-getOpen :: (Subst t a, MonadReader TCEnv m) => Open a -> m a-getOpen (OpenThing []  x) = return x-getOpen (OpenThing ctx x) = do-  ctx' <- getContextId-  unless (ctx `isSuffixOf` ctx') $ fail $ "thing out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")"-  return $ raise (genericLength ctx' - genericLength ctx) x+    findParent m1 m2 = case Map.lookupMax (Map.intersection m1 m2) of+      Nothing       -> empty+      Just (max, _) -> return max --- | Try to use an 'Open' the current context.---   Returns 'Nothing' if current context is not an extension of the---   context in which the 'Open' was created.-tryOpen :: (Subst t a, MonadReader TCEnv m) => Open a -> m (Maybe a)-tryOpen (OpenThing []  x) = return $ Just x-tryOpen (OpenThing ctx x) = do-  ctx' <- getContextId-  if (ctx `isSuffixOf` ctx')-    then return $ Just $ raise (genericLength ctx' - genericLength ctx) x-    else return Nothing+-- | An 'Open' is closed if it has checkpoint 0.+isClosed :: Open a -> Bool+isClosed (OpenThing cp _ _ _) = cp == 0
src/full/Agda/TypeChecking/Monad/Options.hs view
@@ -1,409 +1,477 @@-{-# LANGUAGE CPP #-}  module Agda.TypeChecking.Monad.Options where -import Prelude hiding (mapM)+import Prelude hiding (null) -import Control.Applicative-import Control.Monad.Reader hiding (mapM)-import Control.Monad.State  hiding (mapM)+import Control.Monad          ( unless, when )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer -import Data.Maybe-import Data.Traversable+import qualified Data.Graph as Graph+import Data.List (sort)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set -import Text.PrettyPrint import System.Directory import System.FilePath -import Agda.Syntax.Internal import Agda.Syntax.Common-import Agda.Syntax.Concrete-import {-# SOURCE #-} Agda.TypeChecking.Errors+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 {-# SOURCE #-} Agda.Interaction.FindFile-import Agda.Interaction.Options+import Agda.TypeChecking.Monad.Trace++import Agda.Interaction.FindFile+import Agda.Interaction.Options hiding (setPragmaOptions) import qualified Agda.Interaction.Options.Lenses as Lens-import Agda.Interaction.Response import Agda.Interaction.Library+import Agda.Interaction.Library.Base (LibCache(LibCache), libAbove, libFile, runLibM) -import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.FileName-import Agda.Utils.Maybe-import Agda.Utils.Monad+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.Trie (Trie)-import qualified Agda.Utils.Trie as Trie-import Agda.Utils.Except-import Agda.Utils.Either+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 -#include "undefined.h" import Agda.Utils.Impossible  -- | Sets the pragma options.-+--   Checks for unsafe combinations. setPragmaOptions :: PragmaOptions -> TCM () setPragmaOptions opts = do-  clo <- commandLineOptions-  let unsafe = unsafePragmaOptions opts-  when (optSafe clo && not (null unsafe)) $ typeError (SafeFlagPragma unsafe)-  ok <- liftIO $ runOptM $ checkOpts (clo { optPragmaOptions = opts })-  case ok of-    Left err   -> __IMPOSSIBLE__-    Right opts -> do-      stPragmaOptions .= 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 @["."]@. setCommandLineOptions :: CommandLineOptions -> TCM ()-setCommandLineOptions = setCommandLineOptions' CurrentDir+setCommandLineOptions opts = do+  root <- liftIO (absolute =<< getCurrentDirectory)+  setCommandLineOptions' root opts -setCommandLineOptions' :: RelativeTo -> CommandLineOptions -> TCM ()-setCommandLineOptions' relativeTo opts = do-  z <- liftIO $ runOptM $ checkOpts opts-  case z of-    Left err   -> __IMPOSSIBLE__-    Right opts -> do+setCommandLineOptions'+  :: AbsolutePath+     -- ^ The base directory of relative paths.+  -> CommandLineOptions+  -> TCM ()+setCommandLineOptions' root opts = do+  -- Andreas, 2022-11-19: removed a call to checkOpts which did nothing.       incs <- case optAbsoluteIncludePaths opts of         [] -> do-          opts' <- setLibraryPaths relativeTo opts+          opts' <- setLibraryPaths root opts           let incs = optIncludePaths opts'-          setIncludeDirs incs relativeTo-          getIncludeDirs+          setIncludeDirs incs root+          List1.toList <$> getIncludeDirs         incs -> return incs-      modify $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs }+      modifyTC $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs }       setPragmaOptions (optPragmaOptions opts)       updateBenchmarkingStatus  libToTCM :: LibM a -> TCM a libToTCM m = do-  z <- liftIO $ runExceptT m+  libCache <- useTC stLibCache+  ((z, warns), libCache') <- liftIO $ runLibM m libCache++  setTCLens stLibCache libCache'++  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 -setLibraryPaths :: RelativeTo -> CommandLineOptions -> TCM CommandLineOptions-setLibraryPaths rel o = setLibraryIncludes =<< addDefaultLibraries rel o+-- | 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 $ getAgdaLibFile root+     | otherwise -> return []+  where+  root = takeDirectory $ filePath f++-- | 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.+  -> CommandLineOptions+  -> TCM CommandLineOptions+setLibraryPaths root o =+  setLibraryIncludes =<< addDefaultLibraries root o+ setLibraryIncludes :: CommandLineOptions -> TCM CommandLineOptions-setLibraryIncludes o = do+setLibraryIncludes o+  | not (optUseLibs o) = pure o+  | otherwise = do     let libs = optLibraries o     installed <- libToTCM $ getInstalledLibraries (optOverrideLibrariesFile o)     paths     <- libToTCM $ libraryIncludePaths (optOverrideLibrariesFile o) installed libs     return o{ optIncludePaths = paths ++ optIncludePaths o } -addDefaultLibraries :: RelativeTo -> CommandLineOptions -> TCM CommandLineOptions-addDefaultLibraries rel o-  | or [ not $ null $ optLibraries o-       , not $ optUseLibs o-       , optShowVersion o ] = pure o+addDefaultLibraries+  :: AbsolutePath+     -- ^ The base directory of relative paths.+  -> CommandLineOptions+  -> TCM CommandLineOptions+addDefaultLibraries root o+  | not (null $ optLibraries o) || not (optUseLibs o) = pure o   | otherwise = do-  root <- getProjectRoot rel   (libs, incs) <- libToTCM $ getDefaultLibraries (filePath root) (optDefaultLibs o)   return o{ optIncludePaths = incs ++ optIncludePaths o, optLibraries = libs } -class (Functor m, Applicative m, Monad m) => HasOptions m where-  -- | Returns the pragma options which are currently in effect.-  pragmaOptions      :: m PragmaOptions-  -- | Returns the command line options which are currently in effect.-  commandLineOptions :: m CommandLineOptions+-- This function is only called when an interactor exists+-- (i.e. when Agda actually does something).+addTrustedExecutables+  :: CommandLineOptions+  -> TCM CommandLineOptions+addTrustedExecutables o = do+  trustedExes <- libToTCM $ getTrustedExecutables+  -- Wen, 2020-06-03+  -- Replace the map wholesale instead of computing the union because this function+  -- should never be called more than once, and doing so either has the same result+  -- or is a security risk.+  return o{ optTrustedExecutables = trustedExes } -instance MonadIO m => HasOptions (TCMT m) where-  pragmaOptions = use stPragmaOptions+-- | Set pragma options without checking for consistency.+setOptionsFromPragma :: OptionsPragma -> TCM ()+setOptionsFromPragma = setOptionsFromPragma' False -  commandLineOptions = do-    p  <- use stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> get-    return $ cl { optPragmaOptions = p }+-- | Set pragma options and check them for consistency.+checkAndSetOptionsFromPragma :: OptionsPragma -> TCM ()+checkAndSetOptionsFromPragma = setOptionsFromPragma' True -setOptionsFromPragma :: OptionsPragma -> TCM ()-setOptionsFromPragma ps = do+setOptionsFromPragma' :: Bool -> OptionsPragma -> TCM ()+setOptionsFromPragma' checkConsistency ps = setCurrentRange (pragmaRange ps) $ do     opts <- commandLineOptions-    z    <- liftIO $ runOptM (parsePragmaOptions ps opts)+    let (z, warns) = runOptM (parsePragmaOptions ps opts)+    mapM_ (warning . OptionWarning) warns     case z of-      Left err    -> typeError $ GenericError err-      Right opts' -> setPragmaOptions opts'+      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 :: TCM a -> TCM a+enableDisplayForms :: MonadTCEnv m => m a -> m a enableDisplayForms =-  local $ \e -> e { envDisplayFormsEnabled = True }+  localTC $ \e -> e { envDisplayFormsEnabled = True }  -- | Disable display forms.-disableDisplayForms :: TCM a -> TCM a+disableDisplayForms :: MonadTCEnv m => m a -> m a disableDisplayForms =-  local $ \e -> e { envDisplayFormsEnabled = False }+  localTC $ \e -> e { envDisplayFormsEnabled = False }  -- | Check if display forms are enabled.-displayFormsEnabled :: TCM Bool-displayFormsEnabled = asks envDisplayFormsEnabled+displayFormsEnabled :: MonadTCEnv m => m Bool+displayFormsEnabled = asksTC envDisplayFormsEnabled  -- | Gets the include directories. -- -- Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e. -- 'setCommandLineOptions' must have run). -getIncludeDirs :: TCM [AbsolutePath]+getIncludeDirs :: HasOptions m => m (List1 AbsolutePath) getIncludeDirs = do-  incs <- optAbsoluteIncludePaths <$> commandLineOptions-  case incs of-    [] -> __IMPOSSIBLE__-    _  -> return incs---- | Which directory should form the base of relative include paths?--data RelativeTo-  = ProjectRoot AbsolutePath-    -- ^ The root directory of the \"project\" containing the given-    -- file. The file needs to be syntactically correct, with a module-    -- name matching the file name.-  | CurrentDir-    -- ^ The current working directory.--getProjectRoot :: RelativeTo -> TCM AbsolutePath-getProjectRoot CurrentDir = liftIO (absolute =<< getCurrentDirectory)-getProjectRoot (ProjectRoot f) = do-  Ranged _ m <- moduleName' f-  return (projectRoot f m)+  List1.fromListSafe __IMPOSSIBLE__ . optAbsoluteIncludePaths <$> commandLineOptions  -- | Makes the given directories absolute and stores them as include -- directories. ----- If the include directories change, then the state is reset (completely,--- except for the include directories and 'stInteractionOutputCallback').+-- If the include directories change, then the state is reset+-- (completely, except for the include directories and some other+-- things). -- -- An empty list is interpreted as @["."]@. -setIncludeDirs :: [FilePath] -- ^ New include directories.-               -> RelativeTo -- ^ How should relative paths be interpreted?+setIncludeDirs :: [FilePath]    -- ^ New include directories.+               -> AbsolutePath  -- ^ The base directory of relative paths.                -> TCM ()-setIncludeDirs incs relativeTo = do+setIncludeDirs incs root = do   -- save the previous include dirs-  oldIncs <- gets Lens.getAbsoluteIncludePaths--  root <- getProjectRoot relativeTo+  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-  libdir <- liftIO $ defaultLibDir-      -- NB: This is an absolute file name, but-      -- Agda.Utils.FilePath wants to check absoluteness anyway.-  let primdir = mkAbsolute $ libdir </> "prim"+  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 $ 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 $ fmap pretty incs+    ]+   -- Check whether the include dirs have changed.  If yes, reset state.   -- Andreas, 2013-10-30 comments:   -- The logic, namely using the include-dirs variable as a driver   -- for the interaction, qualifies for a code-obfuscation contest.   -- I guess one Boolean more in the state cost 10.000 EUR at the time   -- of this implementation...-  when (oldIncs /= incs) $ do+  --+  -- Andreas, perhaps you have misunderstood something: If the include+  -- directories have changed and we do not reset the decoded modules,+  -- then we might (depending on how the rest of the code works) end+  -- 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 (List1.toList incs)) $ do     ho <- getInteractionOutputCallback+    tcWarnings <- useTC stTCWarnings -- restore already generated warnings+    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 stLibCache libCache     setInteractionOutputCallback ho--  Lens.putAbsoluteIncludePaths incs+    setDecodedModules keptDecodedModules+    setTCLens stModuleToSourceId modFile -  -- Andreas, 2016-07-11 (reconstructing semantics):-  ---  -- Check that the module name of the project root-  -- is still correct wrt. to the changed include path.+  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+  -- directories, and the same applies to all dependencies.   ---  -- E.g. if the include path was "/" and file "/A/B" was named "module A.B",-  -- and then the include path changes to "/A/", the module name-  -- becomes invalid; correct would then be "module B".--  case relativeTo of-    CurrentDir -> return ()-    ProjectRoot f -> void $ moduleName f-     -- Andreas, 2016-07-12 WAS:-     -- do-     --  Ranged _ m <- moduleName' f-     --  checkModuleName m f Nothing-+  -- File system accesses are cached using the ModuleToSource data+  -- structure: For the old include directories this should mean that+  -- the file system is not accessed, but the file system is accessed+  -- for the new include directories, and certain changes to the file+  -- system could lead to interfaces being discarded. A new+  -- ModuleToSource structure, constructed using the new include+  -- directories, is returned.+  modulesToKeep+    :: List1 AbsolutePath -- New include directories.+    -> DecodedModules  -- Old decoded modules.+    -> 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 TopLevelModuleName ()+    dependencyGraph =+      G.fromNodes+        [ iTopLevelModuleName $ miInterface m+        | m <- Map.elems old+        ]+        `G.union`+      G.fromEdges+        [ G.Edge+            { source = iTopLevelModuleName $ miInterface m+            , target = d+            , label = ()+            }+        | m      <- Map.elems old+        , (d, _) <- iImportedModules $ miInterface m+        ] -setInputFile :: FilePath -> TCM ()-setInputFile file =-    do  opts <- commandLineOptions-        setCommandLineOptions $-          opts { optInputFile = Just file }+    -- All the modules from old, sorted so that all of a module's+    -- dependencies precede it in the list.+    modules :: [ModuleInfo]+    modules =+      map (\case+              Graph.CyclicSCC{} ->+                -- Agda does not allow cycles in the dependency graph.+                __IMPOSSIBLE__+              Graph.AcyclicSCC m ->+                case Map.lookup m old of+                  Just m  -> m+                  Nothing -> __IMPOSSIBLE__) $+      G.sccs' dependencyGraph --- | Should only be run if 'hasInputFile'.-getInputFile :: TCM AbsolutePath-getInputFile = fromMaybeM __IMPOSSIBLE__ $-  getInputFile'+    process ::+      Map TopLevelModuleName ModuleInfo -> ModuleToSourceId ->+      [ModuleInfo] -> TCM (DecodedModules, ModuleToSourceId)+    process !keep !modFile [] = return+      ( Map.fromList $+        Map.toList keep+      , modFile+      )+    process keep modFile (m : ms) = do+      let deps     = map fst $ iImportedModules $ miInterface m+          depsKept = all (`Map.member` keep) deps+      (keep, modFile) <-+        if not depsKept then return (keep, modFile) else do+        let t = iTopLevelModuleName $ miInterface m+        oldF            <- findFile' t+        (newF, modFile) <- runStateT (findFile'_ incs t) modFile+        return $ case (oldF, newF) of+          (Right f1, Right f2) | f1 == f2 ->+            (Map.insert t m keep, modFile)+          _ -> (keep, modFile)+      process keep modFile ms --- | Return the 'optInputFile' as 'AbsolutePath', if any.-getInputFile' :: TCM (Maybe AbsolutePath)-getInputFile' = mapM (liftIO . absolute) =<< do-  optInputFile <$> commandLineOptions+isPropEnabled :: HasOptions m => m Bool+isPropEnabled = optProp <$> pragmaOptions -hasInputFile :: TCM Bool-hasInputFile = isJust <$> optInputFile <$> commandLineOptions+isLevelUniverseEnabled :: HasOptions m => m Bool+isLevelUniverseEnabled = optLevelUniverse <$> pragmaOptions -proofIrrelevance :: TCM Bool-proofIrrelevance = optProofIrrelevance <$> pragmaOptions+isTwoLevelEnabled :: HasOptions m => m Bool+isTwoLevelEnabled = optTwoLevel <$> pragmaOptions  {-# SPECIALIZE hasUniversePolymorphism :: TCM Bool #-} hasUniversePolymorphism :: HasOptions m => m Bool hasUniversePolymorphism = optUniversePolymorphism <$> pragmaOptions -{-# SPECIALIZE sharedFun :: TCM (Term -> Term) #-}-sharedFun :: HasOptions m => m (Term -> Term)-sharedFun = do-  sharing <- optSharing <$> commandLineOptions-  return $ if sharing then shared_ else id--{-# SPECIALIZE shared :: Term -> TCM Term #-}-shared :: HasOptions m => Term -> m Term-shared v = ($ v) <$> sharedFun--{-# SPECIALIZE sharedType :: Type -> TCM Type #-}-sharedType :: HasOptions m => Type -> m Type-sharedType (El s v) = El s <$> shared v--enableCaching :: TCM Bool-enableCaching = optCaching <$> commandLineOptions--showImplicitArguments :: TCM Bool+showImplicitArguments :: HasOptions m => m Bool showImplicitArguments = optShowImplicit <$> pragmaOptions -showIrrelevantArguments :: TCM Bool+showGeneralizedArguments :: HasOptions m => m Bool+showGeneralizedArguments = (\opt -> optShowGeneralized opt) <$> pragmaOptions++showIrrelevantArguments :: HasOptions m => m Bool showIrrelevantArguments = optShowIrrelevant <$> pragmaOptions +showIdentitySubstitutions :: HasOptions m => m Bool+showIdentitySubstitutions = optShowIdentitySubstitutions <$> pragmaOptions+ -- | Switch on printing of implicit and irrelevant arguments. --   E.g. for reification in with-function generation.-withShowAllArguments :: TCM a -> TCM a+--+--   Restores all 'PragmaOptions' after completion.+--   Thus, do not attempt to make persistent 'PragmaOptions'+--   changes in a `withShowAllArguments` bracket.++withShowAllArguments :: ReadTCState m => m a -> m a withShowAllArguments = withShowAllArguments' True -withShowAllArguments' :: Bool -> TCM a -> TCM a-withShowAllArguments' yes ret = do-  opts <- pragmaOptions-  let imp = optShowImplicit opts-      irr = optShowIrrelevant opts-  setPragmaOptions $ opts { optShowImplicit = yes, optShowIrrelevant = yes }-  x <- ret-  opts <- pragmaOptions-  setPragmaOptions $ opts { optShowImplicit = imp, optShowIrrelevant = irr }-  return x+withShowAllArguments' :: ReadTCState m => Bool -> m a -> m a+withShowAllArguments' yes = withPragmaOptions $ \ opts ->+  opts { _optShowImplicit = Value yes, _optShowIrrelevant = Value yes } -{- RETIRED, Andreas, 2012-04-30-setShowImplicitArguments :: Bool -> TCM a -> TCM a-setShowImplicitArguments showImp ret = do-  opts <- pragmaOptions-  let imp = optShowImplicit opts-  setPragmaOptions $ opts { optShowImplicit = showImp }-  x <- ret-  opts <- pragmaOptions-  setPragmaOptions $ opts { optShowImplicit = imp }-  return x--}+withoutPrintingGeneralization :: ReadTCState m => m a -> m a+withoutPrintingGeneralization = withPragmaOptions $ \ opts ->+  opts { _optShowGeneralized = Value False } -ignoreInterfaces :: TCM Bool-ignoreInterfaces = optIgnoreInterfaces <$> commandLineOptions+-- | Change 'PragmaOptions' for a computation and restore afterwards.+withPragmaOptions :: ReadTCState m => (PragmaOptions -> PragmaOptions) -> m a -> m a+withPragmaOptions = locallyTCState stPragmaOptions -positivityCheckEnabled :: TCM Bool-positivityCheckEnabled = not . optDisablePositivity <$> pragmaOptions+positivityCheckEnabled :: HasOptions m => m Bool+positivityCheckEnabled = optPositivityCheck <$> pragmaOptions  {-# SPECIALIZE typeInType :: TCM Bool #-} typeInType :: HasOptions m => m Bool typeInType = not . optUniverseCheck <$> pragmaOptions -etaEnabled :: TCM Bool+etaEnabled :: HasOptions m => m Bool etaEnabled = optEta <$> pragmaOptions -maxInstanceSearchDepth :: TCM Int+maxInstanceSearchDepth :: HasOptions m => m Int maxInstanceSearchDepth = optInstanceSearchDepth <$> pragmaOptions ---------------------------------------------------------------------------- Verbosity---- Invariant (which we may or may not currently break): Debug--- printouts use one of the following functions:------   reportS---   reportSLn---   reportSDoc---- | Retrieve the current verbosity level.-{-# SPECIALIZE getVerbosity :: TCM (Trie String Int) #-}-getVerbosity :: HasOptions m => m (Trie String Int)-getVerbosity = optVerbose <$> pragmaOptions--type VerboseKey = String---- | Check whether a certain verbosity level is activated.------   Precondition: The level must be non-negative.-{-# SPECIALIZE hasVerbosity :: VerboseKey -> Int -> TCM Bool #-}-hasVerbosity :: HasOptions m => VerboseKey -> Int -> m Bool-hasVerbosity k n | n < 0     = __IMPOSSIBLE__-                 | otherwise = do-    t <- getVerbosity-    let ks = wordsBy (`elem` ".:") k-        m  = last $ 0 : Trie.lookupPath ks t-    return (n <= m)---- | Displays a debug message in a suitable way.-{-# SPECIALIZE displayDebugMessage :: Int -> String -> TCM () #-}-displayDebugMessage :: MonadTCM tcm-  => Int     -- ^ The message's debug level.-  -> String  -- ^ Message.-  -> tcm ()-displayDebugMessage n s = liftTCM $-  appInteractionOutputCallback (Resp_RunningInfo n s)---- | Run a computation if a certain verbosity level is activated.------   Precondition: The level must be non-negative.-{-# SPECIALIZE verboseS :: VerboseKey -> Int -> TCM () -> TCM () #-}-verboseS :: MonadTCM tcm => VerboseKey -> Int -> tcm () -> tcm ()-verboseS k n action = whenM (liftTCM $ hasVerbosity k n) action---- | Conditionally print debug string.-{-# SPECIALIZE reportS :: VerboseKey -> Int -> String -> TCM () #-}-reportS :: MonadTCM tcm => VerboseKey -> Int -> String -> tcm ()-reportS k n s = liftTCM $ verboseS k n $ displayDebugMessage n s---- | Conditionally println debug string.-{-# SPECIALIZE reportSLn :: VerboseKey -> Int -> String -> TCM () #-}-reportSLn :: MonadTCM tcm => VerboseKey -> Int -> String -> tcm ()-reportSLn k n s = verboseS k n $-  displayDebugMessage n (s ++ "\n")+maxInversionDepth :: HasOptions m => m Int+maxInversionDepth = optInversionMaxDepth <$> pragmaOptions --- | Conditionally render debug 'Doc' and print it.-{-# SPECIALIZE reportSDoc :: VerboseKey -> Int -> TCM Doc -> TCM () #-}-reportSDoc :: MonadTCM tcm => VerboseKey -> Int -> TCM Doc -> tcm ()-reportSDoc k n d = liftTCM $ verboseS k n $ do-  displayDebugMessage n . (++ "\n") . show =<< do-    d `catchError` \ err ->-      (\ s -> (sep $ map text-                 [ "Printing debug message"-                 , k  ++ ":" ++show n-                 , "failed due to error:" ]) $$-              (nest 2 $ text s)) <$> prettyError err+-- | Returns the 'Language' currently in effect. --- | Print brackets around debug messages issued by a computation.-{-# SPECIALIZE verboseBracket :: VerboseKey -> Int -> String -> TCM a -> TCM a #-}-verboseBracket :: MonadTCM tcm => VerboseKey -> Int -> String -> TCM a -> tcm a-verboseBracket k n s m = liftTCM $ ifNotM (hasVerbosity k n) m $ {- else -} do-  displayDebugMessage n $ "{ " ++ s ++ "\n"-  m `finally` displayDebugMessage n "}\n"+getLanguage :: HasOptions m => m Language+getLanguage = do+  opts <- pragmaOptions+  return $+    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,26 +1,11 @@-module Agda.TypeChecking.Monad.Options where+{-# OPTIONS_GHC -Wunused-imports #-} -import Control.Applicative-import Control.Monad.Trans+module Agda.TypeChecking.Monad.Options where -import Agda.Interaction.Options+import Agda.Interaction.Library.Base+import Agda.Interaction.Options.HasOptions import Agda.TypeChecking.Monad.Base-import Agda.Utils.FileName-import Agda.Utils.Pretty--getIncludeDirs :: TCM [AbsolutePath]--type VerboseKey = String--class (Functor m, Applicative m, Monad m) => HasOptions m where-  -- | Returns the pragma options which are currently in effect.-  pragmaOptions      :: m PragmaOptions-  -- | Returns the command line options which are currently in effect.-  commandLineOptions :: m CommandLineOptions--instance MonadIO m => HasOptions (TCMT m)+import Agda.Utils.List1 (List1) -hasVerbosity :: HasOptions m => VerboseKey -> Int -> m Bool-verboseS :: MonadTCM tcm => VerboseKey -> Int -> tcm () -> tcm ()-reportSLn :: MonadTCM tcm => VerboseKey -> Int -> String -> tcm ()-reportSDoc :: MonadTCM tcm => VerboseKey -> Int -> TCM Doc -> tcm ()+libToTCM       :: LibM a -> TCM a+getIncludeDirs :: HasOptions m => m (List1 AbsolutePath)
+ src/full/Agda/TypeChecking/Monad/Pure.hs view
@@ -0,0 +1,45 @@+{-# 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).+++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 Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Signature++import Agda.Utils.ListT+import Agda.Utils.Update++class+  ( HasBuiltins m+  , HasConstInfo m+  , MonadAddContext m+  , MonadDebug m+  , MonadReduce m+  , MonadTCEnv m+  , ReadTCState m+  ) => PureTCM m where++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)+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/Pure.hs-boot view
@@ -0,0 +1,34 @@+{-# 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 {-# SOURCE #-} Agda.TypeChecking.Monad.Debug+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature++class+  ( HasBuiltins m+  , HasConstInfo m+  , MonadAddContext m+  , MonadDebug m+  , MonadReduce m+  , MonadTCEnv m+  , ReadTCState m+  ) => 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/Sharing.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE CPP              #-}--module Agda.TypeChecking.Monad.Sharing where--import Control.Applicative-import Control.Monad.Reader-import Data.List-import Data.Function-import Data.Traversable--import Agda.Syntax.Internal-import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Options-import Agda.Utils.Monad--#include "undefined.h"-import Agda.Utils.Impossible--updateSharedTerm :: MonadReader TCEnv m => (Term -> m Term) -> Term -> m Term-updateSharedTerm f v =-  ifM (asks envAllowDestructiveUpdate)-      (updateSharedM f v)-      (f $ ignoreSharing v)--updateSharedTermF-#if __GLASGOW_HASKELL__ <= 708-  :: (Applicative m, MonadReader TCEnv m, Traversable f)-#else-  :: (MonadReader TCEnv m, Traversable f)-#endif-  => (Term -> m (f Term)) -> Term -> m (f Term)-updateSharedTermF f v =-  ifM (asks envAllowDestructiveUpdate)-      (updateSharedFM f v)-      (f $ ignoreSharing v)--updateSharedTermT :: (MonadTCM tcm, MonadTrans t, Monad (t tcm)) => (Term -> t tcm Term) -> Term -> t tcm Term-updateSharedTermT f v =-  ifM (lift $ asks envAllowDestructiveUpdate)-      (updateSharedM f v)-      (f $ ignoreSharing v)--forceEqualTerms :: Term -> Term -> TCM ()-forceEqualTerms u v =-  whenM (asks envAllowDestructiveUpdate) $-  when (null $ (intersect `on` pointerChain) u v) $-  case (u, v) of-    (Shared p, Shared q) | p > q -> update u v-    (_, Shared{})                -> update v u-    (Shared{}, _)                -> update u v-    _ -> return ()-  where-    -- TODO: compress pointer chain-    update u@(Shared{}) v = do-        report u v-        setPtr v p `seq` compressPointerChain u `seq` return ()-      where p = last $ pointerChain u-    update _ _ = __IMPOSSIBLE__-    report x y = reportSLn "tc.ptr" 50 $ "setting " ++ show x ++ "\n     to " ++ show y-
src/full/Agda/TypeChecking/Monad/Signature.hs view
@@ -1,1012 +1,1490 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.Monad.Signature where--import Prelude hiding (null)--import Control.Arrow (first, second, (***))-import Control.Applicative hiding (empty)-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Trans.Maybe--import Data.List hiding (null)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid--import Agda.Syntax.Abstract.Name-import Agda.Syntax.Abstract (Ren, ScopeCopyInfo(..))-import Agda.Syntax.Common-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Names-import Agda.Syntax.Position-import Agda.Syntax.Treeless (Compiled(..), TTerm)--import qualified Agda.Compiler.UHC.Pragmas.Base as CR--import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Context-import Agda.TypeChecking.Monad.Options-import Agda.TypeChecking.Monad.Env-import Agda.TypeChecking.Monad.Exception ( ExceptionT )-import Agda.TypeChecking.Monad.Mutual-import Agda.TypeChecking.Monad.Open-import Agda.TypeChecking.Monad.Local-import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Substitute-import {-# SOURCE #-} Agda.TypeChecking.Telescope-import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile-import {-# SOURCE #-} Agda.TypeChecking.Polarity-import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike--import Agda.Utils.Except ( Error )-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.Map as Map-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty-import Agda.Utils.Size-import qualified Agda.Utils.HashMap as HMap--#include "undefined.h"-import Agda.Utils.Impossible---- | Add a constant to the signature. Lifts the definition to top level.-addConstant :: QName -> Definition -> TCM ()-addConstant q d = do-  reportSLn "tc.signature" 20 $ "adding constant " ++ show q ++ " to signature"-  tel <- getContextTelescope-  let tel' = replaceEmptyName "r" $ killRange $ case theDef d of-              Constructor{} -> fmap hideOrKeepInstance tel-              Function{ funProjection = Just Projection{ projProper = True, 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-                  case initLast $ telToList tel of-                    Nothing -> fallback-                    Just (doms, dom) -> telFromList $ fmap hideOrKeepInstance doms ++ [dom]-              _ -> tel-  let d' = abstract tel' $ d { defName = q }-  reportSLn "tc.signature" 30 $ "lambda-lifted definition = " ++ show d'-  modifySignature $ updateDefinitions $ HMap.insertWith (+++) q d'-  i <- currentOrFreshMutualBlock-  setMutualBlock i q-  where-    new +++ old = new { defDisplay = defDisplay new ++ defDisplay old-                      , defInstance = defInstance new `mplus` defInstance old }---- | Set termination info of a defined function symbol.-setTerminates :: QName -> Bool -> TCM ()-setTerminates q b = modifySignature $ updateDefinition q $ updateTheDef $ setT-  where-    setT def@Function{} = def { funTerminates = Just b }-    setT def            = def---- | Modify the clauses of a function.-modifyFunClauses :: QName -> ([Clause] -> [Clause]) -> TCM ()-modifyFunClauses q f =-  modifySignature $ updateDefinition q $ updateTheDef $ updateFunClauses f---- | Lifts clauses to the top-level and adds them to definition.-addClauses :: QName -> [Clause] -> TCM ()-addClauses q cls = do-  tel <- getContextTelescope-  modifyFunClauses q (++ abstract tel cls)--ensureNoCompiledHaskell :: QName -> TCM ()-ensureNoCompiledHaskell q =-  whenM (isJust . compiledHaskell . defCompiledRep <$> getConstInfo q) $-    typeError $ GenericError $ "Multiple Haskell bindings for " ++ show q ++ ". " ++-                               "Note that builtin numbers, booleans, chars and strings don't need " ++-                               "COMPILED pragmas."--addHaskellCode :: QName -> HaskellType -> HaskellCode -> TCM ()-addHaskellCode q hsTy hsDef = do-  ensureNoCompiledHaskell q-  modifySignature $ updateDefinition q $ updateDefCompiledRep $ addHs-  where-    addHs crep = crep { compiledHaskell = Just $ HsDefn hsTy hsDef }--addHaskellExport :: QName -> HaskellType -> String -> TCM ()-addHaskellExport q hsTy hsName = do-  ensureNoCompiledHaskell q-  modifySignature $ updateDefinition q $ updateDefCompiledRep $ addHs-  where-    addHs crep = crep { exportHaskell = Just (HsExport hsTy hsName)}--addHaskellType :: QName -> HaskellType -> TCM ()-addHaskellType q hsTy = do-  ensureNoCompiledHaskell q-  modifySignature $ updateDefinition q $ updateDefCompiledRep $ addHs-  where-    addHs crep = crep { compiledHaskell = Just $ HsType hsTy }--addEpicCode :: QName -> EpicCode -> TCM ()-addEpicCode q epDef = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addEp-  -- TODO: sanity checking-  where-    addEp crep = crep { compiledEpic = Just epDef }--addJSCode :: QName -> String -> TCM ()-addJSCode q jsDef = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addJS-  where-    addJS crep = crep { compiledJS = Just jsDef }--addCoreCode :: QName -> CR.CoreExpr -> TCM ()-addCoreCode q crDef =  modifySignature $ updateDefinition q $ updateDefCompiledRep $ addCore crDef-  where-    addCore e crep = crep { compiledCore = Just $ CrDefn e }--addCoreConstr :: QName -> CR.CoreConstr -> TCM ()-addCoreConstr q con = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addCore-  where-    addCore crep = crep {compiledCore = Just $ CrConstr con }--addCoreType :: QName -> CR.CoreType -> TCM ()-addCoreType q crTy = modifySignature $ updateDefinition q $ updateDefCompiledRep $ addCr-  -- TODO: sanity checking-  where-    addCr crep = crep { compiledCore = Just $ CrType crTy }--setFunctionFlag :: FunctionFlag -> Bool -> QName -> TCM ()-setFunctionFlag flag val q = modifyGlobalDefinition q $ set (theDefLens . funFlag flag) val--markStatic :: QName -> TCM ()-markStatic = setFunctionFlag FunStatic True--markInline :: QName -> TCM ()-markInline = setFunctionFlag FunInline True--unionSignatures :: [Signature] -> Signature-unionSignatures ss = foldr unionSignature emptySignature ss-  where-    unionSignature (Sig a b c) (Sig a' b' c') =-      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---- | Add a section to the signature.------   The current context will be stored as the cumulative module parameters---   for this section.-addSection :: ModuleName -> TCM ()-addSection m = do-  tel <- getContextTelescope-  let sec = Section tel-  -- Make sure we do not overwrite an existing section!-  whenJustM (getSection m) $ \ sec' -> do-    -- At least not with different content!-    if (sec == sec') then do-      -- Andreas, 2015-12-02: test/Succeed/Issue1701II.agda-      -- reports a "redundantly adding existing section".-      reportSLn "tc.section" 10 $ "warning: redundantly adding existing section " ++ show m-      reportSLn "tc.section" 60 $ "with content " ++ show sec-    else do-      reportSLn "impossible" 10 $ "overwriting existing section " ++ show m-      reportSLn "impossible" 60 $ "of content   " ++ show sec'-      reportSLn "impossible" 60 $ "with content " ++ show sec-      __IMPOSSIBLE__-  -- Add the new section.-  setDefaultModuleParameters m-  modifySignature $ over sigSections $ Map.insert m sec--setDefaultModuleParameters :: ModuleName -> TCM ()-setDefaultModuleParameters m =-  stModuleParameters %= Map.insert m defaultModuleParameters---- | Get a section.------   Why Maybe? The reason is that we look up all prefixes of a module to---   compute number of parameters, and for hierarchical top-level modules,---   A.B.C say, A and A.B do not exist.-{-# SPECIALIZE getSection :: ModuleName -> TCM (Maybe Section) #-}-{-# SPECIALIZE getSection :: ModuleName -> ReduceM (Maybe Section) #-}-getSection :: (Functor m, ReadTCState m) => ModuleName -> m (Maybe Section)-getSection m = do-  sig  <- (^. stSignature . sigSections) <$> getTCState-  isig <- (^. stImports   . sigSections) <$> getTCState-  return $ Map.lookup m sig `mplus` Map.lookup m isig---- | Lookup a section telescope.------   If it doesn't exist, like in hierarchical top-level modules,---   the section telescope is empty.-{-# SPECIALIZE lookupSection :: ModuleName -> TCM Telescope #-}-{-# SPECIALIZE lookupSection :: ModuleName -> ReduceM Telescope #-}-lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope-lookupSection m = maybe EmptyTel (^. secTelescope) <$> getSection m---- Add display forms to all names @xn@ such that @x = x1 es1@, ... @xn-1 = xn esn@.-addDisplayForms :: QName -> TCM ()-addDisplayForms x = do-  def  <- getConstInfo x-  args <- drop (projectionArgs $ theDef def) <$> getContextArgs-  add args x x $ map Apply $ raise 1 args -- make room for the single match variable of the display form-  where-    add args top x es0 = do-      def <- getConstInfo x-      let cs = defClauses def-          isCopy = defCopy def-      case cs of-        [ cl ] -> do-          if not isCopy-            then noDispForm x "not a copy" else do-          if not $ all (isVar . namedArg) $ namedClausePats cl-            then noDispForm x "properly matching patterns" else do-          -- We have-          --    x ps = e-          -- and we're trying to generate a display form-          --    x es0 <-- e[es0/ps]-          -- Of course x es0 might be an over- or underapplication, hence the-          -- n/m arithmetic.-          let n          = size $ namedClausePats cl-              (es1, es2) = splitAt n es0-              m          = n - size es1-              vs1 = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1-              sub = parallelS $ reverse $ vs1 ++ replicate m (var 0)-              body = applySubst sub (compiledClauseBody cl) `applyE` es2-          case unSpine <$> body of-            Just (Def y es) -> do-              let df = Display m es $ DTerm $ Def top $ map Apply args-              reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top-                                                ++ "\n  " ++ show df-              addDisplayForm y df-              add args top y es-            Just v          -> noDispForm x $ "not a def body, but " ++ show v-            Nothing         -> noDispForm x $ "bad body"-        [] | Constructor{ conSrcCon = h } <- theDef def -> do-              let y  = conName h-                  df = Display 0 [] $ DTerm $ Con (h {conName = top }) ConOSystem []-              reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top-                                                ++ "\n  " ++ show df-              addDisplayForm y df-        [] -> noDispForm x "no clauses"-        (_:_:_) -> noDispForm x "many clauses"--    noDispForm x reason = reportSLn "tc.display.section" 30 $-      "no display form from " ++ show x ++ " because " ++ reason--    isVar VarP{} = True-    isVar _      = False---- | Module application (followed by module parameter abstraction).-applySection-  :: ModuleName     -- ^ Name of new module defined by the module macro.-  -> Telescope      -- ^ Parameters of new module.-  -> ModuleName     -- ^ Name of old module applied to arguments.-  -> Args           -- ^ Arguments of module application.-  -> ScopeCopyInfo  -- ^ Imported names and modules-  -> TCM ()-applySection new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd } = do-  rd <- closeConstructors rd-  applySection' new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd }-  where-    -- If a datatype is being copied, all its constructors need to be copied,-    -- and if a constructor is copied its datatype needs to be.-    closeConstructors rd = do-        ds <- nub . concat <$> mapM (constructorData . fst) rd-        cs <- nub . concat <$> mapM (dataConstructors . fst) rd-        new <- concat <$> mapM rename (ds ++ cs)-        reportSLn "tc.mod.apply.complete" 30 $-          "also copying: " ++ show new-        return $ new ++ rd-      where-        rename x =-          case lookup x rd of-            Nothing -> do y <- freshName_ (show x)-                          return [(x, qnameFromList [y])]-            Just{}  -> return []--        constructorData x = do-          def <- theDef <$> getConstInfo x-          return $ case def of-            Constructor{ conData = d } -> [d]-            _                          -> []-        dataConstructors x = do-          def <- theDef <$> getConstInfo x-          return $ case def of-            Datatype{ dataCons = cs } -> cs-            Record{ recConHead = h }      -> [conName h]-            _                         -> []--applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM ()-applySection' new ptel old ts ScopeCopyInfo{ renNames = rd, renModules = rm } = do-  reportSLn "tc.mod.apply" 10 $ render $ vcat-    [ text "applySection"-    , text "new  =" <+> text (show new)-    , text "ptel =" <+> text (show ptel)-    , text "old  =" <+> text (show old)-    , text "ts   =" <+> text (show ts)-    ]-  reportSLn "tc.mod.apply" 80 $ render $ vcat-    [ text "arguments:  " <+> text (show ts)-    ]-  mapM_ (copyDef ts) rd-  mapM_ (copySec ts) rm-  mapM_ computePolarity (map snd rd)-  where-    -- Andreas, 2013-10-29-    -- Here, if the name x is not imported, it persists as-    -- old, possibly out-of-scope name.-    -- This old name may used by the case split tactic, leading to-    -- names that cannot be printed properly.-    -- I guess it would make sense to mark non-imported names-    -- as such (out-of-scope) and let splitting fail if it would-    -- produce out-of-scope constructors.-    copyName x = fromMaybe x $ lookup x rd--    argsToUse x = do-      let m = commonParentModule old x-      reportSLn "tc.mod.apply" 80 $ "Common prefix: " ++ show m-      size <$> lookupSection m--    copyDef :: Args -> (QName, QName) -> TCM ()-    copyDef ts (x, y) = do-      def <- getConstInfo x-      np  <- argsToUse (qnameModule x)-      copyDef' np def-      where-        copyDef' np d = do-          reportSLn "tc.mod.apply" 60 $ "making new def for " ++ show y ++ " from " ++ show x ++ " with " ++ show np ++ " args " ++ show (defAbstract d)-          reportSLn "tc.mod.apply" 80 $-            "args = " ++ show ts' ++ "\n" ++-            "old type = " ++ prettyShow (defType d)-          reportSLn "tc.mod.apply" 80 $-            "new type = " ++ prettyShow t-          addConstant y =<< nd y-          makeProjection y-          -- Issue1238: the copied def should be an 'instance' if the original-          -- def is one. Skip constructors since the original constructor will-          -- still work as an instance.-          unless isCon $ whenJust inst $ \ c -> addNamedInstance y c-          -- 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--}-          -- 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-            addDisplayForms y-          where-            ts' = take np ts-            t   = defType d `piApply` ts'-            pol = defPolarity d `apply` ts'-            occ = defArgOccurrences d `apply` ts'-            inst = defInstance d-            -- the name is set by the addConstant function-            nd :: QName -> TCM Definition-            nd y = for def $ \ df -> Defn-                    { defArgInfo        = defArgInfo d-                    , defName           = y-                    , defType           = t-                    , defPolarity       = pol-                    , defArgOccurrences = occ-                    , defDisplay        = []-                    , defMutual         = -1   -- TODO: mutual block?-                    , defCompiledRep    = noCompiledRep-                    , defInstance       = inst-                    , defCopy           = True-                    , defMatchable      = False-                    , theDef            = df }-            oldDef = theDef d-            isCon  = case oldDef of { Constructor{} -> True ; _ -> False }-            mutual = case oldDef of { Function{funMutual = m} -> m              ; _ -> [] }-            extlam = case oldDef of { Function{funExtLam = e} -> e              ; _ -> Nothing }-            with   = case oldDef of { Function{funWith = w}   -> copyName <$> w ; _ -> Nothing }-            -- Andreas, 2015-05-11, to fix issue 1413:-            -- Even if we apply the record argument (must be @var 0@), we stay a projection.-            -- This is because we may abstract the record argument later again.-            -- See succeed/ProjectionNotNormalized.agda-            isVar0 t = case ignoreSharing $ unArg t of Var 0 [] -> True; _ -> False-            proj   = case oldDef of-              Function{funProjection = Just 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'-                            }-              _ -> Nothing-            def =-              case oldDef of-                Constructor{ conPars = np, conData = d } -> return $-                  oldDef { conPars = np - size ts'-                         , conData = copyName d-                         }-                Datatype{ dataPars = np, dataCons = cs } -> return $-                  oldDef { dataPars   = np - size ts'-                         , dataClause = Just cl-                         , dataCons   = map copyName cs-                         }-                Record{ recPars = np, recTel = tel } -> return $-                  oldDef { recPars    = np - size ts'-                         , recClause  = Just cl-                         , recTel     = apply tel ts'-                         }-                _ -> do-                  cc <- compileClauses Nothing [cl] -- Andreas, 2012-10-07 non need for record pattern translation-                  let newDef =-                        set funMacro  (oldDef ^. funMacro) $-                        set funStatic (oldDef ^. funStatic) $-                        set funInline True $-                        emptyFunction-                        { funClauses        = [cl]-                        , funCompiled       = Just cc-                        , funMutual         = mutual-                        , funProjection     = proj-                        , funTerminates     = Just True-                        , funExtLam         = extlam-                        , funWith           = with-                        , funCopatternLHS   = isCopatternLHS [cl]-                        }-                  reportSLn "tc.mod.apply" 80 $ "new def for " ++ show x ++ "\n  " ++ show newDef-                  return newDef--            cl = Clause { clauseRange     = getRange $ defClauses d-                        , clauseTel       = EmptyTel-                        , namedClausePats = []-                        , clauseBody      = Just $ case oldDef of-                            Function{funProjection = Just p} -> projDropParsApply p ProjSystem ts'-                            _ -> Def x $ map Apply ts'-                        , clauseType      = Just $ defaultArg t-                        , clauseCatchall  = False-                        }--    {- Example--    module Top Θ where-      module A Γ where-        module M Φ where-      module B Δ where-        module N Ψ where-          module O Ψ' where-        open A public     -- introduces only M --> A.M into the *scope*-    module C Ξ = Top.B ts--    new section C-      tel = Ξ.(Θ.Δ)[ts]--    calls-      1. copySec ts (Top.A.M, C.M)-      2. copySec ts (Top.B.N, C.N)-      3. copySec ts (Top.B.N.O, C.N.O)-    with-      old = Top.B--    For 1.-      Common prefix is: Top-      totalArgs = |Θ|   (section Top)-      tel       = Θ.Γ.Φ (section Top.A.M)-      ts'       = take totalArgs ts-      Θ₂        = drop totalArgs Θ-      new section C.M-        tel =  Θ₂.Γ.Φ[ts']-    -}-    copySec :: Args -> (ModuleName, ModuleName) -> TCM ()-    copySec ts (x, y) = do-      totalArgs <- argsToUse x-      tel       <- lookupSection x-      let sectionTel =  apply tel $ take totalArgs ts-      reportSLn "tc.mod.apply" 80 $ "Copying section " ++ show x ++ " to " ++ show y-      reportSLn "tc.mod.apply" 80 $ "  ts           = " ++ intercalate "; " (map prettyShow ts)-      reportSLn "tc.mod.apply" 80 $ "  totalArgs    = " ++ show totalArgs-      reportSLn "tc.mod.apply" 80 $ "  tel          = " ++ intercalate " " (map (fst . unDom) $ telToList tel)  -- only names-      reportSLn "tc.mod.apply" 80 $ "  sectionTel   = " ++ intercalate " " (map (fst . unDom) $ telToList ptel) -- only names-      addContext sectionTel $ addSection y---- | Add a display form to a definition (could be in this or imported signature).-addDisplayForm :: QName -> DisplayForm -> TCM ()-addDisplayForm x df = do-  d <- makeLocal df-  let add = updateDefinition x $ \ def -> def{ defDisplay = d : defDisplay def }-  ifM (isLocal x)-    {-then-} (modifySignature add)-    {-else-} (stImportsDisplayForms %= HMap.insertWith (++) x [d])-  whenM (hasLoopingDisplayForm x) $-    typeError . GenericDocError $ text "Cannot add recursive display form for" <+> pretty x--isLocal :: QName -> TCM Bool-isLocal x = isJust . HMap.lookup x <$> use (stSignature . sigDefinitions)--getDisplayForms :: QName -> TCM [LocalDisplayForm]-getDisplayForms q = do-  ds  <- defDisplay <$> getConstInfo q-  ds1 <- maybe [] id . HMap.lookup q <$> use stImportsDisplayForms-  ds2 <- maybe [] id . HMap.lookup q <$> use stImportedDisplayForms-  ifM (isLocal q) (return $ ds ++ ds1 ++ ds2)-                  (return $ ds1 ++ ds ++ ds2)---- | 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 used []       = pure used-    go used (q : qs) = do-      let rhs (Display _ _ e) = e   -- Only look at names in the right-hand side (#1870)-      ds <- (`Set.difference` used) . Set.unions . map (namesIn . rhs . dget)-            <$> (getDisplayForms q `catchError_` \ _ -> pure [])  -- might be a pattern synonym-      go (Set.union ds used) (Set.toList ds ++ qs)---- | Check if a display form is looping.-hasLoopingDisplayForm :: QName -> TCM Bool-hasLoopingDisplayForm q = Set.member q <$> chaseDisplayForms q--canonicalName :: QName -> TCM QName-canonicalName x = do-  def <- theDef <$> getConstInfo x-  case def of-    Constructor{conSrcCon = c}                                -> return $ conName c-    Record{recClause = Just (Clause{ clauseBody = body })}    -> can body-    Datatype{dataClause = Just (Clause{ clauseBody = body })} -> can body-    _                                                         -> return x-  where-    can body = canonicalName $ extract $ fromMaybe __IMPOSSIBLE__ body-    extract (Def x _)  = x-    extract (Shared p) = extract $ derefPtr p-    extract _          = __IMPOSSIBLE__--sameDef :: QName -> QName -> TCM (Maybe QName)-sameDef d1 d2 = do-  c1 <- canonicalName d1-  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 :: QName -> TCM Induction-whatInduction c = do-  def <- theDef <$> getConstInfo c-  case def of-    Datatype{ dataInduction = i } -> return i-    Record{ recRecursive = False} -> return Inductive-    Record{ recInduction = i    } -> return $ fromMaybe Inductive i-    Constructor{ conInd = i }     -> return i-    _                             -> __IMPOSSIBLE__---- | Does the given constructor come from a single-constructor type?------ Precondition: The name has to refer to a constructor.-singleConstructorType :: QName -> TCM Bool-singleConstructorType q = do-  d <- theDef <$> getConstInfo q-  case d of-    Record {}                   -> return True-    Constructor { conData = d } -> do-      di <- theDef <$> getConstInfo d-      return $ case di of-        Record {}                  -> True-        Datatype { dataCons = cs } -> length cs == 1-        _                          -> __IMPOSSIBLE__-    _ -> __IMPOSSIBLE__--class (Functor m, Applicative m, Monad m) => HasConstInfo m where-  -- | Lookup the definition of a name. The result is a closed thing, all free-  --   variables have been abstracted over.-  getConstInfo :: QName -> m Definition-  -- | Lookup the rewrite rules with the given head symbol.-  getRewriteRulesFor :: QName -> m RewriteRules--{-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-}--defaultGetRewriteRulesFor :: (Monad m) => m TCState -> QName -> m RewriteRules-defaultGetRewriteRulesFor getTCState 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]---- | Get the original name of the projection---   (the current one could be from a module application).-getOriginalProjection :: HasConstInfo m => QName -> m QName-getOriginalProjection q = projOrig . fromMaybe __IMPOSSIBLE__ <$> isProjection q--instance HasConstInfo (TCMT IO) where-  getRewriteRulesFor = defaultGetRewriteRulesFor get-  getConstInfo q = join $ pureTCM $ \st env ->-    let defs  = st^.(stSignature . sigDefinitions)-        idefs = st^.(stImports . sigDefinitions)-    in case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of-        []  -> fail $ "Unbound name: " ++ show q ++ " " ++ showQNameId q-        [d] -> mkAbs env d-        ds  -> fail $ "Ambiguous name: " ++ show q-    where-      mkAbs env d-        | treatAbstractly' q' env =-          case makeAbstract d of-            Just d      -> return d-            Nothing     -> notInScope $ qnameToConcrete q-              -- the above can happen since the scope checker is a bit sloppy with 'abstract'-        | otherwise = return d-        where-          q' = case theDef d of-            -- Hack to make abstract constructors work properly. The constructors-            -- live in a module with the same name as the datatype, but for 'abstract'-            -- purposes they're considered to be in the same module as the datatype.-            Constructor{} -> dropLastModule q-            _             -> q--          dropLastModule q@QName{ qnameModule = m } =-            q{ qnameModule = mnameFromList $ ifNull (mnameToList m) __IMPOSSIBLE__ init }--instance (HasConstInfo m) => HasConstInfo (MaybeT m) where-  getConstInfo = lift . getConstInfo-  getRewriteRulesFor = lift . getRewriteRulesFor--instance (HasConstInfo m, Error err) => HasConstInfo (ExceptionT err m) where-  getConstInfo = lift . getConstInfo-  getRewriteRulesFor = lift . getRewriteRulesFor--{-# INLINE getConInfo #-}-getConInfo :: MonadTCM tcm => ConHead -> tcm Definition-getConInfo = liftTCM . getConstInfo . conName---- | Look up the polarity of a definition.-getPolarity :: QName -> TCM [Polarity]-getPolarity q = defPolarity <$> getConstInfo q---- | Look up polarity of a definition and compose with polarity---   represented by 'Comparison'.-getPolarity' :: Comparison -> QName -> TCM [Polarity]-getPolarity' CmpEq  q = map (composePol Invariant) <$> getPolarity q -- return []-getPolarity' CmpLeq q = getPolarity q -- composition with Covariant is identity---- | Set the polarity of a definition.-setPolarity :: QName -> [Polarity] -> TCM ()-setPolarity q pol = do-  reportSLn "tc.polarity.set" 20 $-    "Setting polarity of " ++ show q ++ " to " ++ show pol ++ "."-  modifySignature $ updateDefinition q $ updateDefPolarity $ const pol---- | 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---- | Sets the 'defArgOccurrences' for the given identifier (which--- should already exist in the signature).-setArgOccurrences :: QName -> [Occurrence] -> TCM ()-setArgOccurrences d os = modifyArgOccurrences d $ const os--modifyArgOccurrences :: QName -> ([Occurrence] -> [Occurrence]) -> TCM ()-modifyArgOccurrences d f =-  modifySignature $ updateDefinition d $ updateDefArgOccurrences f--setTreeless :: QName -> TTerm -> TCM ()-setTreeless q t = modifyGlobalDefinition q $ setTT-  where-    setTT def@Defn{theDef = fun@Function{}} =-      def{theDef = fun{funTreeless = Just (Compiled t [])}}-    setTT def = __IMPOSSIBLE__--setCompiledArgUse :: QName -> [Bool] -> TCM ()-setCompiledArgUse q use = modifyGlobalDefinition q $ setTT-  where-    setTT def@Defn{theDef = fun@Function{}} =-      def{theDef = fun{funTreeless = for (funTreeless fun) $ \ c -> c { cArgUsage = use }}}-    setTT def = __IMPOSSIBLE__--getCompiled :: QName -> TCM (Maybe Compiled)-getCompiled q = do-  def <- theDef <$> getConstInfo q-  return $ case def of-    Function{ funTreeless = t } -> t-    _                           -> Nothing--getErasedConArgs :: QName -> TCM [Bool]-getErasedConArgs q = do-  def <- getConstInfo q-  case theDef def of-    Constructor{ conData = d, conPars = np, conErased = es } -> do-      ddef <- getConstInfo d-      case compiledHaskell $ defCompiledRep ddef of-        Nothing -> return es-        Just _  -> do-          -- Can't erase arguments of COMPILED_DATA constructors yet-          TelV tel _ <- telView $ defType def-          return $ replicate (size tel - np) False-    _ -> __IMPOSSIBLE__--setErasedConArgs :: QName -> [Bool] -> TCM ()-setErasedConArgs q args = modifyGlobalDefinition q setArgs-  where-    setArgs def@Defn{theDef = con@Constructor{}} =-      def{ theDef = con{ conErased = args } }-    setArgs def = def   -- no-op for non-constructors--getTreeless :: QName -> TCM (Maybe TTerm)-getTreeless q = fmap cTreeless <$> getCompiled q--getCompiledArgUse :: QName -> TCM [Bool]-getCompiledArgUse q = maybe [] cArgUsage <$> getCompiled q---- | Get the mutually recursive identifiers.-getMutual :: QName -> TCM [QName]-getMutual d = do-  def <- theDef <$> getConstInfo d-  return $ case def of-    Function {  funMutual = m } -> m-    Datatype { dataMutual = m } -> m-    Record   {  recMutual = m } -> m-    _ -> []---- | Set the mutually recursive identifiers.-setMutual :: QName -> [QName] -> TCM ()-setMutual d m = modifySignature $ updateDefinition d $ updateTheDef $ \ def ->-  case def of-    Function{} -> def { funMutual = m }-    Datatype{} -> def {dataMutual = m }-    Record{}   -> def { recMutual = m }-    _          -> __IMPOSSIBLE__---- | Check whether two definitions are mutually recursive.-mutuallyRecursive :: QName -> QName -> TCM Bool-mutuallyRecursive d d' = (d `elem`) <$> getMutual d'---- | Get the number of parameters to the current module.-getCurrentModuleFreeVars :: TCM Nat-getCurrentModuleFreeVars = size <$> (lookupSection =<< currentModule)---- | Compute the number of free variables of a defined name. This is the sum of---   number of parameters shared with the current module and the number of---   anonymous variables (if the name comes from a let-bound module).-getDefFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadReader TCEnv m) => QName -> m Nat-getDefFreeVars = getModuleFreeVars . qnameModule--freeVarsToApply :: QName -> TCM Args-freeVarsToApply = moduleParamsToApply . qnameModule--{-# SPECIALIZE getModuleFreeVars :: ModuleName -> TCM Nat #-}-{-# SPECIALIZE getModuleFreeVars :: ModuleName -> ReduceM Nat #-}-getModuleFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadReader TCEnv m) => ModuleName -> m Nat-getModuleFreeVars m = do-  m0   <- commonParentModule m <$> currentModule-  (+) <$> getAnonymousVariables m <*> (size <$> lookupSection m0)---- | Compute the context variables to apply a definition to.------   We have to insert the module telescope of the common prefix---   of the current module and the module where the definition comes from.---   (Properly raised to the current context.)------   Example:---   @---      module M₁ Γ where---        module M₁ Δ where---          f = ...---        module M₃ Θ where---          ... M₁.M₂.f [insert Γ raised by Θ]---   @-moduleParamsToApply :: ModuleName -> TCM Args-moduleParamsToApply m = do-  -- Get the correct number of free variables (correctly raised) of @m@.--  reportSLn "tc.sig.param" 90 $ "computing module parameters of " ++ show m-  cxt <- getContext-  n   <- getModuleFreeVars m-  tel <- take n . telToList <$> lookupSection m-  sub <- getModuleParameterSub m-  reportSLn "tc.sig.param" 60 $ unlines $-    [ "  n    = " ++ show n-    , "  cxt  = " ++ show (map (fmap fst) cxt)-    , "  sub  = " ++ show sub-    ]-  unless (size tel == n) __IMPOSSIBLE__-  let args = applySubst sub $ zipWith (\ i a -> var i <$ argFromDom a) (downFrom n) tel-  reportSLn "tc.sig.param" 60 $ "  args = " ++ show args--  -- Apply the original ArgInfo, as the hiding information in the current-  -- context might be different from the hiding information expected by @m@.--  getSection m >>= \case-    Nothing -> do-      -- We have no section for @m@.-      -- This should only happen for toplevel definitions, and then there-      -- are no free vars to apply, or?-      -- unless (null args) __IMPOSSIBLE__-      -- No, this invariant is violated by private modules, see Issue1701a.-      return args-    Just (Section stel) -> do-      -- The section telescope of @m@ should be as least-      -- as long as the number of free vars @m@ is applied to.-      -- We still check here as in no case, we want @zipWith@ to silently-      -- drop some @args@.-      -- And there are also anonymous modules, thus, the invariant is not trivial.-      when (size stel < size args) __IMPOSSIBLE__-      return $ zipWith (\ (Dom ai _) (Arg _ v) -> Arg ai v) (telToList stel) args---- | Unless all variables in the context are module parameters, create a fresh---   module to capture the non-module parameters. Used when unquoting to make---   sure generated definitions work properly.-inFreshModuleIfFreeParams :: TCM a -> TCM a-inFreshModuleIfFreeParams k = do-  sub <- getModuleParameterSub =<< currentModule-  if sub == IdS then k else do-    m  <- currentModule-    m' <- qualifyM m . mnameFromList . (:[]) <$> freshName_ "_"-    addSection m'-    withCurrentModule m' k---- | Instantiate a closed definition with the correct part of the current---   context.-instantiateDef :: Definition -> TCM Definition-instantiateDef d = do-  vs  <- freeVarsToApply $ defName d-  verboseS "tc.sig.inst" 30 $ do-    ctx <- getContext-    m   <- currentModule-    reportSLn "tc.sig.inst" 30 $-      "instDef in " ++ show m ++ ": " ++ show (defName d) ++ " " ++-      unwords (map show $ zipWith (<$) (reverse $ map (fst . unDom) ctx) vs)-  return $ d `apply` vs---- | 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-               }-  where-    makeAbs Axiom         = Just Axiom-    makeAbs Datatype   {} = Just AbstractDefn-    makeAbs Function   {} = Just AbstractDefn-    makeAbs Constructor{} = Nothing-    -- Andreas, 2012-11-18:  Make record constructor and projections abstract.-    makeAbs d@Record{}    = Just AbstractDefn-    makeAbs Primitive{}   = __IMPOSSIBLE__-    makeAbs AbstractDefn  = __IMPOSSIBLE__---- | Enter abstract mode. Abstract definition in the current module are transparent.-{-# SPECIALIZE inAbstractMode :: TCM a -> TCM a #-}-inAbstractMode :: MonadReader TCEnv m => m a -> m a-inAbstractMode = local $ \e -> e { envAbstractMode = AbstractMode,-                                   envAllowDestructiveUpdate = False }-                                    -- Allowing destructive updates when seeing through-                                    -- abstract may break the abstraction.---- | Not in abstract mode. All abstract definitions are opaque.-{-# SPECIALIZE inConcreteMode :: TCM a -> TCM a #-}-inConcreteMode :: MonadReader TCEnv m => m a -> m a-inConcreteMode = local $ \e -> e { envAbstractMode = ConcreteMode }---- | Ignore abstract mode. All abstract definitions are transparent.-ignoreAbstractMode :: MonadReader TCEnv m => m a -> m a-ignoreAbstractMode = local $ \e -> e { envAbstractMode = IgnoreAbstractMode,-                                       envAllowDestructiveUpdate = False }-                                       -- Allowing destructive updates when ignoring-                                       -- abstract may break the abstraction.---- | Enter concrete or abstract mode depending on whether the given identifier---   is concrete or abstract.-{-# SPECIALIZE inConcreteOrAbstractMode :: QName -> (Definition -> TCM a) -> TCM a #-}-inConcreteOrAbstractMode :: (MonadReader TCEnv 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 :: MonadReader TCEnv m => QName -> m Bool-treatAbstractly q = asks $ treatAbstractly' q---- | 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 == m || current `isSubModuleOf` m-  where-    current = dropAnon $ envCurrentModule env-    m       = dropAnon $ qnameModule q-    dropAnon (MName ms) = MName $ reverse $ dropWhile isNoName $ reverse ms---- | Get type of a constant, instantiated to the current context.-typeOfConst :: QName -> TCM Type-typeOfConst q = defType <$> (instantiateDef =<< getConstInfo q)---- | Get relevance of a constant.-relOfConst :: QName -> TCM Relevance-relOfConst q = defRelevance <$> getConstInfo q---- | The name must be a datatype.-sortOfConst :: QName -> TCM Sort-sortOfConst q =-    do  d <- theDef <$> getConstInfo q-        case d of-            Datatype{dataSort = s} -> return s-            _                      -> fail $ "Expected " ++ show q ++ " to be a datatype."---- | The number of dropped parameters for a definition.---   0 except for projection(-like) functions and constructors.-droppedPars :: Definition -> Int-droppedPars d = case theDef d of-    Axiom{}                  -> 0-    def@Function{}           -> projectionArgs def-    Datatype  {dataPars = _} -> 0  -- not dropped-    Record     {recPars = _} -> 0  -- not dropped-    Constructor{conPars = n} -> n-    Primitive{}              -> 0-    AbstractDefn             -> __IMPOSSIBLE__---- | Is it the name of a record projection?-{-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}-isProjection :: HasConstInfo m => QName -> m (Maybe Projection)-isProjection qn = isProjection_ . theDef <$> getConstInfo qn--isProjection_ :: Defn -> Maybe Projection-isProjection_ def =-  case def of-    Function { funProjection = result } -> result-    _                                   -> Nothing---- | Is it a function marked STATIC?-isStaticFun :: Defn -> Bool-isStaticFun = (^. funStatic)---- | Is it a function marked INLINE?-isInlineFun :: Defn -> Bool-isInlineFun = (^. funInline)---- | Returns @True@ if we are dealing with a proper projection,---   i.e., not a projection-like function nor a record field value---   (projection applied to argument).-isProperProjection :: Defn -> Bool-isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP ->-  if projIndex isP <= 0 then False else projProper isP---- | Number of dropped initial arguments of a projection(-like) function.-projectionArgs :: Defn -> Int-projectionArgs = maybe 0 (max 0 . pred . projIndex) . isProjection_---- | Check whether a definition uses copatterns.-usesCopatterns :: QName -> TCM Bool-usesCopatterns q = do-  d <- theDef <$> getConstInfo q-  return $ case d of-    Function{ funCopatternLHS = b } -> b-    _ -> False---- | Apply a function @f@ to its first argument, producing the proper---   postfix projection if @f@ is a projection.-applyDef :: ProjOrigin -> QName -> Arg Term -> TCM Term-applyDef o f a = do-  let fallback = return $ Def f [Apply a]-  caseMaybeM (isProjection f) fallback $ \ isP -> do-    if projIndex isP <= 0 then fallback else do-      -- Get the original projection, if existing.-      if not (projProper isP) then fallback else do+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Monad.Signature where++import Prelude hiding (null)++import Control.Arrow                 ( first, second )+import Control.Monad.Except          ( ExceptT )+import Control.Monad.State           ( StateT  )+import Control.Monad.Reader          ( ReaderT )+import Control.Monad.Writer          ( WriterT )+import Control.Monad.Trans.Maybe     ( MaybeT  )+import Control.Monad.Trans.Identity  ( IdentityT )+import Control.Monad.Trans           ( MonadTrans, lift )++import Data.Foldable (for_)+import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap+import Data.Maybe+import Data.Semigroup ((<>))++import Agda.Interaction.Options++import Agda.Syntax.Abstract.Name+import Agda.Syntax.Abstract (Ren, ScopeCopyInfo(..))+import Agda.Syntax.Common+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.Names+import Agda.Syntax.Position+import Agda.Syntax.Treeless (Compiled(..), TTerm, ArgUsage)++import Agda.TypeChecking.Monad.Base+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+import Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Monad.State+import Agda.TypeChecking.Monad.Trace+import Agda.TypeChecking.DropArgs+import Agda.TypeChecking.Warnings+import Agda.TypeChecking.Positivity.Occurrence+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.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+import qualified Agda.Utils.List1 as List1+import Agda.Utils.ListT+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+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 = 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+                  case initLast $ telToList tel of+                    Nothing -> fallback+                    Just (doms, dom) -> telFromList $ fmap hideOrKeepInstance doms ++ [dom]+              _ -> tel+  let d' = abstract tel' $ d { defName = q }+  reportSDoc "tc.signature" 60 $ "lambda-lifted definition =" <?> pretty d'+  modifySignature $ updateDefinitions $ HMap.insertWith (+++) q d'+  i <- currentOrFreshMutualBlock+  setMutualBlock i q+  where+    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 -> Type -> Defn -> TCM ()+addConstant' q info t def = do+  lang <- getLanguage+  addConstant q $ defaultDefn info q t lang def++-- | Set termination info of a defined function symbol.+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.+setCompiledClauses :: QName -> CompiledClauses -> TCM ()+setCompiledClauses q cc = modifySignature $ updateDefinition q $ updateTheDef $ setT+  where+    setT def@Function{} = def { funCompiled = Just cc }+    setT def            = def++-- | Set SplitTree of a defined function symbol.+setSplitTree :: QName -> SplitTree -> TCM ()+setSplitTree q st = modifySignature $ updateDefinition q $ updateTheDef $ setT+  where+    setT def@Function{} = def { funSplitTree = Just st }+    setT def            = def++-- | Modify the clauses of a function.+modifyFunClauses :: QName -> ([Clause] -> [Clause]) -> TCM ()+modifyFunClauses q f =+  modifySignature $ updateDefinition q $ updateTheDef $ updateFunClauses f++-- | Lifts clauses to the top-level and adds them to definition.+--   Also adjusts the 'funCopatternLHS' field if necessary.+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 = do+    pragma <- mkPragma s+    modifySignature $ updateDefinition q $ addCompilerPragma b pragma++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 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 (lensTheDef . funFlag flag) val++markStatic :: QName -> TCM ()+markStatic = setFunctionFlag FunStatic True++markInline :: Bool -> QName -> TCM ()+markInline b = setFunctionFlag FunInline b++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++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+          (d <> d')                     -- instances are accumulated++-- | Add a section to the signature.+--+--   The current context will be stored as the cumulative module parameters+--   for this section.+addSection :: ModuleName -> TCM ()+addSection m = do+  tel <- getContextTelescope+  let sec = Section tel+  -- Make sure we do not overwrite an existing section!+  whenJustM (getSection m) $ \ sec' -> do+    -- At least not with different content!+    if (sec == sec') then do+      -- Andreas, 2015-12-02: test/Succeed/Issue1701II.agda+      -- reports a "redundantly adding existing section".+      reportSDoc "tc.section" 10 $ "warning: redundantly adding existing section" <+> pretty m+      reportSDoc "tc.section" 60 $ "with content" <+> pretty sec+    else do+      reportSDoc "impossible" 10 $ "overwriting existing section" <+> pretty m+      reportSDoc "impossible" 60 $ "of content  " <+> pretty sec'+      reportSDoc "impossible" 60 $ "with content" <+> pretty sec+      __IMPOSSIBLE__+  -- Add the new section.+  setModuleCheckpoint m+  modifySignature $ over sigSections $ Map.insert m sec++-- | Sets the checkpoint for the given module to the current checkpoint.+setModuleCheckpoint :: ModuleName -> TCM ()+setModuleCheckpoint m = do+  chkpt <- viewTC eCurrentCheckpoint+  stModuleCheckpoints `modifyTCLens` Map.insert m chkpt++-- | Get a section.+--+--   Why Maybe? The reason is that we look up all prefixes of a module to+--   compute number of parameters, and for hierarchical top-level modules,+--   A.B.C say, A and A.B do not exist.+{-# SPECIALIZE getSection :: ModuleName -> TCM (Maybe Section) #-}+{-# SPECIALIZE getSection :: ModuleName -> ReduceM (Maybe Section) #-}+getSection :: (Functor m, ReadTCState m) => ModuleName -> m (Maybe Section)+getSection m = do+  sig  <- (^. stSignature . sigSections) <$> getTCState+  isig <- (^. stImports   . sigSections) <$> getTCState+  return $ Map.lookup m sig `mplus` Map.lookup m isig++-- | Lookup a section telescope.+--+--   If it doesn't exist, like in hierarchical top-level modules,+--   the section telescope is empty.+{-# SPECIALIZE lookupSection :: ModuleName -> TCM Telescope #-}+{-# SPECIALIZE lookupSection :: ModuleName -> ReduceM Telescope #-}+lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope+lookupSection m = maybe EmptyTel (^. secTelescope) <$> getSection m++-- | Add display forms for a name @f@ copied by a module application. Essentially if @f@ can reduce to+--+-- @+-- λ xs → A.B.C.f vs+-- @+--+-- by unfolding module application copies (`defCopy`), then we add a display form+--+-- @+-- A.B.C.f vs ==> f xs+-- @+addDisplayForms :: QName -> TCM ()+addDisplayForms x = do+  reportSDoc "tc.display.section" 20 $ "Computing display forms for" <+> pretty x+  def <- getConstInfo x+  let v = case theDef def of+             Constructor{conSrcCon = h} -> Con h{ conName = x } ConOSystem []+             _                          -> Def x []++  -- Compute all unfoldings of x by repeatedly calling reduceDefCopy+  vs <- unfoldings x v+  reportSDoc "tc.display.section" 20 $ nest 2 $ vcat+    [ "unfoldings:" <?> vcat [ "-" <+> pretty v | v <- vs ] ]++  -- Turn unfoldings into display forms+  npars <- subtract (projectionArgs def) <$> getContextSize+  let dfs = map (displayForm npars v) vs+  reportSDoc "tc.display.section" 20 $ nest 2 $ vcat+    [ "displayForms:" <?> vcat [ "-" <+> (pretty y <+> "-->" <?> pretty df) | (y, df) <- dfs ] ]++  -- and add them+  mapM_ (uncurry addDisplayForm) dfs+  where++    -- To get display forms for projections we need to unSpine here.+    view :: Term -> ([Arg ArgName], Term)+    view = second unSpine . lamView++    -- 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 -> (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+        _ -> __IMPOSSIBLE__+      where+        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)++    -- Unfold a single defCopy.+    unfoldOnce :: Term -> TCM (Reduced () Term)+    unfoldOnce v = case view v of+      (xs, Def f es)   -> (fmap . fmap) (unlamView xs) (reduceDefCopyTCM f es)+      (xs, Con c i es) -> (fmap . fmap) (unlamView xs) (reduceDefCopyTCM (conName c) es)+      _                -> pure $ NoReduction ()++    -- Compute all reduceDefCopy unfoldings of `x`. Stop when we hit a non-copy.+    unfoldings :: QName -> Term -> TCM [Term]+    unfoldings x v = unfoldOnce v >>= \ case+      NoReduction{}     -> return []+      YesReduction _ v' -> do+        let headSymbol = case snd $ view v' of+              Def y _   -> Just y+              Con y _ _ -> Just (conName y)+              _         -> Nothing+        case headSymbol of+          Nothing -> return []+          Just y | x == y -> do+            -- This should never happen, but if it does, getting an __IMPOSSIBLE__ is much better+            -- than looping.+            reportSDoc "impossible" 10 $ nest 2 $ vcat+              [ "reduceDefCopy said YesReduction but the head symbol is the same!?"+              , nest 2 $ "v  =" <+> pretty v+              , nest 2 $ "v' =" <+> pretty v'+              ]+            __IMPOSSIBLE__+          Just y -> do+            ifM (defCopy <$> getConstInfo y)+                ((v' :) <$> unfoldings y v')  -- another copy so keep going+                (return [v'])                 -- not a copy, we stop++-- | Module application (followed by module parameter abstraction).+applySection+  :: ModuleName     -- ^ Name of new module defined by the module macro.+  -> Telescope      -- ^ Parameters of new module.+  -> ModuleName     -- ^ Name of old module applied to arguments.+  -> Args           -- ^ Arguments of module application.+  -> ScopeCopyInfo  -- ^ Imported names and modules+  -> TCM ()+applySection new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd } = do+  rd <- closeConstructors rd+  applySection' new ptel old ts ScopeCopyInfo{ renModules = rm, renNames = rd }+  where+    -- If a datatype is being copied, all its constructors need to be copied,+    -- and if a constructor is copied its datatype needs to be.+    closeConstructors :: Ren QName -> TCM (Ren QName)+    closeConstructors rd = do+        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 :: (ModuleName, QName) -> TCM (Ren QName)+        rename (m, x)+          | x `Map.member` rd = pure mempty+          | otherwise =+              -- 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, 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 (qnameModule y, d)+            _                          -> Nothing++        dataConstructors :: (QName, List1.List1 QName) -> TCM [(ModuleName, QName)]+        dataConstructors (x, y List1.:| _) = do+          (theDef <$> getConstInfo x) <&> \case+            Datatype{ dataCons = cs } -> map (qnameModule y,) cs+            Record{ recConHead = h }  -> [(qnameModule y, conName h)]+            _                         -> []++applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM ()+applySection' new ptel old ts ScopeCopyInfo{ renNames = rd, renModules = rm } = do+  do+    noCopyList <- catMaybes <$> mapM getName' constrainedPrims+    for_ (Map.keys rd) $ \ q ->+      when (q `elem` noCopyList) $ typeError (TriedToCopyConstrainedPrim q)++  reportSDoc "tc.mod.apply" 10 $ vcat+    [ "applySection"+    , "new  =" <+> pretty new+    , "ptel =" <+> pretty ptel+    , "old  =" <+> pretty old+    , "ts   =" <+> pretty ts+    ]+  _ <- Map.traverseWithKey (traverse . copyDef ts) rd+  _ <- Map.traverseWithKey (traverse . copySec ts) rm+  computePolarity (Map.elems rd >>= List1.toList)+  where+    -- Andreas, 2013-10-29+    -- Here, if the name x is not imported, it persists as+    -- old, possibly out-of-scope name.+    -- This old name may used by the case split tactic, leading to+    -- names that cannot be printed properly.+    -- I guess it would make sense to mark non-imported names+    -- as such (out-of-scope) and let splitting fail if it would+    -- produce out-of-scope constructors.+    --+    -- Taking 'List1.head' because 'Module.Data.cons' and 'Module.cons' are+    -- 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+      size <$> lookupSection m++    copyDef :: Args -> QName -> QName -> TCM ()+    copyDef ts x y = do+      def <- getConstInfo x+      np  <- argsToUse (qnameModule x)+      -- Issue #3083: We need to use the hiding from the telescope of the+      -- original module. This can be different than the hiding for the common+      -- parent in the case of record modules.+      hidings <- map getHiding . telToList <$> lookupSection (qnameModule x)+      let ts' = zipWith setHiding hidings ts+      commonTel <- lookupSection (commonParentModule old $ qnameModule x)+      reportSDoc "tc.mod.apply" 80 $ vcat+        [ "copyDef" <+> pretty x <+> "->" <+> pretty y+        , "ts' = " <+> pretty ts' ]+      -- 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)+          reportSDoc "tc.mod.apply" 80 $ vcat+            [ "args = " <+> text (show ts')+            , "old type = " <+> pretty (defType d) ]+          reportSDoc "tc.mod.apply" 80 $+            "new type = " <+> pretty t+          addConstant y =<< nd y+          makeProjection y+          -- Issue1238: the copied def should be an 'instance' if the original+          -- def is one. Skip constructors since the original constructor will+          -- still work as an instance.+          -- 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 $ \_ -> 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 || 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 && 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'+            inst = defInstance d+            -- the name is set by the addConstant function+            nd :: QName -> TCM Definition+            nd y = do+              -- The arguments may use some feature of the current+              -- language.+              lang <- getLanguage+              for def $ \ df -> Defn+                    { defArgInfo        = defArgInfo d+                    , defName           = y+                    , defType           = t+                    , defPolarity       = pol+                    , defArgOccurrences = occ+                    , defGeneralizedParams = [] -- This is only needed for type checking data/record defs so no need to copy it.+                    , defDisplay        = []+                    , defMutual         = -1   -- TODO: mutual block?+                    , defCompiledRep    = noCompiledRep+                    , defInstance       = inst+                    , defCopy           = True+                    , defMatchable      = Set.empty+                    , defNoCompilation  = defNoCompilation d+                    , defInjective      = False+                    , defCopatternLHS   = isCopatternLHS [cl]+                    , defBlocked        = defBlocked d+                    , defLanguage       =+                      case defLanguage d of+                        -- Note that Cubical Agda code can be imported+                        -- when --erased-cubical is used.+                        l@(Cubical CFull) -> l+                        Cubical CErased   -> lang+                        WithoutK          -> lang+                        WithK             -> lang+                    , theDef            = df }+            oldDef = theDef d+            isCon  = case oldDef of { Constructor{} -> True ; _ -> False }+            mutual = case oldDef of { Function{funMutual = m} -> m              ; _ -> Nothing }+            extlam = case oldDef of { Function{funExtLam = e} -> e              ; _ -> Nothing }+            with   = case oldDef of { Function{funWith = w}   -> copyName <$> w ; _ -> Nothing }+            -- Andreas, 2015-05-11, to fix issue 1413:+            -- Even if we apply the record argument (must be @var 0@), we stay a projection.+            -- 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 = Right p@Projection{projIndex = n}}+                | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts'))+                -> 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 $+                  oldDef { conPars = np - size ts'+                         , conData = copyName d+                         }+                Datatype{ dataPars = np, dataCons = cs } -> return $+                  oldDef { dataPars   = np - size ts'+                         , dataClause = Just cl+                         , dataCons   = map copyName cs+                         }+                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 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 $+                        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 = Right p} -> projDropParsApply p ProjSystem rel ts'+                            _ -> Def x $ map Apply ts'+                        , clauseType        = Just $ defaultArg t+                        , clauseCatchall    = empty+                        , clauseRecursive   = Just False -- definitely not recursive+                        , clauseUnreachable = Just False -- definitely not unreachable+                        , 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 $ either (const 0) (pred . projIndex) proj+                rel  = getRelevance $ defArgInfo d++    {- Example++    module Top Θ where+      module A Γ where+        module M Φ where+      module B Δ where+        module N Ψ where+          module O Ψ' where+        open A public     -- introduces only M --> A.M into the *scope*+    module C Ξ = Top.B ts++    new section C+      tel = Ξ.(Θ.Δ)[ts]++    calls+      1. copySec ts Top.A.M C.M+      2. copySec ts Top.B.N C.N+      3. copySec ts Top.B.N.O C.N.O+    with+      old = Top.B++    For 1.+      Common prefix is: Top+      totalArgs = |Θ|   (section Top)+      tel       = Θ.Γ.Φ (section Top.A.M)+      ts'       = take totalArgs ts+      Θ₂        = drop totalArgs Θ+      new section C.M+        tel =  Θ₂.Γ.Φ[ts']+    -}+    copySec :: Args -> ModuleName -> ModuleName -> TCM ()+    copySec ts x y = do+      totalArgs <- argsToUse x+      tel       <- lookupSection x+      let sectionTel =  apply tel $ take totalArgs ts+      reportSDoc "tc.mod.apply" 80 $ "Copying section" <+> pretty x <+> "to" <+> pretty y+      reportSDoc "tc.mod.apply" 80 $ "  ts           = " <+> mconcat (List.intersperse "; " (map pretty ts))+      reportSDoc "tc.mod.apply" 80 $ "  totalArgs    = " <+> text (show totalArgs)+      reportSDoc "tc.mod.apply" 80 $ "  tel          = " <+> text (unwords (map (fst . unDom) $ telToList tel))  -- only names+      reportSDoc "tc.mod.apply" 80 $ "  sectionTel   = " <+> text (unwords (map (fst . unDom) $ telToList ptel)) -- only names+      addContext sectionTel $ addSection y++-- | 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])++isLocal :: ReadTCState m => QName -> m Bool+isLocal x = HMap.member x <$> useR (stSignature . sigDefinitions)++getDisplayForms :: (HasConstInfo m, ReadTCState m) => QName -> m [LocalDisplayForm]+getDisplayForms q = do+  ds  <- either (const []) defDisplay <$> getConstInfo' q+  ds1 <- HMap.lookupDefault [] q <$> useR stImportsDisplayForms+  ds2 <- HMap.lookupDefault [] q <$> useR stImportedDisplayForms+  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.+--+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)++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+  case def of+    Constructor{conSrcCon = c}                                -> return $ conName c+    Record{recClause = Just (Clause{ clauseBody = body })}    -> can body+    Datatype{dataClause = Just (Clause{ clauseBody = body })} -> can body+    _                                                         -> return x+  where+    can body = canonicalName $ extract $ fromMaybe __IMPOSSIBLE__ body+    extract (Def x _)  = x+    extract _          = __IMPOSSIBLE__++sameDef :: HasConstInfo m => QName -> QName -> m (Maybe QName)+sameDef d1 d2 = do+  c1 <- canonicalName d1+  c2 <- canonicalName d2+  if (c1 == c2) then return $ Just c1 else return Nothing++-- | Does the given constructor come from a single-constructor type?+--+-- Precondition: The name has to refer to a constructor.+singleConstructorType :: QName -> TCM Bool+singleConstructorType q = do+  d <- theDef <$> getConstInfo q+  case d of+    Record {}                   -> return True+    Constructor { conData = d } -> do+      di <- theDef <$> getConstInfo d+      return $ case di of+        Record {}                  -> True+        Datatype { dataCons = cs } -> natSize cs == 1+        _                          -> __IMPOSSIBLE__+    _ -> __IMPOSSIBLE__++-- | Signature lookup errors.+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.++-- | 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+      , HasOptions m+      , MonadDebug m+      , MonadTCEnv m+      ) => HasConstInfo m where+  -- | 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+      Right d -> return d+      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++  -- | 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:++  default getConstInfo'+    :: (HasConstInfo n, MonadTrans t, m ~ t n)+    => QName -> m (Either SigError Definition)+  getConstInfo' = lift . getConstInfo'++  default getRewriteRulesFor+    :: (HasConstInfo n, MonadTrans t, m ~ t n)+    => QName -> m RewriteRules+  getRewriteRulesFor = lift . getRewriteRulesFor++{-# 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+  def  <- getConstInfo q+  lang <- getLanguage+  case (lang, defLanguage def) of+    (Cubical CErased, Cubical CFull) ->+      locallyTCState+        (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+    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+getOriginalProjection q = projOrig . fromMaybe __IMPOSSIBLE__ <$> isProjection q++instance HasConstInfo (TCMT IO) where+  getRewriteRulesFor = defaultGetRewriteRulesFor+  getConstInfo' q = do+    st  <- getTC+    env <- askTC+    defaultGetConstInfo st env q+  getConstInfo q = getConstInfo' q >>= \case+      Right d -> return d+      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+    case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of+        []  -> return $ Left $ SigUnknown $ "Unbound name: " ++ prettyShow q ++ showQNameId q+        [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+        -- 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'+        | otherwise = return $ Right d+        where+          q' = case theDef d of+            -- Hack to make abstract constructors work properly. The constructors+            -- live in a module with the same name as the datatype, but for 'abstract'+            -- purposes they're considered to be in the same module as the datatype.+            Constructor{} -> dropLastModule q+            _             -> q++          dropLastModule q@QName{ qnameModule = m } =+            q{ qnameModule = mnameFromList $+                 initWithDefault __IMPOSSIBLE__ $ mnameToList m+             }++      -- 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+        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).++instance HasConstInfo m => HasConstInfo (ChangeT m)+instance HasConstInfo m => HasConstInfo (ExceptT err m)+instance HasConstInfo m => HasConstInfo (IdentityT m)+instance HasConstInfo m => HasConstInfo (ListT m)+instance HasConstInfo m => HasConstInfo (MaybeT m)+instance HasConstInfo m => HasConstInfo (ReaderT r m)+instance HasConstInfo m => HasConstInfo (StateT s m)+instance (Monoid w, HasConstInfo m) => HasConstInfo (WriterT w m)+instance HasConstInfo m => HasConstInfo (BlockT m)++{-# INLINE getConInfo #-}+getConInfo :: HasConstInfo m => ConHead -> m Definition+getConInfo = getConstInfo . conName++-- | Look up the polarity of a definition.+getPolarity :: HasConstInfo m => QName -> m [Polarity]+getPolarity q = defPolarity <$> getConstInfo q++-- | Look up polarity of a definition and compose with polarity+--   represented by 'Comparison'.+getPolarity' :: HasConstInfo m => Comparison -> QName -> m [Polarity]+getPolarity' CmpEq  q = map (composePol Invariant) <$> getPolarity q -- return []+getPolarity' CmpLeq q = getPolarity q -- composition with Covariant is identity++-- | Set the polarity of a definition.+setPolarity :: (MonadTCState m, MonadDebug m) => QName -> [Polarity] -> m ()+setPolarity q pol = do+  reportSDoc "tc.polarity.set" 20 $+    "Setting polarity of" <+> pretty q <+> "to" <+> pretty pol <> "."+  modifySignature $ updateDefinition q $ updateDefPolarity $ const pol++-- | Look up the forced arguments of a definition.+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+  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 ()+setArgOccurrences d os = modifyArgOccurrences d $ const os++modifyArgOccurrences :: MonadTCState m => QName -> ([Occurrence] -> [Occurrence]) -> m ()+modifyArgOccurrences d f =+  modifySignature $ updateDefinition d $ updateDefArgOccurrences f++setTreeless :: QName -> TTerm -> TCM ()+setTreeless q t =+  modifyGlobalDefinition q $ updateTheDef $ \case+    fun@Function{} -> fun{ funTreeless = Just $ Compiled t Nothing }+    _ -> __IMPOSSIBLE__++setCompiledArgUse :: QName -> [ArgUsage] -> TCM ()+setCompiledArgUse q use =+  modifyGlobalDefinition q $ updateTheDef $ \case+    fun@Function{} ->+      fun{ funTreeless = funTreeless fun <&> \ c -> c { cArgUsage = Just use } }+    _ -> __IMPOSSIBLE__++getCompiled :: HasConstInfo m => QName -> m (Maybe Compiled)+getCompiled q = do+  (theDef <$> getConstInfo q) <&> \case+    Function{ funTreeless = t } -> t+    _                           -> Nothing++-- | Returns a list of length 'conArity'.+--   If no erasure analysis has been performed yet, this will be a list of 'False's.+getErasedConArgs :: HasConstInfo m => QName -> m [Bool]+getErasedConArgs q = do+  def <- getConstInfo q+  case theDef def of+    Constructor{ conArity, conErased } -> return $+      fromMaybe (replicate conArity False) conErased+    _ -> __IMPOSSIBLE__++setErasedConArgs :: QName -> [Bool] -> TCM ()+setErasedConArgs q args = modifyGlobalDefinition q $ updateTheDef $ \case+    def@Constructor{ conArity }+      | length args == conArity -> def{ conErased = Just args }+      | otherwise               -> __IMPOSSIBLE__+    def -> def   -- no-op for non-constructors++getTreeless :: HasConstInfo m => QName -> m (Maybe TTerm)+getTreeless q = fmap cTreeless <$> getCompiled q++getCompiledArgUse :: HasConstInfo m => QName -> m (Maybe [ArgUsage])+getCompiledArgUse q = (cArgUsage =<<) <$> getCompiled q++-- | add data constructors to a datatype+addDataCons :: QName -> [QName] -> TCM ()+addDataCons d cs = modifySignature $ updateDefinition d $ updateTheDef $ \ def ->+  let !cs' = cs ++ dataCons def in+  case def of+    Datatype{} -> def {dataCons = cs' }+    _          -> __IMPOSSIBLE__++-- | Get the mutually recursive identifiers of a symbol from the signature.+getMutual :: QName -> TCM (Maybe [QName])+getMutual d = getMutual_ . theDef <$> getConstInfo d++-- | Get the mutually recursive identifiers from a `Definition`.+getMutual_ :: Defn -> Maybe [QName]+getMutual_ = \case+    Function {  funMutual = m } -> m+    Datatype { dataMutual = m } -> m+    Record   {  recMutual = m } -> m+    _ -> 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+    Function{} -> def { funMutual = Just m }+    Datatype{} -> def {dataMutual = Just m }+    Record{}   -> def { recMutual = Just m }+    _          -> if null m then def else __IMPOSSIBLE__ -- nothing to do++-- | Check whether two definitions are mutually recursive.+mutuallyRecursive :: QName -> QName -> TCM Bool+mutuallyRecursive d d1 = (d `elem`) . fromMaybe __IMPOSSIBLE__ <$> getMutual d1++-- | A function/data/record definition is nonRecursive if it is not even mutually+--   recursive with itself.+definitelyNonRecursive_ :: Defn -> Bool+definitelyNonRecursive_ = maybe False null . getMutual_++-- | Get the number of parameters to the current module.+getCurrentModuleFreeVars :: TCM Nat+getCurrentModuleFreeVars = size <$> (lookupSection =<< currentModule)++--   For annoying reasons the qnameModule of a pattern lambda is not correct+--   (#2883), so make sure to grab the right module for those.+getDefModule :: HasConstInfo m => QName -> m (Either SigError ModuleName)+getDefModule f = mapRight modName <$> getConstInfo' f+  where+    modName def = case theDef def of+      Function{ funExtLam = Just (ExtLamInfo m _ _) } -> m+      _                                               -> qnameModule f++-- | Compute the number of free variables of a defined name. This is the sum of+--   number of parameters shared with the current module and the number of+--   anonymous variables (if the name comes from a let-bound module).+getDefFreeVars :: (Functor m, Applicative m, ReadTCState m, MonadTCEnv m) => QName -> m Nat+getDefFreeVars = getModuleFreeVars . qnameModule++freeVarsToApply :: (Functor m, HasConstInfo m, HasOptions m,+                    ReadTCState m, MonadTCEnv m, MonadDebug m)+                => QName -> m Args+freeVarsToApply q = do+  vs <- moduleParamsToApply $ qnameModule q+  -- Andreas, 2021-07-14, issue #5470+  -- getConstInfo will fail if q is not in scope,+  -- but in this case there are no free vars to apply, since+  -- we cannot be in a child module of its defining module.+  -- So if we short cut the nil-case here, we avoid the internal error of #5470.+  if null vs then return [] else do+  t <- defType <$> getConstInfo q+  let TelV tel _ = telView'UpTo (size vs) t+  unless (size tel == size vs) __IMPOSSIBLE__+  return $ zipWith (\ arg dom -> unArg arg <$ argFromDom dom) vs $ telToList tel++{-# SPECIALIZE getModuleFreeVars :: ModuleName -> TCM Nat #-}+{-# SPECIALIZE getModuleFreeVars :: ModuleName -> ReduceM Nat #-}+getModuleFreeVars :: (Functor m, Applicative m, MonadTCEnv m, ReadTCState m)+                  => ModuleName -> m Nat+getModuleFreeVars m = do+  m0   <- commonParentModule m <$> currentModule+  (+) <$> getAnonymousVariables m <*> (size <$> lookupSection m0)++-- | Compute the context variables to apply a definition to.+--+--   We have to insert the module telescope of the common prefix+--   of the current module and the module where the definition comes from.+--   (Properly raised to the current context.)+--+--   Example:+--   @+--      module M₁ Γ where+--        module M₁ Δ where+--          f = ...+--        module M₃ Θ where+--          ... M₁.M₂.f [insert Γ raised by Θ]+--   @+moduleParamsToApply :: (Functor m, Applicative m, HasOptions m,+                        MonadTCEnv m, ReadTCState m, MonadDebug m)+                    => ModuleName -> m Args+moduleParamsToApply m = do++  traceSDoc "tc.sig.param" 90 ("computing module parameters of " <+> pretty m) $ do++  -- Jesper, 2020-01-22: If the module parameter substitution for the+  -- module cannot be found, that likely means we are within a call to+  -- @inTopContext@. In that case we should provide no arguments for+  -- the module parameters (see #4383).+  caseMaybeM (getModuleParameterSub m) (return []) $ \sub -> do++  traceSDoc "tc.sig.param" 60 (do+    cxt <- getContext+    nest 2 $ vcat+      [ "cxt  = " <+> prettyTCM (PrettyContext cxt)+      , "sub  = " <+> pretty sub+      ]) $ do++  -- Get the correct number of free variables (correctly raised) of @m@.+  n   <- getModuleFreeVars m+  traceSDoc "tc.sig.param" 60 (nest 2 $ "n    = " <+> text (show n)) $ do+  tel <- take n . telToList <$> lookupSection m+  traceSDoc "tc.sig.param" 60 (nest 2 $ "tel  = " <+> pretty tel) $ do+  unless (size tel == n) __IMPOSSIBLE__+  let args = applySubst sub $ zipWith (\ i a -> var i <$ argFromDom a) (downFrom n) tel+  traceSDoc "tc.sig.param" 60 (nest 2 $ "args = " <+> prettyList_ (map pretty args)) $ do++  -- Apply the original ArgInfo, as the hiding information in the current+  -- context might be different from the hiding information expected by @m@.++  getSection m >>= \case+    Nothing -> do+      -- We have no section for @m@.+      -- This should only happen for toplevel definitions, and then there+      -- are no free vars to apply, or?+      -- unless (null args) __IMPOSSIBLE__+      -- No, this invariant is violated by private modules, see Issue1701a.+      return args+    Just (Section stel) -> do+      -- The section telescope of @m@ should be as least+      -- as long as the number of free vars @m@ is applied to.+      -- We still check here as in no case, we want @zipWith@ to silently+      -- drop some @args@.+      -- And there are also anonymous modules, thus, the invariant is not trivial.+      when (size stel < size args) __IMPOSSIBLE__+      return $ zipWith (\ !dom (Arg _ v) -> v <$ argFromDom dom) (telToList stel) args++-- | Unless all variables in the context are module parameters, create a fresh+--   module to capture the non-module parameters. Used when unquoting to make+--   sure generated definitions work properly.+inFreshModuleIfFreeParams :: TCM a -> TCM a+inFreshModuleIfFreeParams k = do+  msub <- getModuleParameterSub =<< currentModule+  if isNothing msub || msub == Just IdS then k else do+    m  <- currentModule+    m' <- qualifyM m . mnameFromList1 . singleton <$>+            freshName_ ("_" :: String)+    addSection m'+    withCurrentModule m' k++-- | Instantiate a closed definition with the correct part of the current+--   context.+{-# SPECIALIZE instantiateDef :: Definition -> TCM Definition #-}+instantiateDef+  :: ( Functor m, HasConstInfo m, HasOptions m+     , ReadTCState m, MonadTCEnv m, MonadDebug m )+  => Definition -> m Definition+instantiateDef d = do+  vs  <- freeVarsToApply $ defName d+  verboseS "tc.sig.inst" 30 $ do+    ctx <- getContextNames+    m   <- currentModule+    reportSDoc "tc.sig.inst" 30 $+      "instDef in" <+> pretty m <> ":" <+> pretty (defName d) <+>+      fsep (map pretty $ zipWith (<$) ctx vs)+  return $ d `apply` vs++instantiateRewriteRule :: (Functor m, HasConstInfo m, HasOptions m,+                           ReadTCState m, MonadTCEnv m, MonadDebug m)+                       => RewriteRule -> m RewriteRule+instantiateRewriteRule rew = do+  traceSDoc "rewriting" 95 ("instantiating rewrite rule" <+> pretty (rewName rew) <+> "to the local context.") $ do+  vs  <- freeVarsToApply $ rewName rew+  let rew' = rew `apply` vs+  traceSLn "rewriting" 95 ("instantiated rewrite rule: ") $ do+  traceSLn "rewriting" 95 (show rew') $ do+  return rew'++instantiateRewriteRules :: (Functor m, HasConstInfo m, HasOptions m,+                            ReadTCState m, MonadTCEnv m, MonadDebug m)+                        => RewriteRules -> m RewriteRules+instantiateRewriteRules = mapM instantiateRewriteRule++-- | 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+    makeAbs d@GeneralizableVar{} = Just d+    makeAbs d@Datatype {} = Just $ AbstractDefn d+    makeAbs d@Function {} = Just $ AbstractDefn d+    makeAbs Constructor{} = Nothing+    -- Andreas, 2012-11-18:  Make record constructor and projections abstract.+    -- Andreas, 2017-08-14:  Projections are actually not abstract (issue #2682).+    -- Return the Defn under a wrapper to allow e.g. eligibleForProjectionLike+    -- to see whether the abstract thing is a record type or not.+    makeAbs d@Record{}    = Just $ AbstractDefn d+    makeAbs Primitive{}   = __IMPOSSIBLE__+    makeAbs PrimitiveSort{} = __IMPOSSIBLE__+    makeAbs AbstractDefn{} = __IMPOSSIBLE__++-- | Enter abstract mode. Abstract definition in the current module are transparent.+{-# SPECIALIZE inAbstractMode :: TCM a -> TCM a #-}+inAbstractMode :: MonadTCEnv m => m a -> m a+inAbstractMode = localTC $ \e -> e { envAbstractMode = AbstractMode }++-- | Not in abstract mode. All abstract definitions are opaque.+{-# SPECIALIZE inConcreteMode :: TCM a -> TCM a #-}+inConcreteMode :: MonadTCEnv m => m a -> m a+inConcreteMode = localTC $ \e -> e { envAbstractMode = ConcreteMode }++-- | Ignore abstract mode. All abstract definitions are transparent.+ignoreAbstractMode :: MonadTCEnv m => m a -> m a+ignoreAbstractMode = localTC $ \e -> e { envAbstractMode = IgnoreAbstractMode }++-- | 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+  let+    k1 = case defAbstract def of+      AbstractDef -> inAbstractMode+      ConcreteDef -> inConcreteMode++    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 #-}+typeOfConst :: (HasConstInfo m, ReadTCState m) => QName -> m Type+typeOfConst q = defType <$> (instantiateDef =<< getConstInfo q)++-- | Get relevance of a constant.+{-# SPECIALIZE relOfConst :: QName -> TCM Relevance #-}+relOfConst :: HasConstInfo m => QName -> m Relevance+relOfConst q = getRelevance <$> getConstInfo q++-- | Get modality of a constant.+{-# SPECIALIZE modalityOfConst :: QName -> TCM Modality #-}+modalityOfConst :: HasConstInfo m => QName -> m Modality+modalityOfConst q = getModality <$> getConstInfo q++-- | The number of dropped parameters for a definition.+--   0 except for projection(-like) functions and constructors.+droppedPars :: Definition -> Int+droppedPars d = case theDef d of+    Axiom{}                  -> 0+    DataOrRecSig{}           -> 0+    GeneralizableVar{}       -> 0+    def@Function{}           -> projectionArgs d+    Datatype  {dataPars = _} -> 0  -- not dropped+    Record     {recPars = _} -> 0  -- not dropped+    Constructor{conPars = n} -> n+    Primitive{}              -> 0+    PrimitiveSort{}          -> 0+    AbstractDefn{}           -> 0 -- not impossible when quoting, PR #7828++-- | Is it the name of a record projection?+{-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}+isProjection :: HasConstInfo m => QName -> m (Maybe Projection)+isProjection qn = isProjection_ . theDef <$> getConstInfo qn++isProjection_ :: Defn -> Maybe Projection+isProjection_ def =+  case def of+    Function { funProjection = Right result } -> Just result+    _                                         -> Nothing++-- | Is it the name of a non-irrelevant record projection?+{-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}+isRelevantProjection :: HasConstInfo m => QName -> m (Maybe Projection)+isRelevantProjection qn = isRelevantProjection_ <$> getConstInfo qn++isRelevantProjection_ :: Definition -> Maybe Projection+isRelevantProjection_ def =+  if isIrrelevant def then Nothing else isProjection_ $ theDef def++-- | Is it a function marked STATIC?+isStaticFun :: Defn -> Bool+isStaticFun = (^. funStatic)++-- | Is it a function marked INLINE?+isInlineFun :: Defn -> Bool+isInlineFun = (^. funInline)++-- | Returns @True@ if we are dealing with a proper projection,+--   i.e., not a projection-like function nor a record field value+--   (projection applied to argument).+isProperProjection :: Defn -> Bool+isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP ->+  (projIndex isP > 0) && isJust (projProper isP)++-- | Number of dropped initial arguments of a projection(-like) function.+projectionArgs :: Definition -> Int+projectionArgs = maybe 0 (max 0 . pred . projIndex) . isRelevantProjection_++-- | Check whether a definition uses copatterns.+usesCopatterns :: (HasConstInfo m, HasBuiltins m) => QName -> m Bool+usesCopatterns q = defCopatternLHS <$> getConstInfo q++-- | Apply a function @f@ to its first argument, producing the proper+--   postfix projection if @f@ is a projection which is not irrelevant.+applyDef :: (HasConstInfo m)+         => ProjOrigin -> QName -> Arg Term -> m Term+applyDef o f a = do+  let fallback = return $ Def f [Apply a]+  -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.+  caseMaybeM (isRelevantProjection f) fallback $ \ isP -> do+    if projIndex isP <= 0 then fallback else do+      -- Get the original projection, if existing.+      if isNothing (projProper isP) then fallback else do         return $ unArg a `applyE` [Proj o $ projOrig isP]
src/full/Agda/TypeChecking/Monad/Signature.hs-boot view
@@ -1,9 +1,54 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Signature where +import Control.Monad.Reader+import Control.Monad.State++import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Internal (ModuleName, Telescope)-import Agda.TypeChecking.Monad.Base (TCM, ReadTCState) +import Agda.TypeChecking.Monad.Base+  ( TCM, ReadTCState, HasOptions, MonadTCEnv+  , Definition, RewriteRules+  )+import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug)++import Agda.Syntax.Common.Pretty (prettyShow)++data SigError = SigUnknown String | SigAbstract | SigCubicalNotErasure++notSoPrettySigCubicalNotErasure :: QName -> String++class ( Functor m+      , Applicative m+      , HasOptions m+      , MonadDebug m+      , MonadTCEnv m+      ) => HasConstInfo m where+  getConstInfo :: QName -> m Definition+  getConstInfo q = getConstInfo' q >>= \case+      Right d -> return d+      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++  default getConstInfo' :: (HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m (Either SigError Definition)+  getConstInfo' = lift . getConstInfo'++  default getRewriteRulesFor :: (HasConstInfo n, MonadTrans t, m ~ t n) => QName -> m RewriteRules+  getRewriteRulesFor = lift . getRewriteRulesFor++instance HasConstInfo m => HasConstInfo (ReaderT r m)+instance HasConstInfo m => HasConstInfo (StateT s m)++instance HasConstInfo TCM where+ inFreshModuleIfFreeParams :: TCM a -> TCM a lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope-
src/full/Agda/TypeChecking/Monad/SizedTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Stuff for sized types that does not require modules --   "Agda.TypeChecking.Reduce" or "Agda.TypeChecking.Constraints"@@ -6,28 +6,70 @@  module Agda.TypeChecking.Monad.SizedTypes where -import Control.Applicative+import Control.Monad.Except ( MonadError(..) ) -import Agda.Interaction.Options+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav  import Agda.Syntax.Common import Agda.Syntax.Internal  import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Substitute ()+import Agda.TypeChecking.Substitute -import Agda.Utils.Except ( MonadError(catchError) )+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.Syntax.Common.Pretty+import Agda.Utils.Singleton -#include "undefined.h" 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' ------------------------------------------------------------------------ @@ -40,73 +82,44 @@  -- | Check if a type is the 'primSize' type. The argument should be 'reduce'd. class IsSizeType a where-  isSizeType :: a -> TCM (Maybe BoundedSize)+  isSizeType :: (HasOptions m, HasBuiltins m) => a -> m (Maybe BoundedSize) +instance IsSizeType a => IsSizeType (Dom a) where+  isSizeType = isSizeType . unDom++instance IsSizeType a => IsSizeType (b,a) where+  isSizeType = isSizeType . snd+ instance IsSizeType a => IsSizeType (Type' a) where   isSizeType = isSizeType . unEl  instance IsSizeType Term where   isSizeType v = isSizeTypeTest <*> pure v -isSizeTypeTest :: TCM (Term -> Maybe BoundedSize)+instance IsSizeType CompareAs where+  isSizeType (AsTermsOf a) = isSizeType a+  isSizeType AsSizes       = return $ Just BoundedNo+  isSizeType AsTypes       = return Nothing++isSizeTypeTest :: (HasOptions m, HasBuiltins m) => m (Term -> Maybe BoundedSize) isSizeTypeTest =-  flip (ifM (optSizedTypes <$> pragmaOptions)) (return $ const Nothing) $ do+  flip (ifM sizedTypesOption) (return $ const Nothing) $ do     (size, sizelt) <- getBuiltinSize     let testType (Def d [])        | Just d == size   = Just BoundedNo         testType (Def d [Apply v]) | Just d == sizelt = Just $ BoundedLt $ unArg v         testType _                                    = Nothing-    return $ testType . ignoreSharing--getBuiltinDefName :: String -> TCM (Maybe QName)-getBuiltinDefName s = fromDef . fmap ignoreSharing <$> getBuiltin' s-  where-    fromDef (Just (Def d [])) = Just d-    fromDef _                 = Nothing--getBuiltinSize :: TCM (Maybe QName, Maybe QName)-getBuiltinSize = do-  size   <- getBuiltinDefName builtinSize-  sizelt <- getBuiltinDefName builtinSizeLt-  return (size, sizelt)+    return testType -isSizeNameTest :: TCM (QName -> Bool)-isSizeNameTest = ifM (optSizedTypes <$> pragmaOptions)+isSizeNameTest :: (HasOptions m, HasBuiltins m) => m (QName -> Bool)+isSizeNameTest = ifM sizedTypesOption   isSizeNameTestRaw   (return $ const False) -isSizeNameTestRaw :: TCM (QName -> Bool)+isSizeNameTestRaw :: (HasOptions m, HasBuiltins m) => m (QName -> Bool) isSizeNameTestRaw = do   (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 _ [] <- ignoreSharing <$> primSize-    Def _ [] <- ignoreSharing <$> primSizeInf-    Def _ [] <- ignoreSharing <$> primSizeSuc-    optSizedTypes <$> pragmaOptions-  `catchError` \_ -> return False---- | 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 ------------------------------------------------------------------------@@ -123,36 +136,37 @@ sizeType_ :: QName -> Type sizeType_ size = El sizeSort $ Def size [] +{-# SPECIALIZE sizeType :: TCM Type #-} -- | The built-in type @SIZE@.-sizeType :: TCM Type-sizeType = El sizeSort <$> primSize+sizeType :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => m Type+sizeType = El sizeSort . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSize  -- | The name of @SIZESUC@.-sizeSucName :: TCM (Maybe QName)+sizeSucName :: (HasBuiltins m, HasOptions m) => m (Maybe QName) sizeSucName = do-  ifM (not . optSizedTypes <$> pragmaOptions) (return Nothing) $ tryMaybe $ do-    Def x [] <- ignoreSharing <$> primSizeSuc-    return x+  ifM (not <$> sizedTypesOption) (return Nothing) $ do+    getBuiltin' builtinSizeSuc >>= \case+      Just (Def x []) -> return $ Just x+      _               -> return Nothing -sizeSuc :: Nat -> Term -> TCM Term+{-# 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 [] <- ignoreSharing <$> primSizeSuc-  return $ case iterate (sizeSuc_ suc) v !!! n of-             Nothing -> __IMPOSSIBLE__-             Just t  -> t+  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeSuc+  return $ fromMaybe __IMPOSSIBLE__ (iterate (sizeSuc_ suc) v !!! n)  sizeSuc_ :: QName -> Term -> Term sizeSuc_ suc v = Def suc [Apply $ defaultArg v]  -- | Transform list of terms into a term build from binary maximum.-sizeMax :: [Term] -> TCM Term+sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+        => List1 Term -> m Term sizeMax vs = case vs of-  []  -> __IMPOSSIBLE__  -- we do not have a zero size-  [v] -> return v+  v :| [] -> return v   vs  -> do-    Def max [] <- primSizeMax+    max <- getBuiltinName_ builtinSizeMax     return $ foldr1 (\ u v -> Def max $ map (Apply . defaultArg) [u,v]) vs  @@ -163,25 +177,56 @@ -- | A useful view on sizes. data SizeView = SizeInf | SizeSuc Term | OtherSize Term -sizeView :: Term -> TCM SizeView+-- | Expects argument to be 'reduce'd.+sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m)+         => Term -> m SizeView sizeView v = do-  Def inf [] <- ignoreSharing <$> primSizeInf-  Def suc [] <- ignoreSharing <$> primSizeSuc-  case ignoreSharing v of+  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)     _                          -> return $ OtherSize v +-- | A de Bruijn index under some projections.++data ProjectedVar = ProjectedVar+  { pvIndex :: Int+  , prProjs :: [(ProjOrigin, QName)]+  }+  deriving (Show)++-- | Ignore 'ProjOrigin' in equality test.++instance Eq ProjectedVar where+  ProjectedVar i prjs == ProjectedVar i' prjs' =+    i == i' && map snd prjs == map snd prjs'++viewProjectedVar :: Term -> Maybe ProjectedVar+viewProjectedVar = \case+  Var i es -> ProjectedVar i <$> mapM isProjElim es+  _ -> Nothing++unviewProjectedVar :: ProjectedVar -> Term+unviewProjectedVar (ProjectedVar i prjs) = Var i $ map (uncurry Proj) prjs+ type Offset = Nat  -- | A deep view on sizes. data DeepSizeView   = DSizeInf-  | DSizeVar Nat Offset+  | DSizeVar ProjectedVar Offset   | DSizeMeta MetaId Elims Offset   | DOtherSize Term   deriving (Show) +instance Pretty DeepSizeView where+  pretty = \case+    DSizeInf        -> "∞"+    DSizeVar pv o    -> pretty (unviewProjectedVar pv) <+> "+" <+> pretty o+    DSizeMeta x es o -> pretty (MetaV x es) <+> "+" <+> pretty o+    DOtherSize t     -> pretty t+ data SizeViewComparable a   = NotComparable   | YesAbove DeepSizeView a@@ -198,7 +243,7 @@   _ -> NotComparable  sizeViewSuc_ :: QName -> DeepSizeView -> DeepSizeView-sizeViewSuc_ suc v = case v of+sizeViewSuc_ suc = \case   DSizeInf         -> DSizeInf   DSizeVar i n     -> DSizeVar i (n + 1)   DSizeMeta x vs n -> DSizeMeta x vs (n + 1)@@ -206,8 +251,8 @@  -- | @sizeViewPred k v@ decrements @v@ by @k@ (must be possible!). sizeViewPred :: Nat -> DeepSizeView -> DeepSizeView-sizeViewPred 0 v = v-sizeViewPred k v = case v of+sizeViewPred 0 = id+sizeViewPred k = \case   DSizeInf -> DSizeInf   DSizeVar  i    n | n >= k -> DSizeVar  i    (n - k)   DSizeMeta x vs n | n >= k -> DSizeMeta x vs (n - k)@@ -215,7 +260,7 @@  -- | @sizeViewOffset v@ returns the number of successors or Nothing when infty. sizeViewOffset :: DeepSizeView -> Maybe Offset-sizeViewOffset v = case v of+sizeViewOffset = \case   DSizeInf         -> Nothing   DSizeVar i n     -> Just n   DSizeMeta x vs n -> Just n@@ -236,10 +281,11 @@ unSizeView (SizeSuc v)   = sizeSuc 1 v unSizeView (OtherSize v) = return v -unDeepSizeView :: DeepSizeView -> TCM Term-unDeepSizeView v = case v of+unDeepSizeView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+               => DeepSizeView -> m Term+unDeepSizeView = \case   DSizeInf         -> primSizeInf-  DSizeVar i     n -> sizeSuc n $ var i+  DSizeVar pv    n -> sizeSuc n $ unviewProjectedVar pv   DSizeMeta x us n -> sizeSuc n $ MetaV x us   DOtherSize u     -> return u @@ -247,38 +293,38 @@ -- * View on sizes where maximum is pulled to the top ------------------------------------------------------------------------ -type SizeMaxView = [DeepSizeView]+type SizeMaxView = List1 DeepSizeView+type SizeMaxView' = [DeepSizeView]  maxViewMax :: SizeMaxView -> SizeMaxView -> SizeMaxView maxViewMax v w = case (v,w) of-  (DSizeInf : _, _) -> [DSizeInf]-  (_, DSizeInf : _) -> [DSizeInf]-  _                 -> foldr maxViewCons w v+  (DSizeInf :| _, _) -> singleton DSizeInf+  (_, DSizeInf :| _) -> singleton DSizeInf+  _                 -> Fold.foldr maxViewCons w v  -- | @maxViewCons v ws = max v ws@.  It only adds @v@ to @ws@ if it is not --   subsumed by an element of @ws@. maxViewCons :: DeepSizeView -> SizeMaxView -> SizeMaxView-maxViewCons _ [DSizeInf] = [DSizeInf]-maxViewCons DSizeInf _   = [DSizeInf]+maxViewCons _ (DSizeInf :| _) = singleton DSizeInf+maxViewCons DSizeInf _        = singleton DSizeInf maxViewCons v ws = case sizeViewComparableWithMax v ws of-  NotComparable  -> v:ws-  YesAbove _ ws' -> v:ws'+  NotComparable  -> List1.cons v ws+  YesAbove _ ws' -> v :| ws'   YesBelow{}     -> ws  -- | @sizeViewComparableWithMax v ws@ tries to find @w@ in @ws@ that compares with @v@ --   and singles this out. --   Precondition: @v /= DSizeInv@.-sizeViewComparableWithMax :: DeepSizeView -> SizeMaxView -> SizeViewComparable SizeMaxView-sizeViewComparableWithMax v ws = case ws of-  []     -> __IMPOSSIBLE__-  [w]    -> fmap (const []) $ sizeViewComparable v w-  (w:ws) -> case sizeViewComparable v w of-            NotComparable -> fmap (w:) $ sizeViewComparableWithMax v ws-            r  -> fmap (const ws) r+sizeViewComparableWithMax :: DeepSizeView -> SizeMaxView -> SizeViewComparable SizeMaxView'+sizeViewComparableWithMax v (w :| ws) =+  case (ws, sizeViewComparable v w) of+    (w':ws', NotComparable) -> (w:) <$> sizeViewComparableWithMax v (w' :| ws')+    (ws    , r)             -> fmap (const ws) r   maxViewSuc_ :: QName -> SizeMaxView -> SizeMaxView-maxViewSuc_ suc = map (sizeViewSuc_ suc)+maxViewSuc_ suc = fmap (sizeViewSuc_ suc) -unMaxView :: SizeMaxView -> TCM Term-unMaxView vs = sizeMax =<< mapM unDeepSizeView vs+unMaxView :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+          => SizeMaxView -> m Term+unMaxView vs = sizeMax =<< Trav.mapM unDeepSizeView vs
src/full/Agda/TypeChecking/Monad/State.hs view
@@ -1,25 +1,26 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}- -- | Lenses for 'TCState' and more.  module Agda.TypeChecking.Monad.State where -import Control.Arrow (first)-import Control.Applicative import qualified Control.Exception as E-import Control.Monad.State (put, get, gets, modify)-import Control.Monad.Trans (liftIO) -import Data.Map (Map)+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 Data.Monoid import Data.Set (Set) import qualified Data.Set as Set  import Agda.Benchmarking --- import {-# SOURCE #-} Agda.Interaction.Response+import Agda.Compiler.Backend.Base (pattern Backend, backendName, mayEraseType)++import Agda.Interaction.Library ( classifyBuiltinModule_ ) import Agda.Interaction.Response   (InteractionOutputCallback, Response) @@ -27,121 +28,161 @@ import Agda.Syntax.Scope.Base import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Abstract (PatternSynDefn, PatternSynDefns)+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 {-# SOURCE #-} Agda.TypeChecking.Monad.Options+import Agda.TypeChecking.Warnings++import Agda.TypeChecking.Monad.Debug (reportSDoc, reportSLn, verboseS) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.CompiledClause -import Agda.Utils.Hash-import qualified Agda.Utils.HashMap as HMap+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.FileId ( File, getIdFile, registerFileId' ) import Agda.Utils.Lens-import Agda.Utils.Monad (bracket_, modify')-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 -#include "undefined.h" import Agda.Utils.Impossible  -- | Resets the non-persistent part of the type checking state.  resetState :: TCM ()-resetState = do-    pers <- gets stPersistentState-    put $ initState { stPersistentState = pers }+resetState = modifyTC \ s -> initStateFromPersistentState (s ^. lensPersistentState)  -- | Resets all of the type checking state. -----   Keep only 'Benchmark' information.+--   Keep only the session state (backend information, 'Benchmark', file ids).  resetAllState :: TCM ()-resetAllState = do-    b <- getBenchmark-    put $ updatePersistentState (\ s -> s { stBenchmark = b }) initState--- resetAllState = put 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 = disableDestructiveUpdate . bracket_ get (\ s -> do-   b <- getBenchmark-   put 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 <- get-  result <- compute-  newState <- get-  do-    b <- getBenchmark-    put 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+localTCStateSavingWarnings compute = do+  (result, newState) <- localTCStateSaving compute+  modifyTC $ over stTCWarnings $ const $ newState ^. stTCWarnings+  return result +-- | A fresh TCM instance.+--+-- The computation is run in a fresh state, with the exception that+-- the persistent state is preserved. If the computation changes the+-- state, then these changes are ignored, except for changes to the+-- persistent state. (Changes to the persistent state are also ignored+-- if errors other than type errors or IO exceptions are encountered.)++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 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) -> Right a <$ keepPersistent s+    Left err -> Left err <$+      case err of+        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) }  modifyPersistentState :: (PersistentTCState -> PersistentTCState) -> TCM ()-modifyPersistentState = modify . updatePersistentState+modifyPersistentState = modifyTC . updatePersistentState  -- | 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 :: TCM ScopeInfo-getScope = use stScope+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_ :: (ScopeInfo -> ScopeInfo) -> TCM ()-modifyScope_ f = stScope %= f+modifyScope_ :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m ()+modifyScope_ f = stScope `modifyTCLens` f +{-# INLINE modifyScope #-} -- | Modify the current scope.-modifyScope :: (ScopeInfo -> ScopeInfo) -> TCM ()+modifyScope :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m () modifyScope f = modifyScope_ (recomputeInverseScopeMaps . f) +{-# INLINE useScope #-}+-- | Get a part of the current scope.+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' ScopeInfo a -> (a -> a) -> m b -> m b+locallyScope l = locallyTCState $ stScope . l++{-# INLINE withScope #-} -- | Run a computation in a local scope.-withScope :: ScopeInfo -> TCM a -> TCM (a, ScopeInfo)-withScope s m = do-  s' <- getScope-  setScope s-  x   <- m-  s'' <- getScope-  setScope s'-  return (x, s'')+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_ :: ScopeInfo -> TCM a -> TCM a+withScope_ :: ReadTCState m => ScopeInfo -> m a -> m a withScope_ s m = fst <$> withScope s m  -- | Discard any changes to the scope by a computation.@@ -153,16 +194,21 @@   return x  -- | Scope error.-notInScope :: C.QName -> TCM a-notInScope x = do-  printScope "unbound" 5 ""-  typeError $ NotInScope [x]+notInScopeError :: C.QName -> TCM a+notInScopeError x = do+  printScope "unbound" 25 ""+  typeError $ NotInScope x +notInScopeWarning :: C.QName -> TCM ()+notInScopeWarning x = do+  printScope "unbound" 25 ""+  warning $ NotInScopeW x+ -- | Debug print the scope. printScope :: String -> Int -> String -> TCM () printScope tag v s = verboseS ("scope." ++ tag) v $ do   scope <- getScope-  reportSDoc ("scope." ++ tag) v $ return $ vcat [ text s, text $ show scope ]+  reportSDoc ("scope." ++ tag) v $ return $ vcat [ text s, pretty scope ]  --------------------------------------------------------------------------- -- * Signature@@ -170,28 +216,35 @@  -- ** Lens for 'stSignature' and 'stImports' -modifySignature :: (Signature -> Signature) -> TCM ()-modifySignature f = stSignature %= f+{-# INLINE modifySignature  #-}+modifySignature :: MonadTCState m => (Signature -> Signature) -> m ()+modifySignature f = stSignature `modifyTCLens` f -modifyImportedSignature :: (Signature -> Signature) -> TCM ()-modifyImportedSignature f = stImports %= f+{-# INLINE modifyImportedSignature #-}+modifyImportedSignature :: MonadTCState m => (Signature -> Signature) -> m ()+modifyImportedSignature f = stImports `modifyTCLens` f -getSignature :: TCM Signature-getSignature = use stSignature+{-# 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 --   representation of a function during compilation.-modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM ()-modifyGlobalDefinition q f = modifySignature (updateDefinition q f) >>-                             modifyImportedSignature (updateDefinition q f)+modifyGlobalDefinition :: MonadTCState m => QName -> (Definition -> Definition) -> m ()+modifyGlobalDefinition q f = do+  modifySignature         $ updateDefinition q f+  modifyImportedSignature $ updateDefinition q f -setSignature :: Signature -> TCM ()+{-# 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 :: Signature -> TCM a -> TCM a+withSignature :: (ReadTCState m, MonadTCState m) => Signature -> m a -> m a withSignature sig m = do   sig0 <- getSignature   setSignature sig@@ -202,15 +255,30 @@ -- ** Modifiers for rewrite rules addRewriteRulesFor :: QName -> RewriteRules -> [QName] -> Signature -> Signature addRewriteRulesFor f rews matchables =-    (over sigRewriteRules $ HMap.insertWith mappend f rews)-  . (updateDefinition f $ updateTheDef setNotInjective)-  . (foldr (.) id $ map (\g -> updateDefinition g setMatchable) matchables)+    over sigRewriteRules (HMap.insertWith mappend f rews)+  . updateDefinition f (updateTheDef setNotInjective . setCopatternLHS)+  . (setMatchableSymbols f matchables)     where       setNotInjective def@Function{} = def { funInv = NotInjective }       setNotInjective def            = def -      setMatchable def = def { defMatchable = True }+      setCopatternLHS =+        updateDefCopatternLHS (|| any hasProjectionPattern rews) +      hasProjectionPattern rew = any (isJust . isProjElim) $ rewPats rew++setMatchableSymbols :: QName -> [QName] -> Signature -> Signature+setMatchableSymbols f matchables =+  foldr ((.) . (\g -> updateDefinition g setMatchable)) id matchables+    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@@ -237,67 +305,183 @@ updateDefCompiledRep :: (CompiledRepresentation -> CompiledRepresentation) -> (Definition -> Definition) updateDefCompiledRep f def = def { defCompiledRep = f (defCompiledRep def) } +addCompilerPragma :: BackendName -> CompilerPragma -> Definition -> Definition+addCompilerPragma backend pragma = updateDefCompiledRep $ Map.insertWith (++) backend [pragma]+ updateFunClauses :: ([Clause] -> [Clause]) -> (Defn -> Defn) updateFunClauses f def@Function{ funClauses = cs} = def { funClauses = f cs } updateFunClauses f _                              = __IMPOSSIBLE__ +updateCovering :: ([Clause] -> [Clause]) -> (Defn -> Defn)+updateCovering f def@Function{ funCovering = cs} = def { funCovering = f cs }+updateCovering f _                               = __IMPOSSIBLE__+ updateCompiledClauses :: (Maybe CompiledClauses -> Maybe CompiledClauses) -> (Defn -> Defn) updateCompiledClauses f def@Function{ funCompiled = cc} = def { funCompiled = f cc } updateCompiledClauses f _                              = __IMPOSSIBLE__ +updateDefCopatternLHS :: (Bool -> Bool) -> Definition -> Definition+updateDefCopatternLHS f def@Defn{ defCopatternLHS = b } = def { defCopatternLHS = f b }++updateDefBlocked :: (Blocked_ -> Blocked_) -> Definition -> Definition+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 .= NameId 0 (hashString (show 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 <- use stFreshNameId+  nextN <- useTC stFreshNameId+  nextM <- useTC stFreshMetaId+  nextO <- useTC stFreshOpaqueId   setTopLevelModule x   y <- m-  stFreshNameId .= 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+ ------------------------------------------------------------------------------ * Haskell imports+-- * Backends and foreign code --------------------------------------------------------------------------- --- | Tell the compiler to import the given Haskell module.-addHaskellImport :: String -> TCM ()-addHaskellImport i = stHaskellImports %= Set.insert i+-- | Look for a backend of the given name. --- | Get the Haskell imports.-getHaskellImports :: TCM (Set String)-getHaskellImports = use stHaskellImports+lookupBackend :: ReadTCState m => BackendName -> m (Maybe Backend)+lookupBackend name = useTC stBackends <&> \ backends ->+  listToMaybe [ b | b@(Backend b') <- backends, backendName b' == name ] --- | Tell the compiler to import the given Haskell module.-addHaskellImportUHC :: String -> TCM ()-addHaskellImportUHC i = stHaskellImportsUHC %= Set.insert i+-- | Get the currently active backend (if any). --- | Get the Haskell imports.-getHaskellImportsUHC :: TCM (Set String)-getHaskellImportsUHC = use stHaskellImportsUHC+activeBackend :: TCM (Maybe Backend)+activeBackend = runMaybeT $ do+  bname <- MaybeT $ asksTC envActiveBackendName+  lift $ fromMaybe __IMPOSSIBLE__ <$> lookupBackend bname -addInlineHaskell :: String -> TCM ()-addInlineHaskell s = stHaskellCode %= (s :)+-- | 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 . ForeignCodeStack . (ForeignCode r code :) . maybe [] getForeignCodeStack+ --------------------------------------------------------------------------- -- * Interaction output callback --------------------------------------------------------------------------- -getInteractionOutputCallback :: TCM InteractionOutputCallback+getInteractionOutputCallback :: ReadTCState m => m InteractionOutputCallback getInteractionOutputCallback-  = gets $ stInteractionOutputCallback . stPersistentState+  = getsTC $ stInteractionOutputCallback . stPersistentState  appInteractionOutputCallback :: Response -> TCM () appInteractionOutputCallback r@@ -311,21 +495,32 @@ -- * Pattern synonyms --------------------------------------------------------------------------- -getPatternSyns :: TCM PatternSynDefns-getPatternSyns = use stPatternSyns+getPatternSyns :: ReadTCState m => m PatternSynDefns+getPatternSyns = useR stPatternSyns  setPatternSyns :: PatternSynDefns -> TCM () setPatternSyns m = modifyPatternSyns (const m)  -- | Lens for 'stPatternSyns'. modifyPatternSyns :: (PatternSynDefns -> PatternSynDefns) -> TCM ()-modifyPatternSyns f = stPatternSyns %= f+modifyPatternSyns f = stPatternSyns `modifyTCLens` f -getPatternSynImports :: TCM PatternSynDefns-getPatternSynImports = use stPatternSynImports+getPatternSynImports :: ReadTCState m => m PatternSynDefns+getPatternSynImports = useR stPatternSynImports -lookupPatternSyn :: QName -> TCM PatternSynDefn-lookupPatternSyn x = do+-- | Get both local and imported pattern synonyms+getAllPatternSyns :: ReadTCState m => m PatternSynDefns+getAllPatternSyns = Map.union <$> getPatternSyns <*> getPatternSynImports++lookupPatternSyn :: AmbiguousQName -> TCM PatternSynDefn+lookupPatternSyn (AmbQ xs) = do+  defs <- traverse lookupSinglePatternSyn xs+  case mergePatternSynDefs defs of+    Just def   -> return def+    Nothing    -> typeError $ CannotResolveAmbiguousPatternSynonym $ List1.zip xs defs++lookupSinglePatternSyn :: QName -> TCM PatternSynDefn+lookupSinglePatternSyn x = do     s <- getPatternSyns     case Map.lookup x s of         Just d  -> return d@@ -333,99 +528,38 @@             si <- getPatternSynImports             case Map.lookup x si of                 Just d  -> return d-                Nothing -> notInScope $ 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 = gets $ theBenchmark---- | Lens modify for 'Benchmark'.-modifyBenchmark :: (Benchmark -> Benchmark) -> TCM ()-modifyBenchmark = modify' . updateBenchmark---- | Run a fresh instance of the TCM (with initial state).---   'Benchmark' info is preserved.-freshTCM :: TCM a -> TCM (Either TCErr a)-freshTCM m = do-  -- Prepare an initial state with current benchmark info.-  b <- getBenchmark-  a <- use lensAccumStatistics-  let s = updateBenchmark (const b)-        . set lensAccumStatistics a-        $ initState-  -- Run subcomputation in initial state.-  -- If we encounter an exception, we lose the state and the-  -- benchmark info.-  -- We could retrieve i from a type error, which carries the state,-  -- but we do not care for benchmarking in the presence of errors.-  r <- liftIO $ (Right <$> runTCM initEnv s m) `E.catch` (return . Left)-  case r of-    Left err     -> return $ Left err-    Right (a, s) -> do-      -- Keep only the benchmark info from the final state of the subcomp.-      modifyBenchmark $ const $ theBenchmark s-      lensAccumStatistics .= (s^.lensAccumStatistics)-      return $ Right a+                Nothing -> notInScopeError $ qnameToConcrete x  --------------------------------------------------------------------------- -- * 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 %= Map.unionWith Set.union itable- -- | Lens for 'stInstanceDefs'. updateInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> (TCState -> TCState) updateInstanceDefs = over stInstanceDefs  modifyInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> TCM ()-modifyInstanceDefs = modify . updateInstanceDefs+modifyInstanceDefs = modifyTC . updateInstanceDefs  getAllInstanceDefs :: TCM TempInstanceTable getAllInstanceDefs = do-  (table,xs) <- use stInstanceDefs-  itable <- use 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 () addUnknownInstance x = do-  reportSLn "tc.decl.instance" 10 $ "adding definition " ++ show x ++ " to the instance table (the type is not yet known)"+  reportSLn "tc.decl.instance" 10 $+    "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 " ++ show x ++ " to instance table for " ++ show 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,68 +1,92 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Collect statistics.  module Agda.TypeChecking.Monad.Statistics-    ( tick, tickN, tickMax, getStatistics, modifyStatistics, printStatistics+    ( MonadStatistics(..), tick, tickN, tickMax, getStatistics, modifyStatistics, printStatistics     ) where -import qualified Data.Map as Map+import Control.DeepSeq+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Trans.Maybe +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.Options+import Agda.TypeChecking.Monad.Debug -import Agda.Utils.Lens 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+  modifyCounter :: String -> (Integer -> Integer) -> m ()++  default modifyCounter+    :: (MonadStatistics n, MonadTrans t, t n ~ m)+    =>  String -> (Integer -> Integer) -> m ()+  modifyCounter x = lift . modifyCounter x++instance MonadStatistics m => MonadStatistics (ExceptT e m)+instance MonadStatistics m => MonadStatistics (MaybeT m)+instance MonadStatistics m => MonadStatistics (ReaderT r m)+instance MonadStatistics m => MonadStatistics (StateT  s m)+instance (MonadStatistics m, Monoid w) => MonadStatistics (WriterT w m)++instance MonadStatistics TCM where+  modifyCounter x f = modifyStatistics $ force . update+    where+      -- We need to be strict in the map.+      -- Andreas, 2014-03-22:  Could we take Data.Map.Strict instead of this hack?+      -- Or force the map by looking up the very element we inserted?+      -- force m = Map.lookup x m `seq` m+      -- Or use insertLookupWithKey?+      -- update m = old `seq` m' where+      --   (old, m') = Map.insertLookupWithKey (\ _ new old -> f old) x dummy m+      -- Ulf, 2018-04-10: Neither of these approaches are strict enough in the+      -- map (nor are they less hacky). It's not enough to be strict in the+      -- values stored in the map, we also need to be strict in the *structure*+      -- of the map. A less hacky solution is to deepseq the map.+      force m = rnf m `seq` m+      update  = Map.insertWith (\ new old -> f old) x dummy+      dummy   = f 0+ -- | Get the statistics.-getStatistics :: TCM Statistics-getStatistics = use stStatistics+getStatistics :: ReadTCState m => m Statistics+getStatistics = useR stStatistics  -- | Modify the statistics via given function. modifyStatistics :: (Statistics -> Statistics) -> TCM ()-modifyStatistics f = stStatistics %= f+modifyStatistics f = stStatistics `modifyTCLens` f  -- | Increase specified counter by @1@.-tick :: String -> TCM ()+tick :: MonadStatistics m => String -> m () tick x = tickN x 1  -- | Increase specified counter by @n@.-tickN :: String -> Integer -> TCM ()+tickN :: MonadStatistics m => String -> Integer -> m () tickN s n = modifyCounter s (n +)  -- | Set the specified counter to the maximum of its current value and @n@.-tickMax :: String -> Integer -> TCM ()+tickMax :: MonadStatistics m => String -> Integer -> m () tickMax s n = modifyCounter s (max n) --- | Modify specified counter by a function @f@.-modifyCounter :: String -> (Integer -> Integer) -> TCM ()-modifyCounter x f = modifyStatistics $ force . update-  where-    -- We need to be strict in the map.-    -- Andreas, 2014-03-22:  Could we take Data.Map.Strict instead of this hack?-    -- Or force the map by looking up the very element we inserted?-    -- force m = Map.lookup x m `seq` m-    -- Or use insertLookupWithKey?-    -- update m = old `seq` m' where-    --   (old, m') = Map.insertLookupWithKey (\ _ new old -> f old) x dummy m-    force m = sum (Map.elems m) `seq` m-    update  = Map.insertWith (\ new old -> f old) x dummy-    dummy   = f 0---- | Print the given statistics if verbosity "profile" is given.-printStatistics :: Int -> Maybe C.TopLevelModuleName -> Statistics -> TCM ()-printStatistics vl mmname stats = verboseS "profile" vl $ do+-- | Print the given statistics.+printStatistics+  :: (MonadDebug m, MonadTCEnv m, HasOptions m)+  => 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 "Accumlated 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,126 +1,294 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Trace where  import Prelude hiding (null) -import Control.Monad.Reader+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 {-# SOURCE #-} Agda.Interaction.Highlighting.Generate-  (highlightAsTypeChecked)+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++import Agda.Interaction.Response+import Agda.Interaction.Highlighting.Precise+import Agda.Interaction.Highlighting.Range (rToR, minus)+ import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Options+  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 Agda.Utils.Maybe-import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow) -#include "undefined.h"-import Agda.Utils.Impossible- --------------------------------------------------------------------------- -- * Trace --------------------------------------------------------------------------- -interestingCall :: Closure Call -> Bool-interestingCall cl = case clValue cl of+interestingCall :: Call -> Bool+interestingCall = \case     InferVar{}              -> False     InferDef{}              -> False     CheckArguments _ [] _ _ -> False     SetRange{}              -> False     NoHighlighting{}        -> False-    _                       -> True--traceCallM :: MonadTCM tcm => tcm Call -> tcm a -> tcm a-traceCallM mkCall m = flip traceCall m =<< mkCall---- | Record a function call in the trace.-{-# SPECIALIZE traceCall :: Call -> TCM a -> TCM a #-}-traceCall :: MonadTCM tcm => Call -> tcm a -> tcm a-traceCall mkCall m = do-  let call      = mkCall-      callRange = getRange call-  -- Andreas, 2016-09-13 issue #2177-  -- 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 <- asks 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-  cl <- liftTCM $ buildClosure call-  let trace = local $ foldr (.) id $-        [ \e -> e { envCall = Just cl } | interestingCall cl ] ++-        [ \e -> e { envHighlightingRange = callRange }-          | callRange /= noRange && highlightCall call || isNoHighlighting call ] ++-        [ \e -> e { envRange = callRange } | callRange /= noRange ]-  wrap <- ifM (do l <- envHighlightingLevel <$> ask-                  return (l == Interactive && highlightCall call))-              (do oldRange <- envHighlightingRange <$> ask-                  return $ highlightAsTypeChecked oldRange callRange)-              (return id)-  wrap $ trace m-  where-  -- | Should the given call trigger interactive highlighting?-  highlightCall call = case call of+    -- Andreas, 2019-08-07, expanded catch-all pattern.+    -- The previous presence of a catch-all raises the following question:+    -- are all of the following really interesting?     CheckClause{}             -> True+    CheckLHS{}                -> True     CheckPattern{}            -> True+    CheckPatternLinearityType{}  -> True+    CheckPatternLinearityValue{} -> True     CheckLetBinding{}         -> True     InferExpr{}               -> True     CheckExprCall{}           -> True     CheckDotPattern{}         -> True-    CheckPatternShadowing{}   -> True     IsTypeCall{}              -> True     IsType_{}                 -> True-    InferVar{}                -> True-    InferDef{}                -> True     CheckArguments{}          -> True+    CheckMetaSolution{}       -> True+    CheckTargetType{}         -> True     CheckDataDef{}            -> True     CheckRecDef{}             -> True     CheckConstructor{}        -> True-    CheckFunDef{}             -> True+    CheckIApplyConfluence{}   -> True+    CheckConArgFitsIn{}       -> True+    CheckFunDefCall{}         -> True     CheckPragma{}             -> True     CheckPrimitive{}          -> True     CheckIsEmpty{}            -> True+    CheckConfluence{}         -> True+    CheckModuleParameters{}   -> True     CheckWithFunctionType{}   -> True     CheckSectionApplication{} -> True-    ScopeCheckExpr{}          -> False-    ScopeCheckDeclaration{}   -> False-    ScopeCheckLHS{}           -> False-    NoHighlighting{}          -> True-    CheckProjection{}         -> False-    SetRange{}                -> False-    ModuleContents{}          -> False+    CheckNamedWhere{}         -> True+    ScopeCheckExpr{}          -> True+    ScopeCheckDeclaration{}   -> True+    ScopeCheckLHS{}           -> True+    CheckProjection{}         -> True+    ModuleContents{}          -> True -  isNoHighlighting NoHighlighting{} = True-  isNoHighlighting _                = False+class (MonadTCEnv m, ReadTCState m) => MonadTrace m where -{-# SPECIALIZE traceCallCPS :: Call -> (r -> TCM a) -> ((r -> TCM a) -> TCM b) -> TCM b #-}-traceCallCPS :: MonadTCM tcm => Call -> (r -> tcm a) -> ((r -> tcm a) -> tcm b) -> tcm b-traceCallCPS mkCall ret cc = traceCall mkCall (cc ret)+  -- | Record a function call in the trace.+  traceCall :: Call -> m a -> m a+  traceCall call m = do+    cl <- buildClosure call+    traceClosureCall cl m -{-# SPECIALIZE traceCallCPS_ :: Call -> TCM a -> (TCM a -> TCM b) -> TCM b #-}-traceCallCPS_ :: MonadTCM tcm => Call -> tcm a -> (tcm a -> tcm b) -> tcm b-traceCallCPS_ mkCall ret cc =-    traceCallCPS mkCall (const ret) (\k -> cc $ k ())+  traceCallM :: m Call -> m a -> m a+  traceCallM call m = flip traceCall m =<< call -getCurrentRange :: TCM Range-getCurrentRange = asks envRange+  -- | Like 'traceCall', but resets 'envCall' and the current ranges to the+  --   previous values in the continuation.+  --+  traceCallCPS :: Call -> ((a -> m b) -> m b) -> ((a -> m b) -> m b)+  traceCallCPS call k ret = do +    -- Save current call and ranges.+    TCEnv{ envCall = mcall, envRange = r, envHighlightingRange = hr } <- askTC++    -- Run given computation under given call.+    traceCall call $ k $ \ a -> do++      -- 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.+  printHighlightingInfo :: RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()++  default printHighlightingInfo+    :: (MonadTrans t, MonadTrace n, t n ~ m)+    => 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++instance MonadTrace m => MonadTrace (StateT s m) where+  traceClosureCall c f = StateT (traceClosureCall c . runStateT f)++instance (MonadTrace m, Monoid w) => MonadTrace (WriterT w m) where+  traceClosureCall c f = WriterT $ traceClosureCall c $ runWriterT f++instance MonadTrace m => MonadTrace (ExceptT e m) where+  traceClosureCall c f = ExceptT $ traceClosureCall c $ runExceptT f++instance MonadTrace TCM where+  traceClosureCall cl m = do+    -- Andreas, 2016-09-13 issue #2177+    -- 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.)++    -- Compute update to 'Range' and 'Call' components of 'TCEnv'.+    let withCall = localTC $ foldr (.) id $ concat $+          [ [ \e -> e { envCall = Just cl } | interestingCall call ]+          , [ \e -> e { envHighlightingRange = callRange }+            | callHasRange && highlightCall+              || isNoHighlighting+            ]+          , [ \e -> e { envRange = callRange } | callHasRange ]+          ]++    -- For interactive highlighting, also wrap computation @m@ in 'highlightAsTypeChecked':+    ifNotM (pure highlightCall `and2M` do (Interactive ==) . envHighlightingLevel <$> askTC)+      {-then-} (withCall m)+      {-else-} $ do+        oldRange <- envHighlightingRange <$> askTC+        highlightAsTypeChecked oldRange callRange $+          withCall m+    where+    call = clValue cl+    callRange = getRange call+    callHasRange = not $ null callRange++    -- Should the given call trigger interactive highlighting?+    highlightCall = case call of+      CheckClause{}             -> True+      CheckLHS{}                -> True+      CheckPattern{}            -> True+      CheckPatternLinearityType{}  -> False+      CheckPatternLinearityValue{} -> False+      CheckLetBinding{}         -> True+      InferExpr{}               -> True+      CheckExprCall{}           -> True+      CheckDotPattern{}         -> True+      IsTypeCall{}              -> True+      IsType_{}                 -> True+      InferVar{}                -> True+      InferDef{}                -> True+      CheckArguments{}          -> True+      CheckMetaSolution{}       -> False+      CheckTargetType{}         -> False+      CheckDataDef{}            -> True+      CheckRecDef{}             -> True+      CheckConstructor{}        -> True+      CheckConArgFitsIn{}       -> False+      CheckFunDefCall _ _ _ h   -> h+      CheckPragma{}             -> True+      CheckPrimitive{}          -> True+      CheckIsEmpty{}            -> True+      CheckConfluence{}         -> False+      CheckIApplyConfluence{}   -> False+      CheckModuleParameters{}   -> False+      CheckWithFunctionType{}   -> True+      CheckSectionApplication{} -> True+      CheckNamedWhere{}         -> False+      ScopeCheckExpr{}          -> False+      ScopeCheckDeclaration{}   -> False+      ScopeCheckLHS{}           -> False+      NoHighlighting{}          -> True+      CheckProjection{}         -> False+      SetRange{}                -> False+      ModuleContents{}          -> False++    isNoHighlighting = case call of+      NoHighlighting{} -> True+      _ -> False++  printHighlightingInfo remove info = do+    modToSrc <- useTC stModuleToSource+    method   <- viewTC eHighlightingMethod+    reportSDoc "highlighting" 50 $ pure $ vcat+      [ "Printing highlighting info:"+      , nest 2 $ (text . show) info+      , "File modules:"+      , nest 2 $ pretty modToSrc+      ]+    unless (null info) $ do+      appInteractionOutputCallback $+          Resp_HighlightingInfo info remove method modToSrc+++getCurrentRange :: MonadTCEnv m => m Range+getCurrentRange = asksTC envRange+ -- | Sets the current range (for error messages etc.) to the range --   of the given object, if it has a range (i.e., its range is not 'noRange').-setCurrentRange :: HasRange x => x -> TCM a -> TCM a+setCurrentRange :: (MonadTrace m, HasRange x) => x -> m a -> m a setCurrentRange x = applyUnless (null r) $ traceCall $ SetRange r   where r = getRange x++-- | @highlightAsTypeChecked rPre r m@ runs @m@ and returns its+--   result. Additionally, some code may be highlighted:+--+-- * If @r@ is non-empty and not a sub-range of @rPre@ (after+--   'P.continuousPerLine' has been applied to both): @r@ is+--   highlighted as being type-checked while @m@ is running (this+--   highlighting is removed if @m@ completes /successfully/).+--+-- * Otherwise: Highlighting is removed for @rPre - r@ before @m@+--   runs, and if @m@ completes successfully, then @rPre - r@ is+--   highlighted as being type-checked.++highlightAsTypeChecked+  :: (MonadTrace m)+  => Range   -- ^ @rPre@+  -> Range   -- ^ @r@+  -> m a+  -> m a+highlightAsTypeChecked rPre r m+  | r /= noRange && delta == rPre' = wrap r'    highlight clear+  | otherwise                      = wrap delta clear     highlight+  where+  rPre'     = rToR (P.continuousPerLine rPre)+  r'        = rToR (P.continuousPerLine r)+  delta     = rPre' `minus` r'+  clear     = mempty+  highlight = parserBased { otherAspects = Set.singleton TypeChecks }++  wrap rs x y = do+    p rs x+    v <- m+    p rs y+    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
@@ -0,0 +1,249 @@++{-| EDSL to construct terms without touching De Bruijn indices.++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+  -- an extended context++  [t,u] <- mapM open [t,u]++  -- @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.+  -- We apply f with the (<@>) combinator from Agda.TypeChecking.Primitive.++  lam "f" $ \ f -> f <@> t <@> u++-}+module Agda.TypeChecking.Names where++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 )+import Control.Monad.Trans    ( MonadTrans, lift )++import Data.List              ( isSuffixOf )++import Agda.Syntax.Common hiding (Nat)+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Pretty ()  -- instances only++import Agda.Utils.Fail (Fail, runFail_)+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.Impossible++newtype NamesT m a = NamesT { unName :: ReaderT Names m a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadTrans+           , MonadState s+           , MonadIO+           , HasOptions+           , MonadDebug+           , MonadTCEnv+           , MonadTCState+           , MonadTCM+           , ReadTCState+           , MonadReduce+           , MonadError e+           , MonadAddContext+           , HasBuiltins+           , HasConstInfo+           , PureTCM+           )+++-- | 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++runNames :: Names -> NamesT Identity a -> a+runNames n m = runIdentity (runNamesT n m)++currentCxt :: Monad m => NamesT m Names+currentCxt = NamesT ask++{-# 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+      -- trace ("out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")")+       __IMPOSSIBLE__+++{-# 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+cl' :: Applicative m => a -> NamesT m a+cl' = pure++cl :: Monad m => m a -> NamesT m a+cl = lift++{-# 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++-- | 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)))+++-- * 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 (\ x -> f x)++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))+++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
@@ -1,17 +1,17 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}  -- | Tools to manipulate patterns in abstract syntax --   in the TCM (type checking monad).  module Agda.TypeChecking.Patterns.Abstract where -import Data.List-import Data.Traversable hiding (mapM, sequence)+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.Views+import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Concrete (FieldAssignment') import Agda.Syntax.Common import Agda.Syntax.Info as A@@ -20,81 +20,94 @@ import Agda.Syntax.Position  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin--import Agda.Utils.Functor+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Warnings (raiseWarningsOnUsage) -#include "undefined.h" import Agda.Utils.Impossible  -- | Expand literal integer pattern into suc/zero constructor patterns. ---expandLitPattern :: NamedArg A.Pattern -> TCM (NamedArg A.Pattern)-expandLitPattern p = traverse (traverse expand) p-  where-    expand p = case asView p of-      (xs, A.LitP (LitNat r n))-        | n < 0     -> __IMPOSSIBLE__-        | n > 20    -> tooBig-        | otherwise -> do-          Con z _ _ <- ignoreSharing <$> primZero-          Con s _ _ <- ignoreSharing <$> primSuc-          let zero  = A.ConP cinfo (A.AmbQ [setRange r $ conName z]) []-              suc p = A.ConP cinfo (A.AmbQ [setRange r $ conName s]) [defaultNamedArg p]-              info  = A.PatRange r-              cinfo = A.ConPatInfo ConOCon info-              p'    = foldr ($) zero $ genericReplicate n suc-          return $ foldr (A.AsP info) p' xs-      _ -> return p-    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."+expandLitPattern+  :: (MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m)+  => A.Pattern -> m A.Pattern+expandLitPattern = \case+  A.LitP info (LitNat n)+    | n < 0     -> typeError NegativeLiteralInPattern  -- Andreas, issue #2365, negative literals not yet supported.+    | n > 20    -> typeError LiteralTooBig+    | otherwise -> do+      z <- getBuiltinName_ builtinZero+      s <- getBuiltinName_ builtinSuc+      let r     = getRange info+      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   -- | Expand away (deeply) all pattern synonyms in a pattern.-class ExpandPatternSynonyms a where-  expandPatternSynonyms :: a -> TCM a -instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Maybe a) where-  expandPatternSynonyms = traverse expandPatternSynonyms+-- Unfortunately, the more general type signature+--+--   expandPatternSynonyms :: forall a p . APatternLike a p => p -> TCM p+--+-- is rejected by GHC 7.10+--+--   Could not deduce (APatternLike A.Expr p)+--     arising from a use of ‘postTraverseAPatternM’+--+-- I am mystified (Andreas, 2017-07-27) -instance ExpandPatternSynonyms a => ExpandPatternSynonyms [a] where-  expandPatternSynonyms = traverse expandPatternSynonyms+-- expandPatternSynonyms :: forall a p . APatternLike a p => p -> TCM p -instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Arg a) where-  expandPatternSynonyms = traverse expandPatternSynonyms+-- As a workaround, we define this function only for a = A.Exp, p = A.Pattern'+-- and keep the type class ExpandPatternSynonyms (which would otherwise be superfluous). -instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Named n a) where-  expandPatternSynonyms = traverse expandPatternSynonyms+expandPatternSynonyms' :: forall e. A.Pattern' e -> TCM (A.Pattern' e)+expandPatternSynonyms' = postTraverseAPatternM $ \case -instance ExpandPatternSynonyms a => ExpandPatternSynonyms (FieldAssignment' a) where+  A.PatternSynP i x as -> setCurrentRange i $ do+    (ns, p) <- killRange <$> lookupPatternSyn x++    -- Andreas, 2020-02-11, issue #3734+    -- If lookup of ambiguous pattern synonym was successful,+    -- we are justified to complain if one of the definitions+    -- involved in the resolution is tagged with a warning.+    -- This is less than optimal, since we do not rule out+    -- the invalid alternatives by typing, but we cannot do+    -- better here.+    mapM_ raiseWarningsOnUsage $ A.unAmbQ x++    -- Must expand arguments before instantiating otherwise pattern+    -- synonyms could get into dot patterns (which is __IMPOSSIBLE__).+    p <- expandPatternSynonyms' (vacuous p :: A.Pattern' e)++    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+        let subE _ = __IMPOSSIBLE__   -- No dot patterns in p+        return $ setRange (getRange i) $ substPattern' subE s p++  p -> return p++class ExpandPatternSynonyms a where+  expandPatternSynonyms :: a -> TCM a++  default expandPatternSynonyms+    :: (Traversable f, ExpandPatternSynonyms b, f b ~ a) => a -> TCM a   expandPatternSynonyms = traverse expandPatternSynonyms -instance ExpandPatternSynonyms A.Pattern where- expandPatternSynonyms p =-  case p of-    A.VarP{}             -> return p-    A.WildP{}            -> return p-    A.DotP{}             -> return p-    A.LitP{}             -> return p-    A.AbsurdP{}          -> return p-    A.ProjP{}            -> return p-    A.ConP i ds as       -> A.ConP i ds <$> expandPatternSynonyms as-    A.DefP i q as        -> A.DefP i q <$> expandPatternSynonyms as-    A.AsP i x p          -> A.AsP i x <$> expandPatternSynonyms p-    A.RecP i as          -> A.RecP i <$> expandPatternSynonyms as-    A.PatternSynP i x as -> setCurrentRange i $ do-      p <- killRange <$> lookupPatternSyn x-        -- Must expand arguments before instantiating otherwise pattern-        -- synonyms could get into dot patterns (which is __IMPOSSIBLE__)-      instPatternSyn p =<< expandPatternSynonyms as+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Maybe a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms [a]+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Arg a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (Named n a)+instance ExpandPatternSynonyms a => ExpandPatternSynonyms (FieldAssignment' a) -      where-        instPatternSyn :: A.PatternSynDefn -> [NamedArg A.Pattern] -> TCM A.Pattern-        instPatternSyn (ns, p) as = do-          p <- expandPatternSynonyms (vacuous p)-          case A.insertImplicitPatSynArgs (A.WildP . PatRange) (getRange x) ns as of-            Nothing       -> typeError $ BadArgumentsToPatternSynonym x-            Just (_, _:_) -> typeError $ TooFewArgumentsToPatternSynonym x-            Just (s, [])  -> return $ setRange (getRange i) $ A.substPattern s p+instance ExpandPatternSynonyms (A.Pattern' e) where+  expandPatternSynonyms = expandPatternSynonyms'
+ src/full/Agda/TypeChecking/Patterns/Internal.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Tools to manipulate patterns in internal syntax+--   in the TCM (type checking monad).++module Agda.TypeChecking.Patterns.Internal where++import Control.Monad++import Data.Maybe++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Reduce (reduce)+import Agda.TypeChecking.Substitute.DeBruijn++import Agda.Utils.Impossible++-- | Convert a term (from a dot pattern) to a DeBruijn pattern.++class TermToPattern a b where+  termToPattern :: a -> TCM b++  default termToPattern :: (TermToPattern a' b', Traversable f, a ~ f a', b ~ f b') => a -> TCM b+  termToPattern = traverse termToPattern++instance TermToPattern a b => TermToPattern [a] [b] where+instance TermToPattern a b => TermToPattern (Arg a) (Arg b) where+instance TermToPattern a b => TermToPattern (Named c a) (Named c b) where++instance (DeBruijn (Pattern' a)) => TermToPattern Term (Pattern' a) where+  termToPattern t = (reduce >=> constructorForm) t >>= \case+    -- Constructors.+    Con c _ args -> ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)+    Var i []    -> return $ deBruijnVar i+    Lit l       -> return $ litP l+    t           -> return $ dotP t++dotPatternsToPatterns :: forall a. (DeBruijn (Pattern' a))+                      => Pattern' a -> TCM (Pattern' a)+dotPatternsToPatterns = postTraversePatternM dotToPat+  where+    dotToPat :: Pattern' a -> TCM (Pattern' a)+    dotToPat = \case+      DotP o t -> termToPattern t+      p        -> return p
src/full/Agda/TypeChecking/Patterns/Match.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NondecreasingIndentation #-}  -- | Pattern matcher used in the reducer for clauses that@@ -9,40 +7,38 @@  import Prelude hiding (null) +import Control.Monad import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.Monoid-import Data.Traversable (traverse)  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern  import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Monad hiding (reportSDoc)+import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad.Builtin (getName', builtinHComp) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records-import Agda.TypeChecking.Datatypes  import Agda.Utils.Empty-import Agda.Utils.Functor (for, ($>))-import Agda.Utils.List+import Agda.Utils.Functor (for, ($>), (<&>)) import Agda.Utils.Maybe-import Agda.Utils.Monad+import Agda.Utils.Monad ( anyM, or2M) import Agda.Utils.Null import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple -#include "undefined.h" 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@@ -51,35 +47,49 @@   null _              = False  matchedArgs :: Empty -> Int -> IntMap (Arg a) -> [Arg a]-matchedArgs err n vs = map get [0..n-1]+matchedArgs err n vs = map (fromMaybe (absurd err)) $ matchedArgs' n vs++matchedArgs' :: Int -> IntMap (Arg a) -> [Maybe (Arg a)]+matchedArgs' n vs = map get [0 .. n - 1]   where-    get k = fromMaybe (absurd err) $ IntMap.lookup k vs+    get k = IntMap.lookup k vs  -- | Builds a proper substitution from an IntMap produced by match(Co)patterns buildSubstitution :: (DeBruijn a)-                  => Empty -> Int -> IntMap (Arg a) -> Substitution' a-buildSubstitution err n vs = parallelS $ map unArg $ matchedArgs err n vs+                  => Impossible -> Int -> IntMap (Arg a) -> Substitution' a+buildSubstitution err n vs = foldr cons idS $ matchedArgs' n vs+  where cons Nothing  = strengthenS' err 1+        cons (Just v) = consS (unArg v)  --- 'mappend' is UNUSED.------ instance Monoid (Match a) where---     mempty = Yes mempty []+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 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+    Yes s us   <> Yes s' vs        = Yes (s <> s') (us <> vs) ---     Yes s us   `mappend` Yes s' vs        = Yes (s `mappend` s') (us ++ vs)---     Yes _ _    `mappend` No               = No---     Yes _ _    `mappend` DontKnow m       = DontKnow m---     No         `mappend` _                = No+instance Monoid (Match a) where+    mempty = empty+    mappend = (<>) ---     -- @NotBlocked (StuckOn e)@ means blocked by a variable.---     -- In this case, no instantiation of---     -- meta-variables will make progress.---     DontKnow b `mappend` DontKnow b'      = DontKnow $ b `mappend` b'+-- | Whether the inconclusive matches are only on lazy patterns.+data OnlyLazy = OnlyLazy | NonLazy ---     -- One could imagine DontKnow _ `mappend` No = No, but would break the---     -- equivalence to case-trees.---     DontKnow m `mappend` _                = DontKnow m+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. @@ -99,27 +109,49 @@ -- upon failure, no further matching is performed.  foldMatch-  :: forall p v . (p -> v -> ReduceM (Match Term, v))-  -> [p] -> [v] -> ReduceM (Match Term, [v])+  :: forall m p v . (IsProjP p, MonadMatch m)+  => (p -> v -> m (Match Term, v))+  -> [p] -> [v] -> m (Match Term, [v]) foldMatch match = loop where-  loop :: [p] -> [v] -> ReduceM (Match Term, [v])+  loop :: [p] -> [v] -> m (Match Term, [v])   loop ps0 vs0 = do     case (ps0, vs0) of       ([], []) -> return (empty, [])       (p : ps, v : vs) -> do         (r, v') <- match p v         case r of-          No         -> return (No        , v' : vs)-          DontKnow m -> return (DontKnow m, v' : vs)-          Yes s us   -> do+          No | Just{} <- isProjP p -> return (No, v' : vs)+          No -> do+            -- Issue 2964: Even when the first pattern doesn't match we should+            -- continue to the next patterns (and potentially block on them)+            -- because the splitting order in the case tree may not be+            -- left-to-right.+            (r', _vs') <- loop ps vs+            -- Issue 2968: do not use vs' here, because it might+            -- contain ill-typed terms due to eta-expansion at wrong+            -- type.+            return (r <> r', 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-            let vs1 = v' : vs'-            case r' of-              Yes s' us' -> return (Yes (s `mappend` s') (us `mappend` us'), vs1)-              No         -> return (No                                     , vs1)-              DontKnow m -> return (DontKnow m                             , vs1)+            return (r <> r', v' : vs')       _ -> __IMPOSSIBLE__ ++-- TODO refactor matchPattern* to work with Elim instead.+mergeElim :: Elim -> Arg Term -> Elim+mergeElim Apply{} arg = Apply arg+mergeElim (IApply x y _) arg = IApply x y (unArg arg)+mergeElim Proj{} _ = __IMPOSSIBLE__++mergeElims :: [Elim] -> [Arg Term] -> [Elim]+mergeElims = zipWith mergeElim++type MonadMatch m = PureTCM m+ -- | @matchCopatterns ps es@ matches spine @es@ against copattern spine @ps@. -- --   Returns 'Yes' and a substitution for the pattern variables@@ -133,100 +165,152 @@ --   In any case, also returns spine @es@ in reduced form --   (with all the weak head reductions performed that were necessary --   to come to a decision).-matchCopatterns :: [NamedArg DeBruijnPattern]+matchCopatterns :: MonadMatch m+                => [NamedArg DeBruijnPattern]                 -> [Elim]-                -> ReduceM (Match Term, [Elim])+                -> m (Match Term, [Elim]) matchCopatterns ps vs = do   traceSDoc "tc.match" 50-    (vcat [ text "matchCopatterns"-          , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) ps)-          , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)+    (vcat [ "matchCopatterns"+          , nest 2 $ "ps =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) ps)+          , nest 2 $ "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)           ]) $ do-     -- Buggy, see issue 1124:-     -- mapFst mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs-     foldMatch (matchCopattern . namedArg) ps vs+  -- Buggy, see issue 1124:+  -- mapFst mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs+  foldMatch (matchCopattern . namedArg) ps vs  -- | Match a single copattern.-matchCopattern :: DeBruijnPattern+matchCopattern :: MonadMatch m+               => DeBruijnPattern                -> Elim-               -> ReduceM (Match Term, Elim)+               -> m (Match Term, Elim) matchCopattern pat@ProjP{} elim@(Proj _ q) = do-  ProjP _ p <- normaliseProjP pat-  q         <- getOriginalProjection q+  p <- normaliseProjP pat <&> \case+         ProjP _ p -> p+         _         -> __IMPOSSIBLE__+  q       <- getOriginalProjection q   return $ if p == q then (Yes YesSimplification empty, elim)                      else (No,                          elim)-matchCopattern ProjP{} Apply{}   = __IMPOSSIBLE__-matchCopattern _       Proj{}    = __IMPOSSIBLE__+-- The following two cases are not impossible, see #2964+matchCopattern ProjP{} elim@Apply{}   = return (No , elim)+matchCopattern _       elim@Proj{}    = return (No , elim) matchCopattern p       (Apply v) = mapSnd Apply <$> matchPattern p v+matchCopattern p       e@(IApply x y r) = mapSnd (mergeElim e) <$> matchPattern p (defaultArg r) -matchPatterns :: [NamedArg DeBruijnPattern]+{-# SPECIALIZE matchPatterns :: [NamedArg DeBruijnPattern] -> [Arg Term] -> TCM (Match Term, [Arg Term]) #-}+matchPatterns :: MonadMatch m+              => [NamedArg DeBruijnPattern]               -> [Arg Term]-              -> ReduceM (Match Term, [Arg Term])+              -> m (Match Term, [Arg Term]) matchPatterns ps vs = do+  reportSDoc "tc.match" 20 $+     vcat [ "matchPatterns"+          , nest 2 $ "ps =" <+> prettyTCMPatternList ps+          , nest 2 $ "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)+          ]+   traceSDoc "tc.match" 50-    (vcat [ text "matchPatterns"-          , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (text . show) ps)-          , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)+    (vcat [ "matchPatterns"+          , nest 2 $ "ps =" <+> fsep (punctuate comma $ map (text . show) ps)+          , nest 2 $ "vs =" <+> fsep (punctuate comma $ map prettyTCM vs)           ]) $ do-     -- Buggy, see issue 1124:-     -- (ms,vs) <- unzip <$> zipWithM' (matchPattern . namedArg) ps vs-     -- return (mconcat ms, vs)-     foldMatch (matchPattern . namedArg) ps vs+  -- Buggy, see issue 1124:+  -- (ms,vs) <- unzip <$> zipWithM' (matchPattern . namedArg) ps vs+  -- return (mconcat ms, vs)+  foldMatch (matchPattern . namedArg) ps vs  -- | Match a single pattern.-matchPattern :: DeBruijnPattern+matchPattern :: MonadMatch m+             => DeBruijnPattern              -> Arg Term-             -> ReduceM (Match Term, Arg Term)+             -> m (Match Term, Arg Term) matchPattern p u = case (p, u) of   (ProjP{}, _            ) -> __IMPOSSIBLE__-  (VarP x , arg          ) -> return (Yes NoSimplification entry, arg)+  (IApplyP _ _ _ x , arg ) -> return (Yes NoSimplification entry, arg)     where entry = singleton (dbPatVarIndex x, arg)-  (DotP _ , arg@(Arg _ v)) -> return (Yes NoSimplification empty, arg)-  (LitP l , arg@(Arg _ v)) -> do-    w <- reduceB' v+  (VarP _ x , arg          ) -> return (Yes NoSimplification entry, arg)+    where entry = singleton (dbPatVarIndex x, arg)+  (DotP _ _ , arg@(Arg _ v)) -> return (Yes NoSimplification empty, arg)+  (LitP _ l , arg@(Arg _ v)) -> do+    w <- reduceB v     let arg' = arg $> ignoreBlocking w-    case ignoreSharing <$> w of+    case w of       NotBlocked _ (Lit l')           | l == l'            -> return (Yes YesSimplification empty , arg')           | otherwise          -> return (No                          , arg')-      NotBlocked _ (MetaV x _) -> return (DontKnow $ Blocked x ()     , arg')-      Blocked x _              -> return (DontKnow $ Blocked x ()     , 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 isNothing $ conPRecord cpi then fallback else do-    isEtaRecordCon (conName c) >>= \case-      Nothing -> fallback-      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)) <$> do-          matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f]-    where-    isEtaRecordCon :: QName -> ReduceM (Maybe [Arg QName])-    isEtaRecordCon c = do-      (theDef <$> getConstInfo c) >>= \case-        Constructor{ conData = d } -> do-          (theDef <$> getConstInfo d) >>= \case-            r@Record{ recFields = fs } | recEtaEquality r -> return $ Just 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 NonLazy ps v+ where     -- Default: not an eta record constructor.-    fallback = do-        w <- reduceB' v+  fallback :: MonadMatch m+           => 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 lazy ps v++  -- Regardless of blocking, constructors and a properly applied @hcomp@+  -- can be matched on.+  isMatchable' :: HasBuiltins m => m (Blocked Term -> Maybe Term)+  isMatchable' = do+    mhcomp <- getName' builtinHComp+    return $ \ r ->+      case ignoreBlocking r of+        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 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 ignoreSharing <$> w of+        w <- case w of                NotBlocked r (Def f es) ->   -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?                  unfoldDefinitionE True reduceB' (Def f []) f es                    -- reduceB is used here because some constructors@@ -237,24 +321,85 @@         -- Jesper, 23-06-2016: Note that unfoldCorecursion may destroy         -- constructor forms, so we only call constructorForm after.         w <- traverse constructorForm =<< case w of-               NotBlocked r u -> unfoldCorecursion u  -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?+               NotBlocked r u -> liftReduce $ unfoldCorecursion u  -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?                _ -> return w         let v = ignoreBlocking w             arg = Arg info v  -- the reduced argument-        case ignoreSharing <$> w of-          NotBlocked _ (Con c' ci vs)-            | c == c'               -> do-                (m, vs) <- yesSimplification <$> matchPatterns ps vs-                return (m, Arg info $ Con c' ci vs)-            | otherwise             -> return (No                          , arg)-          NotBlocked _ (MetaV x vs) -> return (DontKnow $ Blocked x ()     , arg)-          Blocked x _               -> return (DontKnow $ Blocked x ()     , arg)-          NotBlocked r _            -> return (DontKnow $ NotBlocked r' () , arg)++        case w of+          b | Just t <- isMatchable b ->+            case mtc t of+              Just (bld, vs) -> do+                (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 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 -------------------------------------++-- | Match a single pattern.+matchPatternP :: MonadMatch m+              => DeBruijnPattern+              -> Arg DeBruijnPattern+              -> m (Match DeBruijnPattern)+matchPatternP p (Arg info (DotP _ v)) = do+  (m, arg) <- matchPattern p (Arg info v)+  return $ fmap (DotP defaultPatternInfo) m+matchPatternP p arg@(Arg info q) = do+  let varMatch x = return $ Yes NoSimplification $ singleton (dbPatVarIndex x, arg)+      termMatch  = do+        (m, arg) <- matchPattern p (fmap patternToTerm arg)+        return $ fmap (DotP defaultPatternInfo) m+  case p of+    ProjP{}         -> __IMPOSSIBLE__+    IApplyP _ _ _ x -> varMatch x+    VarP _ x        -> varMatch x+    DotP _ _        -> return $ Yes NoSimplification empty+    LitP{}          -> termMatch -- Literal patterns bind no variables so we can fall back to the Term version.+    DefP{}          -> termMatch++    ConP c cpi ps ->+      case q of+        ConP c' _ qs | c == c'   -> matchPatternsP ps ((map . fmap) namedThing qs)+                     | otherwise -> return No+        LitP{} -> fmap toLitP <$> termMatch+          where toLitP (DotP _ (Lit l)) = litP l   -- All bindings should be to literals+                toLitP _                = __IMPOSSIBLE__+        _      -> termMatch++matchPatternsP :: MonadMatch m+               => [NamedArg DeBruijnPattern]+               -> [Arg DeBruijnPattern]+               -> 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 @@ -6,14 +7,17 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad-import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM) import Agda.TypeChecking.Substitute (DeBruijn) -import Agda.Utils.Empty+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 ()) -buildSubstitution :: (DeBruijn a) => Empty -> Int -> IntMap (Arg a) -> Substitution' a+data OnlyLazy = OnlyLazy | NonLazy -matchPatterns   :: [NamedArg DeBruijnPattern] -> Args  -> ReduceM (Match Term, Args)-matchCopatterns :: [NamedArg DeBruijnPattern] -> Elims -> ReduceM (Match Term, Elims)+buildSubstitution :: (DeBruijn a) => Impossible -> Int -> IntMap (Arg a) -> Substitution' a++type MonadMatch m = PureTCM m++matchPatterns   :: MonadMatch m => [NamedArg DeBruijnPattern] -> Args -> m (Match Term, Args)+matchCopatterns :: MonadMatch m => [NamedArg DeBruijnPattern] -> Elims -> m (Match Term, Elims)
src/full/Agda/TypeChecking/Polarity.hs view
@@ -1,36 +1,42 @@-{-# LANGUAGE CPP               #-}+-- | Computing the polarity (variance) of function arguments,+--   for the sake of subtyping. -module Agda.TypeChecking.Polarity where+module Agda.TypeChecking.Polarity+  ( -- * Polarity computation+    computePolarity+    -- * Auxiliary functions+  , composePol+  , nextPolarity+  , purgeNonvariant+  , polFromOcc+  ) where -import Control.Applicative-import Control.Monad.State+import Control.Monad  ( forM_, zipWithM ) -import Data.List import Data.Maybe-import Data.Traversable (traverse)+import Data.Semigroup ( Semigroup(..) )  import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Datatypes (getNumberOfParameters) import Agda.TypeChecking.Pretty+import Agda.TypeChecking.SizedTypes import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Free hiding (Occurrence(..))+import Agda.TypeChecking.Free import Agda.TypeChecking.Positivity.Occurrence -import Agda.Interaction.Options- import Agda.Utils.List import Agda.Utils.Maybe ( whenNothingM ) import Agda.Utils.Monad-import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Singleton import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -62,7 +68,7 @@ composePol Contravariant x = neg x  polFromOcc :: Occurrence -> Polarity-polFromOcc o = case o of+polFromOcc = \case   GuardPos  -> Covariant   StrictPos -> Covariant   JustPos   -> Covariant@@ -84,31 +90,59 @@ purgeNonvariant :: [Polarity] -> [Polarity] purgeNonvariant = map (\ p -> if p == Nonvariant then Covariant else p) ++-- | A quick transliterations of occurrences to polarities.+polarityFromPositivity+  :: (HasConstInfo m, MonadTCEnv m, MonadTCState m, MonadDebug m)+  => QName -> m ()+polarityFromPositivity x = inConcreteOrAbstractMode x $ \ def -> do++  -- Get basic polarity from positivity analysis.+  let npars = droppedPars def+  let pol0 = replicate npars Nonvariant ++ map polFromOcc (defArgOccurrences def)+  reportSLn "tc.polarity.set" 15 $+    "Polarity of " ++ prettyShow x ++ " from positivity: " ++ prettyShow pol0++  -- set the polarity in the signature (not the final polarity, though)+  setPolarity x $ drop npars pol0+ ------------------------------------------------------------------------ -- * Computing the polarity of a symbol. ------------------------------------------------------------------------  -- | Main function of this module.-computePolarity :: QName -> TCM ()-computePolarity x = inConcreteOrAbstractMode x $ \ def -> do-  reportSLn "tc.polarity.set" 25 $ "Computing polarity of " ++ show x+computePolarity+  :: ( HasOptions m, HasConstInfo m, HasBuiltins m+     , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m+     , MonadDebug m, MonadPretty m )+  => [QName] -> m ()+computePolarity xs = do -  -- get basic polarity from positivity analysis+ -- Andreas, 2017-04-26, issue #2554+ -- First, for mutual definitions, obtain a crude polarity from positivity.+ when (length xs >= 2) $ mapM_ polarityFromPositivity xs++ -- Then, refine it.+ forM_ xs $ \ x -> inConcreteOrAbstractMode x $ \ def -> do+  reportSLn "tc.polarity.set" 25 $ "Refining polarity of " ++ prettyShow x++  -- Again: get basic polarity from positivity analysis.   let npars = droppedPars def   let pol0 = replicate npars Nonvariant ++ map polFromOcc (defArgOccurrences def)-  reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ show x ++ " from positivity: " ++ show pol0+  reportSLn "tc.polarity.set" 15 $+    "Polarity of " ++ prettyShow x ++ " from positivity: " ++ prettyShow pol0  {-   -- get basic polarity from shape of def (arguments matched on or not?)   def      <- getConstInfo x   let usagePol = usagePolarity $ theDef def-  reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ show x ++ " from definition form: " ++ show usagePol+  reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ prettyShow x ++ " from definition form: " ++ prettyShow usagePol   let n = genericLength usagePol  -- n <- getArity x   reportSLn "tc.polarity.set" 20 $ "  arity = " ++ show n    -- refine polarity by positivity information   pol0 <- zipWith (/\) usagePol <$> mapM getPol [0..n - 1]-  reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ show x ++ " from positivity: " ++ show pol0+  reportSLn "tc.polarity.set" 15 $ "Polarity of " ++ prettyShow x ++ " from positivity: " ++ prettyShow pol0 -}    -- compute polarity of sized types@@ -119,29 +153,17 @@   -- Instantiation takes place in Rules.Decl.instantiateDefinitionType   -- t <- instantiateFull t -- Andreas, 2014-04-11 Issue 1099: needed for   --                        -- variable occurrence test in  dependentPolarity.-  reportSDoc "tc.polarity.set" 15 $ text "Refining polarity with type " <+> prettyTCM t+  reportSDoc "tc.polarity.set" 15 $+    "Refining polarity with type " <+> prettyTCM t+  reportSDoc "tc.polarity.set" 60 $+    "Refining polarity with type (raw): " <+> (text .show) t+   pol <- dependentPolarity t (enablePhantomTypes (theDef def) pol1) pol1-  reportSLn "tc.polarity.set" 10 $ "Polarity of " ++ show x ++ ": " ++ show pol+  reportSLn "tc.polarity.set" 10 $ "Polarity of " ++ prettyShow x ++ ": " ++ prettyShow pol    -- set the polarity in the signature   setPolarity x $ drop npars pol -- purgeNonvariant pol -- temporarily disable non-variance -  -- make 'Nonvariant' args 'UnusedArg' in type and clause telescope-  -- Andreas 2012-11-18: skip this for abstract definitions (fixing issue 755).-  -- This means that the most precise type for abstract definitions-  -- is not available, even to other abstract definitions.-  -- A proper fix would be to introduce a second type for use within abstract.-  ---  -- Andreas, 2015-07-01: I thought one should do this for-  -- abstract local definitions in @where@ blocks to fix Issue 1366b,-  --but it is not necessary.-  -- t <- if (defAbstract def == AbstractDef) && not (isAnonymousModuleName $ qnameModule x)-  t <- if (defAbstract def == AbstractDef)-         then return t-         else nonvariantToUnusedArg pol t-  modifySignature $ updateDefinition x $-   updateTheDef (nonvariantToUnusedArgInDef pol) . updateDefType (const t)- -- | Data and record parameters are used as phantom arguments all over --   the test suite (and possibly in user developments). --   @enablePhantomTypes@ turns 'Nonvariant' parameters to 'Covariant'@@ -151,7 +173,7 @@   Datatype{ dataPars = np } -> enable np   Record  { recPars  = np } -> enable np   _                         -> pol-  where enable np = let (pars, rest) = genericSplitAt np pol+  where enable np = let (pars, rest) = splitAt np pol                     in  purgeNonvariant pars ++ rest  {- UNUSED@@ -181,87 +203,42 @@ --   else if it is a data/record parameter but not a size argument. [See issue 1596] -- --   Precondition: the "phantom" polarity list has the same length as the polarity list.-dependentPolarity :: Type -> [Polarity] -> [Polarity] -> TCM [Polarity]+dependentPolarity+  :: (HasOptions m, HasBuiltins m, MonadReduce m, MonadAddContext m, MonadDebug m)+  => Type -> [Polarity] -> [Polarity] -> m [Polarity] dependentPolarity t _      []          = return []  -- all remaining are 'Invariant' dependentPolarity t []     (_ : _)     = __IMPOSSIBLE__ dependentPolarity t (q:qs) pols@(p:ps) = do   t <- reduce $ unEl t-  case ignoreSharing t of+  reportSDoc "tc.polarity.dep" 20 $ "dependentPolarity t = " <+> prettyTCM t+  reportSDoc "tc.polarity.dep" 70 $ "dependentPolarity t = " <+> (text . show) t+  case t of     Pi dom b -> do-      let c = absBody b-      ps <- dependentPolarity c qs ps-      let mp = ifM (isJust <$> isSizeType (unDom dom)) (return p) (return q)-      p  <- case b of-              Abs{} | p /= Invariant  ->-                -- Andreas, 2014-04-11 see Issue 1099-                -- Free variable analysis is not in the monad,-                -- hence metas must have been instantiated before!-                ifM (relevantInIgnoringNonvariant 0 c ps)-                  (return Invariant)-                  mp-              _ -> mp+      ps <- underAbstraction dom b $ \ c -> dependentPolarity c qs ps+      let fallback = ifM (isJust <$> isSizeType (unDom dom)) (return p) (return q)+      p <- case b of+        Abs{} | p /= Invariant  ->+          -- Andreas, 2014-04-11 see Issue 1099+          -- Free variable analysis is not in the monad,+          -- hence metas must have been instantiated before!+          ifM (relevantInIgnoringNonvariant 0 (absBody b) ps)+            {- then -} (return Invariant)+            {- else -} fallback+        _ -> fallback       return $ p : ps     _ -> return pols  -- | Check whether a variable is relevant in a type expression, --   ignoring domains of non-variant arguments.-relevantInIgnoringNonvariant :: Nat -> Type -> [Polarity] -> TCM Bool+relevantInIgnoringNonvariant :: MonadReduce m => Nat -> Type -> [Polarity] -> m Bool relevantInIgnoringNonvariant i t []     = return $ i `relevantInIgnoringSortAnn` t-relevantInIgnoringNonvariant i t (p:ps) = do-  t <- reduce $ unEl t-  case ignoreSharing t of-    Pi a b -> if p /= Nonvariant && i `relevantInIgnoringSortAnn` a then return True-              else relevantInIgnoringNonvariant (i + 1) (absBody b) ps-    _ -> return $ i `relevantInIgnoringSortAnn` t---- * Turn polarity 'Nonvariant' into relevance 'UnusedArg'---- | Record information that an argument is unused in 'Relevance'.-mkUnused :: Relevance -> Relevance-mkUnused Relevant = UnusedArg   -- commenting out this line switches off 'UnusedArg' polarity machinery-mkUnused r        = r  -- 'Irrelevant' is more informative than 'UnusedArg'.---- | Improve 'Relevance' information in a type by polarity information.---   'Nonvariant' becomes 'UnusedArg'.-nonvariantToUnusedArg :: [Polarity] -> Type -> TCM Type-nonvariantToUnusedArg []     t = return t-nonvariantToUnusedArg (p:ps) t = do-  t <- reduce t-  case ignoreSharingType t of-    El s (Pi a b) -> do-      let a' = if p == Nonvariant then mapRelevance mkUnused a else a-      El s . Pi a' <$> traverse (nonvariantToUnusedArg ps) b-        -- we do not lift properly but bound variables do not matter for reduce-        -- also, we do not maintain the context-    _ -> return t---- | Propagate 'Nonvariant' 'Polarity' to 'Relevance' information in---   'Arg's of a defined symbol.-nonvariantToUnusedArgInDef :: [Polarity] -> Defn -> Defn-nonvariantToUnusedArgInDef pol def = case def of-  Function { funClauses = cl } ->-       def { funClauses = map (nonvariantToUnusedArgInClause pol) cl }-  _ -> def--nonvariantToUnusedArgInClause :: [Polarity] -> Clause -> Clause-nonvariantToUnusedArgInClause pol cl@Clause{clauseTel = tel, namedClausePats = ps} =-  let adjPat p Nonvariant-        | properlyMatching (namedArg p) = __IMPOSSIBLE__ -- if we match, we cannot be Nonvariant (sanity check)-        | otherwise                     = mapRelevance mkUnused p-      adjPat p _    = p-      -- change relevance of 'Nonvariant' arguments to 'UnusedArg'-      -- note that the associated patterns cannot be 'ConP' or 'LitP'-      ps'   = zipWith adjPat ps (pol ++ repeat Invariant)-      -- get a list of 'Relevance's for the variables bound in the pattern-      rels0 = getRelevance <$> (concatMap (patternVars . fmap namedThing) ps')-      -- this is the order the variables appear in the telescope-      perm  = fromMaybe __IMPOSSIBLE__ $ clausePerm cl-      rels  = permute perm rels0-      -- now improve 'Relevance' in 'Telescope' by pattern relevance-      updateDom UnusedArg = mapRelevance mkUnused-      updateDom r          = id-      tel' = telFromList $ zipWith updateDom rels $ telToList tel-   in cl { namedClausePats = ps', clauseTel = tel'}+relevantInIgnoringNonvariant i t (p:ps) =+  ifNotPiType t+    {-then-} (\ t -> return $ i `relevantInIgnoringSortAnn` t) $+    {-else-} \ a b ->+      if p /= Nonvariant && i `relevantInIgnoringSortAnn` a+        then return True+        else relevantInIgnoringNonvariant (i + 1) (absBody b) ps  ------------------------------------------------------------------------ -- * Sized types@@ -270,54 +247,68 @@ -- | Hack for polarity of size indices. --   As a side effect, this sets the positivity of the size index. --   See test/succeed/PolaritySizeSucData.agda for a case where this is needed.-sizePolarity :: QName -> [Polarity] -> TCM [Polarity]+sizePolarity+  :: forall m .+     ( HasOptions m, HasConstInfo m, HasBuiltins m, ReadTCState m+     , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m+     , MonadDebug m, MonadPretty m )+  => QName -> [Polarity] -> m [Polarity] sizePolarity d pol0 = do   let exit = return pol0-  ifM (not . optSizedTypes <$> pragmaOptions) exit $ do+  ifNotM sizedTypesOption exit $ {- else -} do     def <- getConstInfo d     case theDef def of       Datatype{ dataPars = np, dataCons = cons } -> do         let TelV tel _      = telView' $ defType def-            (parTel, ixTel) = genericSplitAt np $ telToList tel+            (parTel, ixTel) = splitAt np $ telToList tel         case ixTel of           []                 -> exit  -- No size index-          Dom _ (_, a) : _ -> ifM ((/= Just BoundedNo) <$> isSizeType a) exit $ do+          Dom{unDom = (_,a)} : _ -> ifM ((/= Just BoundedNo) <$> isSizeType a) exit $ do             -- we assume the size index to be 'Covariant' ...-            let pol   = genericTake np pol0+            let pol   = take np pol0                 polCo = pol ++ [Covariant]                 polIn = pol ++ [Invariant]             setPolarity d $ polCo             -- and seek confirm it by looking at the constructor types-            let check c = do+            let check :: QName -> m Bool+                check c = do                   t <- defType <$> getConstInfo c                   addContext (telFromList parTel) $ do                     let pars = map (defaultArg . var) $ downFrom np                     TelV conTel target <- telView =<< (t `piApplyM` pars)-                    case conTel of-                      EmptyTel  -> return False  -- no size argument-                      ExtendTel arg  tel ->-                        ifM ((/= Just BoundedNo) <$> isSizeType (unDom arg)) (return False) $ do -- also no size argument-                          -- First constructor argument has type Size+                    loop target conTel+                  where+                  loop :: Type -> Telescope -> m Bool+                  -- no suitable size argument+                  loop _ EmptyTel = do+                    reportSDoc "tc.polarity.size" 15 $+                      "constructor" <+> prettyTCM c <+> "fails size polarity check"+                    return False -                          -- check that only positive occurences in tel-                          let isPos = underAbstraction arg tel $ \ tel -> do-                                pols <- zipWithM polarity [0..] $ map (snd . unDom) $ telToList tel-                                reportSDoc "tc.polarity.size" 25 $-                                  text $ "to pass size polarity check, the following polarities need all to be covariant: " ++ show pols-                                return $ all (`elem` [Nonvariant, Covariant]) pols+                  -- try argument @dom@+                  loop target (ExtendTel dom tel) = do+                    isSz <- isSizeType dom+                    underAbstraction dom tel $ \ tel -> do+                      let continue = loop target tel -                          -- check that the size argument appears in the-                          -- right spot in the target type-                          let sizeArg = size tel-                              isLin = addContext conTel $ checkSizeIndex d np sizeArg target+                      -- check that dom == Size+                      if isSz /= Just BoundedNo then continue else do -                          ok <- isPos `and2M` isLin-                          reportSDoc "tc.polarity.size" 15 $-                            text "constructor" <+> prettyTCM c <+>-                            text (if ok then "passes" else "fails") <+>-                            text "size polarity check"-                          return ok+                        -- check that the size argument appears in the+                        -- right spot in the target type+                        let sizeArg = size tel+                        isLin <- addContext tel $ checkSizeIndex d sizeArg target+                        if not isLin then continue else do +                          -- check that only positive occurences in tel+                          pols <- zipWithM polarity [0..] $ map (snd . unDom) $ telToList tel+                          reportSDoc "tc.polarity.size" 25 $+                            text $ "to pass size polarity check, the following polarities need all to be covariant: " ++ prettyShow pols+                          if any (`notElem` [Nonvariant, Covariant]) pols then continue else do+                            reportSDoc "tc.polarity.size" 15 $+                              "constructor" <+> prettyTCM c <+> "passes size polarity check"+                            return True+             ifNotM (andM $ map check cons)                 (return polIn) -- no, does not conform to the rules of sized types               $ do  -- yes, we have a sized type here@@ -328,97 +319,108 @@                 return polCo       _ -> exit --- | @checkSizeIndex d np i a@ checks that constructor target type @a@---   has form @d ps (↑ i) idxs@ where @|ps| = np@.+-- | @checkSizeIndex d i a@ checks that constructor target type @a@+--   has form @d ps (↑ⁿ i) idxs@ where @|ps| = np(d)@. -- --   Precondition: @a@ is reduced and of form @d ps idxs0@.-checkSizeIndex :: QName -> Nat -> Nat -> Type -> TCM Bool-checkSizeIndex d np i a = do-  reportSDoc "tc.polarity.size" 15 $ withShowAllArguments $-    text "checking that constructor target type " <+> prettyTCM a <+>-    text "is data type " <+> prettyTCM d <+>-    text "has size index successor of " <+> prettyTCM (var i)-  case ignoreSharing $ unEl a of+checkSizeIndex+  :: (HasConstInfo m, ReadTCState m, MonadDebug m, MonadPretty m, MonadTCError m)+  => QName -> Nat -> Type -> m Bool+checkSizeIndex d i a = do+  reportSDoc "tc.polarity.size" 15 $ withShowAllArguments $ vcat+    [ "checking that constructor target type " <+> prettyTCM a+    , "  is data type " <+> prettyTCM d+    , "  and has size index (successor(s) of) " <+> prettyTCM (var i)+    ]+  case unEl a of     Def d0 es -> do       whenNothingM (sameDef d d0) __IMPOSSIBLE__-      s <- sizeView $ unArg ix+      np <- fromMaybe __IMPOSSIBLE__ <$> getNumberOfParameters d0+      let (pars, Apply ix : ixs) = splitAt np es+      s <- deepSizeView $ unArg ix       case s of-        SizeSuc v | Var j [] <- ignoreSharing v, i == j+        DSizeVar (ProjectedVar j []) _ | i == j           -> return $ not $ freeIn i (pars ++ ixs)         _ -> return False-      where-        (pars, Apply ix : ixs) = genericSplitAt np es     _ -> __IMPOSSIBLE__ --- | @polarities i a@ computes the list of polarities of de Bruijn index @i@+-- | @polarity i a@ computes the least polarity of de Bruijn index @i@ --   in syntactic entity @a@.-class HasPolarity a where-  polarities :: Nat -> a -> TCM [Polarity]+polarity+  :: (HasPolarity a, HasConstInfo m, MonadReduce m)+  => Nat -> a -> m Polarity+polarity i x = getLeastPolarity $ polarity' i Covariant x --- | @polarity i a@ computes the polarity of de Bruijn index @i@---   in syntactic entity @a@ by taking the infimum of all 'polarities'.-polarity :: HasPolarity a => Nat -> a -> TCM Polarity-polarity i x = do-  ps <- polarities i x-  case ps of-    [] -> return Nonvariant-    ps -> return $ foldr1 (/\) ps+-- | A monoid for lazily computing the infimum of the polarities of a variable in some object.+-- Allows short-cutting. -instance HasPolarity a => HasPolarity (Arg a) where-  polarities i = polarities i . unArg+newtype LeastPolarity m = LeastPolarity { getLeastPolarity :: m Polarity} -instance HasPolarity a => HasPolarity (Dom a) where-  polarities i = polarities i . unDom+instance Monad m => Singleton Polarity (LeastPolarity m) where+  singleton = LeastPolarity . return -instance HasPolarity a => HasPolarity (Abs a) where-  polarities i (Abs   _ b) = polarities (i + 1) b-  polarities i (NoAbs _ v) = polarities i v+instance Monad m => Semigroup (LeastPolarity m) where+  LeastPolarity mp <> LeastPolarity mq = LeastPolarity $ do+    mp >>= \case+      Invariant  -> return Invariant  -- Shortcut for the absorbing element.+      Nonvariant -> mq                -- The neutral element.+      p          -> (p /\) <$> mq -instance HasPolarity a => HasPolarity [a] where-  polarities i xs = concat <$> mapM (polarities i) xs+instance Monad m => Monoid (LeastPolarity m) where+  mempty  = singleton Nonvariant+  mappend = (<>) -instance (HasPolarity a, HasPolarity b) => HasPolarity (a, b) where-  polarities i (x, y) = (++) <$> polarities i x <*> polarities i y+-- | Bind for 'LeastPolarity'.+(>>==) :: Monad m => m a -> (a -> LeastPolarity m) -> LeastPolarity m+m >>== k = LeastPolarity $ m >>= getLeastPolarity . k -instance HasPolarity Type where-  polarities i (El _ v) = polarities i v+-- | @polarity' i p a@ computes the least polarity of de Bruijn index @i@+--   in syntactic entity @a@, where root occurrences count as @p@.+--+--   Ignores occurrences in sorts.+class HasPolarity a where+  polarity'+    :: (HasConstInfo m, MonadReduce m)+    => Nat -> Polarity -> a -> LeastPolarity m -instance HasPolarity a => HasPolarity (Elim' a) where-  polarities i Proj{}    = return []-  polarities i (Apply a) = polarities i a+  default polarity'+    :: (HasConstInfo m, MonadReduce m, HasPolarity b, Foldable t, t b ~ a)+    => Nat -> Polarity -> a -> LeastPolarity m+  polarity' i = foldMap . polarity' i -instance HasPolarity Term where-  polarities i v = do-   v <- instantiate v-   case v of-    -- Andreas, 2012-09-06: taking the polarities of the arguments-    -- without taking the variance of the function into account seems wrong.-    Var n ts  | n == i -> (Covariant :) . map (const Invariant) <$> polarities i ts-              | otherwise -> map (const Invariant) <$> polarities i ts-    Lam _ t    -> polarities i t-    Lit _      -> return []-    Level l    -> polarities i l-    Def x ts   -> do-      pols <- getPolarity x-      let compose p ps = map (composePol p) ps-      concat . zipWith compose (pols ++ repeat Invariant) <$> mapM (polarities i) ts-    Con _ _ ts -> polarities i ts -- constructors can be seen as monotone in all args.-    Pi a b     -> (++) <$> (map neg <$> polarities i a) <*> polarities i b-    Sort s     -> return [] -- polarities i s -- return []-    MetaV _ ts -> map (const Invariant) <$> polarities i ts-    Shared p   -> polarities i $ derefPtr p-    DontCare t -> polarities i t -- return []+instance HasPolarity a => HasPolarity [a]+instance HasPolarity a => HasPolarity (Arg a)+instance HasPolarity a => HasPolarity (Dom a)+instance HasPolarity a => HasPolarity (Elim' a)+instance HasPolarity a => HasPolarity (Level' a)+instance HasPolarity a => HasPolarity (PlusLevel' a) -instance HasPolarity Level where-  polarities i (Max as) = polarities i as+-- | Does not look into sort.+instance HasPolarity a => HasPolarity (Type'' t a) -instance HasPolarity PlusLevel where-  polarities i ClosedLevel{} = return []-  polarities i (Plus _ l) = polarities i l+instance (HasPolarity a, HasPolarity b) => HasPolarity (a, b) where+  polarity' i p (x, y) = polarity' i p x <> polarity' i p y -instance HasPolarity LevelAtom where-  polarities i l = case l of-    MetaLevel _ vs   -> map (const Invariant) <$> polarities i vs-    BlockedLevel _ v -> polarities i v-    NeutralLevel _ v -> polarities i v-    UnreducedLevel v -> polarities i v+instance HasPolarity a => HasPolarity (Abs a) where+  polarity' i p (Abs   _ b) = polarity' (i + 1) p b+  polarity' i p (NoAbs _ v) = polarity' i p v++instance HasPolarity Term where+  polarity' i p v = instantiate v >>== \case+    -- Andreas, 2012-09-06: taking the polarity' of the arguments+    -- without taking the variance of the function into account seems wrong.+    Var n ts+      | n == i    -> singleton p <> polarity' i Invariant ts+      | otherwise -> polarity' i Invariant ts+    Lam _ t       -> polarity' i p t+    Lit _         -> mempty+    Level l       -> polarity' i p l+    Def x ts      -> getPolarity x >>== \ pols ->+                       let ps = map (composePol p) pols ++ repeat Invariant+                       in  mconcat $ zipWith (polarity' i) ps ts+    Con _ _ ts    -> polarity' i p ts   -- Constructors can be seen as monotone in all args.+    Pi a b        -> polarity' i (neg p) a <> polarity' i p b+    Sort s        -> mempty -- polarity' i p s -- mempty+    MetaV _ ts    -> polarity' i Invariant ts+    DontCare t    -> polarity' i p t -- mempty+    Dummy{}       -> mempty
src/full/Agda/TypeChecking/Polarity.hs-boot view
@@ -1,8 +1,19 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Polarity where -import Agda.Syntax.Internal+import Agda.Syntax.Abstract.Name                        (QName) import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin                  (HasBuiltins)+import Agda.TypeChecking.Monad.Context                  (MonadAddContext)+import Agda.TypeChecking.Monad.Debug                    (MonadDebug)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)+import {-# SOURCE #-} Agda.TypeChecking.Pretty          (MonadPretty) -computePolarity :: QName -> TCM ()+computePolarity+  :: ( HasOptions m, HasConstInfo m, HasBuiltins m+     , MonadTCEnv m, MonadTCState m, MonadReduce m, MonadAddContext m, MonadTCError m+     , MonadDebug m, MonadPretty m )+  => [QName] -> m ()+ composePol      :: Polarity -> Polarity -> Polarity
src/full/Agda/TypeChecking/Positivity.hs view
@@ -1,131 +1,157 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE UndecidableInstances #-}+{-# 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.Reader-import Control.Monad.State (get)+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )  import Data.Either import qualified Data.Foldable as Fold-import Data.Function-import Data.Graph (SCC(..), flattenSCC)+import Data.Function (on)+import Data.Graph (SCC(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.List as List hiding (null)+import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid (mconcat)+import Data.Sequence (Seq) 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.Position (fuseRange, Range, HasRange(..), noRange) import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern-import Agda.TypeChecking.Datatypes (isDataOrRecordType, DataOrRecord(..))-import Agda.TypeChecking.Records+import Agda.Syntax.Position (HasRange(..), noRange)+import Agda.TypeChecking.Datatypes ( isDataOrRecordType )+import Agda.TypeChecking.Functions import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (primInf, CoinductionKit(..), coinductionKit)-import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Patterns.Match ( properlyMatching ) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings  import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+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.Permutation as Perm+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 -#include "undefined.h" import Agda.Utils.Impossible -type Graph n e = Graph.Graph n n e+type Graph n e = Graph.Graph n e  -- | 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 = disableDestructiveUpdate $ do+checkStrictlyPositive mi qset = do   -- compute the occurrence graph for qs   let qs = Set.toList qset-  reportSDoc "tc.pos.tick" 100 $ text "positivity of" <+> prettyTCM qs+  reportSDoc "tc.pos.tick" 100 $ "positivity of" <+> prettyTCM qs   g <- buildOccurrenceGraph qset-  let (gstar, sccs') =+  let (gstar, sccs) =         Graph.gaussJordanFloydWarshallMcNaughtonYamada $ fmap occ g-  reportSDoc "tc.pos.tick" 100 $ text "constructed graph"+  reportSDoc "tc.pos.tick" 100 $ "constructed graph"   reportSLn "tc.pos.graph" 5 $ "Positivity graph: N=" ++ show (size $ Graph.nodes g) ++                                " E=" ++ show (length $ Graph.edges g)   reportSDoc "tc.pos.graph" 10 $ vcat-    [ text "positivity graph for" <+> (fsep $ map prettyTCM qs)+    [ "positivity graph for" <+> fsep (map prettyTCM qs)     , nest 2 $ prettyTCM g     ]   reportSLn "tc.pos.graph" 5 $     "Positivity graph (completed): E=" ++ show (length $ Graph.edges gstar)   reportSDoc "tc.pos.graph" 50 $ vcat-    [ text "transitive closure of positivity graph for" <+>+    [ "transitive closure of positivity graph for" <+>       prettyTCM qs     , nest 2 $ prettyTCM gstar     ]    -- remember argument occurrences for qs in the signature   setArgOccs qset qs gstar-  reportSDoc "tc.pos.tick" 100 $ text "set args"+  reportSDoc "tc.pos.tick" 100 $ "set args"    -- check positivity for all strongly connected components of the graph for qs-  let sccs = map flattenSCC sccs'   reportSDoc "tc.pos.graph.sccs" 10 $ do-    let (triv, others) = partitionEithers $ for sccs' $ \ scc -> case scc of+    let (triv, others) = partitionEithers $ for sccs $ \case           AcyclicSCC v -> Left v           CyclicSCC vs -> Right vs     sep [ text $ show (length triv) ++ " trivial sccs"         , text $ show (length others) ++ " non-trivial sccs with lengths " ++             show (map length others)         ]-  reportSDoc "tc.pos.graph.sccs" 15 $ text $ "  sccs = " ++ show sccs-  forM_ sccs $ \ scc -> setMut [ q | DefNode q <- scc ]-  mapM_ (checkPos g gstar) $ qs-  reportSDoc "tc.pos.tick" 100 $ text "checked positivity"+  reportSLn "tc.pos.graph.sccs" 15 $+    "  sccs = " ++ prettyShow [ scc | CyclicSCC scc <- sccs ] +  -- #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"+   where-    checkPos :: Graph Node Edge ->+    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-        reportSDoc "tc.pos.check" 10 $ text "Checking positivity of" <+> prettyTCM q+      whenJust (isDatatype def) $ \ dr -> do+        reportSDoc "tc.pos.check" 10 $ "Checking positivity of" <+> prettyTCM q          let loop :: Maybe Occurrence             loop = Graph.lookup (DefNode q) (DefNode q) gstar +            g' :: Graph Node (Edge (Seq OccursWhere))+            g' = fmap (fmap DS.singleton) g+             -- Note the property-            -- Agda.Utils.Graph.AdjacencyMap.Unidirectional.Tests.prop_productOfEdgesInBoundedWalk,+            -- Internal.Utils.Graph.AdjacencyMap.Unidirectional.prop_productOfEdgesInBoundedWalk,             -- which relates productOfEdgesInBoundedWalk to             -- gaussJordanFloydWarshallMcNaughtonYamada.              reason bound =               case productOfEdgesInBoundedWalk-                     occ g (DefNode q) (DefNode q) bound of+                     occ g' (DefNode q) (DefNode q) bound of                 Just (Edge _ how) -> how                 Nothing           -> __IMPOSSIBLE__ @@ -140,7 +166,7 @@         -- ASR (23 December 2015). We don't raise a strictly positive         -- error if the NO_POSITIVITY_CHECK pragma was set on in the         -- mutual block. See Issue 1614.-        when (Info.mutualPositivityCheck mi) $+        when (Info.mutualPositivityCheck mi == YesPositivityCheck) $           whenM positivityCheckEnabled $             case loop of             Just o | o <= JustPos ->@@ -148,11 +174,12 @@             _ -> return ()          -- if we find an unguarded record, mark it as such-        when (dr == IsRecord) $-          case loop of+        case dr of+          IsData -> return ()+          IsRecord pat -> case loop of             Just o | o <= StrictPos -> do               reportSDoc "tc.pos.record" 5 $ how "not guarded" StrictPos-              unguardedRecord q+              unguardedRecord q pat               checkInduction q             -- otherwise, if the record is recursive, mark it as well             Just o | o <= GuardPos -> do@@ -163,8 +190,8 @@             -- unless it is coinductive or a no-eta-equality record.             Nothing -> do               reportSDoc "tc.pos.record" 10 $-                text "record type " <+> prettyTCM q <+>-                text "is not recursive"+                "record type " <+> prettyTCM q <+>+                "is not recursive"               nonRecursiveRecord q             _ -> return () @@ -173,155 +200,100 @@       -- ASR (01 January 2016). We don't raise this error if the       -- NO_POSITIVITY_CHECK pragma was set on in the record. See       -- Issue 1760.-      when (Info.mutualPositivityCheck mi) $+      when (Info.mutualPositivityCheck mi == YesPositivityCheck) $         whenM positivityCheckEnabled $ do         -- Check whether the recursive record has been declared as         -- 'Inductive' or 'Coinductive'.  Otherwise, error.         unlessM (isJust . recInduction . theDef <$> getConstInfo q) $           setCurrentRange (nameBindingSite $ qnameName q) $-            typeError . GenericDocError =<<-              text "Recursive record" <+> prettyTCM q <+>-              text "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} -> Just IsRecord+        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 [q] = return ()  -- no mutual recursion-    setMut qs  = forM_ qs $ \ q -> setMutual q (delete q qs)-      -- TODO: The previous line is at least quadratic in the length-      -- of qs (assuming that the expression "delete q qs" is always-      -- forced, for instance due to serialisation). 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-      -- Compute a map from each name in q to the maximal argument index-      let maxs = Map.fromListWith max-           [ (q, i) | ArgNode q i <- Set.toList $ Graph.sourceNodes g, q `Set.member` qset ]-      forM_ qs $ \ q -> inConcreteOrAbstractMode q $ \ def -> do-        reportSDoc "tc.pos.args" 10 $ text "checking args of" <+> prettyTCM q+      -- Andreas, 2018-05-11, issue #3049: we need to be pessimistic about+      -- argument polarity beyond the formal arity of the function.+      --+      -- -- Compute a map from each name in q to the maximal argument index+      -- let maxs = Map.fromListWith max+      --      [ (q, i) | ArgNode q i <- Set.toList $ Graph.nodes g, q `Set.member` qset ]+      forM_ qs $ \ q -> inConcreteOrAbstractMode q $ \ def -> when (hasDefinition $ theDef def) $ do+        reportSDoc "tc.pos.args" 10 $ "checking args of" <+> prettyTCM q         n <- getDefArity def         -- If there is no outgoing edge @ArgNode q i@, all @n@ arguments are @Unused@.         -- Otherwise, we obtain the occurrences from the Graph.         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 .. max m (n - 1)]+            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-          [ text "args of" <+> prettyTCM q <+> text "="-          , nest 2 $ prettyList $ map (text . show) args+          [ "args of" <+> prettyTCM q <+> "="+          , nest 2 $ prettyList $ map prettyTCM args           ]         -- 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--getDefArity :: Definition -> TCM Int-getDefArity def = case theDef def of-  defn@Function{} -> do-    let dropped = projectionArgs defn-    -- TODO: instantiateFull followed by arity could perhaps be-    -- optimised, presumably the instantiation can be performed-    -- lazily.-    subtract dropped . arity <$> instantiateFull (defType def)-  Datatype{ dataPars = n } -> return n-  Record{ recPars = n }    -> return n-  _                        -> return 0---- Operations on occurrences ----------------------------------------------- See also Agda.TypeChecking.Positivity.Occurrence.--(>*<) :: OccursWhere -> OccursWhere -> OccursWhere-Unknown      >*< _            = Unknown-Known _    _ >*< Unknown      = Unknown-Known r1 os1 >*< Known r2 os2 = Known (fuseRange r1 r2) (os1 DS.>< os2)--instance PrettyTCM OccursWhere where-  prettyTCM o = prettyOs $ map maxOneLeftOfArrow $ uniq $ splitOnDef o-    where-      nth 0 = pwords "first"-      nth 1 = pwords "second"-      nth 2 = pwords "third"-      nth n = pwords $ show (n + 1) ++ "th"--      -- remove consecutive duplicates-      uniq = map head . group--      prettyOs [] = __IMPOSSIBLE__-      prettyOs [o] = prettyO o <> text "."-      prettyOs (o:os) = prettyO o <> text ", which occurs" $$ prettyOs os--      prettyO Unknown      = empty-      prettyO (Known _ ws) =-        Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws--      prettyW w = case w of-        LeftOfArrow  -> pwords "to the left of an arrow"-        DefArg q i   -> pwords "in the" ++ nth i ++ pwords "argument to" ++-                          [prettyTCM q]-        UnderInf     -> pwords "under" ++-                        [do -- this cannot fail if an 'UnderInf' has been generated-                            Def inf _ <- ignoreSharing <$> primInf-                            prettyTCM inf]-        VarArg       -> pwords "in an argument to a bound variable"-        MetaArg      -> pwords "in an argument to 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]-        InClause i   -> pwords "in the" ++ nth i ++ pwords "clause"-        Matched      -> pwords "as matched against"-        InDefOf d    -> pwords "in the definition of" ++ [prettyTCM d]--      maxOneLeftOfArrow Unknown      = Unknown-      maxOneLeftOfArrow (Known r ws) = Known r $-        noArrows-          DS.><-        case DS.viewl startsWithArrow of-          DS.EmptyL  -> DS.empty-          w DS.:< ws -> w DS.<| DS.filter (not . isArrow) ws-        where-        (noArrows, startsWithArrow) = DS.breakl isArrow ws+        modifyArgOccurrences q (mergeOccs $!! args) -        isArrow LeftOfArrow{} = True-        isArrow _             = False+      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) -      splitOnDef Unknown      = [Unknown]-      splitOnDef (Known r ws) = split ws DS.empty-        where-        split ws acc = case DS.viewl ws of-          w@InDefOf{} DS.:< ws -> let rest = split ws (DS.singleton w) in-                                  if DS.null acc-                                  then rest-                                  else Known r acc : rest-          w           DS.:< ws -> split ws (acc DS.|> w)-          DS.EmptyL            -> [Known r acc]+      -- 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,+      -- since no occurrence could possibly be found, naturally.+      hasDefinition :: Defn -> Bool+      hasDefinition = \case+        Axiom{}            -> False+        DataOrRecSig{}     -> False+        GeneralizableVar{} -> False+        AbstractDefn{}     -> False+        Primitive{}        -> False+        PrimitiveSort{}    -> False+        Constructor{}      -> False+        Function{}         -> True+        Datatype{}         -> True+        Record{}           -> True -instance Sized OccursWhere where-  size Unknown      = 1-  size (Known _ ws) = 1 + size ws+getDefArity :: Definition -> TCM Int+getDefArity def = do+  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 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]  -- | Used to build 'Occurrences' and occurrence graphs.@@ -337,68 +309,64 @@ data OccurrencesBuilder'   = Concat' [OccurrencesBuilder']   | OccursAs' Where OccurrencesBuilder'-  | OccursHere' Item OccursWhere+  | OccursHere' Item -emptyOB :: OccurrencesBuilder-emptyOB = Concat []+-- | The semigroup laws only hold up to flattening of 'Concat'.+instance Semigroup OccurrencesBuilder where+  occs1 <> occs2 = Concat [occs1, occs2] -(>+<) :: OccurrencesBuilder -> OccurrencesBuilder -> OccurrencesBuilder-occs1 >+< occs2 = Concat [occs1, occs2]+-- | The monoid laws only hold up to flattening of 'Concat'.+instance Monoid OccurrencesBuilder where+  mempty  = Concat []+  mappend = (<>)+  mconcat = Concat --- | Removes 'OnlyVarsUpTo' entries and adds 'OccursWhere' entries.------ WARNING: There can be lots of sharing between the generated--- 'OccursWhere' entries. Traversing all of these entries could be--- expensive. (See 'computeEdges' for an example.)+-- | Removes 'OnlyVarsUpTo' entries. preprocess :: OccurrencesBuilder -> OccurrencesBuilder'-preprocess ob = case pp Nothing DS.empty ob of+preprocess ob = case pp Nothing ob of   Nothing -> Concat' []   Just ob -> ob   where-  pp :: Maybe Nat-        -- ^ Variables larger than or equal to this number, if any,-        --   are not retained.-     -> DS.Seq Where+  pp :: Maybe Nat  -- Variables larger than or equal to this number, if any,+                   -- are not retained.      -> OccurrencesBuilder      -> Maybe OccurrencesBuilder'-  pp !m ws (Concat obs)        = case catMaybes $ map (pp m ws) obs of-                                   []  -> Nothing-                                   obs -> return (Concat' obs)-  pp  m ws (OccursAs w ob)     = OccursAs' w <$> pp m (ws DS.|> w) ob-  pp  m ws (OnlyVarsUpTo n ob) = pp (Just $! maybe n (min n) m) ws ob-  pp  m ws (OccursHere i)      = do guard keep-                                    return (OccursHere' i (Known (getRange i) ws))-    where-    keep = case (m, i) of-      (Nothing, _)      -> True-      (_, ADef _)       -> True-      (Just m, AnArg i) -> i < m+  pp !m = \case+    Concat obs -> case mapMaybe (pp m) obs of+      []  -> Nothing+      obs -> return (Concat' obs) --- | A type used locally in 'flatten'.-data OccursWheres-  = OccursWheres :++ OccursWheres-  | Occurs OccursWhere+    OccursAs w ob -> OccursAs' w <$> pp m ob +    OnlyVarsUpTo n ob -> pp (Just $! maybe n (min n) m) ob++    OccursHere i -> do+      guard keep+      return (OccursHere' i)+      where+      keep = case (m, i) of+        (Nothing, _)      -> True+        (_, ADef _)       -> True+        (Just m, AnArg i _) -> i < m+ -- | An interpreter for 'OccurrencesBuilder'. -- -- WARNING: There can be lots of sharing between the generated -- 'OccursWhere' entries. Traversing all of these entries could be -- expensive. (See 'computeEdges' for an example.)-flatten :: OccurrencesBuilder -> Occurrences+flatten :: OccurrencesBuilder -> Map Item Integer flatten =-  fmap (flip flatten'' []) .-  Map.fromListWith (:++) .+  Map.fromListWith (+) .   flip flatten' [] .   preprocess   where-  flatten' :: OccurrencesBuilder'-           -> [(Item, OccursWheres)] -> [(Item, OccursWheres)]-  flatten' (Concat' obs)     = foldr (\occs f -> flatten' occs . f) id obs-  flatten' (OccursAs' _ ob)  = flatten' ob-  flatten' (OccursHere' i o) = ((i, Occurs o) :)--  flatten'' (os1 :++ os2) = flatten'' os1 . flatten'' os2-  flatten'' (Occurs o)    = (o :)+  flatten'+    :: OccurrencesBuilder'+    -> [(Item, Integer)]+    -> [(Item, Integer)]+  flatten' (Concat' obs)    = foldr (\occs f -> flatten' occs . f) id obs+  flatten' (OccursAs' _ ob) = flatten' ob+  flatten' (OccursHere' i)  = ((i, 1) :)  -- | Context for computing occurrences. data OccEnv = OccEnv@@ -414,8 +382,13 @@   }  -- | 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+  mappend = (<>)+  mconcat = mconcat <.> sequence+ withExtendedOccEnv :: Maybe Item -> OccM a -> OccM a withExtendedOccEnv i = withExtendedOccEnv' [i] @@ -425,27 +398,38 @@ -- | Running the monad getOccurrences   :: (Show a, PrettyTCM a, ComputeOccurrences a)-  => [Maybe Item] -> a -> TCM OccurrencesBuilder+  => [Maybe Item]  -- ^ Extension of the 'OccEnv', usually a local variable context.+  -> a+  -> TCM OccurrencesBuilder getOccurrences vars a = do-  reportSDoc "tc.pos.occ" 70 $ text "computing occurrences in " <+> text (show a)-  reportSDoc "tc.pos.occ" 20 $ text "computing occurrences in " <+> prettyTCM a-  kit <- coinductionKit-  return $ runReader (occurrences a) $ OccEnv vars $ fmap nameOfInf kit+  reportSDoc "tc.pos.occ" 70 $ "computing occurrences in " <+> text (show a)+  reportSDoc "tc.pos.occ" 20 $ "computing occurrences in " <+> prettyTCM a+  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 +  default occurrences :: (Foldable t, ComputeOccurrences b, t b ~ a) => a -> OccM OccurrencesBuilder+  occurrences = foldMap occurrences+ instance ComputeOccurrences Clause where   occurrences cl = do     let ps    = namedClausePats cl         items = IntMap.elems $ patItems ps -- sorted from low to high DBI-    (Concat (mapMaybe matching (zip [0..] ps)) >+<) <$>-      withExtendedOccEnv' items (occurrences $ clauseBody cl)+    -- 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.@@ -457,21 +441,29 @@         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 -> do-      vars <- asks vars-      occs <- occurrences args-      -- Apparently some development version of GHC chokes if the-      -- following line is replaced by vars ! i.-      let mi | i < length vars = vars !! i-             | otherwise       = flip trace __IMPOSSIBLE__ $-                 "impossible: occurrence of de Bruijn index " ++ show i ++-                 " in vars " ++ show vars ++ " is unbound"-      return $ maybe emptyOB OccursHere mi >+< OccursAs VarArg occs+    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__ $+              "impossible: occurrence of de Bruijn index " ++ show i +++              " in vars " ++ show vars ++ " is unbound"+     Def d args   -> do       inf <- asks inf       let occsAs = if Just d /= inf then OccursAs . DefArg d else \ n ->@@ -479,43 +471,31 @@             -- the first is a level argument (n==0, counting from 0!)             if n == 1 then OccursAs UnderInf else OccursAs (DefArg d n)       occs <- mapM occurrences args-      return $ OccursHere (ADef d) >+< Concat (zipWith occsAs [0..] occs)+      return . Concat $ OccursHere (ADef d) : zipWith occsAs [0..] occs+     Con _ _ args -> occurrences args     MetaV _ args -> OccursAs MetaArg <$> occurrences args-    Pi a b       -> do-      oa <- occurrences a-      ob <- occurrences b-      return $ OccursAs LeftOfArrow oa >+< ob+    Pi a b       -> (OccursAs LeftOfArrow <$> occurrences a) <> occurrences b     Lam _ b      -> occurrences b     Level l      -> occurrences l-    Lit{}        -> return emptyOB-    Sort{}       -> return emptyOB-    DontCare _   -> return emptyOB -- Andreas, 2011-09-09: do we need to check for negative occurrences in irrelevant positions?-    Shared p     -> occurrences $ derefPtr p+    Lit{}        -> mempty+    Sort{}       -> mempty+    -- Jesper, 2020-01-12: this information is also used for the+    -- occurs check, so we need to look under DontCare (see #4371)+    DontCare v   -> occurrences v+    Dummy{}      -> mempty  instance ComputeOccurrences Level where-  occurrences (Max as) = occurrences as+  occurrences (Max _ as) = occurrences as  instance ComputeOccurrences PlusLevel where-  occurrences ClosedLevel{} = return emptyOB-  occurrences (Plus _ l)    = occurrences l--instance ComputeOccurrences LevelAtom where-  occurrences l = case l of-    MetaLevel x es   -> occurrences $ MetaV x es-      -- Andreas, 2016-07-25, issue 2108-      -- NOT: OccursAs MetaArg <$> occurrences vs-      -- since we need to unSpine!-      -- (Otherwise, we run into __IMPOSSIBLE__ at Proj elims)-    BlockedLevel _ v -> occurrences v-    NeutralLevel _ v -> occurrences v-    UnreducedLevel v -> occurrences v+  occurrences (Plus _ l) = occurrences l  instance ComputeOccurrences Type where   occurrences (El _ v) = occurrences v  instance ComputeOccurrences a => ComputeOccurrences (Tele a) where-  occurrences EmptyTel        = return emptyOB+  occurrences EmptyTel        = mempty   occurrences (ExtendTel a b) = occurrences (a, b)  instance ComputeOccurrences a => ComputeOccurrences (Abs a) where@@ -523,34 +503,31 @@   occurrences (NoAbs _ b) = occurrences b  instance ComputeOccurrences a => ComputeOccurrences (Elim' a) where-  occurrences Proj{}    = __IMPOSSIBLE__-  occurrences (Apply a) = occurrences a--instance ComputeOccurrences a => ComputeOccurrences (Arg a) where-  occurrences = occurrences . unArg--instance ComputeOccurrences a => ComputeOccurrences (Dom a) where-  occurrences = occurrences . unDom+  occurrences Proj{}         = __IMPOSSIBLE__  -- unSpine+  occurrences (Apply a)      = occurrences a+  occurrences (IApply x y a) = occurrences (x,(y,a)) -- TODO Andrea: conservative -instance ComputeOccurrences a => ComputeOccurrences [a] where-  occurrences vs = Concat <$> mapM occurrences vs+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 instance ComputeOccurrences a => ComputeOccurrences (Maybe a) where-  occurrences (Just v) = occurrences v-  occurrences Nothing  = return emptyOB  instance (ComputeOccurrences a, ComputeOccurrences b) => ComputeOccurrences (a, b) where-  occurrences (x, y) = do-    ox <- occurrences x-    oy <- occurrences y-    return $ ox >+< oy+  occurrences (x, y) = occurrences x <> occurrences y --- | Computes the occurrences in the given definition.+instance ComputeOccurrences Int where+  occurrences _ = mempty++-- | Computes the number of occurrences of different 'Item's in the+-- given definition. -- -- WARNING: There can be lots of sharing between the 'OccursWhere' -- entries. Traversing all of these entries could be expensive. (See -- 'computeEdges' for an example.)-computeOccurrences :: QName -> TCM Occurrences+computeOccurrences :: QName -> TCM (Map Item Integer) computeOccurrences q = flatten <$> computeOccurrences' q  -- | Computes the occurrences in the given definition.@@ -558,170 +535,179 @@ computeOccurrences' q = inConcreteOrAbstractMode q $ \ def -> do   reportSDoc "tc.pos" 25 $ do     let a = defAbstract def-    m <- asks envAbstractMode-    cur <- asks envCurrentModule-    text "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show m)+    m <- asksTC envAbstractMode+    cur <- asksTC envCurrentModule+    o <- asksTC envCurrentOpaqueId+    "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show o) <+> text (show m)       <+> prettyTCM cur   OccursAs (InDefOf q) <$> case theDef def of+     Function{funClauses = cs} -> do-      n  <- getDefArity def-      cs <- map (etaExpandClause n) <$> instantiateFull cs+      cs <- mapM etaExpandClause =<< instantiateFull cs       Concat . zipWith (OccursAs . InClause) [0..] <$>         mapM (getOccurrences []) cs+     Datatype{dataClause = Just c} -> getOccurrences [] =<< instantiateFull c-    Datatype{dataPars = np, dataCons = cs}       -> do-      -- Andreas, 2013-02-27: first, each data index occurs as matched on.-      TelV tel t <- telView $ defType def-      let xs  = [np .. size tel - 1] -- argument positions corresponding to indices-          ioccs = Concat $ map (OccursAs Matched . OccursHere . AnArg) xs+    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 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 telD) (return 0) $ \ dom _ -> do+        caseMaybeM (isSizeType dom) (return 0) $ \ _ -> return 1+      let np = np0 + sizeIndex+      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-            a <- defType <$> getConstInfo c-            TelV tel t <- telView' <$> normalise a -- normalization needed e.g. for test/succeed/Bush.agda-            let indices = case unEl t of-                            Def _ vs -> genericDrop np vs-                            _        -> __IMPOSSIBLE__-            let tel'    = telFromList $ genericDrop np $ telToList tel-                vars np = map (Just . AnArg) $ downFrom np-            (>+<) <$> (OccursAs (ConArgType c) <$> getOccurrences (vars np) tel')-                  <*> (OccursAs (IndArgType c) . OnlyVarsUpTo np <$> getOccurrences (vars $ size tel) indices)-      (>+<) ioccs <$> (Concat <$> mapM conOcc cs)+            -- 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, 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++            -- 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.+            (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+              -- that reduces to a data type once UnconfirmedReductions are confirmed+              -- as safe by the termination checker.+              -- 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'.+              case unEl t of+                Def q' vs+                  | q == q' -> do+                      let indices = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop np vs+                      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+                Sort{}     -> __IMPOSSIBLE__  -- not a constructor target+                Lam{}      -> __IMPOSSIBLE__  -- not a type+                Lit{}      -> __IMPOSSIBLE__  -- not a type+                Con{}      -> __IMPOSSIBLE__  -- not a type+                Level{}    -> __IMPOSSIBLE__  -- not a type+                DontCare{} -> __IMPOSSIBLE__  -- not a type+                Dummy{}    -> __IMPOSSIBLE__++      -- 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 tel' = telFromList $ genericDrop np $ telToList tel-          vars = map (Just . AnArg) $ downFrom np-      getOccurrences vars =<< instantiateFull tel'+      let (tel0,tel1) = splitTelescopeAt np tel+      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{} -> return emptyOB-    Axiom{}       -> return emptyOB-    Primitive{}   -> return emptyOB-    AbstractDefn  -> __IMPOSSIBLE__---- | Eta expand a clause to have the given number of variables.---   Warning: doesn't put correct types in telescope!---   This is used instead of special treatment of lambdas---   (which was unsound: issue 121)-etaExpandClause :: Nat -> Clause -> Clause-etaExpandClause n c-  | m <= 0    = c-  | otherwise = c-      { namedClausePats = raise m (namedClausePats c) ++-                          map (\i -> defaultArg $ namedDBVarP i underscore) (downFrom m)-      , clauseBody      = liftBody m $ clauseBody c-      , clauseTel       = telFromList $-          telToList (clauseTel c) ++ (replicate m $ (underscore,) <$> dummyDom)-          -- dummyDom, not __IMPOSSIBLE__, because of debug printing.-      }+    Constructor{}      -> mempty+    Axiom{}            -> mempty+    DataOrRecSig{}     -> mempty+    Primitive{}        -> mempty+    PrimitiveSort{}    -> mempty+    GeneralizableVar{} -> mempty+    AbstractDefn{}     -> __IMPOSSIBLE__   where-    m = n - genericLength (namedClausePats c)+    parametersToItems :: Telescope -> Nat -> TCM [Maybe Item]+    parametersToItems tel n = reverse <$>+      zipWithM (\i -> fmap (Just . AnArg i) . getOccurrencesFromType)+        [0 .. n -1]+        (snd . unDom <$> telToList tel) -    vars = map (defaultArg . var) $ downFrom m---    vars = reverse [ defaultArg $ var i | i <- [0..m - 1] ] -    liftBody m (Just v) = Just $ raise m v `apply` vars-    liftBody m Nothing  = Nothing- -- Building the occurrence graph ------------------------------------------  data Node = DefNode !QName           | ArgNode !QName !Nat   deriving (Eq, Ord) -instance Show Node where-  show (DefNode q)   = show q-  show (ArgNode q i) = show q ++ "." ++ show i--instance PrettyTCM Node where-  prettyTCM (DefNode q)   = prettyTCM q-  prettyTCM (ArgNode q i) = prettyTCM q <> text ("." ++ show i)--instance PrettyTCM n => PrettyTCM (WithNode n Edge) where-  prettyTCM (WithNode n (Edge o w)) =-    prettyTCM o <+> prettyTCM n <+> fsep (pwords $ show w)- -- | Edge labels for the positivity graph.-data Edge = Edge !Occurrence OccursWhere-  deriving (Eq, Ord, Show)+data Edge a = Edge !Occurrence a+  deriving (Eq, Ord, Show, Functor) -instance Null Edge where-  null (Edge o _) = null o-  empty = Edge empty Unknown+-- | Merges two edges between the same source and target. +mergeEdges :: Edge a -> Edge a -> Edge a+mergeEdges _                    e@(Edge Mixed _)     = e -- dominant+mergeEdges e@(Edge Mixed _)     _                    = e+mergeEdges (Edge Unused _)      e                    = e -- neutral+mergeEdges e                    (Edge Unused _)      = e+mergeEdges (Edge JustNeg _)     e@(Edge JustNeg _)   = e+mergeEdges _                    e@(Edge JustNeg w)   = Edge Mixed w+mergeEdges e@(Edge JustNeg w)   _                    = Edge Mixed w+mergeEdges _                    e@(Edge JustPos _)   = e -- dominates strict pos.+mergeEdges e@(Edge JustPos _)   _                    = e+mergeEdges _                    e@(Edge StrictPos _) = e -- dominates 'GuardPos'+mergeEdges e@(Edge StrictPos _) _                    = e+mergeEdges (Edge GuardPos _)    e@(Edge GuardPos _)  = e+ -- | These operations form a semiring if we quotient by the relation -- \"the 'Occurrence' components are equal\". -instance SemiRing Edge where-  ozero = Edge ozero Unknown-  oone  = Edge oone  Unknown--  oplus _                    e@(Edge Mixed _)     = e -- dominant-  oplus e@(Edge Mixed _) _                        = e-  oplus (Edge Unused _)      e                    = e -- neutral-  oplus e                    (Edge Unused _)      = e-  oplus (Edge JustNeg _)     e@(Edge JustNeg _)   = e-  oplus _                    e@(Edge JustNeg w)   = Edge Mixed w-  oplus e@(Edge JustNeg w)   _                    = Edge Mixed w-  oplus _                    e@(Edge JustPos _)   = e -- dominates strict pos.-  oplus e@(Edge JustPos _)   _                    = e-  oplus _                    e@(Edge StrictPos _) = e -- dominates 'GuardPos'-  oplus e@(Edge StrictPos _) _                    = e-  oplus (Edge GuardPos _)    e@(Edge GuardPos _)  = e+instance SemiRing (Edge (Seq OccursWhere)) where+  ozero = Edge ozero DS.empty+  oone  = Edge oone  DS.empty -  otimes (Edge o1 w1) (Edge o2 w2) = Edge (otimes o1 o2) (w1 >*< w2)+  oplus = mergeEdges --- | As 'OccursWhere' does not have an 'oplus' we cannot do something meaningful---   for the @OccursWhere@ here.------   E.g. @ostar (Edge JustNeg w) = Edge Mixed (w `oplus` (w >*< w))@---   would probably more sense, if we could do it.-instance StarSemiRing Edge where-  ostar (Edge o w) = Edge (ostar o) w+  otimes (Edge o1 w1) (Edge o2 w2) = Edge (otimes o1 o2) (w1 DS.>< w2)  -- | WARNING: There can be lots of sharing between the 'OccursWhere' -- entries in the edges. Traversing all of these entries could be -- expensive. (See 'computeEdges' for an example.)-buildOccurrenceGraph :: Set QName -> TCM (Graph Node Edge)+buildOccurrenceGraph :: Set QName -> TCM (Graph Node (Edge OccursWhere)) buildOccurrenceGraph qs =-  Graph.fromListWith oplus . concat <$>+  Graph.fromEdgesWith mergeEdges . concat <$>     mapM defGraph (Set.toList qs)   where-    defGraph :: QName -> TCM [Graph.Edge Node Node Edge]+    defGraph :: QName -> TCM [Graph.Edge Node (Edge OccursWhere)]     defGraph q = inConcreteOrAbstractMode q $ \ _def -> do       occs <- computeOccurrences' q        reportSDoc "tc.pos.occs" 40 $-        (text "Occurrences in" <+> prettyTCM q <> text ":")+        (("Occurrences in" <+> prettyTCM q) <> ":")           $+$-        (nest 2 $ vcat $-           map (\(i, (n, s)) ->-                   text (show i) <> text ":" <+> text (show n) <+>-                   text "occurrences, of total size" <+>-                   text (show s)) $-           sortBy (compare `on` fst . snd) $-           map (\(i, os) -> (i, (length os, sum $ map size os))) $+        nest 2 (vcat $+           map (\(i, n) ->+                   (pretty i <> ":") <+> text (show n) <+>+                   "occurrences") $+           List.sortBy (compare `on` snd) $            Map.toList (flatten occs))-      reportSDoc "tc.pos.occs" 50 $-        (nest 2 $ vcat $-           map (\(i, os) ->-                   (text (show i) <> text ":")-                     $+$-                   (nest 2 $ vcat $ map (text . show) os))-               (Map.toList (flatten occs)))        -- Placing this line before the reportSDoc lines above creates a       -- space leak: occs is retained for too long.       es <- computeEdges qs q occs        reportSDoc "tc.pos.occs.edges" 60 $-        text "Edges:"+        "Edges:"           $+$-        (nest 2 $ vcat $+        nest 2 (vcat $            map (\e ->                    let Edge o w = Graph.label e in                    prettyTCM (Graph.source e) <+>-                   text "-[" <+> text (show o) <> text "," <+>-                                 text (show w) <+> text "]->" <+>+                   "-[" <+> (return (P.pretty o) <> ",") <+>+                                 return (P.pretty w) <+> "]->" <+>                    prettyTCM (Graph.target e))                es) @@ -738,13 +724,13 @@ -- polarity 'StrictPos', 'JustNeg' or 'JustPos', and contain the -- following 'OccursWhere' elements: ----- * @'Known' ('DS.fromList' ['InDefOf' "F", 'InClause' 0])@,+-- * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0])@, ----- * @'Known' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow'])@,+-- * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow'])@, ----- * @'Known' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow'])@,+-- * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow'])@, ----- * @'Known' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow', 'LeftOfArrow'])@,+-- * @'OccursWhere' _ 'DS.empty' ('DS.fromList' ['InDefOf' "F", 'InClause' 0, 'LeftOfArrow', 'LeftOfArrow', 'LeftOfArrow'])@, -- -- * and so on. computeEdges@@ -753,51 +739,177 @@   -> QName      -- ^ The current name.   -> OccurrencesBuilder-  -> TCM [Graph.Edge Node Node Edge]+  -> TCM [Graph.Edge Node (Edge OccursWhere)] computeEdges muts q ob =-  ($ []) <$> mkEdge __IMPOSSIBLE__ StrictPos (preprocess ob)+  ($ []) <$> mkEdge StrictPos (preprocess ob)+                    __IMPOSSIBLE__ DS.empty DS.empty   where-  mkEdge to !pol ob = case ob of-    Concat' obs     -> foldr (liftM2 (.)) (return id)-                         [ mkEdge to pol ob | ob <- obs ]-    OccursAs' w ob  -> do (to, pol) <- mkEdge' to pol w-                          mkEdge to pol ob-    OccursHere' i o -> return $-                         if null pol-                         then id-                         else (Graph.Edge-                                 { Graph.source = case i of-                                                    AnArg i -> ArgNode q i-                                                    ADef q  -> DefNode q-                                 , Graph.target = to-                                 , Graph.label  = Edge pol o-                                 } :)+  mkEdge+     :: Occurrence+     -> OccurrencesBuilder'+     -> Node          -- The current target node.+     -> DS.Seq Where  -- 'Where' information encountered before the current target+                      -- node was (re)selected.+     -> DS.Seq Where  -- 'Where' information encountered after the current target+                      -- node was (re)selected.+     -> TCM ([Graph.Edge Node (Edge OccursWhere)] ->+             [Graph.Edge Node (Edge OccursWhere)])+  mkEdge !pol ob to cs os = case ob of+    Concat' obs ->+      foldr (liftM2 (.)) (return id)+            [ mkEdge pol ob to cs os | ob <- obs ] -  mkEdge' to !pol w = case w of-    VarArg         -> mixed+    OccursAs' w ob -> do+      (to', pol) <- mkEdge' to pol w+      let mk = mkEdge pol ob+      case to' of+        Nothing -> mk to cs            (os DS.|> w)+        Just to -> mk to (cs DS.>< os) (DS.singleton w)++    OccursHere' i ->+      let o = OccursWhere (getRange i) cs os in+      case i of+        AnArg i t ->+          return $ applyUnless (null pol) (Graph.Edge+            { Graph.source = ArgNode q i+            , Graph.target = to+            , Graph.label  = Edge pol o+            } :)+        ADef q' ->+          -- Andreas, 2017-04-26, issue #2555+          -- Skip nodes pointing outside the mutual block.+          return $ applyUnless (null pol || Set.notMember q' muts)+            (Graph.Edge+               { Graph.source = DefNode q'+               , Graph.target = to+               , Graph.label  = Edge pol o+               } :)++  -- This function might return a new target node.+  mkEdge'+    :: Node  -- The current target node.+    -> Occurrence+    -> Where+    -> TCM (Maybe Node, Occurrence)+  mkEdge' to !pol = \case+    VarArg p i     -> addPol p     MetaArg        -> mixed     LeftOfArrow    -> negative     DefArg d i     -> do       pol' <- isGuarding d       if Set.member d muts-        then return (ArgNode d i, pol')+        then return (Just (ArgNode d i), pol')         else addPol =<< otimes pol' <$> getArgOccurrence d i     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.     InDefOf d      -> do       pol' <- isGuarding d-      return (DefNode d, pol')+      return (Just (DefNode d), pol')     where-    keepGoing   = return (to, pol)-    mixed       = return (to, Mixed)-    negative    = return (to, otimes pol JustNeg)-    addPol pol' = return (to, otimes pol pol')+    keepGoing   = return (Nothing, pol)+    mixed       = return (Nothing, Mixed)+    negative    = return (Nothing, otimes pol JustNeg)+    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++-- Pretty-printing -----------------------------------------------------++instance Pretty Node where+  pretty = \case+    DefNode q   -> P.pretty q+    ArgNode q i -> P.pretty q <> P.text ("." ++ show i)++instance PrettyTCM Node where+  prettyTCM = return . P.pretty++instance PrettyTCMWithNode (Edge OccursWhere) where+  prettyTCMWithNode (WithNode n (Edge o w)) = vcat+    [ prettyTCM o <+> prettyTCM n+    , nest 2 $ return $ P.pretty w+    ]++instance PrettyTCM (Seq OccursWhere) where+  prettyTCM =+    fmap snd . prettyOWs . map adjustLeftOfArrow . uniq . Fold.toList+    where+      nth 0 = pwords "first"+      nth 1 = pwords "second"+      nth 2 = pwords "third"+      nth n = pwords $ show (n + 1) ++ "th"++      -- Removes consecutive duplicates.+      uniq :: [OccursWhere] -> [OccursWhere]+      uniq = map List1.head . List1.groupBy ((==) `on` snd')+        where+        snd' (OccursWhere _ _ ws) = ws++      prettyOWs :: MonadPretty m => [OccursWhere] -> m (String, Doc)+      prettyOWs []  = __IMPOSSIBLE__+      prettyOWs [o] = do+        (s, d) <- prettyOW o+        return (s, d <> ".")+      prettyOWs (o:os) = do+        (s1, d1) <- prettyOW  o+        (s2, d2) <- prettyOWs os+        return (s1, d1 <> ("," P.<+> "which" P.<+> P.text s2 P.$$ d2))++      prettyOW :: MonadPretty m => OccursWhere -> m (String, Doc)+      prettyOW (OccursWhere _ cs ws)+        | null cs   = prettyWs ws+        | otherwise = do+            (s, d1) <- prettyWs ws+            (_, d2) <- prettyWs cs+            return (s, d1 P.$$ "(" <> d2 <> ")")++      prettyWs :: MonadPretty m => Seq Where -> m (String, Doc)+      prettyWs ws = case Fold.toList ws of+        [InDefOf d, IsIndex] ->+          (,) "is" <$> fsep (pwords "an index of" ++ [prettyTCM d])+        _ ->+          (,) "occurs" <$>+            Fold.foldrM (\w d -> return d $$ fsep (prettyW w)) empty ws++      prettyW :: MonadPretty m => Where -> [m Doc]+      prettyW = \case+        LeftOfArrow  -> pwords "to the left of an arrow"+        DefArg q i   -> pwords "in the" ++ nth i ++ pwords "argument of" +++                          [prettyTCM q]+        UnderInf     -> pwords "under" +++                        [do -- this cannot fail if an 'UnderInf' has been generated+                            inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinInf+                            prettyTCM inf]+        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"+        InDefOf d    -> pwords "in the definition of" ++ [prettyTCM d]++      adjustLeftOfArrow :: OccursWhere -> OccursWhere+      adjustLeftOfArrow (OccursWhere r cs os) =+        OccursWhere r (DS.filter (not . isArrow) cs) $+          noArrows+            DS.><+          case DS.viewl startsWithArrow of+            DS.EmptyL  -> DS.empty+            w DS.:< ws -> w DS.<| DS.filter (not . isArrow) ws+        where+        (noArrows, startsWithArrow) = DS.breakl isArrow os++        isArrow LeftOfArrow{} = True+        isArrow _             = False
src/full/Agda/TypeChecking/Positivity/Occurrence.hs view
@@ -1,66 +1,88 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Occurrences.  module Agda.TypeChecking.Positivity.Occurrence-  ( Occurrence(..)+  ( PragmaPolarities+  , Occurrence(..)   , OccursWhere(..)   , Where(..)   , boundToEverySome   , productOfEdgesInBoundedWalk+  , modalPolarityToOccurrence   ) where -import Control.Applicative+import Prelude hiding (null)+ import Control.DeepSeq import Control.Monad-import Data.Either-import Data.Maybe-import Data.Typeable (Typeable)++import Data.Foldable (toList)+ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import qualified Data.Sequence as DS+import Data.Sequence (Seq) +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.List+import Agda.Utils.List1 (List1) import Agda.Utils.Null import Agda.Utils.SemiRing+import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible  -- Specification of occurrences -------------------------------------------  -- 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-  = Unknown-    -- ^ an unknown position (treated as negative)-  | Known Range (DS.Seq Where)-    -- ^ The elements of the sequence, from left to right, explain how-    -- to get to the occurrence.-  deriving (Show, Eq, Ord)+  = OccursWhere Range (Seq Where) (Seq Where)+    -- ^ The elements of the sequences, read from left to right,+    -- explain how to get to the occurrence. The second sequence+    -- 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, 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-  | InDefOf QName    -- ^ in the definition of a constant-  deriving (Show, Eq, Ord)+  | 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+ -- | Subterm occurrences for positivity checking. --   The constructors are listed in increasing information they provide: --   @Mixed <= JustPos <= StrictPos <= GuardPos <= Unused@@@ -72,8 +94,42 @@   | StrictPos -- ^ Strictly positive occurrence.   | GuardPos  -- ^ Guarded strictly positive occurrence (i.e., under ∞).  For checking recursive records.   | Unused    --  ^ No occurrence.-  deriving (Typeable, Show, Eq, Ord, Enum, Bounded)+  deriving (Show, Eq, Ord, Enum, Bounded) +-- Pretty instances.++instance Pretty Occurrence where+  pretty = text . \case+    Unused    -> "_"+    Mixed     -> "*"+    JustNeg   -> "-"+    JustPos   -> "+"+    StrictPos -> "++"+    GuardPos  -> "g+"++instance Pretty Where where+  pretty = \case+    LeftOfArrow  -> "LeftOfArrow"+    DefArg q i   -> "DefArg"     <+> pretty q <+> pretty i+    UnderInf     -> "UnderInf"+    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"+    InDefOf q    -> "InDefOf"    <+> pretty q++instance Pretty OccursWhere where+  pretty = \case+    OccursWhere _r ws1 ws2 ->+      "OccursWhere _" <+> pretty (toList ws1) <+> pretty (toList ws2)++-- Other instances for 'Occurrence'.+ instance NFData Occurrence where rnf x = seq x ()  instance KillRange Occurrence where@@ -129,14 +185,23 @@ instance Null Occurrence where   empty = Unused --- | The map contains bindings of the form @bound |-> es@, satisfying+-- Other instances for 'OccursWhere'.++-- There is an orphan PrettyTCM instance for Seq OccursWhere in+-- Agda.TypeChecking.Positivity.++instance Sized OccursWhere where+  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@, -- @'foldr1' 'otimes' w '<=' bound@ iff -- @'or' [ 'all' every w '&&' 'any' some w | (every, some) <- ess ]@.  boundToEverySome ::   Map Occurrence [(Occurrence -> Bool, Occurrence -> Bool)]-boundToEverySome = Map.fromList+boundToEverySome = Map.fromListWith __IMPOSSIBLE__   [ ( JustPos     , [((/= Unused), (`elem` [Mixed, JustNeg, JustPos]))]     )@@ -150,28 +215,39 @@     )   ] --- | @productOfEdgesInBoundedWalk occ g u v bound@ returns @'Just' e@--- iff there is a walk @c@ (a list of edges) in @g@, from @u@ to @v@,--- for which the product @'foldr1' 'otimes' ('map' occ c) '<=' bound@.--- In this case the returned value @e@ is the product @'foldr1'--- 'otimes' c@ for one such walk.+-- | @productOfEdgesInBoundedWalk occ g u v bound@ returns a value+-- distinct from 'Nothing' iff there is a walk @c@ (a list of edges)+-- in @g@, from @u@ to @v@, for which the product @'foldr1' 'otimes'+-- ('map' occ c) '<=' bound@. In this case the returned value is+-- @'Just' ('foldr1' 'otimes' c)@ for one such walk @c@. -- -- Preconditions: @u@ and @v@ must belong to @g@, and @bound@ must -- belong to the domain of @boundToEverySome@.  -- There is a property for this function in--- Agda.Utils.Graph.AdjacencyMap.Unidirectional.Tests.+-- Internal.Utils.Graph.AdjacencyMap.Unidirectional.  productOfEdgesInBoundedWalk ::   (SemiRing e, Ord n) =>-  (e -> Occurrence) -> Graph n n e -> n -> n -> Occurrence -> Maybe e+  (e -> Occurrence) -> Graph n e -> n -> n -> Occurrence -> Maybe e productOfEdgesInBoundedWalk occ g u v bound =   case Map.lookup bound boundToEverySome of     Nothing  -> __IMPOSSIBLE__     Just ess ->-      case msum [ Graph.walkSatisfying (every . occ) (some . occ) g u v+      case msum [ Graph.walkSatisfying+                    (every . occ . Graph.label)+                    (some . occ . Graph.label)+                    g u v                 | (every, some) <- ess                 ] of         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,58 +1,67 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE UndecidableInstances #-}---- To define <>, we will probably need to add:---import Prelude hiding ((<>))--- but using that now gives warnings and doesn't silence -Wsemigroup-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-semigroup    #-}-#endif-#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif---module Agda.TypeChecking.Pretty where+-- Each function here should either have an INLINE or a SPECIALIZE pragma.+--+module Agda.TypeChecking.Pretty+    ( module Agda.TypeChecking.Pretty+    , module Reexport+    ) where -import Prelude hiding (null)+import Prelude hiding ( null ) -import Control.Applicative hiding (empty)+import Control.Applicative  (liftA2) import Control.Monad+import Control.Monad.Except +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.Semigroup (Semigroup((<>)))+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 import Agda.Syntax.Translation.InternalToAbstract import Agda.Syntax.Translation.ReflectedToAbstract import Agda.Syntax.Translation.AbstractToConcrete+import qualified Agda.Syntax.Translation.AbstractToConcrete as Reexport (MonadAbsToCon) import qualified Agda.Syntax.Translation.ReflectedToAbstract as R-import qualified Agda.Syntax.Reflected as R import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Reflected as R import qualified Agda.Syntax.Abstract.Pretty as AP import Agda.Syntax.Concrete.Pretty (bracesAndSemicolons) import qualified Agda.Syntax.Concrete.Pretty as CP 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.Monad.Builtin (equalityUnview) 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 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 ) -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -61,424 +70,520 @@  type Doc = P.Doc -comma, colon, equals :: TCM Doc-comma  = return P.comma-colon  = return P.colon-equals = return P.equals--pretty :: P.Pretty a => a -> TCM Doc-pretty x = return $ P.pretty x+comma, colon, equals :: Applicative m => m Doc+comma  = pure P.comma        ; {-# INLINE comma  #-}+colon  = pure P.colon        ; {-# INLINE colon  #-}+equals = pure P.equals       ; {-# INLINE equals #-} -prettyA :: (P.Pretty c, ToConcrete a c) => a -> TCM Doc-prettyA x = AP.prettyA x+{-# INLINE pretty #-}+pretty :: (Applicative m, P.Pretty a) => a -> m Doc+pretty = pure . P.pretty -prettyAs :: (P.Pretty c, ToConcrete a [c]) => a -> TCM Doc-prettyAs x = AP.prettyAs x+{-# INLINE prettyA #-}+prettyA :: (ToConcrete a, P.Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc+prettyA = AP.prettyA -text :: String -> TCM Doc-text s = return $ P.text s+{-# 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 = AP.prettyAs -multiLineText :: String -> TCM Doc-multiLineText s = return $ 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 #-} -pwords :: String -> [TCM Doc]-pwords s = map return $ P.pwords s+{-# INLINE pwords #-}+pwords :: Applicative m => String -> [m Doc]+pwords = map pure . P.pwords -fwords :: String -> TCM Doc-fwords s = return $ 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 :: [TCM Doc] -> TCM Doc-sep ds  = P.sep <$> sequence ds-fsep ds = P.fsep <$> sequence ds-hsep ds = P.hsep <$> sequence ds-hcat ds = P.hcat <$> sequence ds-vcat ds = P.vcat <$> sequence ds+{-# INLINE sequenceAFoldable #-}+-- | @sequenceAFoldable == sequenceA . Fold.toList@+sequenceAFoldable :: (Applicative m, Foldable t) => t (m a) -> m [a]+sequenceAFoldable = Fold.foldr (liftA2 (:)) (pure []) -hang :: TCM Doc -> Int -> TCM Doc -> TCM Doc+{-# INLINE hang #-}+hang :: Applicative m => m Doc -> Int -> m Doc -> m Doc hang p n q = P.hang <$> p <*> pure n <*> q -($$), ($+$), (<>), (<+>) :: TCM Doc -> TCM Doc -> TCM Doc-d1 $$ d2  = (P.$$) <$> d1 <*> d2-d1 $+$ d2 = (P.$+$) <$> d1 <*> d2-d1 <> d2  = (P.<>) <$> d1 <*> d2-d1 <+> d2 = (P.<+>) <$> d1 <*> d2+infixl 6 <+>, <?>+infixl 5 $$, $+$ -nest :: Int -> TCM Doc -> TCM Doc-nest n d   = P.nest n <$> d+($$), ($+$), (<+>), (<?>) :: Applicative m => m Doc -> m Doc -> m Doc+($$ ) = liftA2 (P.$$)   ; {-# INLINE ($$)  #-}+($+$) = liftA2 (P.$+$)  ; {-# INLINE ($+$) #-}+(<+>) = liftA2 (P.<+>)  ; {-# INLINE (<+>) #-}+(<?>) = liftA2 (P.<?>)  ; {-# INLINE (<?>) #-} -braces, dbraces, brackets, parens :: TCM Doc -> TCM Doc-braces d   = P.braces <$> d-dbraces d  = CP.dbraces <$> d-brackets d = P.brackets <$> d-parens d   = P.parens <$> d+nest :: Functor m => Int -> m Doc -> m Doc+nest = fmap . P.nest    ; {-# INLINE nest  #-} +braces, dbraces, brackets, parens, parensNonEmpty+  , doubleQuotes, quotes :: Functor m => m Doc -> m Doc+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                 ; {-# INLINE pshow          #-}++pluralS :: (Functor m, Sized a) => a -> m Doc -> m Doc+pluralS = fmap . P.pluralS             ; {-# INLINE pluralS        #-}+ -- | Comma-separated list in brackets.-prettyList :: [TCM Doc] -> TCM Doc-prettyList ds = brackets $ fsep $ punctuate comma ds+{-# INLINE prettyList #-}+prettyList :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+prettyList = fmap P.pretty . sequenceAFoldable  -- | 'prettyList' without the brackets.-prettyList_ :: [TCM Doc] -> TCM Doc-prettyList_ ds = fsep $ punctuate comma ds+{-# 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_ = fsep . punctuate comma -punctuate :: TCM Doc -> [TCM Doc] -> [TCM Doc]-punctuate _ [] = []-punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty])+{-# 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   = []+  | otherwise = zipWith (<>) ds (replicate n d ++ [pure empty])   where-    n = length ds - 1+    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 = 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 (<>) ; {-# INLINE (<>) #-}+ class PrettyTCM a where-  prettyTCM :: a -> TCM Doc+  prettyTCM :: MonadPretty m => a -> m Doc -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 Interval where prettyTCM = pretty--- instance PrettyTCM Position where prettyTCM = pretty+-- | Pretty print with a given context precedence+prettyTCMCtx :: (PrettyTCM a, MonadPretty m) => Precedence -> a -> m Doc+prettyTCMCtx p = withContextPrecedence p . prettyTCM +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 #-} -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM [a] where-#else-instance PrettyTCM a => PrettyTCM [a] where-#endif   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+{-# SPECIALIZE prettyTCM :: (PrettyTCM a, PrettyTCM b, PrettyTCM c) => (a, b, c) -> TCM Doc #-} -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 Permutation  where prettyTCM = text . show-instance PrettyTCM Polarity     where prettyTCM = text . show-instance PrettyTCM R.Term       where prettyTCM = prettyA <=< toAbstractWithoutImplicit+instance PrettyTCM a => PrettyTCM (MaybeReduced a) where+  prettyTCM = prettyTCM . ignoreReduced+{-# SPECIALIZE prettyTCM :: PrettyTCM a => MaybeReduced a -> TCM Doc #-} -instance (Show a, PrettyTCM a, Subst a a) => PrettyTCM (Substitution' a) where-  prettyTCM IdS        = text "idS"-  prettyTCM (Wk m IdS) = text "wkS" <+> pretty m-  prettyTCM EmptyS     = text "emptyS"+instance (Pretty a, PrettyTCM a, EndoSubst a) => PrettyTCM (Substitution' a) where+  prettyTCM IdS        = "idS"+  prettyTCM (Wk m IdS) = "wkS" <+> pretty m+  prettyTCM (EmptyS _) = "emptyS"   prettyTCM rho = prettyTCM u <+> comma <+> prettyTCM rho1     where       (rho1, rho2) = splitS 1 rho       u            = lookupS rho2 0--instance PrettyTCM ModuleParameters where-  prettyTCM = prettyTCM . mpSubstitution+{-# SPECIALIZE prettyTCM :: (Pretty a, PrettyTCM a, EndoSubst a) => Substitution' a -> TCM Doc #-}  instance PrettyTCM Clause where   prettyTCM cl = do-    x <- qualify_ <$> freshName_ "<unnamedclause>"+    x <- qualify_ <$> freshName_ ("<unnamedclause>" :: String)     prettyTCM (QNamed x cl)+{-# SPECIALIZE prettyTCM :: Clause -> TCM Doc #-}  instance PrettyTCM a => PrettyTCM (Judgement a) where-  prettyTCM (HasType a t) = prettyTCM a <+> text ":" <+> prettyTCM t-  prettyTCM (IsSort  a t) = text "Sort" <+> prettyTCM a <+> text ":" <+> prettyTCM t+  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) = text "[" <+> prettyTCM a <+> text "]" <> text (show x)+  prettyTCM (Blocked x a) = ("[" <+> prettyTCM a <+> "]") <> text (P.prettyShow x)   prettyTCM (NotBlocked _ x) = prettyTCM x--instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Named_ a) where-  prettyTCM x = prettyA =<< reify x--instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Arg a) where-  prettyTCM x = prettyA =<< reify x--instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Dom a) where-  prettyTCM x = prettyA =<< reify x+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Blocked a -> TCM Doc #-}  instance (PrettyTCM k, PrettyTCM v) => PrettyTCM (Map k v) where-  prettyTCM m = text "Map" <> braces (sep $ punctuate comma-    [ hang (prettyTCM k <+> text "=") 2 (prettyTCM v) | (k, v) <- Map.toList m ])+  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  #-} -#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} PrettyTCM ArgName where-#else-instance PrettyTCM ArgName where-#endif-  prettyTCM = text . show+-- instance {-# OVERLAPPING #-} PrettyTCM ArgName where+--   prettyTCM = text . P.prettyShow  -- instance (Reify a e, ToConcrete e c, P.Pretty c, PrettyTCM a) => PrettyTCM (Elim' a) where instance PrettyTCM Elim where-  prettyTCM (Apply v) = text "$" <+> prettyTCM v-  prettyTCM (Proj _ f)= text "." <> 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+  prettyTCM (IApply x y v) = "I$" <+> prettyTCM v+  prettyTCM (Apply v) = "$" <+> prettyTCM v+  prettyTCM (Proj _ f)= "." <> prettyTCM f+{-# SPECIALIZE prettyTCM :: Elim -> TCM Doc #-} -instance PrettyTCM A.TypedBinding where-  prettyTCM = prettyA+deriving instance (PrettyTCM x, PrettyTCM a) => PrettyTCM (Boundary' x a) -instance PrettyTCM Relevance where-  prettyTCM Irrelevant = text "."-  prettyTCM NonStrict  = text ".."-  prettyTCM Relevant   = empty-  prettyTCM Forced{}   = empty-  prettyTCM UnusedArg  = empty+instance PrettyTCM Modality where+  prettyTCM mod = hsep+    [ prettyTCM (getQuantity mod)+    , prettyTCM (getRelevance mod)+    , prettyTCM (getModalPolarity mod)+    ]+{-# SPECIALIZE prettyTCM :: Modality -> TCM Doc #-} -instance PrettyTCM ProblemConstraint where-  prettyTCM (PConstr []   c) = prettyTCM c-  prettyTCM (PConstr pids c) = prettyList (map prettyTCM pids) <+> prettyTCM c+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 Constraint where-    prettyTCM c = case c of-        ValueCmp cmp ty s t ->-            sep [ sep [ prettyTCM s-                      , prettyTCM cmp <+> prettyTCM t-                      ]-                , nest 2 $ text ":" <+> prettyTCM ty-                ]-        ElimCmp cmps t v us vs ->-          sep [ sep [ prettyTCM us-                    , nest 2 $ text "~~" <+> prettyTCM vs-                    ]-              , text ":" <+> prettyTCM t ]-        LevelCmp cmp a b ->-            sep [ prettyTCM a-                , prettyTCM cmp <+> prettyTCM b-                ]-        TypeCmp cmp a b ->-            sep [ prettyTCM a-                , prettyTCM cmp <+> prettyTCM b-                ]-        TelCmp a b cmp tela telb ->-            sep [ prettyTCM tela-                , prettyTCM cmp <+> prettyTCM telb-                ]-        SortCmp cmp s1 s2 ->-            sep [ prettyTCM s1-                , prettyTCM cmp <+> prettyTCM s2-                ]-        Guarded c pid ->-            sep [ prettyTCM c-                , nest 2 $ brackets $ text "blocked on problem" <+> prettyTCM pid-                ]-        UnBlock m   -> do-            -- BlockedConst t <- mvInstantiation <$> lookupMeta m-            mi <- mvInstantiation <$> lookupMeta m-            case mi of-              BlockedConst t ->-                sep [ pretty m <+> text ":="-                    , nest 2 $ prettyTCM t-                    ]-              PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \p ->-                sep [ pretty m <+> text ":="-                    , nest 2 $ prettyTCM p ]-              Open{}  -> __IMPOSSIBLE__-              OpenIFS{}  -> __IMPOSSIBLE__-              InstV{} -> __IMPOSSIBLE__-        FindInScope m mb mcands -> do-            t <- getMetaType m-            sep [ hang (text "Resolve instance argument" <+> blk) 2 $-                  hang (pretty m <+> text ":") 2 $ prettyTCM t-                , cands-                ]-          where-            blk = case mb of-                    Nothing -> empty-                    Just b  -> parens $ text "blocked on" <+> pretty b-            cands =-              case mcands of-                Nothing -> text "No candidates yet"-                Just cnds ->-                  hang (text "Candidates") 2 $-                    vcat [ hang (overlap c <+> prettyTCM (candidateTerm c) <+> text ":") 2 $-                            prettyTCM (candidateType c) | c <- cnds ]-              where overlap c | candidateOverlappable c = text "overlap"-                              | otherwise               = empty-        IsEmpty r t ->-            sep [ text "Is empty:", nest 2 $ prettyTCM t ]-        CheckSizeLtSat t ->-            sep [ text "Is not empty type of sizes:", nest 2 $ prettyTCM t ]+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 e a) =-    sep [ prettyA e <+> text ":?", prettyTCM a ]-  prettyTCM (CheckArgs _ _ es t0 t1 _) =-    sep [ parens $ text "_ :" <+> prettyTCM t0+  prettyTCM (CheckExpr cmp e a) =+    sep [ prettyA e <+> ":?", prettyTCM a ]+  prettyTCM (CheckArgs _ _ _ es t0 t1 _) =+    sep [ parens $ "_ :" <+> prettyTCM t0         , nest 2 $ prettyList $ map prettyA es-        , nest 2 $ text ":?" <+> prettyTCM t1 ]-  prettyTCM (CheckLambda (Arg ai (xs, mt)) e t) =-    sep [ return CP.lambda <+>-          (CP.prettyRelevance ai .-           CP.prettyHiding ai (if isNothing mt && length xs == 1 then id+        , nest 2 $ ":?" <+> prettyTCM t1 ]+  prettyTCM (CheckProjAppToKnownPrincipalArg cmp e _ _ _ _ t _ _ _ _) = prettyTCM (CheckExpr cmp e t)+  prettyTCM (CheckLambda cmp (Arg ai (xs, mt)) e t) =+    sep [ pure CP.lambda <+>+          (prettyRelevance ai .+           prettyHiding ai (if isNothing mt && natSize xs == 1 then id                                else P.parens) <$> do             fsep $-              map prettyTCM xs ++-              caseMaybe mt [] (\ a -> [text ":", prettyTCM a])) <+>-          return CP.arrow <+>+              map prettyTCM (List1.toList xs) +++              caseMaybe mt [] (\ a -> [":", prettyTCM a])) <+>+          pure CP.arrow <+>           prettyTCM e <+>-          text ":?"+          ":?"         , prettyTCM t         ]-  prettyTCM (UnquoteTactic v _ _) = do+  prettyTCM (DoQuoteTerm _ v _) = do     e <- reify v-    let noInfo = A.exprNoRange-    prettyTCM (A.App noInfo (A.Unquote noInfo) (defaultNamedArg e))+    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 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 . concat)-    )+  prettyTCM tel = P.fsep . map P.pretty <$> do+      abstractToConcreteTelescope =<< reify tel+{-# SPECIALIZE prettyTCM :: Telescope -> TCM Doc #-}  newtype PrettyContext = PrettyContext Context  instance PrettyTCM PrettyContext where-  prettyTCM (PrettyContext ctx) = prettyTCM $ telFromList' nameToArgName $ map ctxEntry $ reverse ctx--instance PrettyTCM Context where-  prettyTCM = prettyTCM . PrettyContext--instance PrettyTCM CtxId where-  prettyTCM (CtxId x) = prettyTCM x--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 (VarP x)      = prettyTCM x-  prettyTCM (DotP t)      = text ".(" <> prettyTCM t <> text ")"-  prettyTCM (ConP c i ps) = (if b then braces else parens) $ prTy $+  prettyTCM :: forall m. MonadPretty m => Pattern' a -> m Doc+  prettyTCM (IApplyP _ _ _ x)    = prettyTCM x+  prettyTCM (VarP _ x)    = prettyTCM x+  prettyTCM (DotP _ t)    = ".(" <> prettyTCM t <> ")"+  prettyTCM (DefP o q ps) = parens $+        prettyTCM q <+> fsep (map (prettyTCM . namedArg) ps)+  prettyTCM (ConP c i ps) = -- (if b then braces else parens) $ prTy $+        parens $         prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)-        where-        b = maybe False (/= ConOCon) $ conPRecord i-        showRec :: TCM Doc+      where+        -- NONE OF THESE BINDINGS IS USED AT THE MOMENT:+        b = conPRecord i && patOrigin (conPInfo i) /= PatOCon+        showRec :: m Doc -- Defined, but currently not used         showRec = sep-          [ text "record"+          [ "record"           , bracesAndSemicolons <$> zipWithM showField (conFields c) ps           ]-        showField x p =-          sep [ prettyTCM (A.qnameName x) <+> text "=" , nest 2 $ prettyTCM $ namedArg p ]+        showField :: Arg QName -> NamedArg (Pattern' a) -> m Doc -- NB:: Defined but not used+        showField (Arg ai x) p =+          sep [ prettyTCM (A.qnameName x) <+> "=" , nest 2 $ prettyTCM $ namedArg p ]+        showCon :: m Doc -- NB:: Defined but not used         showCon = parens $ prTy $ prettyTCM c <+> fsep (map (prettyTCM . namedArg) ps)-        prTy d = d -- caseMaybe (conPType i) d $ \ t -> d  <+> text ":" <+> prettyTCM t-  prettyTCM (LitP l)      = text (show l)-  prettyTCM (ProjP _ q)   = text ("." ++ show q)+        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:-prettyTCMPatternList :: [NamedArg DeBruijnPattern] -> TCM Doc-prettyTCMPatternList = prettyList . map prettyA <=< reifyPatterns+prettyTCMPatterns :: MonadPretty m => [NamedArg DeBruijnPattern] -> m [Doc]+prettyTCMPatterns = mapM prettyA <=< reifyPatterns -instance PrettyTCM (Elim' DisplayTerm) where-  prettyTCM (Apply v) = text "$" <+> prettyTCM (unArg v)-  prettyTCM (Proj _ f)= text "." <> prettyTCM f+{-# SPECIALIZE prettyTCMPatternList :: [NamedArg DeBruijnPattern] -> TCM Doc #-}+prettyTCMPatternList :: MonadPretty m => [NamedArg DeBruijnPattern] -> m Doc+prettyTCMPatternList = prettyList . map prettyA <=< reifyPatterns -raisePatVars :: Int -> NLPat -> NLPat-raisePatVars k (PVar id x bvs) = PVar id (k+x) bvs-raisePatVars k (PWild)     = PWild-raisePatVars k (PDef f es) = PDef f $ (fmap . fmap) (raisePatVars k) es-raisePatVars k (PLam i u)  = PLam i $ fmap (raisePatVars k) u-raisePatVars k (PPi a b)   =-  PPi (fmap (raisePatVarsInType k) a) (fmap (raisePatVarsInType k) b)-raisePatVars k (PBoundVar i es) = PBoundVar i $ (fmap . fmap) (raisePatVars k) es-raisePatVars k (PTerm t)   = PTerm t+-- | 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 -raisePatVarsInType :: Int -> NLPType -> NLPType-raisePatVarsInType k (NLPType l a) =-  NLPType (raisePatVars k l) (raisePatVars k a)+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 id x bvs) = prettyTCM (Var x (map (Apply . fmap var) bvs))-  prettyTCM (PWild)     = text $ "_"+  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 (raisePatVars 1 $ absBody u))-  prettyTCM (PPi a b)   = parens $-    text ("(" ++ absName b ++ " :") <+> prettyTCM (unDom a) <> text ") →" <+>-    (addContext (absName b) $ prettyTCM (raisePatVarsInType 1 $ 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)   = text "." <> parens (prettyTCM t)+  prettyTCM (PTerm t)   = "." <> parens (prettyTCM t)+{-# SPECIALIZE prettyTCM :: NLPat -> TCM Doc #-}  instance PrettyTCM NLPType where-  prettyTCM (NLPType PWild a) = prettyTCM a-  prettyTCM (NLPType l     a) = text "{" <> prettyTCM l <> text "}" <> prettyTCM a+  prettyTCM (NLPType s a) = prettyTCM a+{-# SPECIALIZE prettyTCM :: NLPType -> TCM Doc #-} +instance PrettyTCM NLPSort where+  prettyTCM = \case+    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 (Apply v) = prettyTCM (unArg v)-  prettyTCM (Proj _ f)= text "." <> prettyTCM f+  prettyTCM (IApply x y v) = prettyTCM 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) = fsep+  prettyTCM (RewriteRule q gamma f ps rhs b _c _top) = fsep     [ prettyTCM q-    , prettyTCM gamma <+> text " |- "+    , prettyTCM gamma <+> " |- "     , addContext gamma $ sep       [ prettyTCM (PDef f ps)-      , text " --> "+      , " --> "       , prettyTCM rhs-      , text " : "+      , " : "       , prettyTCM b       ]     ]+{-# SPECIALIZE prettyTCM :: RewriteRule -> TCM Doc #-}  instance PrettyTCM Occurrence where-  prettyTCM GuardPos  = text "-[g+]->"-  prettyTCM StrictPos = text "-[++]->"-  prettyTCM JustPos   = text "-[+]->"-  prettyTCM JustNeg   = text "-[-]->"-  prettyTCM Mixed     = text "-[*]->"-  prettyTCM Unused    = text "-[ ]->"+  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 -instance PrettyTCM n => PrettyTCM (WithNode n Occurrence) where-  prettyTCM (WithNode n o) = prettyTCM o <+> prettyTCM n+-- | Pretty-print something paired with a (printable) node.+-- | This intermediate typeclass exists to avoid UndecidableInstances.+class PrettyTCMWithNode a where+  prettyTCMWithNode :: (PrettyTCM n, MonadPretty m) => WithNode n a -> m Doc -instance (PrettyTCM n, PrettyTCM (WithNode n e)) => PrettyTCM (Graph n n e) where+instance PrettyTCMWithNode Occurrence where+  prettyTCMWithNode (WithNode n o) = prettyTCM o <+> prettyTCM n++instance (PrettyTCM n, PrettyTCMWithNode e) => PrettyTCM (Graph n e) where   prettyTCM g = vcat $ map pr $ Map.assocs $ Graph.graph g     where       pr (n, es) = sep         [ prettyTCM n-        , nest 2 $ vcat $ map (prettyTCM . uncurry WithNode) $ Map.assocs es+        , 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,30 +1,66 @@-{-# LANGUAGE FlexibleInstances #-}- module Agda.TypeChecking.Pretty where --- import Agda.Syntax.Common+import Data.String (IsString)+import Data.Semigroup (Semigroup)++import Agda.Syntax.Common (NameId) import Agda.Syntax.Internal--- import Agda.Syntax.Literal -import Agda.TypeChecking.Monad-import Agda.Utils.Pretty (Doc)--- import qualified Agda.Utils.Pretty as P+import Agda.TypeChecking.Monad.Base+import {-# SOURCE #-} Agda.TypeChecking.Monad.MetaVars (MonadInteractionPoints)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Pure (PureTCM) -text                  :: String             -> TCM Doc-sep, fsep, hsep, vcat :: [TCM Doc]          -> TCM Doc-($$), (<>), (<+>)     :: TCM Doc -> TCM Doc -> TCM Doc+import Agda.Utils.Null (Null)+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+($$), (<+>), (<?>)    :: Applicative m => m Doc -> m Doc -> m Doc+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++-- The definition of MonadAbsToCon is inlined so that the module+-- Agda.Syntax.Translation.AbstractToConcrete does not need to be+-- imported.+type MonadPretty m =+  ( MonadFresh NameId m+  , MonadInteractionPoints m+  , MonadStConcreteNames m+  , HasOptions m+  , PureTCM m+  , IsString (m Doc)+  , Null (m Doc)+  , Semigroup (m Doc)+  )++-- 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)+ class PrettyTCM a where-    prettyTCM :: a -> TCM Doc+  prettyTCM :: MonadPretty m => a -> m Doc +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 instance PrettyTCM Sort instance PrettyTCM DisplayTerm instance PrettyTCM DBPatVar+instance PrettyTCM PrettyContext
+ src/full/Agda/TypeChecking/Pretty/Call.hs view
@@ -0,0 +1,233 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Pretty.Call where++import Prelude hiding ( null )++import Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Views+import Agda.Syntax.Common+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.Null++import Agda.Utils.Impossible++import Agda.Version (docsUrl)++sayWhere :: MonadPretty m => HasRange a => a -> m Doc -> m Doc+sayWhere x d = prettyTCM (getRange x) $$ d++instance PrettyTCM CallInfo where+  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++    CheckClause t cl -> do++      verboseS  "error.checkclause" 40 $ do+        reportSLn "error.checkclause" 60 $ "prettyTCM CheckClause: cl = " ++ show (deepUnscope cl)+        clc <- abstractToConcrete_ cl+        reportSLn "error.checkclause" 40 $ "cl (Concrete) = " ++ show clc++      fsep $+        pwords "when checking that the clause"+        ++ [prettyA cl] ++ pwords "has type" ++ [prettyTCM t]++    CheckLHS lhs -> vcat $+      [ fsep $ pwords "when checking the clause left hand side"+      , prettyA $ lhs { A.spLhsInfo = (A.spLhsInfo lhs) { A.lhsEllipsis = NoEllipsis } }+      ]++    CheckPattern p tel t -> addContext tel $ fsep $+      pwords "when checking that the pattern"+      ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]++    CheckPatternLinearityType x -> fsep $+      pwords "when checking that all occurrences of pattern variable"+      ++ [pretty x] ++ pwords "have the same type"++    CheckPatternLinearityValue x -> fsep $+      pwords "when checking that all occurrences of pattern variable"+      ++ [pretty x] ++ pwords "have the same value"++    CheckLetBinding b -> fsep $+      pwords "when checking the let binding" ++ [prettyA b]++    InferExpr e -> fsep $ pwords "when inferring the type of" ++ [prettyA e]++    CheckExprCall cmp e t -> fsep $+      pwords "when checking that the expression"+      ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]++    IsTypeCall cmp e s -> fsep $+      pwords "when checking that the expression"+      ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]++    IsType_ e -> fsep $+      pwords "when checking that the expression"+      ++ [prettyA e] ++ pwords "is a type"++    CheckProjection _ x t -> fsep $+      pwords "when checking the projection" +++      [ sep [ prettyTCM x <+> ":"+            , nest 2 $ prettyTCM t ] ]++    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] +++      pwords "of metavariable" ++ [prettyTCM m] +++      pwords "has the expected type" ++ [prettyTCM a]++    CheckTargetType r infTy expTy -> sep+      [ "when checking that the inferred type of an application"+      , nest 2 $ prettyTCM infTy+      , "matches the expected type"+      , nest 2 $ prettyTCM expTy ]++    CheckRecDef _ x ps cs ->+      fsep $ pwords "when checking the definition of" ++ [prettyTCM x]++    CheckDataDef _ x ps cs ->+      fsep $ pwords "when checking the definition of" ++ [prettyTCM x]++    CheckConstructor d _ _ (A.Axiom _ _ _ _ c _) -> fsep $+      pwords "when checking the constructor" ++ [prettyTCM c] +++      pwords "in the declaration of" ++ [prettyTCM d]++    CheckConstructor{} -> __IMPOSSIBLE__++    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]++    CheckPragma _ p ->+      fsep $ pwords "when checking the pragma"+             ++ [prettyA $ RangeAndPragma noRange p]++    CheckPrimitive _ x e -> fsep $+      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" +++      [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] +++      pwords "matches the inferred value" ++ [prettyTCM v]++    CheckNamedWhere m -> fsep $+      pwords "when checking the named where block" ++ [prettyA m]++    InferVar x ->+      fsep $ pwords "when inferring the type of" ++ [prettyTCM x]++    InferDef x ->+      fsep $ pwords "when inferring the type of" ++ [prettyTCM x]++    CheckIsEmpty r t ->+      fsep $ pwords "when checking that" ++ [prettyTCM t] +++             pwords "has no constructors"++    CheckConfluence r1 r2 ->+      fsep $ pwords "when checking confluence of the rewrite rule" +++             [prettyTCM r1] ++ pwords "with" +++             if r1 == r2 then pwords "itself" else [prettyTCM r2]++    ScopeCheckExpr e -> fsep $ pwords "when scope checking" ++ [pretty e]++    ScopeCheckDeclaration d ->+      fsep (pwords "when scope checking the" ++ [ pluralS ds "declaration" ]) $$+      nest 2 (vcat $ fmap pretty ds)+      where+      ds     = D.notSoNiceDeclarations d++    ScopeCheckLHS x p ->+      fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] +++             pwords "in the definition of" ++ [pretty x]++    NoHighlighting -> empty++    SetRange r -> fsep (pwords "when doing something at") <+> prettyTCM r++    CheckSectionApplication _ erased m1 modapp -> fsep $+      pwords "when checking the module application" +++      [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
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Pretty.Call where++import Agda.TypeChecking.Monad.Base+import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM)++instance PrettyTCM Call
+ src/full/Agda/TypeChecking/Pretty/Constraint.hs view
@@ -0,0 +1,184 @@++module Agda.TypeChecking.Pretty.Constraint where++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 (on)++import Control.Monad++import Agda.Syntax.Common+import Agda.Syntax.Position+import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Info     as A+import Agda.Syntax.Fixity+import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Errors+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Null+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+    r   = getRange c+    f :: MonadPretty m => m Doc -> m Doc+    f d = if null $ P.pretty r+          then d+          else d $$ nest 4 ("[ at" <+> prettyTCM r <+> "]")++{-# 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 = do+  cs' <- filterM interestingConstraint cs+  let+    isBlocked = not . null . allBlockingProblems . constraintUnblocker+    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'+++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)++  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+        ValueCmpOnFace cmp p ty s t ->+            sep [ prettyTCM p <+> "|"+                , prettyCmp (prettyTCM cmp) s t ]+            <?> (":" <+> prettyTCMCtx TopCtx ty)+        ElimCmp cmps fs t v us vs -> prettyCmp "~~" us vs   <?> (":" <+> prettyTCMCtx TopCtx t)+        LevelCmp cmp a b         -> prettyCmp (prettyTCM cmp) a b+        SortCmp cmp s1 s2        -> prettyCmp (prettyTCM cmp) s1 s2+        UnBlock m   -> do+            lookupMetaInstantiation m >>= \case+              BlockedConst t -> prettyCmp ":=" m t+              PostponedTypeCheckingProblem cl -> enterClosure cl $ \p ->+                prettyCmp ":=" m p+              OpenMeta{}  -> __IMPOSSIBLE__+              InstV{} -> empty+              -- Andreas, 2017-01-11, issue #2637:+              -- The size solver instantiates some metas with infinity+              -- without cleaning up the UnBlock constraints.+              -- Thus, this case is not IMPOSSIBLE.+              --+              -- InstV args t -> do+              --   reportS "impossible" 10+              --     [ "UnBlock meta " ++ show m ++ " surprisingly has InstV instantiation:"+              --     , 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+              ]+          where+            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 i q cs err -> do+            t <- defType <$> getConstInfo q+            vcat [ "Check definition of" <+> prettyTCM q <+> ":" <+> prettyTCM t+                 , nest 2 $ "stuck because" <?> prettyTCM err ]+        HasBiggerSort a -> "Has bigger sort:" <+> prettyTCM a+        HasPTSRule a b -> "Has PTS rule:" <+> case b of+          NoAbs _ b -> prettyTCM (a,b)+          Abs x b   -> "(" <> (prettyTCM a <+> "," <+> addContext x (prettyTCM b)) <> ")"+        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 <- lookupLocalMeta x+          case mvJudgement m of+            HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t+            IsSort{} -> prettyTCM x <+> "is a sort"+        CheckType t ->+          prettyTCM t <+> "is a well-formed type"+        CheckLockedVars t ty lk lk_ty -> do+          "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty+        UsableAtModality _ ms mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> prettyTCM t+          -- TODO: print @ms : Maybe Sort@ as well?++      where+        prettyCmp+          :: (PrettyTCM a, PrettyTCM b, MonadPretty m)+          => m Doc -> a -> b -> m Doc+        prettyCmp cmp x y = prettyTCMCtx TopCtx x <?> (cmp <+> prettyTCMCtx TopCtx y)
+ src/full/Agda/TypeChecking/Pretty/Constraint.hs-boot view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Pretty.Constraint where++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        :: MonadPretty m => ProblemConstraint -> m Bool++instance PrettyTCM ProblemConstraint
+ src/full/Agda/TypeChecking/Pretty/Warning.hs view
@@ -0,0 +1,887 @@++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, filterM, forM, (<=<) )++import Data.Char ( toLower )+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 Data.Set (Set)+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, enterClosure )+import Agda.TypeChecking.Positivity () --instance only+import Agda.TypeChecking.Pretty+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 {-# SOURCE #-} Agda.TypeChecking.MetaVars++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.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.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 _ _ doc _ _) = doc <$ do+    reportSLn "warning" 2 $ "Warning raised at " ++ prettyShow loc++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 $ fmap prettyTCM $ Set1.toAscList ms)++    UnsolvedInteractionMetas is ->+      fsep ( pwords "Unsolved interaction metas at the following locations:" )+      $$ 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 $ List1.toList cs+      if null pcs+        then fsep $ pwords "Unsolved constraints"  -- #4065: keep minimal warning text+        else vcat+          [ fsep $ pwords "Failed to solve the following constraints:"+          , nest 2 $ return $ P.vcat $ List.nub pcs+          ]++    TerminationIssue errs1 -> do+      dropTopLevel <- topLevelModuleDropper+      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 -> "Unreachable" <+> pluralS pss "clause"++    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" ++ [ pluralS cs "clause" ] +++            pwords "could not be preserved as definitional equalities in the translation to a case tree:"+           ) <|+      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]++    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 r | (r,x) <- List.sort rms ]+            , fsep $ pwords "Suggestion: add a `variable Any : Set _` and replace unsolved metas by Any"+            ]++    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 " ++ 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 $ Fold.toList xs+      ]++    UselessPatternDeclarationForRecord s -> fwords $ unwords+      [ "`pattern' attribute ignored for", s, "record" ]+      -- the @s@ is a qualifier like "eta" or "coinductive"++    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 "," $ fmap pretty xs+      ]++    UselessInline q -> fsep $+      pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] +++      pwords "to have a separate Haskell definition"++    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 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 $+      pwords "Instance arguments with explicit arguments are never considered by instance search," +++      pwords "so having an instance argument" ++ [return b] ++ pwords "has no effect."++    InversionDepthReached f -> do+      maxDepth <- maxInversionDepth+      fsep $ pwords "Refusing to invert pattern matching of" ++ [prettyTCM f] +++             pwords ("because the maximum depth (" ++ show maxDepth ++ ") has been reached.") +++             pwords "Most likely this means you have an unsatisfiable constraint, but it could" +++             pwords "also mean that you need to increase the maximum depth using the flag" +++             pwords "--inversion-max-depth=N"++    InvalidCharacterLiteral c -> fsep $+      pwords "Invalid character literal" ++ [text $ show c] +++      pwords "(surrogate code points are not supported)"++    UselessPragma _r d -> return d++    SafeFlagPostulate q -> fsep $+      pwords "Cannot postulate" ++ [prettyTCM q] ++ pwords "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.")++    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++    OptionWarning ow -> pretty ow++    ParseWarning pw -> pretty pw++    DeprecationWarning old new version -> fsep $+      [text old] ++ pwords "has been deprecated. Use" ++ [text new] ++ pwords+      "instead. This will be an error in Agda" ++ [text version <> "."]++    NicifierIssue w -> pretty w++    UserWarning str -> text (T.unpack str)++    ModuleDoesntExport m names modules xs -> vcat+      [ fsep $ pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:"+      , prettyNotInScopeNames False (suggestion names)   ys+      , prettyNotInScopeNames False (suggestion modules) ms+      ]+      where+      ys, ms :: [C.ImportedName]+      ys            = map ImportedName   ys0+      ms            = map ImportedModule ms0+      (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)++    FixityInRenamingModule _rs -> fsep $ pwords "Modules do not have fixity"++    LibraryWarning lw -> pretty lw++    InfectiveImport msg -> return msg++    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"+      , prettyTCM rhs1 , "and" , prettyTCM rhs2+      , "which are not equal because"+      , return err+      ]++    RewriteMaybeNonConfluent lhs1 lhs2 cs -> vcat $ concat+      [ [ fsep $ concat+          [ pwords "Couldn't determine overlap between left-hand sides"+          , [ prettyTCM lhs1 , text "and" , prettyTCM lhs2 ]+          , pwords "because of unsolved constraints:"+          ]+        ]+      , map (nest 2 . return) cs+      ]++    RewriteAmbiguousRules lhs rhs1 rhs2 -> vcat+      [ ( fsep $ concat+          [ pwords "Global confluence check failed:" , [prettyTCM lhs]+          , pwords "can be rewritten to either" , [prettyTCM rhs1]+          , pwords "or" , [prettyTCM rhs2 <> "."]+          ])+      , fsep $ concat+        [ pwords "Possible fix: add a rewrite rule with left-hand side"+        , [prettyTCM lhs] , pwords "to resolve the ambiguity."+        ]+      ]++    RewriteMissingRule u v rhou -> vcat+      [ fsep $ concat+        [ pwords "Global confluence check failed:" , [prettyTCM u]+        , pwords "unfolds to" , [prettyTCM v] , pwords "which should further unfold to"+        , [prettyTCM rhou] , pwords "but it does not."+        ]+      , fsep $ concat+        [ pwords "Possible fix: add a rule to rewrite"+        , [ prettyTCM v , "to" , prettyTCM rhou ]+        ]+      ]++    DuplicateRecordDirective dir ->+      "Ignoring duplicate record directive: " <+> pretty dir++    PragmaCompileErased bn qn -> fsep $ concat+      [ pwords "The backend"+      , [ prettyTCM bn+        , "erases"+        , prettyTCM qn+        ]+      , pwords "so the COMPILE pragma will be ignored."+      ]++    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) $ singleton x+      ]+      where+      suggestion inscope x = nest 2 $ par $ concat+        [ [ "did you forget space around the ':'?"  | ':' `elem` s ]+        , [ "did you forget space around the '->'?" | "->" `List.isInfixOf` s ]+        , maybeToList $ didYouMean inscope C.unqualify x+        ]+        where+        par []  = empty+        par [d] = parens d+        par ds  = parens $ vcat ds+        s = P.prettyShow x++    AsPatternShadowsConstructorOrPatternSynonym patsyn -> fsep $ concat+      [ 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+  W.DuplicateFields xrs    -> prettyDuplicateFields    $ fmap fst xrs+  W.TooManyFields q ys xrs -> prettyTooManyFields q ys $ fmap fst xrs++prettyDuplicateFields :: MonadPretty m => List1 C.Name -> m Doc+prettyDuplicateFields xs = fsep $ concat+    [ [ "Duplicate", pluralS xs "field" ]+    , punctuate comma (fmap pretty xs)+    , pwords "in record"+    ]++{-# 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 (fmap pretty xs)+    , if null missing then [] else concat+      [ pwords "but it would have the"+      , fields missing+      , punctuate comma (map pretty missing)+      ]+    ]+  where+    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)+  => Bool          -- ^ Print range?+  -> (a -> m Doc)  -- ^ Correction suggestion generator.+  -> [a]           -- ^ Names that are not in scope.+  -> m Doc+prettyNotInScopeNames printRange suggestion xs = nest 2 $ vcat $ map name xs+  where+  name x = fsep+    [ pretty x+    , if printRange then "at" <+> prettyTCM (getRange x) else empty+    , 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)+  => [C.QName]     -- ^ Names in scope.+  -> (a -> b)      -- ^ Canonization function for similarity search.+  -> a             -- ^ A name which is not in scope.+  -> Maybe (m Doc) -- ^ "did you mean" hint.+didYouMean inscope canon x+  | null ys   = Nothing+  | otherwise = Just $ sep+      [ "did you mean"+      , nest 2 (vcat $ punctuate " or" $+                 map (\ y -> text $ "'" ++ y ++ "'") ys)+        <> "?"+      ]+  where+  strip :: Pretty b => b -> String+  strip        = map toLower . filter (/= '_') . prettyShow+  -- dropModule x = fromMaybe x $ List.stripPrefix "module " x+  maxDist n    = div n 3+  close a b    = editDistance a b <= maxDist (length a)+  ys           = map prettyShow $ filter (close (strip $ canon x) . strip . C.unqualify) inscope+++prettyTCWarnings :: Set TCWarning -> TCM String+prettyTCWarnings = List.intercalate "\n" <.> map P.render <.> prettyTCWarnings'++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 :: Set TCWarning -> TCM [TCWarning]+filterTCWarnings wset = case Set.toAscList wset of+  -- #4065: Always keep the only warning+  [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  -> (`filterM` ws) $ \ w -> case tcWarning w of+    UnsolvedConstraints cs -> anyM interestingConstraint cs+    _ -> pure True+++-- | Turns warnings, if any, into errors.+tcWarningsToError :: [TCWarning] -> TCM ()+tcWarningsToError mws = case (unsolvedHoles, otherWarnings) of+   ([], [])                   -> return ()+   (_unsolvedHoles@(_:_), []) -> typeError SolvedButOpenHoles+   (_ , 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)+   (unsolvedHoles, otherWarnings) = List.partition (isUnsolvedIM . tcWarning) mws+   isUnsolvedIM UnsolvedInteractionMetas{} = True+   isUnsolvedIM _                          = False+++-- | Depending which flags are set, one may happily ignore some+-- warnings.++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); _ -> ([], 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++  -- filter out the warnings the flags told us to ignore+  let cleanUp w = let wName = warningName w in+        wName /= SafeFlagPragma_+        && wName `Set.member` warnSet++  return $ Set.union sfp $ Set.filter (cleanUp . tcWarning) ws++applyFlagsToTCWarnings :: HasOptions m => Set TCWarning -> m (Set TCWarning)+applyFlagsToTCWarnings = applyFlagsToTCWarningsPreserving Set.empty++{-# 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++  allCons <- getAllConstraints+  unsolvedConstraints  <- filterM (fmap isNothing . isBoundaryConstraint) allCons+  interactionBoundary  <- catMaybes <$> traverse isBoundaryConstraint allCons++  unsolvedMetas        <- getUnsolvedMetas++  mapM warning_ $ catMaybes+    [ 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.++{-# SPECIALIZE getAllWarnings :: WhichWarnings -> TCM (Set TCWarning) #-}+getAllWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning)+getAllWarnings = getAllWarningsPreserving Set.empty++{-# 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            <- Set.fromList <$> getAllUnsolvedWarnings+  collectedTCWarnings <- useTC stTCWarnings++  -- 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++  Set.filter (showWarn . tcWarning) <$> do+    applyFlagsToTCWarningsPreserving keptWarnings $+      unsolved `Set.union` collectedTCWarnings++getAllWarningsOfTCErr :: TCErr -> TCM (Set TCWarning)+getAllWarningsOfTCErr = \case+  TypeError _ tcst cls -> case clValue cls of+    NonFatalErrors{} -> return empty+    _ -> localTCState $ do+      putTC tcst+      -- We filter out the unsolved(Metas/Constraints) to stay+      -- true to the previous error messages.+      Set.filter (not . isUnsolvedWarning . tcWarning) <$> getAllWarnings AllWarnings+  _ -> return empty
+ src/full/Agda/TypeChecking/Pretty/Warning.hs-boot view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Pretty.Warning where++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,818 +1,987 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE UndecidableInstances       #-}--{-| Primitive functions, such as addition on builtin integers.--}-module Agda.TypeChecking.Primitive where--import Control.Monad-import Control.Applicative-import Control.Monad.Reader (asks)--import Data.Char-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Traversable (traverse)-import Data.Monoid (mempty)--import Numeric.IEEE ( IEEE(identicalIEEE) )--import Agda.Interaction.Options--import Agda.Syntax.Position-import Agda.Syntax.Common hiding (Nat)-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Generic (TermLike(..))-import Agda.Syntax.Literal-import Agda.Syntax.Concrete.Pretty ()-import Agda.Syntax.Fixity--import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)-import qualified Agda.TypeChecking.Monad as TCM-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Errors-import Agda.TypeChecking.Level-import Agda.TypeChecking.Quote (QuotingKit, quoteTermWithKit, quoteTypeWithKit, quoteClauseWithKit, quotingKit)-import Agda.TypeChecking.Pretty ()  -- instances only--import Agda.Utils.Monad-import Agda.Utils.Pretty (pretty)-import Agda.Utils.String ( Str(Str), unStr )-import Agda.Utils.Maybe--#include "undefined.h"-import Agda.Utils.Impossible-import Debug.Trace-------------------------------------------------------------------------------- * Primitive functions------------------------------------------------------------------------------data PrimitiveImpl = PrimImpl Type PrimFun---- Haskell type to Agda type--newtype Nat = Nat { unNat :: Integer }-            deriving (Eq, Ord, Num, Enum, Real)---- In GHC > 7.8 deriving Integral causes an unnecessary toInteger--- warning.-instance Integral Nat where-  toInteger = unNat-  quotRem (Nat a) (Nat b) = (Nat q, Nat r)-    where (q, r) = quotRem a b--instance TermLike Nat where-  traverseTerm  _ = id-  traverseTermM _ = pure-  foldTerm _      = mempty--instance Show Nat where-  show = show . toInteger--newtype Lvl = Lvl { unLvl :: Integer }-  deriving (Eq, Ord)--instance Show Lvl where-  show = show . unLvl--class PrimType a where-  primType :: a -> TCM Type--instance (PrimType a, PrimType b) => PrimTerm (a -> b) where-  primTerm _ = unEl <$> (primType (undefined :: a) --> primType (undefined :: b))--instance PrimTerm a => PrimType a where-  primType _ = el $ primTerm (undefined :: a)--class    PrimTerm a       where primTerm :: a -> TCM Term-instance PrimTerm Integer where primTerm _ = primInteger-instance PrimTerm Bool    where primTerm _ = primBool-instance PrimTerm Char    where primTerm _ = primChar-instance PrimTerm Double  where primTerm _ = primFloat-instance PrimTerm Str     where primTerm _ = primString-instance PrimTerm Nat     where primTerm _ = primNat-instance PrimTerm Lvl     where primTerm _ = primLevel-instance PrimTerm QName   where primTerm _ = primQName-instance PrimTerm MetaId  where primTerm _ = primAgdaMeta-instance PrimTerm Type    where primTerm _ = primAgdaTerm--instance PrimTerm Fixity' where primTerm _ = primFixity--instance PrimTerm a => PrimTerm [a] where-  primTerm _ = list (primTerm (undefined :: a))--instance PrimTerm a => PrimTerm (IO a) where-  primTerm _ = io (primTerm (undefined :: a))---- From Agda term to Haskell value--class ToTerm a where-  toTerm  :: TCM (a -> Term)-  toTermR :: TCM (a -> ReduceM Term)--  toTermR = (pure .) <$> toTerm--instance ToTerm Nat     where toTerm = return $ Lit . LitNat noRange . toInteger-instance ToTerm Lvl     where toTerm = return $ Level . Max . (:[]) . ClosedLevel . unLvl-instance ToTerm Double  where toTerm = return $ Lit . LitFloat noRange-instance ToTerm Char    where toTerm = return $ Lit . LitChar noRange-instance ToTerm Str     where toTerm = return $ Lit . LitString noRange . unStr-instance ToTerm QName   where toTerm = return $ Lit . LitQName noRange-instance ToTerm MetaId  where-  toTerm = do-    file <- fromMaybe __IMPOSSIBLE__ <$> asks TCM.envCurrentPath-    return $ Lit . LitMeta noRange file--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)]-    return fromInt--instance ToTerm Bool where-  toTerm = do-    true  <- primTrue-    false <- primFalse-    return $ \b -> if b then true else false--instance ToTerm Term where-  toTerm  = do kit <- quotingKit; runReduceF (quoteTermWithKit kit)-  toTermR = do kit <- quotingKit; return (quoteTermWithKit kit)--instance ToTerm Type where-  toTerm  = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit)-  toTermR = do kit <- quotingKit; return (quoteTypeWithKit kit)--instance ToTerm ArgInfo where-  toTerm = do-    info <- primArgArgInfo-    vis  <- primVisible-    hid  <- primHidden-    ins  <- primInstance-    rel  <- primRelevant-    irr  <- primIrrelevant-    return $ \ i -> info `applys`-      [ case getHiding i of-          NotHidden -> vis-          Hidden    -> hid-          Instance  -> ins-      , case getRelevance i of-          Relevant   -> rel-          Irrelevant -> irr-          NonStrict  -> rel-          Forced{}   -> irr-          UnusedArg  -> irr-      ]--instance ToTerm Fixity' where-  toTerm = (. theFixity) <$> toTerm--instance ToTerm Fixity where-  toTerm = do-    lToTm  <- toTerm-    aToTm  <- toTerm-    fixity <- primFixityFixity-    return $ \ Fixity{fixityAssoc = a, fixityLevel = l} ->-      fixity `apply` [defaultArg (aToTm a), defaultArg (lToTm l)]--instance ToTerm Associativity where-  toTerm = do-    lassoc <- primAssocLeft-    rassoc <- primAssocRight-    nassoc <- primAssocNon-    return $ \ a ->-      case a of-        NonAssoc   -> nassoc-        LeftAssoc  -> lassoc-        RightAssoc -> rassoc--instance ToTerm PrecedenceLevel where-  toTerm = do-    (iToTm :: Integer -> Term) <- toTerm-    related   <- primPrecRelated-    unrelated <- primPrecUnrelated-    return $ \ p ->-      case p of-        Unrelated -> unrelated-        Related n -> related `apply` [defaultArg $ iToTm n]---- | @buildList A ts@ builds a list of type @List A@. Assumes that the terms---   @ts@ all have type @A@.-buildList :: TCM ([Term] -> Term)-buildList = do-    nil'  <- primNil-    cons' <- primCons-    let nil       = nil'-        cons x xs = cons' `applys` [x, xs]-    return $ foldr cons nil--instance ToTerm a => ToTerm [a] where-  toTerm = do-    mkList <- buildList-    fromA  <- toTerm-    return $ mkList . map fromA---- From Haskell value to Agda term--type FromTermFunction a = Arg Term ->-                          ReduceM (Reduced (MaybeReduced (Arg Term)) a)--class FromTerm a where-  fromTerm :: TCM (FromTermFunction a)--instance FromTerm Integer where-  fromTerm = do-    Con pos _    [] <- ignoreSharing <$> primIntegerPos-    Con negsuc _ [] <- ignoreSharing <$> primIntegerNegSuc-    toNat         <- fromTerm :: TCM (FromTermFunction Nat)-    return $ \ v -> do-      b <- reduceB' v-      let v'  = ignoreBlocking b-          arg = (<$ v')-      case ignoreSharing $ unArg (ignoreBlocking b) of-        Con c ci [u]-          | c == pos    ->-            redBind (toNat u)-              (\ u' -> notReduced $ arg $ Con c ci [ignoreReduced u']) $ \ n ->-            redReturn $ fromIntegral n-          | c == negsuc ->-            redBind (toNat u)-              (\ u' -> notReduced $ arg $ Con c ci [ignoreReduced u']) $ \ n ->-            redReturn $ fromIntegral $ -n - 1-        _ -> return $ NoReduction (reduced b)--instance FromTerm Nat where-  fromTerm = fromLiteral $ \l -> case l of-    LitNat _ n -> Just $ fromInteger n-    _          -> Nothing--instance FromTerm Lvl where-  fromTerm = fromReducedTerm $ \l -> case l of-    Level (Max [ClosedLevel n]) -> Just $ Lvl n-    _                           -> Nothing--instance FromTerm Double where-  fromTerm = fromLiteral $ \l -> case l of-    LitFloat _ x -> Just x-    _            -> Nothing--instance FromTerm Char where-  fromTerm = fromLiteral $ \l -> case l of-    LitChar _ c -> Just c-    _           -> Nothing--instance FromTerm Str where-  fromTerm = fromLiteral $ \l -> case l of-    LitString _ s -> Just $ Str s-    _             -> Nothing--instance FromTerm QName where-  fromTerm = fromLiteral $ \l -> case l of-    LitQName _ x -> Just x-    _             -> Nothing--instance FromTerm MetaId where-  fromTerm = fromLiteral $ \l -> case l of-    LitMeta _ _ x -> Just x-    _             -> Nothing--instance FromTerm Bool where-    fromTerm = do-        true  <- primTrue-        false <- primFalse-        fromReducedTerm $ \t -> case t of-            _   | t =?= true  -> Just True-                | t =?= false -> Just False-                | otherwise   -> Nothing-        where-            a =?= b = ignoreSharing a === ignoreSharing b-            Def x [] === Def y []   = x == y-            Con x _ [] === Con y _ [] = x == y-            Var n [] === Var m []   = n == m-            _        === _          = False--instance (ToTerm a, FromTerm a) => FromTerm [a] where-  fromTerm = do-    nil'  <- primNil-    cons' <- primCons-    nil   <- isCon nil'-    cons  <- isCon cons'-    toA   <- fromTerm-    fromA <- toTerm-    return $ mkList nil cons toA fromA-    where-      isCon (Lam _ b)  = isCon $ absBody b-      isCon (Con c _ _)= return c-      isCon (Shared p) = isCon (derefPtr p)-      isCon v          = __IMPOSSIBLE__--      mkList nil cons toA fromA t = do-        b <- reduceB' t-        let t = ignoreBlocking b-        let arg = (<$ t)-        case ignoreSharing $ unArg t of-          Con c ci []-            | c == nil  -> return $ YesReduction NoSimplification []-          Con c ci [x,xs]-            | c == cons ->-              redBind (toA x)-                  (\x' -> notReduced $ arg $ Con c ci [ignoreReduced x',xs]) $ \y ->-              redBind-                  (mkList nil cons toA fromA xs)-                  (fmap $ \xs' -> arg $ Con c ci [defaultArg $ fromA y, xs']) $ \ys ->-              redReturn (y : ys)-          _ -> return $ NoReduction (reduced b)---- | 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--redReturn :: a -> ReduceM (Reduced a' a)-redReturn = return . YesReduction YesSimplification--fromReducedTerm :: (Term -> Maybe a) -> TCM (FromTermFunction a)-fromReducedTerm f = return $ \t -> do-    b <- reduceB' t-    case f $ ignoreSharing $ unArg (ignoreBlocking b) of-        Just x  -> return $ YesReduction NoSimplification x-        Nothing -> return $ NoReduction (reduced b)--fromLiteral :: (Literal -> Maybe a) -> TCM (FromTermFunction a)-fromLiteral f = fromReducedTerm $ \t -> case t of-    Lit lit -> f lit-    _       -> Nothing---- trustMe : {a : Level} {A : Set a} {x y : A} -> x ≡ y-primTrustMe :: TCM PrimitiveImpl-primTrustMe = do-  clo <- commandLineOptions-  when (optSafe clo) (typeError SafeFlagPrimTrustMe)-  t    <- hPi "a" (el primLevel) $-          hPi "A" (return $ sort $ varSort 0) $-          hPi "x" (El (varSort 1) <$> varM 0) $-          hPi "y" (El (varSort 2) <$> varM 1) $-          El (varSort 3) <$>-            primEquality <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0-  Con rf ci [] <- ignoreSharing <$> primRefl-  n         <- conPars . theDef <$> getConInfo rf-  -- Andreas, 2015-02-27  Forced Big vs. Forced Small should not matter here-  let refl x | n == 2    = Con rf ci [setRelevance (Forced Small) $ hide $ defaultArg x]-             | n == 3    = Con rf ci []-             | otherwise = __IMPOSSIBLE__-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ts ->-      case ts of-        [a, t, u, v] -> do-            -- Andreas, 2013-07-22.-            -- Note that we cannot call the conversion checker here,-            -- because 'reduce' might be called in a context where-            -- some bound variables do not have a type (just 'Prop),-            -- and the conversion checker for eliminations does not-            -- like this.-            -- We can only do untyped equality, e.g., by normalisation.-            (u', v') <- normalise' (u, v)-            if u' == v' then redReturn (refl $ unArg u) else-              return (NoReduction $ map notReduced [a, t, u, v])-{- OLD:--              -- BAD:-              noConstraints $-                equalTerm (El (Type $ lvlView $ unArg a) (unArg t)) (unArg u) (unArg v)-              redReturn (refl $ unArg u)-            `catchError` \_ -> return (NoReduction $ map notReduced [a, t, u, v])--}-        _ -> __IMPOSSIBLE__---- Used for both primForce and primForceLemma.-genPrimForce :: TCM Type -> (Term -> Arg Term -> Term) -> TCM PrimitiveImpl-genPrimForce b ret = do-  let varEl s a = El (varSort s) <$> a-      varT s a  = varEl s (varM a)-      varS s    = pure $ sort $ varSort s-  t <- hPi "a" (el primLevel) $-       hPi "b" (el primLevel) $-       hPi "A" (varS 1) $-       hPi "B" (varT 2 0 --> varS 1) b-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 6 $ \ ts ->-    case ts of-      [a, b, s, t, u, f] -> do-        u <- reduceB' u-        let isWHNF Blocked{} = return False-            isWHNF (NotBlocked _ u) =-              case ignoreSharing $ unArg u of-                Lit{}      -> return True-                Con{}      -> return True-                Lam{}      -> return True-                Pi{}       -> return True-                Sort{}     -> return True  -- sorts and levels are considered whnf-                Level{}    -> return True-                DontCare{} -> return True-                Def q _    -> do-                  def <- theDef <$> getConstInfo q-                  return $ case def of-                    Datatype{} -> True-                    Record{}   -> True-                    _          -> False-                MetaV{}    -> return False-                Var{}      -> return False-                Shared{}   -> __IMPOSSIBLE__--        ifM (isWHNF u)-            (redReturn $ ret (unArg f) (ignoreBlocking u))-            (return $ NoReduction $ map notReduced [a, b, s, t] ++ [reduced u, notReduced f])-      _ -> __IMPOSSIBLE__--primForce :: TCM PrimitiveImpl-primForce = do-  let varEl s a = El (varSort s) <$> a-      varT s a  = varEl s (varM a)-      varS s    = pure $ sort $ varSort s-  genPrimForce (nPi "x" (varT 3 1) $-                (nPi "y" (varT 4 2) $ varEl 4 $ varM 2 <@> varM 0) -->-                varEl 3 (varM 1 <@> varM 0)) $-    \ f u -> apply f [u]--primForceLemma :: TCM PrimitiveImpl-primForceLemma = do-  let varEl s a = El (varSort s) <$> a-      varT s a  = varEl s (varM a)-      varS s    = pure $ sort $ varSort s-  refl  <- primRefl-  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)-                                       <@> (pure (Def force []) <#> varM 5 <#> varM 4 <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0)-                                       <@> (varM 0 <@> varM 1)-               ) $ \ _ _ -> refl--mkPrimLevelZero :: TCM PrimitiveImpl-mkPrimLevelZero = do-  t <- primType (undefined :: Lvl)-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Level $ Max []--mkPrimLevelSuc :: TCM PrimitiveImpl-mkPrimLevelSuc = do-  t <- primType (id :: Lvl -> Lvl)-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 1 $ \ ~[a] -> do-    l <- levelView' $ unArg a-    redReturn $ Level $ levelSuc l--mkPrimLevelMax :: TCM PrimitiveImpl-mkPrimLevelMax = do-  t <- primType (max :: Op Lvl)-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 2 $ \ ~[a, b] -> do-    Max as <- levelView' $ unArg a-    Max bs <- levelView' $ unArg b-    redReturn $ Level $ levelMax $ as ++ bs--mkPrimFun1TCM :: (FromTerm a, ToTerm b, TermLike b) =>-                 TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl-mkPrimFun1TCM mt f = do-    toA   <- fromTerm-    fromB <- toTermR-    t     <- mt-    return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 1 $ \ts ->-      case ts of-        [v] ->-          redBind (toA v) (\v' -> [v']) $ \x -> do-            b <- f x-            case allMetas b of-              (m:_) -> return $ NoReduction [reduced (Blocked m v)]-              []       -> redReturn =<< fromB b-        _ -> __IMPOSSIBLE__---- Tying the knot-mkPrimFun1 :: (PrimType a, FromTerm a, PrimType b, ToTerm b) =>-              (a -> b) -> TCM PrimitiveImpl-mkPrimFun1 f = do-    toA   <- fromTerm-    fromB <- toTerm-    t     <- primType f-    return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 1 $ \ts ->-      case ts of-        [v] ->-          redBind (toA v)-              (\v' -> [v']) $ \x ->-          redReturn $ fromB $ f x-        _ -> __IMPOSSIBLE__--mkPrimFun2 :: ( PrimType a, FromTerm a, ToTerm a-              , PrimType b, FromTerm b-              , PrimType c, ToTerm c ) =>-              (a -> b -> c) -> TCM PrimitiveImpl-mkPrimFun2 f = do-    toA   <- fromTerm-    fromA <- toTerm-    toB   <- fromTerm-    fromC <- toTerm-    t     <- primType f-    return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 2 $ \ts ->-      case ts of-        [v,w] ->-          redBind (toA v)-              (\v' -> [v', notReduced w]) $ \x ->-          redBind (toB w)-              (\w' -> [ reduced $ notBlocked $ Arg (argInfo v) (fromA x)-                      , w']) $ \y ->-          redReturn $ fromC $ f x y-        _ -> __IMPOSSIBLE__--mkPrimFun4 :: ( PrimType a, FromTerm a, ToTerm a-              , PrimType b, FromTerm b, ToTerm b-              , PrimType c, FromTerm c, ToTerm c-              , PrimType d, FromTerm d-              , PrimType e, ToTerm e ) =>-              (a -> b -> c -> d -> e) -> TCM PrimitiveImpl-mkPrimFun4 f = do-    (toA, fromA) <- (,) <$> fromTerm <*> toTerm-    (toB, fromB) <- (,) <$> fromTerm <*> toTerm-    (toC, fromC) <- (,) <$> fromTerm <*> toTerm-    toD          <- fromTerm-    fromE        <- toTerm-    t <- primType f-    return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ts ->-      let argFrom fromX a 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 ->-          redBind (toB b)-              (\b' -> [argFrom fromA a x, b', notReduced c, notReduced d]) $ \y ->-          redBind (toC c)-              (\c' -> [ argFrom fromA a x-                      , argFrom fromB b y-                      , c', notReduced d]) $ \z ->-          redBind (toD d)-              (\d' -> [ argFrom fromA a x-                      , argFrom fromB b y-                      , argFrom fromC c z-                      , d']) $ \w ->--          redReturn $ fromE $ f x y z w-        _ -> __IMPOSSIBLE__---- Type combinators--infixr 4 -->-infixr 4 .-->-infixr 4 ..-->--(-->), (.-->), (..-->) :: TCM Type -> TCM Type -> TCM Type-a --> b = garr id a b-a .--> b = garr (const $ Irrelevant) a b-a ..--> b = garr (const $ NonStrict) a b--garr :: (Relevance -> Relevance) -> TCM Type -> TCM Type -> TCM Type-garr f a b = do-  a' <- a-  b' <- b-  return $ El (getSort a' `sLub` getSort b') $-           Pi (Dom (mapRelevance f defaultArgInfo) a') (NoAbs "_" b')--gpi :: ArgInfo -> String -> TCM Type -> TCM Type -> TCM Type-gpi info name a b = do-  a <- a-  b <- addContext (name, Dom info a) b-  let y = stringToArgName name-  return $ El (getSort a `dLub` Abs y (getSort b))-              (Pi (Dom info a) (Abs y b))--hPi, nPi :: String -> TCM Type -> TCM Type -> TCM Type-hPi = gpi $ setHiding Hidden defaultArgInfo-nPi = gpi defaultArgInfo--varM :: Int -> TCM Term-varM = return . var--infixl 9 <@>, <#>--gApply :: Hiding -> TCM Term -> TCM Term -> TCM Term-gApply h a b = do-    x <- a-    y <- b-    return $ x `apply` [Arg (setHiding h defaultArgInfo) y]--(<@>),(<#>) :: TCM Term -> TCM Term -> TCM Term-(<@>) = gApply NotHidden-(<#>) = gApply Hidden--list :: TCM Term -> TCM Term-list t = primList <@> t--io :: TCM Term -> TCM Term-io t = primIO <@> t--el :: TCM Term -> TCM Type-el t = El (mkType 0) <$> t--tset :: TCM Type-tset = return $ sort (mkType 0)--tSetOmega :: TCM Type-tSetOmega = return $ sort Inf--sSizeUniv :: Sort-sSizeUniv = mkType 0--- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428--- sSizeUniv = SizeUniv--tSizeUniv :: TCM 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 = return $ El Inf $ Sort SizeUniv---- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@.-argN :: e -> Arg e-argN = Arg defaultArgInfo--domN :: e -> Dom e-domN = Dom defaultArgInfo---- | Abbreviation: @argH = 'hide' 'Arg' 'defaultArgInfo'@.-argH :: e -> Arg e-argH = Arg $ setHiding Hidden defaultArgInfo--domH :: e -> Dom e-domH = Dom $ setHiding Hidden defaultArgInfo-------------------------------------------------------------------------------- * The actual primitive functions------------------------------------------------------------------------------type Op   a = a -> a -> a-type Fun  a = a -> a-type Rel  a = a -> a -> Bool-type Pred a = a -> Bool--primitiveFunctions :: Map String (TCM PrimitiveImpl)-primitiveFunctions = Map.fromList--  -- Ulf, 2015-10-28: Builtin integers now map to a datatype, and since you-  -- can define these functions (reasonably) efficiently using the primitive-  -- functions on natural numbers there's no need for them anymore. Keeping the-  -- show function around for convenience, and as a test case for a primitive-  -- function taking an integer.-  -- -- Integer functions-  -- [ "primIntegerPlus"     |-> mkPrimFun2 ((+)        :: Op Integer)-  -- , "primIntegerMinus"    |-> mkPrimFun2 ((-)        :: Op Integer)-  -- , "primIntegerTimes"    |-> mkPrimFun2 ((*)        :: Op Integer)-  -- , "primIntegerDiv"      |-> mkPrimFun2 (div        :: Op Integer)    -- partial-  -- , "primIntegerMod"      |-> mkPrimFun2 (mod        :: Op Integer)    -- partial-  -- , "primIntegerEquality" |-> mkPrimFun2 ((==)       :: Rel Integer)-  -- , "primIntegerLess"     |-> mkPrimFun2 ((<)        :: Rel Integer)-  -- , "primIntegerAbs"      |-> mkPrimFun1 (Nat . abs  :: Integer -> Nat)-  -- , "primNatToInteger"    |-> mkPrimFun1 (toInteger  :: Nat -> Integer)-  [ "primShowInteger"     |-> mkPrimFun1 (Str . show :: Integer -> Str)--  -- 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 -> Nat -> Nat -> Nat)-  , "primNatModSucAux"    |->-      let aux :: Nat -> Nat -> Nat -> Nat -> 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)--  -- Level functions-  , "primLevelZero"       |-> mkPrimLevelZero-  , "primLevelSuc"        |-> mkPrimLevelSuc-  , "primLevelMax"        |-> mkPrimLevelMax--  -- Floating point functions-  , "primNatToFloat"      |-> mkPrimFun1 (fromIntegral    :: Nat -> Double)-  , "primFloatPlus"       |-> mkPrimFun2 ((+)             :: Op Double)-  , "primFloatMinus"      |-> mkPrimFun2 ((-)             :: Op Double)-  , "primFloatTimes"      |-> mkPrimFun2 ((*)             :: Op Double)-  , "primFloatNegate"     |-> mkPrimFun1 (negate          :: Fun Double)-  , "primFloatDiv"        |-> mkPrimFun2 ((/)             :: Op Double)-  -- ASR (2016-09-29). We use bitwise equality for comparing Double-  -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove-  -- a contradiction (see Issue #2169).-  , "primFloatEquality"   |-> mkPrimFun2 (floatEq         :: Rel Double)-  , "primFloatNumericalEquality" |-> mkPrimFun2 ((==)     :: Rel Double)-  , "primFloatNumericalLess"     |-> mkPrimFun2 (floatLt  :: Rel Double)-  , "primFloatSqrt"       |-> mkPrimFun1 (sqrt            :: Double -> Double)-  , "primRound"           |-> mkPrimFun1 (round           :: Double -> Integer)-  , "primFloor"           |-> mkPrimFun1 (floor           :: Double -> Integer)-  , "primCeiling"         |-> mkPrimFun1 (ceiling         :: Double -> Integer)-  , "primExp"             |-> mkPrimFun1 (exp             :: Fun Double)-  , "primLog"             |-> mkPrimFun1 (log             :: Fun Double)-  , "primSin"             |-> mkPrimFun1 (sin             :: Fun Double)-  , "primCos"             |-> mkPrimFun1 (cos             :: Fun Double)-  , "primTan"             |-> mkPrimFun1 (tan             :: Fun Double)-  , "primASin"            |-> mkPrimFun1 (asin            :: Fun Double)-  , "primACos"            |-> mkPrimFun1 (acos            :: Fun Double)-  , "primATan"            |-> mkPrimFun1 (atan            :: Fun Double)-  , "primATan2"           |-> mkPrimFun2 (atan2           :: Double -> Double -> Double)-  , "primShowFloat"       |-> mkPrimFun1 (Str . show      :: Double -> Str)--  -- 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)-  , "primNatToChar"       |-> mkPrimFun1 (toEnum . fromIntegral . (`mod` 0x110000)  :: Nat -> Char)-  , "primShowChar"        |-> mkPrimFun1 (Str . show . pretty . LitChar noRange)--  -- String functions-  , "primStringToList"    |-> mkPrimFun1 unStr-  , "primStringFromList"  |-> mkPrimFun1 Str-  , "primStringAppend"    |-> mkPrimFun2 (\s1 s2 -> Str $ unStr s1 ++ unStr s2)-  , "primStringEquality"  |-> mkPrimFun2 ((==) :: Rel Str)-  , "primShowString"      |-> mkPrimFun1 (Str . show . pretty . LitString noRange . unStr)--  -- Other stuff-  , "primTrustMe"         |-> primTrustMe-    -- 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 (Str . show :: QName -> Str)-  , "primQNameFixity"     |-> mkPrimFun1 (nameFixity . qnameName)-  , "primMetaEquality"    |-> mkPrimFun2 ((==) :: Rel MetaId)-  , "primMetaLess"        |-> mkPrimFun2 ((<) :: Rel MetaId)-  , "primShowMeta"        |-> mkPrimFun1 (Str . show . pretty :: MetaId -> Str)-  ]-  where-    (|->) = (,)--floatEq :: Double -> Double -> Bool-floatEq x y = identicalIEEE x y || (isNaN x && isNaN y)--floatLt :: Double -> Double -> Bool-floatLt x y =-  case compareFloat x y of-    LT -> True-    _  -> False-  where-    -- Also implemented in the GHC/UHC backends-    compareFloat :: Double -> Double -> Ordering-    compareFloat x y-      | identicalIEEE x y          = EQ-      | isNegInf x                 = LT-      | isNegInf y                 = GT-      | isNaN x && isNaN y         = EQ-      | isNaN x                    = LT-      | isNaN y                    = GT-      | otherwise                  = compare x y-    isNegInf z = z < 0 && isInfinite z--lookupPrimitiveFunction :: String -> TCM PrimitiveImpl-lookupPrimitiveFunction x =-  fromMaybe (typeError $ NoSuchPrimitiveFunction x)-            (Map.lookup x primitiveFunctions)--lookupPrimitiveFunctionQ :: QName -> TCM (String, PrimitiveImpl)-lookupPrimitiveFunctionQ q = do-  let s = case qnameName q of-            Name _ x _ _ -> show x-  PrimImpl t pf <- lookupPrimitiveFunction s-  return (s, PrimImpl t $ pf { primFunName = q })--getBuiltinName :: String -> TCM (Maybe QName)-getBuiltinName b = do-  caseMaybeM (getBuiltin' b) (return Nothing) $ \v -> do-    v <- normalise v-    let getName (Def x _) = x-        getName (Con x _ _) = conName x-        getName (Lam _ b) = getName $ ignoreSharing $ unAbs b-        getName _         = __IMPOSSIBLE__-    return $ Just $ getName (ignoreSharing v)--isBuiltin :: QName -> String -> TCM Bool-isBuiltin q b = (Just q ==) <$> getBuiltinName b+{-# 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+       , module Agda.TypeChecking.Primitive+       ) where++import Data.Char+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word++import qualified Agda.Interaction.Options.Lenses as Lens++import Agda.Syntax.Common hiding (Nat)+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Generic (TermLike(..))+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Literal++import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst)+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Reduce.Monad as Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Level++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.Syntax.Common.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Size++import Agda.Utils.Impossible++-- Haskell type to Agda type++newtype Nat = Nat { unNat :: Integer }+            deriving (Eq, Ord, Num, Enum, Real)++-- In GHC > 7.8 deriving Integral causes an unnecessary toInteger+-- warning.+instance Integral Nat where+  toInteger = unNat+  quotRem (Nat a) (Nat b) = (Nat q, Nat r)+    where (q, r) = quotRem a b++instance TermLike Nat where+  traverseTermM _ = pure+  foldTerm _      = mempty++instance Pretty Nat where+  pretty = pretty . toInteger++newtype Lvl = Lvl { unLvl :: Integer }+  deriving (Eq, Ord)++instance Pretty Lvl where+  pretty = pretty . unLvl++class PrimType a where+  primType :: a -> TCM Type++  -- This used to be a catch-all instance `PrimType a => PrimTerm a` which required UndecidableInstances.+  -- Now we declare the instances separately, but enforce the catch-all-ness with a superclass constraint on PrimTerm.+  default primType :: PrimTerm a => a -> TCM Type+  primType _ = el $ primTerm (undefined :: a)++class PrimType a => PrimTerm a where+  primTerm :: a -> TCM Term++instance (PrimType a, PrimType b) => PrimType (a -> b)+instance (PrimType a, PrimType b) => PrimTerm (a -> b) where+  primTerm _ = unEl <$> (primType (undefined :: a) --> primType (undefined :: b))++instance (PrimType a, PrimType b) => PrimType (a, b)+instance (PrimType a, PrimType b) => PrimTerm (a, b) where+  primTerm _ = do+    sigKit <- fromMaybeM (typeError $ NoBindingForBuiltin BuiltinSigma) getSigmaKit+    let sig = Def (sigmaName sigKit) []+    a'       <- primType (undefined :: a)+    b'       <- primType (undefined :: b)+    Type la  <- pure $ getSort a'+    Type lb  <- pure $ getSort b'+    pure sig <#> pure (Level la)+             <#> pure (Level lb)+             <@> pure (unEl a')+             <@> pure (nolam $ unEl b')++instance PrimType Integer+instance PrimTerm Integer where primTerm _ = primInteger++instance PrimType Word64+instance PrimTerm Word64  where primTerm _ = primWord64++instance PrimType Bool+instance PrimTerm Bool    where primTerm _ = primBool++instance PrimType Char+instance PrimTerm Char    where primTerm _ = primChar++instance PrimType Double+instance PrimTerm Double  where primTerm _ = primFloat++instance PrimType Text+instance PrimTerm Text    where primTerm _ = primString++instance PrimType Nat+instance PrimTerm Nat     where primTerm _ = primNat++instance PrimType Lvl+instance PrimTerm Lvl     where primTerm _ = primLevel++instance PrimType QName+instance PrimTerm QName   where primTerm _ = primQName++instance PrimType MetaId+instance PrimTerm MetaId  where primTerm _ = primAgdaMeta++instance PrimType Type+instance PrimTerm Type    where primTerm _ = primAgdaTerm++instance PrimType Fixity'+instance PrimTerm Fixity' where primTerm _ = primFixity++instance PrimTerm a => PrimType [a]+instance PrimTerm a => PrimTerm [a] where+  primTerm _ = list (primTerm (undefined :: a))++instance PrimTerm a => PrimType (Maybe a)+instance PrimTerm a => PrimTerm (Maybe a) where+  primTerm _ = tMaybe (primTerm (undefined :: a))++instance PrimTerm a => PrimType (IO a)+instance PrimTerm a => PrimTerm (IO a) where+  primTerm _ = io (primTerm (undefined :: a))++-- From Agda term to Haskell value++class ToTerm a where+  toTerm  :: TCM (a -> ReduceM Term)++toTermTCM :: ToTerm a => TCM (a -> TCM Term)+toTermTCM = (runReduceM .) <$> toTerm++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+    top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+    return $ pure . Lit . LitMeta top++instance ToTerm Integer where+  toTerm = do+    pos     <- primIntegerPos+    negsuc  <- primIntegerNegSuc+    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 -> pure $ if b then true else false++instance ToTerm Term where+  toTerm = do quoteTermWithKit <$> quotingKit++instance ToTerm (Dom Type) where+  toTerm = do quoteDomWithKit <$> quotingKit++instance ToTerm Type where+  toTerm = quoteTypeWithKit <$> quotingKit++instance ToTerm ArgInfo where+  toTerm = do+    info <- primArgArgInfo+    vis  <- primVisible+    hid  <- primHidden+    ins  <- primInstance+    rel  <- primRelevant+    irr  <- primIrrelevant+    return $ \ i -> pure $ info `applys`+      [ case getHiding i of+          NotHidden  -> vis+          Hidden     -> hid+          Instance{} -> ins+      , case getRelevance i of+          Relevant        {} -> rel+          Irrelevant      {} -> irr+          ShapeIrrelevant {} -> rel+      ]++instance ToTerm Fixity' where+  toTerm = (. theFixity) <$> toTerm++instance ToTerm Fixity where+  toTerm = do+    lToTm  <- toTerm+    aToTm  <- toTerm+    fixity <- primFixityFixity+    return $ \ Fixity{fixityAssoc = a, fixityLevel = l} ->+      apply2 fixity <$> aToTm a <*> lToTm l++instance ToTerm Associativity where+  toTerm = do+    lassoc <- primAssocLeft+    rassoc <- primAssocRight+    nassoc <- primAssocNon+    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 <- toTerm+    related   <- primPrecRelated+    unrelated <- primPrecUnrelated+    return $ \ p ->+      case p of+        Unrelated -> pure unrelated+        Related n -> apply1 related <$> iToTm n++instance (ToTerm a, ToTerm b) => ToTerm (a, b) where+  toTerm = do+    sigKit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+    let con = Con (sigmaCon sigKit) ConOSystem []+    fromA <- toTerm+    fromB <- toTerm+    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@.+buildList :: TCM ([Term] -> Term)+buildList = do+    nil'  <- primNil+    cons' <- primCons+    let nil       = nil'+        cons x xs = cons' `applys` [x, xs]+    return $ foldr cons nil++instance ToTerm a => ToTerm [a] where+  toTerm = do+    mkList <- buildList+    fromA  <- toTerm+    return $ mkList <.> mapM fromA++instance ToTerm a => ToTerm (Maybe a) where+  toTerm = do+    nothing <- primNothing+    just    <- primJust+    fromA   <- toTerm+    return $ maybe (pure nothing) (apply1 just <.> fromA)++-- From Haskell value to Agda term++type FromTermFunction a = Arg Term ->+                          ReduceM (Reduced (MaybeReduced (Arg Term)) a)++class FromTerm a where+  fromTerm :: TCM (FromTermFunction a)++instance FromTerm Integer where+  fromTerm = do+    Con pos _    [] <- primIntegerPos+    Con negsuc _ [] <- primIntegerNegSuc+    toNat         <- fromTerm :: TCM (FromTermFunction Nat)+    return $ \ v -> do+      b <- reduceB' v+      let v'  = ignoreBlocking b+          arg = (<$ v')+      case unArg (ignoreBlocking b) of+        Con c ci [Apply u]+          | c == pos    ->+            redBind (toNat u)+              (\ u' -> pure $ notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->+            redReturn $ fromIntegral n+          | c == negsuc ->+            redBind (toNat u)+              (\ u' -> pure $ notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->+            redReturn $ fromIntegral $ -n - 1+        _ -> return $ NoReduction (reduced b)++instance FromTerm Nat where+  fromTerm = fromLiteral $ \case+    LitNat n -> Just $ fromInteger n+    _ -> Nothing++instance FromTerm Word64 where+  fromTerm = fromLiteral $ \ case+    LitWord64 n -> Just n+    _ -> Nothing++instance FromTerm Lvl where+  fromTerm = fromReducedTerm $ \case+    Level (ClosedLevel n) -> Just $ Lvl n+    _ -> Nothing++instance FromTerm Double where+  fromTerm = fromLiteral $ \case+    LitFloat x -> Just x+    _ -> Nothing++instance FromTerm Char where+  fromTerm = fromLiteral $ \case+    LitChar c -> Just c+    _ -> Nothing++instance FromTerm Text where+  fromTerm = fromLiteral $ \case+    LitString s -> Just s+    _ -> Nothing++instance FromTerm QName where+  fromTerm = fromLiteral $ \case+    LitQName x -> Just x+    _ -> Nothing++instance FromTerm MetaId where+  fromTerm = fromLiteral $ \case+    LitMeta _ x -> Just x+    _ -> Nothing++instance FromTerm Bool where+    fromTerm = do+        true  <- primTrue+        false <- primFalse+        fromReducedTerm $ \case+            t   | t =?= true  -> Just True+                | t =?= false -> Just False+                | otherwise   -> Nothing+        where+            a =?= b = a === b+            Def x [] === Def y []   = x == y+            Con x _ [] === Con y _ [] = x == y+            Var n [] === Var m []   = n == m+            _        === _          = False++instance (ToTerm a, FromTerm a) => FromTerm [a] where+  fromTerm = do+    nil   <- isCon <$> primNil+    cons  <- isCon <$> primCons+    toA   <- fromTerm+    mkList nil cons toA <$> toTerm+    where+      isCon (Lam _ b)   = isCon $ absBody b+      isCon (Con c _ _) = c+      isCon v           = __IMPOSSIBLE__++      mkList nil cons toA fromA t = do+        b <- reduceB' t+        let t = ignoreBlocking b+        let arg = (<$ t)+        case unArg t of+          Con c ci []+            | c == nil  -> return $ YesReduction NoSimplification []+          Con c ci es+            | c == cons, Just [x,xs] <- allApplyElims es ->+              redBind (toA x)+                  (\x' -> pure $ notReduced $ arg $ Con c ci (map Apply [ignoreReduced x',xs])) $ \y ->+              redBind+                  (mkList nil cons toA fromA xs)+                  (\ 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)++instance FromTerm a => FromTerm (Maybe a) where+  fromTerm = do+    nothing <- isCon <$> primNothing+    just    <- isCon <$> primJust+    toA     <- fromTerm+    return $ \ t -> do+      let arg = (<$ t)+      b <- reduceB' t+      let t = ignoreBlocking b+      case unArg t of+        Con c ci []+          | c == nothing -> return $ YesReduction NoSimplification Nothing+        Con c ci es+          | c == just, Just [x] <- allApplyElims es ->+            redBind (toA x)+              (\ x' -> pure $ notReduced $ arg $ Con c ci [Apply (ignoreReduced x')])+              (redReturn . Just)+        _ -> return $ NoReduction (reduced b)++    where+      isCon (Lam _ b)   = isCon $ absBody b+      isCon (Con c _ _) = c+      isCon v           = __IMPOSSIBLE__+++fromReducedTerm :: (Term -> Maybe a) -> TCM (FromTermFunction a)+fromReducedTerm f = return $ \t -> do+    b <- reduceB' t+    case f $ unArg (ignoreBlocking b) of+        Just x  -> return $ YesReduction NoSimplification x+        Nothing -> return $ NoReduction (reduced b)++fromLiteral :: (Literal -> Maybe a) -> TCM (FromTermFunction a)+fromLiteral f = fromReducedTerm $ \case+    Lit lit -> f lit+    _       -> Nothing++-- | @mkPrimInjective@ takes two Set0 @a@ and @b@ and a function @f@ of type+--   @a -> b@ and outputs a primitive internalizing the fact that @f@ is injective.+mkPrimInjective :: Type -> Type -> QName -> TCM PrimitiveImpl+mkPrimInjective a b qn = do+  -- Define the type+  eqName <- primEqualityName+  let lvl0     = ClosedLevel 0+  let eq a t u = El (Type lvl0) <$> pure (Def eqName []) <#> pure (Level lvl0)+                                <#> pure (unEl a) <@> t <@> u+  let f    = pure (Def qn [])+  ty <- nPi "t" (pure a) $ nPi "u" (pure a) $+              (eq b (f <@> varM 1) (f <@> varM 0))+          --> (eq a (      varM 1) (      varM 0))++    -- Get the constructor corresponding to BUILTIN REFL+  refl <- getRefl++  -- Implementation: when the equality argument reduces to refl so does the primitive.+  -- If the user want the primitive to reduce whenever the two values are equal (no+  -- matter whether the equality is refl), they can combine it with @eraseEquality@.+  return $ PrimImpl ty $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do+    let t  = headWithDefault __IMPOSSIBLE__ ts+    let eq = unArg $ fromMaybe __IMPOSSIBLE__ $ lastMaybe ts+    reduce' eq >>= \case+      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+  mkPrimInjective meta nat toNat++primCharToNatInjective :: TCM PrimitiveImpl+primCharToNatInjective = do+  char  <- primType (undefined :: Char)+  nat   <- primType (undefined :: Nat)+  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+  mkPrimInjective string chars toList++primStringFromListInjective :: TCM PrimitiveImpl+primStringFromListInjective = do+  chars  <- primType (undefined :: String)+  string <- primType (undefined :: Text)+  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+  mkPrimInjective word nat toNat++primFloatToWord64Injective :: TCM PrimitiveImpl+primFloatToWord64Injective = do+  float  <- primType (undefined :: Double)+  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+  mkPrimInjective name words toWords++getRefl :: TCM (Arg Term -> Term)+getRefl = do+  -- BUILTIN REFL maybe a constructor with one (the principal) argument or only parameters.+  -- Get the ArgInfo of the principal argument of refl.+  con@(Con rf ci []) <- primRefl+  minfo <- fmap (setOrigin Inserted) <$> getReflArgInfo rf+  pure $ case minfo of+    Just ai -> Con rf ci . (:[]) . Apply . setArgInfo ai+    Nothing -> const con++-- | @primEraseEquality : {a : Level} {A : Set a} {x y : A} -> x ≡ y -> x ≡ y@+primEraseEquality :: TCM PrimitiveImpl+primEraseEquality = do+  -- primEraseEquality is incompatible with --without-K+  -- We raise an error warning if --safe is set and a mere warning otherwise+  whenM withoutKOption $+    ifM (Lens.getSafeMode <$> commandLineOptions)+      {- then -} (warning SafeFlagWithoutKFlagPrimEraseEquality)+      {- else -} (warning WithoutKFlagPrimEraseEquality)+  -- Get the name and type of BUILTIN EQUALITY+  eq   <- primEqualityName+  eqTy <- defType <$> getConstInfo eq+  -- E.g. @eqTy = eqTel → Set a@ where @eqTel = {a : Level} {A : Set a} (x y : A)@.+  TelV eqTel eqCore <- telView eqTy+  let eqSort = case unEl eqCore of+        Sort s -> s+        _      -> __IMPOSSIBLE__++  -- Construct the type of primEraseEquality, e.g.+  -- @{a : Level} {A : Set a} {x y : A} → eq {a} {A} x y -> eq {a} {A} x y@.+  t <- let xeqy = pure $ El eqSort $ Def eq $ map Apply $ teleArgs eqTel in+       telePi_ (fmap hide eqTel) <$> (xeqy --> xeqy)++  -- Get the constructor corresponding to BUILTIN REFL+  refl <- getRefl++  -- The implementation of primEraseEquality:+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ (1 + size eqTel) $ \ ts -> do+    let (u, v) = fromMaybe __IMPOSSIBLE__ $ last2 =<< initMaybe ts+    -- Andreas, 2013-07-22.+    -- Note that we cannot call the conversion checker here,+    -- because 'reduce' might be called in a context where+    -- some bound variables do not have a type (just __DUMMY_TYPE__),+    -- and the conversion checker for eliminations does not+    -- like this.+    -- We can only do untyped equality, e.g., by normalisation.+    (u', v') <- normalise' (u, v)+    if u' == v' then redReturn $ refl u else+      return $ NoReduction $ map notReduced ts++-- | Get the 'ArgInfo' of the principal argument of BUILTIN REFL.+--+--   Returns @Nothing@ for e.g.+--   @+--     data Eq {a} {A : Set a} (x : A) : A → Set a where+--       refl : Eq x x+--   @+--+--   Returns @Just ...@ for e.g.+--   @+--     data Eq {a} {A : Set a} : (x y : A) → Set a where+--       refl : ∀ x → Eq x x+--   @++getReflArgInfo :: ConHead -> TCM (Maybe ArgInfo)+getReflArgInfo rf = do+  def <- getConInfo rf+  TelV reflTel _ <- telView $ defType def+  return $ fmap getArgInfo $ listToMaybe $ drop (conPars $ theDef def) $ telToList reflTel+++-- | Used for both @primForce@ and @primForceLemma@.+genPrimForce :: TCM Type -> (Term -> Arg Term -> Term) -> TCM PrimitiveImpl+genPrimForce b ret = do+  let varEl s a = El (varSort s) <$> a+      varT s a  = varEl s (varM a)+      varS s    = pure $ sort $ varSort s+  t <- hPi "a" (el primLevel) $+       hPi "b" (el primLevel) $+       hPi "A" (varS 1) $+       hPi "B" (varT 2 0 --> varS 1) b+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts ->+    case ts of+      [a, b, s, t, u, f] -> do+        u <- reduceB' u+        let isWHNF Blocked{} = return False+            isWHNF (NotBlocked _ u) =+              case unArg u of+                Lit{}      -> return True+                Con{}      -> return True+                Lam{}      -> return True+                Pi{}       -> return True+                Sort{}     -> return True  -- sorts and levels are considered whnf+                Level{}    -> return True+                DontCare{} -> return True+                Def q _    -> do+                  def <- theDef <$> getConstInfo q+                  return $ case def of+                    Datatype{} -> True+                    Record{}   -> True+                    _          -> False+                Var{}      -> return False+                MetaV{}    -> __IMPOSSIBLE__+                Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s+        ifM (isWHNF u)+            (redReturn $ ret (unArg f) (ignoreBlocking u))+            (return $ NoReduction $ map notReduced [a, b, s, t] ++ [reduced u, notReduced f])+      _ -> __IMPOSSIBLE__++primForce :: TCM PrimitiveImpl+primForce = do+  let varEl s a = El (varSort s) <$> a+      varT s a  = varEl s (varM a)+  genPrimForce (nPi "x" (varT 3 1) $+                nPi "y" (varT 4 2) (varEl 4 $ varM 2 <@> varM 0) -->+                varEl 3 (varM 1 <@> varM 0)) $+    \ f u -> apply f [u]++primForceLemma :: TCM PrimitiveImpl+primForceLemma = do+  let varEl s a = El (varSort s) <$> a+      varT s a  = varEl s (varM a)+  refl  <- primRefl+  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)+                                       <@> (pure (Def force []) <#> varM 5 <#> varM 4 <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0)+                                       <@> (varM 0 <@> varM 1)+               ) $ \ _ _ -> refl++mkPrimLevelZero :: TCM PrimitiveImpl+mkPrimLevelZero = do+  t <- primType (undefined :: Lvl)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Level $ ClosedLevel 0++mkPrimLevelSuc :: TCM PrimitiveImpl+mkPrimLevelSuc = do+  t <- primType (id :: Lvl -> Lvl)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ~[a] -> do+    l <- levelView' $ unArg a+    redReturn $ Level $ levelSuc l++mkPrimLevelMax :: TCM PrimitiveImpl+mkPrimLevelMax = do+  t <- primType (max :: Op Lvl)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ~[a, b] -> do+    a' <- levelView' $ unArg a+    b' <- levelView' $ unArg b+    redReturn $ Level $ levelLub a' b'++primLockUniv' :: TCM PrimitiveImpl+primLockUniv' = do+  let t = sort $ Type $ levelSuc $ Max 0 []+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort LockUniv++mkPrimFun1TCM :: (FromTerm a, ToTerm b) =>+                 TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl+mkPrimFun1TCM mt f = do+    toA   <- fromTerm+    fromB <- toTerm+    t     <- mt+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts ->+      case ts of+        [v] ->+          redBind (toA v) (pure . singleton) $ \ x -> do+            b <- fromB =<< f x+            case allMetas Set.singleton b of+              ms | Set.null ms -> redReturn b+                 | otherwise   -> return $ NoReduction [reduced (Blocked (unblockOnAllMetas ms) v)]+        _ -> __IMPOSSIBLE__++-- Tying the knot+mkPrimFun1 :: (PrimType a, FromTerm a, PrimType b, ToTerm b) =>+              (a -> b) -> TCM PrimitiveImpl+mkPrimFun1 f = do+    toA   <- fromTerm+    fromB <- toTerm+    t     <- primType f+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts ->+      case ts of+        [v] ->+          redBind (toA v) (pure . singleton) $ \ x ->+          redReturn =<< fromB (f x)+        _ -> __IMPOSSIBLE__++mkPrimFun2 :: ( PrimType a, FromTerm a, ToTerm a+              , PrimType b, FromTerm b+              , PrimType c, ToTerm c ) =>+              (a -> b -> c) -> TCM PrimitiveImpl+mkPrimFun2 f = do+    toA   <- fromTerm+    fromA <- toTerm+    toB   <- fromTerm+    fromC <- toTerm+    t     <- primType f+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ts ->+      case ts of+        [v,w] ->+          redBind (toA v)+              (\v' -> pure [v', notReduced w]) $ \x ->+          redBind (toB w)+              (\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+              , PrimType b, FromTerm b, ToTerm b+              , PrimType c, FromTerm c+              , PrimType d, ToTerm d ) =>+              (a -> b -> c -> d) -> TCM PrimitiveImpl+mkPrimFun3 f = do+    (toA, fromA) <- (,) <$> fromTerm <*> toTerm+    (toB, fromB) <- (,) <$> fromTerm <*> toTerm+    toC          <- fromTerm+    fromD        <- toTerm+    t <- primType f+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ts ->+      let argFrom fromX a x =+            reduced . notBlocked . Arg (argInfo a) <$> fromX x+      in case ts of+        [a,b,c] ->+          redBind (toA a)+              (\a' -> pure [a', notReduced b, notReduced c]) $ \x ->+          redBind (toB b)+              (\b' -> sequence+                [ argFrom fromA a x+                , pure b'+                , pure $ notReduced c ]) $ \y ->+          redBind (toC c)+              (\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+              , PrimType b, FromTerm b, ToTerm b+              , PrimType c, FromTerm c, ToTerm c+              , PrimType d, FromTerm d+              , PrimType e, ToTerm e ) =>+              (a -> b -> c -> d -> e) -> TCM PrimitiveImpl+mkPrimFun4 f = do+    (toA, fromA) <- (,) <$> fromTerm <*> toTerm+    (toB, fromB) <- (,) <$> fromTerm <*> toTerm+    (toC, fromC) <- (,) <$> fromTerm <*> toTerm+    toD          <- fromTerm+    fromE        <- toTerm+    t <- primType f+    return $ PrimImpl t $ primFun __IMPOSSIBLE__ 4 $ \ts ->+      let argFrom fromX a x =+            reduced . notBlocked . Arg (argInfo a) <$> fromX x+      in case ts of+        [a,b,c,d] ->+          redBind (toA a)+              (\a' -> pure $ a' : map notReduced [b, c, d]) $ \x ->+          redBind (toB b)+              (\b' -> sequence+                [ argFrom fromA a x+                , pure b'+                , pure $ notReduced c+                , pure $ notReduced d ]) $ \y ->+          redBind (toC c)+              (\c' -> sequence+                [ argFrom fromA a x+                , argFrom fromB b y+                , pure c'+                , pure $ notReduced d ]) $ \z ->+          redBind (toD d)+              (\d' -> sequence+                [ argFrom fromA a x+                , argFrom fromB b y+                , argFrom fromC c z+                , pure d' ]) $ \w ->++          redReturn =<< fromE (f x y z w)+        _ -> __IMPOSSIBLE__+++---------------------------------------------------------------------------+-- * The actual primitive functions+---------------------------------------------------------------------------++type Op   a = a -> a -> a+type Fun  a = a -> a+type Rel  a = a -> a -> Bool+type Pred a = a -> Bool++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+  --   is bad for caching since it happens when scope checking import declarations (rebinding+  --   primitives). During type checking, the caching machinery might then load a cached state with+  --   out-of-date checkpoint ids. Make sure to preserve warnings though, since they include things+  --   like using unsafe things primitives with `--safe`.++  -- Ulf, 2015-10-28: Builtin integers now map to a datatype, and since you+  -- can define these functions (reasonably) efficiently using the primitive+  -- functions on natural numbers there's no need for them anymore. Keeping the+  -- show function around for convenience, and as a test case for a primitive+  -- function taking an integer.+  -- -- Integer functions+  -- [ "primIntegerPlus"     |-> mkPrimFun2 ((+)        :: Op Integer)+  -- , "primIntegerMinus"    |-> mkPrimFun2 ((-)        :: Op Integer)+  -- , "primIntegerTimes"    |-> mkPrimFun2 ((*)        :: Op Integer)+  -- , "primIntegerDiv"      |-> mkPrimFun2 (div        :: Op Integer)    -- partial+  -- , "primIntegerMod"      |-> mkPrimFun2 (mod        :: Op Integer)    -- partial+  -- , "primIntegerEquality" |-> mkPrimFun2 ((==)       :: Rel Integer)+  -- , "primIntegerLess"     |-> mkPrimFun2 ((<)        :: Rel Integer)+  -- , "primIntegerAbs"      |-> mkPrimFun1 (Nat . abs  :: Integer -> Nat)+  -- , "primNatToInteger"    |-> mkPrimFun1 (toInteger  :: Nat -> Integer)+  [ 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      |->+      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++  -- -- Level functions+  , PrimLevelZero         |-> mkPrimLevelZero+  , PrimLevelSuc          |-> mkPrimLevelSuc+  , PrimLevelMax          |-> mkPrimLevelMax++  -- Floating point functions+  --+  -- Wen, 2020-08-26: Primitives which convert from Float into other, more+  -- well-behaved numeric types should check for unrepresentable values, e.g.,+  -- NaN and the infinities, and return `nothing` if those are encountered, to+  -- ensure that the returned numbers are sensible. That means `primFloatRound`,+  -- `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++  -- 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)++  -- 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++  -- Other stuff+  , 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+                                          :: QName -> (Word64, Word64))+  , 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
@@ -0,0 +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 PrimitiveId (TCM PrimitiveImpl)
+ src/full/Agda/TypeChecking/Primitive/Base.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE ApplicativeDo #-}++module Agda.TypeChecking.Primitive.Base where++import Control.Monad             ( mzero )+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT )++import qualified Data.Map as Map++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Names+import {-# SOURCE #-} Agda.TypeChecking.Primitive+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce ( reduce )+import Agda.TypeChecking.Monad.Signature+import Agda.TypeChecking.Substitute++import Agda.Utils.Functor+import Agda.Utils.Impossible+import Agda.Utils.Maybe+import Agda.Syntax.Common.Pretty ( prettyShow )++-- Type combinators++infixr 4 -->+infixr 4 .-->+infixr 4 ..-->++(-->), (.-->), (..-->) :: 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 shapeIrrelevant) a b++garr :: Applicative m => (Relevance -> Relevance) -> m Type -> m Type -> m Type+garr f a b = do+  a' <- a+  b' <- b+  pure $ El (funSort (getSort a') (getSort b')) $+    Pi (mapRelevance f $ defaultDom a') (NoAbs "_" b')++gpi :: (MonadAddContext m, MonadDebug m)+    => ArgInfo -> String -> m Type -> m Type -> m Type+gpi info name a b = do+  a <- a+  let dom :: Dom Type+      dom = defaultNamedArgDom info name a+  b <- addContext (name, dom) b+  let y = stringToArgName name+  return $ El (mkPiSort dom (Abs y b))+              (Pi dom (Abs y b))++hPi, nPi :: (MonadAddContext m, MonadDebug m)+         => String -> m Type -> m Type -> m Type+hPi = gpi $ setHiding Hidden defaultArgInfo+nPi = gpi defaultArgInfo++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 (\ 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+   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 UType 0) <$> t)++elSSet :: Functor m => m Term -> m Type+elSSet t = (El (SSet $ ClosedLevel 0) <$> t)++nolam :: Term -> Term+nolam = Lam defaultArgInfo . NoAbs "_"++varM :: Applicative m => Int -> m Term+varM = pure . var++infixl 9 <@>, <#>++gApply :: Applicative m => Hiding -> m Term -> m Term -> m Term+gApply h a b = gApply' (setHiding h defaultArgInfo) a b++gApply' :: Applicative m => ArgInfo -> m Term -> m Term -> m Term+gApply' info a b = do+    x <- a+    y <- b+    pure $ x `apply` [Arg info y]++(<@>),(<#>),(<..>) :: Applicative m => m Term -> m Term -> m Term+(<@>) = gApply NotHidden+(<#>) = gApply Hidden+(<..>) = gApply' defaultIrrelevantArgInfo++(<@@>) :: Applicative m => m Term -> (m Term,m Term,m Term) -> m Term+t <@@> (x,y,r) = do+  t <- t+  x <- x+  y <- y+  r <- r+  pure $ t `applyE` [IApply x y r]++list :: TCM Term -> TCM Term+list t = primList <@> t++tMaybe :: TCM Term -> TCM Term+tMaybe t = primMaybe <@> t++io :: TCM Term -> TCM Term+io t = primIO <@> t++path :: TCM Term -> TCM Term+path t = primPath <@> t++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 = SizeUniv++-- | @SizeUniv@ as a type.+tSizeUniv :: Applicative m => m Type+tSizeUniv = pure $ sort sSizeUniv++tLevelUniv :: Applicative m => m Type+tLevelUniv = pure $ sort $ LevelUniv++-- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@.+argN :: e -> Arg e+argN = Arg defaultArgInfo++domN :: e -> Dom e+domN = defaultDom++-- | Abbreviation: @argH = 'hide' 'Arg' 'defaultArgInfo'@.+argH :: e -> Arg e+argH = Arg $ setHiding Hidden defaultArgInfo++domH :: e -> Dom e+domH = setHiding Hidden . defaultDom++---------------------------------------------------------------------------+-- * Accessing the primitive functions+---------------------------------------------------------------------------++lookupPrimitiveFunction :: PrimitiveId -> TCM PrimitiveImpl+lookupPrimitiveFunction x =+  fromMaybe (do+                reportSDoc "tc.prim" 20 $ "Lookup of primitive function" <+> pretty x <+> "failed"+                typeError $ NoSuchPrimitiveFunction (getBuiltinId x))+            (Map.lookup x primitiveFunctions)++lookupPrimitiveFunctionQ :: QName -> TCM (PrimitiveId, PrimitiveImpl)+lookupPrimitiveFunctionQ q = do+  let s = prettyShow (nameCanonical $ qnameName 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) => 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+      Def x _   -> return x+      Con x _ _ -> return $ conName x+      Lam _ b   -> getQNameFromTerm $ unAbs b+      _ -> mzero++isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> BuiltinId -> m Bool+isBuiltin q b = (Just q ==) <$> getBuiltinName b++------------------------------------------------------------------------+-- * Builtin Sigma+------------------------------------------------------------------------++data SigmaKit = SigmaKit+  { sigmaName :: QName+  , sigmaCon  :: ConHead+  , sigmaFst  :: QName+  , sigmaSnd  :: QName+  }+  deriving (Eq,Show)++getSigmaKit :: (HasBuiltins m, HasConstInfo m) => m (Maybe SigmaKit)+getSigmaKit = do+  ms <- getBuiltinName' builtinSigma+  case ms of+    Nothing -> return Nothing+    Just sigma -> do+      def <- theDef <$> getConstInfo sigma+      case def of+        Record { recFields = [fst,snd], recConHead = con } -> do+          return . Just $ SigmaKit+            { sigmaName = sigma+            , sigmaCon  = con+            , sigmaFst  = unDom fst+            , sigmaSnd  = unDom snd+            }+        _ -> __IMPOSSIBLE__  -- This invariant is ensured in bindBuiltinSigma
+ src/full/Agda/TypeChecking/Primitive/Cubical.hs view
@@ -0,0 +1,1366 @@+{-# LANGUAGE NondecreasingIndentation #-}++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,12 +1,68 @@-{-# LANGUAGE CPP               #-}+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.TypeChecking.ProjectionLike where+-- | Dropping initial arguments (``parameters'') from a function which can be+--   easily reconstructed from its principal argument.+--+--   A function which has such parameters is called ``projection-like''.+--+--   The motivation for this optimization comes from the use of nested records.+--+--   First, let us look why proper projections need not store the parameters:+--   The type of a projection @f@ is of the form+--   @+--      f : Γ → R Γ → C+--   @+--   where @R@ is the record type and @C@ is the type of the field @f@.+--   Given a projection application+--   @+--      p pars u+--   @+--   we know that the type of the principal argument @u@ is+--   @+--      u : R pars+--   @+--   thus, the parameters @pars@ are redundant in the projection application+--   if we can always infer the type of @u@.+--   For projections, this is case, because the principal argument @u@ must be+--   neutral; otherwise, if it was a record value, we would have a redex,+--   yet Agda maintains a β-normal form.+--+--   The situation for projections can be generalized to ``projection-like''+--   functions @f@.  Conditions:+--+--     1. The type of @f@ is of the form @f : Γ → D Γ → ...@ for some+--        type constructor @D@ which can never reduce.+--+--     2. For every reduced welltyped application @f pars u ...@,+--        the type of @u@ is inferable.+--+--   This then allows @pars@ to be dropped always.+--+--   Condition 2 is approximated by a bunch of criteria, for details see function+--   'makeProjection'.+--+--   Typical projection-like functions are compositions of projections+--   which arise from nested records.+--+--   Notes:+--+--     1. This analysis could be dualized to ``constructor-like'' functions+--        whose parameters are reconstructable from the target type.+--        But such functions would need to be fully applied.+--+--     2. A more general analysis of which arguments are reconstructible+--        can be found in+--+--          Jason C. Reed, Redundancy elimination for LF+--          LFTMP 2004. -import Control.Monad+module Agda.TypeChecking.ProjectionLike where  import qualified Data.Map as Map import Data.Monoid (Any(..), getAny) +import Agda.Interaction.Options+ import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Internal@@ -17,19 +73,23 @@ 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.Size import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible --- | View for a @Def f (Apply a : es)@ where @isProjection f@.+-- | View for a @Def f (Apply a : es)@ where @isRelevantProjection f@. --   Used for projection-like @f@s. data ProjectionView   = ProjectionView@@ -58,21 +118,25 @@ projView :: HasConstInfo m => Term -> m ProjectionView projView v = do   let fallback = return $ NoProjection v-  case ignoreSharing v of-    Def f es -> caseMaybeM (isProjection f) fallback $ \ isP -> do+  case v of+    Def f es -> caseMaybeM (isRelevantProjection f) fallback $ \ isP -> do       if projIndex isP <= 0 then fallback else do         case es of           []           -> return $ LoneProjectionLike f $ projArgInfo isP           Apply a : es -> return $ ProjectionView f a es           -- Since a projection is a function, it cannot be projected itself.           Proj{}  : _  -> __IMPOSSIBLE__+          -- The principal argument of a projection-like cannot be the interval?+          IApply{} : _ -> __IMPOSSIBLE__+     _ -> 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.) ---reduceProjectionLike :: Term -> TCM Term+reduceProjectionLike :: PureTCM m => Term -> m Term reduceProjectionLike v = do   -- Andreas, 2013-11-01 make sure we do not reduce a constructor   -- because that could be folded back into a literal by reduce.@@ -82,6 +146,10 @@                             -- ordinary reduce, only different for Def's     _                -> return v +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.@@ -95,103 +163,158 @@ --   No precondition. --   Preserves constructorForm, since it really does only something --   on (applications of) projection-like functions.-elimView :: Bool -> Term -> TCM Term-elimView loneProjToLambda v = do-  reportSDoc "tc.conv.elim" 30 $ text "elimView of " <+> prettyTCM v-  reportSLn  "tc.conv.elim" 50 $ "v = " ++ show v+elimView :: PureTCM m => ProjEliminator -> Term -> m Term+elimView pe v = do+  reportSDoc "tc.conv.elim" 60 $ "elimView of " <+> prettyTCM v   v <- reduceProjectionLike v-  reportSDoc "tc.conv.elim" 40 $-    text "elimView (projections reduced) of " <+> prettyTCM v-  pv <- projView v-  case pv of-    NoProjection{}        -> return v-    LoneProjectionLike f ai-      | loneProjToLambda  -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]-      | otherwise         -> return v-    ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView loneProjToLambda (unArg a)+  reportSDoc "tc.conv.elim" 65 $+    "elimView (projections reduced) of " <+> prettyTCM v+  case pe of+    NoPostfix -> return v+    _         -> do+      pv <- projView v+      case pv of+        NoProjection{}        -> return v+        LoneProjectionLike f ai+          | 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 :: QName -> TCM Bool-eligibleForProjectionLike d = do-  defn <- theDef <$> getConstInfo d-  return $ case defn of+eligibleForProjectionLike :: (HasConstInfo m) => QName -> m Bool+eligibleForProjectionLike d = eligible . theDef <$> getConstInfo d+  where+  eligible = \case     Datatype{} -> True     Record{}   -> True     Axiom{}    -> True+    DataOrRecSig{}     -> True+    GeneralizableVar{} -> False     Function{}    -> False     Primitive{}   -> False+    PrimitiveSort{} -> False     Constructor{} -> __IMPOSSIBLE__-    AbstractDefn  -> False+    AbstractDefn d -> eligible d+      -- Andreas, 2017-08-14, issue #2682:+      -- Abstract records still export the projections.       -- Andreas, 2016-10-11 AIM XXIV       -- Projection-like at abstract types violates the parameter reconstructibility property.       -- See test/Fail/AbstractTypeProjectionLike.  -- | Turn a definition into a projection if it looks like a projection.+--+-- Conditions for projection-likeness of @f@:+--+--   1. The type of @f@ must be of the shape @Γ → D Γ → C@ for @D@+--      a name (@Def@) which is 'eligibleForProjectionLike':+--      @data@ / @record@ / @postulate@.+--+--   2. The application of f should only get stuck if the principal argument+--      is inferable (neutral).  Thus:+--+--      a. @f@ cannot have absurd clauses (which are stuck even if the principal+--         argument is a constructor).+--+--      b. @f@ cannot be abstract as it does not reduce outside abstract blocks+--         (always stuck).+--+--      c. @f@ cannot match on other arguments than the principal argument.+--+--      d. @f@ cannot match deeply.+--+--      e. @f@s body may not mention the parameters.+--+--      f. A rhs of @f@ cannot be a record expression, since this will be+--         translated to copatterns by recordExpressionsToCopatterns.+--         Thus, an application of @f@ waiting for a projection+--         can be stuck even when the principal argument is a constructor.+--+--      g. @f@ cannot be an irrelevant definition (Andreas, 2022-03-07, #5809),+--         as those are not reduced.+--+-- For internal reasons:+--+--   3. @f@ cannot be constructor headed+--+--   4. @f@ cannot be recursive, since we have not implemented a function+--      which goes through the bodies of the @f@ and the mutually recursive+--      functions and drops the parameters from all applications of @f@.+--+-- Examples for these reasons: see test/Succeed/NotProjectionLike.agda+ makeProjection :: QName -> TCM ()-makeProjection x = -- if True then return () else do+makeProjection x = whenM (optProjectionLike <$> pragmaOptions) $ do  inTopContext $ do-  -- reportSLn "tc.proj.like" 30 $ "Considering " ++ show x ++ " for projection likeness"+  reportSLn "tc.proj.like" 70 $ "Considering " ++ prettyShow x ++ " for projection likeness"   defn <- getConstInfo x   let t = defType defn   reportSDoc "tc.proj.like" 20 $ sep-    [ text "Checking for projection likeness "-    , prettyTCM x <+> text " : " <+> prettyTCM t+    [ "Checking for projection likeness "+    , prettyTCM x <+> " : " <+> prettyTCM t     ]-  case theDef defn of+  if isIrrelevant defn then+    reportSDoc "tc.proj.like" 30 $ "  projection-like functions cannot be irrelevant"+  else case theDef defn of     Function{funClauses = cls}       | any (isNothing . clauseBody) cls ->         reportSLn "tc.proj.like" 30 $ "  projection-like functions cannot have absurd clauses"+      | any (maybe __IMPOSSIBLE__ isRecordExpression . clauseBody) cls ->+        reportSLn "tc.proj.like" 30 $ "  projection-like functions cannot have record rhss"     -- Constructor-headed functions can't be projection-like (at the moment). The reason     -- for this is that invoking constructor-headedness will circumvent the inference of     -- 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, funCompiled = cc0, funInv = NotInjective,-                 funMutual = [], -- Andreas, 2012-09-28: only consider non-mutual funs (or those whose recursion status has not yet been determined)-                 funAbstr = ConcreteDef} -> do+    def@Function{funProjection = Left MaybeProjection, funClauses = cls,+                 funSplitTree = st0, funCompiled = cc0, funInv = NotInjective,+                 funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs+                 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: " ++ show ps0+                                                else "  candidates: " ++ prettyShow ps0       unless (null ps0) $ do         -- Andreas 2012-09-26: only consider non-recursive functions for proj.like.         -- Issue 700: problems with recursive funs. in term.checker and reduction         ifM recursive (reportSLn "tc.proj.like" 30 $ "  recursive functions are not considered for projection-likeness") $ do-          ps <- return $ filter (checkOccurs cls . snd) ps0-          when (null ps) $-            reportSLn "tc.proj.like" 50 $-              "  occurs check failed\n    clauses = " ++ show cls-          case reverse ps of-            []         -> return ()-            (d, n) : _ -> do-              reportSDoc "tc.proj.like" 10 $ sep-                [ prettyTCM x <+> text " : " <+> prettyTCM t-                , text $ " is projection like in argument " ++ show n ++ " for type " ++ show d+          {- else -}+          case lastMaybe (filter (checkOccurs cls . snd) ps0) of+            Nothing -> reportSDoc "tc.proj.like" 50 $ nest 2 $ vcat+              [ "occurs check failed"+              , nest 2 $ "clauses =" <?> vcat (map pretty cls) ]+            Just (d, n) -> do+              -- Yes, we are projection-like!+              reportSDoc "tc.proj.like" 10 $ vcat+                [ prettyTCM x <+> " : " <+> prettyTCM t+                , nest 2 $ sep+                  [ "is projection like in argument",  prettyTCM n, "for type", prettyTCM (unArg d) ]                 ]-{--              reportSLn "tc.proj.like" 10 $-                show (defName defn) ++ " is projection like in argument " ++-                show n ++ " for type " ++ show d--}+              __CRASH_WHEN__ "tc.proj.like.crash" 1000+               let cls' = map (dropArgs n) cls                   cc   = dropArgs n cc0-              -- cc <- compileClauses (Just (x, __IMPOSSIBLE__)) cls'-              reportSLn "tc.proj.like" 60 $ "  rewrote clauses to\n    " ++ show cc+                  st   = dropArgs n st0+              reportSLn "tc.proj.like" 60 $ unlines+                [ "  rewrote clauses to"+                , "    " ++ show cc+                ]                -- Andreas, 2013-10-20 build parameter dropping function               let pIndex = n + 1                   tel = take pIndex $ telToList $ theTel $ telView' t               unless (length tel == pIndex) __IMPOSSIBLE__               let projection = Projection-                    { projProper   = False+                    { projProper   = Nothing                     , projOrig     = x                     , projFromType = d                     , projIndex    = pIndex-                    , projLams     = ProjLams $ map (\ (Dom ai (y, _)) -> Arg ai y) tel+                    , projLams     = ProjLams $ map (argFromDom . fmap fst) tel                     }               let newDef = def-                           { funProjection     = Just projection+                           { funProjection     = Right projection                            , funClauses        = cls'+                           , funSplitTree      = st                            , funCompiled       = cc                            , funInv            = dropArgs n $ funInv def                            }@@ -202,12 +325,37 @@                                    }     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"-    _ -> reportSLn "tc.proj.like" 30 $ "  not a function"+    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"+    AbstractDefn{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but AbstractDefn"+    Constructor{}  -> reportSLn "tc.proj.like" 30 $ "  not a function, but Constructor"+    Datatype{}     -> reportSLn "tc.proj.like" 30 $ "  not a function, but Datatype"+    Primitive{}    -> reportSLn "tc.proj.like" 30 $ "  not a function, but Primitive"+    PrimitiveSort{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but PrimitiveSort"+    Record{}       -> reportSLn "tc.proj.like" 30 $ "  not a function, but Record"   where+    -- If the user wrote a record expression as rhs,+    -- the recordExpressionsToCopatterns translation will turn this into copatterns,+    -- violating the conditions of projection-likeness.+    -- Andreas, 2019-07-11, issue #3843.+    isRecordExpression :: Term -> Bool+    isRecordExpression = \case+      Con _ ConORec _ -> True+      _ -> False     -- @validProj (d,n)@ checks whether the head @d@ of the type of the     -- @n@th argument is injective in all args (i.d. being name of data/record/axiom).     validProj :: (Arg QName, Int) -> TCM Bool@@ -219,24 +367,24 @@     -- and/or positivity checkers.     recursive = do       occs <- computeOccurrences x-      let xocc = Map.lookup (ADef x) occs-      case xocc of-        Just (_ : _) -> return True -- recursive occurrence-        _            -> return False+      case Map.lookup (ADef x) occs of+        Just n | n >= 1 -> return True -- recursive occurrence+        _               -> return False      checkOccurs cls n = all (nonOccur n) cls      nonOccur n cl =-      and [ take n p == [0..n - 1]-          , onlyMatch n ps  -- projection-like functions are only allowed to match on the eliminatee-                            -- otherwise we may end up projecting from constructor applications, in-                            -- which case we can't reconstruct the dropped parameters-          , checkBody m n b ]+        (take n p == [0..n - 1]) &&+        onlyMatch n ps &&  -- projection-like functions are only allowed to match on the eliminatee+                          -- otherwise we may end up projecting from constructor applications, in+                          -- which case we can't reconstruct the dropped parameters+        checkBody m n b       where         Perm _ p = fromMaybe __IMPOSSIBLE__ $ clausePerm cl         ps       = namedClausePats cl-        b        = compiledClauseBody cl-        m        = size $ concatMap patternVars $ clausePats cl+        b        = compiledClauseBody cl  -- Renumbers variables to match order in patterns+                                          -- and includes dot patterns as variables.+        m        = size $ concatMap patternVars ps  -- This also counts dot patterns!       onlyMatch n ps = all (shallowMatch . namedArg) (take 1 ps1) &&@@ -247,13 +395,16 @@         shallowMatch _             = True         noMatches = all (noMatch . namedArg)         noMatch ConP{} = False+        noMatch DefP{} = False         noMatch LitP{} = False         noMatch ProjP{}= False         noMatch VarP{} = True         noMatch DotP{} = True+        noMatch IApplyP{} = True +    -- Make sure non of the parameters occurs in the body of the function.     checkBody m n b = not . getAny $ runFree badVar IgnoreNot b-      where badVar (x,_) = Any $ m-1-n < x && x < m+      where badVar x = Any $ m - n <= x && x < m      -- @candidateArgs [var 0,...,var(n-1)] t@ adds @(n,d)@ to the output,     -- if @t@ is a function-type with domain @t 0 .. (n-1)@@@ -268,9 +419,9 @@     --     candidateArgs :: [Term] -> Type -> [(Arg QName, Int)]     candidateArgs vs t =-      case ignoreSharing $ unEl t of+      case unEl t of         Pi a b-          | Def d es <- ignoreSharing $ unEl $ unDom a,+          | Def d es <- unEl $ unDom a,             Just us  <- allApplyElims es,             vs == map unArg us -> (d <$ argFromDom a, length vs) : candidateRec b           | otherwise          -> candidateRec b@@ -278,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,7 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.ProjectionLike where  import Agda.Syntax.Abstract.Name (QName) import Agda.TypeChecking.Monad.Base+import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)  makeProjection :: QName -> TCM ()-eligibleForProjectionLike :: QName -> TCM Bool+eligibleForProjectionLike :: (HasConstInfo m) => QName -> m Bool
src/full/Agda/TypeChecking/Quote.hs view
@@ -1,53 +1,55 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Quote where -import Control.Applicative-import Control.Monad.State (runState, get, put)-import Control.Monad.Reader (asks)-import Control.Monad.Writer (execWriterT, tell)-import Control.Monad.Trans (lift)+import Control.Monad -import Data.Char import Data.Maybe (fromMaybe)-import Data.Traversable (traverse)+import qualified Data.Text as T +import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern ( dbPatPerm' )+import Agda.Syntax.Internal.Pattern ( hasDefP ) import Agda.Syntax.Literal-import Agda.Syntax.Position-import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Datatypes ( getConHead )-import Agda.TypeChecking.DropArgs-import Agda.TypeChecking.Free import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Exception import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive.Base import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope -import Agda.Utils.Except import Agda.Utils.Impossible-import Agda.Utils.Monad ( ifM )-import Agda.Utils.Permutation ( Permutation(Perm), compactP, reverseP )-import Agda.Utils.String ( Str(Str), unStr )-import Agda.Utils.VarSet (VarSet)-import qualified Agda.Utils.VarSet as Set-import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.List1 ( pattern (:|) )+import Agda.Utils.List2 ( pattern List2 )+import Agda.Utils.Size+import qualified Agda.Utils.Maybe.Strict as Strict -#include "undefined.h"+-- | Parse @quote@.+quotedName :: (MonadTCError m, MonadAbsToCon m) => A.Expr -> m QName+quotedName = \case+  -- 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 (AmbQ (x :| xs)) = case xs of+      []   -> return x+      y:ys -> typeError $ CannotQuote $ CannotQuoteAmbiguous $ List2 x y ys + data QuotingKit = QuotingKit   { quoteTermWithKit   :: Term       -> ReduceM Term   , quoteTypeWithKit   :: Type       -> ReduceM Term-  , quoteClauseWithKit :: Clause     -> ReduceM Term   , quoteDomWithKit    :: Dom Type   -> ReduceM Term   , quoteDefnWithKit   :: Definition -> ReduceM Term   , quoteListWithKit   :: forall a. (a -> ReduceM Term) -> [a] -> ReduceM Term@@ -55,12 +57,15 @@  quotingKit :: TCM QuotingKit quotingKit = do-  currentFile     <- fromMaybe __IMPOSSIBLE__ <$> asks envCurrentPath+  currentModule   <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule   hidden          <- primHidden   instanceH       <- primInstance   visible         <- primVisible   relevant        <- primRelevant   irrelevant      <- primIrrelevant+  quantity0       <- primQuantity0+  quantityω       <- primQuantityω+  modality        <- primModalityConstructor   nil             <- primNil   cons            <- primCons   abs             <- primAbsAbs@@ -76,6 +81,7 @@   meta            <- primAgdaTermMeta   lit             <- primAgdaTermLit   litNat          <- primAgdaLitNat+  litWord64       <- primAgdaLitNat   litFloat        <- primAgdaLitFloat   litChar         <- primAgdaLitChar   litString       <- primAgdaLitString@@ -91,12 +97,15 @@   absurdP         <- primAgdaPatAbsurd   set             <- primAgdaSortSet   setLit          <- primAgdaSortLit+  prop            <- primAgdaSortProp+  propLit         <- primAgdaSortPropLit+  inf             <- primAgdaSortInf   unsupportedSort <- primAgdaSortUnsupported   sucLevel        <- primLevelSuc   lub             <- primLevelMax   lkit            <- requireLevels-  Con z _ _       <- ignoreSharing <$> primZero-  Con s _ _       <- ignoreSharing <$> primSuc+  Con z _ _       <- primZero+  Con s _ _       <- primSuc   unsupported     <- primAgdaTermUnsupported    agdaDefinitionFunDef          <- primAgdaDefinitionFunDef@@ -116,22 +125,35 @@       t !@! u = pure t @@ pure u        quoteHiding :: Hiding -> ReduceM Term-      quoteHiding Hidden    = pure hidden-      quoteHiding Instance  = pure instanceH-      quoteHiding NotHidden = pure visible+      quoteHiding Hidden     = pure hidden+      quoteHiding Instance{} = pure instanceH+      quoteHiding NotHidden  = pure visible        quoteRelevance :: Relevance -> ReduceM Term-      quoteRelevance Relevant   = pure relevant-      quoteRelevance Irrelevant = pure irrelevant-      quoteRelevance NonStrict  = pure relevant-      quoteRelevance Forced{}   = pure relevant-      quoteRelevance UnusedArg  = pure relevant+      quoteRelevance = \case+        Relevant        {} -> pure relevant+        Irrelevant      {} -> pure irrelevant+        ShapeIrrelevant {} -> pure relevant +      quoteQuantity :: Quantity -> ReduceM Term+      quoteQuantity (Quantity0 _) = pure quantity0+      quoteQuantity (Quantity1 _) = __IMPOSSIBLE__+      quoteQuantity (Quantityω _) = pure quantityω++      -- TODO: quote Annotation+      quoteModality :: Modality -> ReduceM Term+      quoteModality m =+        modality !@ quoteRelevance (getRelevance m)+                 @@ quoteQuantity  (getQuantity  m)+       quoteArgInfo :: ArgInfo -> ReduceM Term-      quoteArgInfo (ArgInfo h r _ _) = arginfo !@ quoteHiding h @@ quoteRelevance r+      quoteArgInfo (ArgInfo h m _ _ _) =+        arginfo !@ quoteHiding h+                @@ quoteModality m        quoteLit :: Literal -> ReduceM Term       quoteLit l@LitNat{}    = litNat    !@! Lit l+      quoteLit l@LitWord64{} = litWord64 !@! Lit l       quoteLit l@LitFloat{}  = litFloat  !@! Lit l       quoteLit l@LitChar{}   = litChar   !@! Lit l       quoteLit l@LitString{} = litString !@! Lit l@@ -140,55 +162,84 @@        -- We keep no ranges in the quoted term, so the equality on terms       -- is only on the structure.-      quoteSortLevelTerm :: Level -> ReduceM Term-      quoteSortLevelTerm (Max [])              = setLit !@! Lit (LitNat noRange 0)-      quoteSortLevelTerm (Max [ClosedLevel n]) = setLit !@! Lit (LitNat noRange n)-      quoteSortLevelTerm l                     = set !@ quoteTerm (unlevelWithKit lkit l)+      quoteSortLevelTerm :: Term -> Term -> Level -> ReduceM Term+      quoteSortLevelTerm fromLit fromLevel (ClosedLevel n) = fromLit !@! Lit (LitNat n)+      quoteSortLevelTerm fromLit fromLevel l               = fromLevel !@ quoteTerm (unlevelWithKit lkit l)        quoteSort :: Sort -> ReduceM Term-      quoteSort (Type t) = quoteSortLevelTerm t-      quoteSort Prop     = pure unsupportedSort-      quoteSort Inf      = pure unsupportedSort+      quoteSort (Type t) = quoteSortLevelTerm setLit set t+      quoteSort (Prop t) = quoteSortLevelTerm propLit prop t+      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 DLub{}   = 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) = pure unsupportedSort+      quoteSort (DefS d es)  = pure unsupportedSort+      quoteSort (DummyS s)   =__IMPOSSIBLE_VERBOSE__ s        quoteType :: Type -> ReduceM Term       quoteType (El _ t) = quoteTerm t        quoteQName :: QName -> ReduceM Term-      quoteQName x = pure $ Lit $ LitQName noRange x+      quoteQName x = pure $ Lit $ LitQName x        quotePats :: [NamedArg DeBruijnPattern] -> ReduceM Term       quotePats ps = list $ map (quoteArg quotePat . fmap namedThing) ps        quotePat :: DeBruijnPattern -> ReduceM Term-      quotePat (VarP x) | isAbsurdPatternName (dbPatVarName x) = pure absurdP-      quotePat (VarP x)          = varP !@! quoteString (dbPatVarName x)-      quotePat (DotP _)          = pure dotP+      quotePat p@(VarP _ x)+       | patternOrigin p == Just PatOAbsurd = absurdP !@! quoteNat (toInteger $ dbPatVarIndex x)+      quotePat (VarP o x)        = varP !@! quoteNat (toInteger $ dbPatVarIndex x)+      quotePat (DotP _ t)        = dotP !@ quoteTerm t       quotePat (ConP c _ ps)     = conP !@ quoteQName (conName c) @@ quotePats ps-      quotePat (LitP l)          = litP !@ quoteLit l+      quotePat (LitP _ l)        = litP !@ quoteLit l       quotePat (ProjP _ x)       = projP !@ quoteQName x+      -- #4763: quote IApply co/patterns as though they were variables+      quotePat (IApplyP _ _ _ x) = varP !@! quoteNat (toInteger $ dbPatVarIndex x)+      quotePat DefP{}            = pure unsupported -      quoteClause :: Clause -> ReduceM Term-      quoteClause cl@Clause{namedClausePats = ps, clauseBody = body} =+      quoteClause :: Either a Projection -> Clause -> ReduceM Term+      quoteClause proj cl@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body} =         case body of-          Nothing -> absurdClause !@ quotePats ps-          Just b  ->-            let perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm' False ps -- Dot patterns don't count (#2203)-                v    = applySubst (renamingR perm) b-            in normalClause !@ quotePats ps @@ quoteTerm v+          Nothing -> absurdClause !@ quoteTelescope tel @@ quotePats ps'+          Just b  -> normalClause !@ quoteTelescope tel @@ quotePats ps' @@ quoteTerm b+        where+          -- #5128: restore dropped parameters if projection-like+          ps' =+            case proj of+              Left _ -> ps+              Right p  -> pars ++ ps+                where+                  n    = projIndex p - 1+                  pars = map toVar $ take n $ zip (downFrom $ size tel) (telToList tel)+                  toVar (i, d) = argFromDom d <&> \ (x, _) -> unnamed $ I.varP (DBPatVar x i) +      quoteTelescope :: Telescope -> ReduceM Term+      quoteTelescope tel = quoteList quoteTelEntry $ telToList tel++      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 []       = pure nil-      list (a : as) = cons !@ a @@ list as+      list = foldr (\ a as -> cons !@ a @@ as) (pure nil)        quoteList :: (a -> ReduceM Term) -> [a] -> ReduceM Term       quoteList q xs = list (map q xs) -      quoteDom :: (Type -> ReduceM Term) -> Dom Type -> ReduceM Term-      quoteDom q (Dom info t) = arg !@ quoteArgInfo info @@ q t+      quoteDom :: (a -> ReduceM Term) -> Dom a -> ReduceM Term+      quoteDom q Dom{domInfo = info, unDom = t} = arg !@ quoteArgInfo info @@ q t -      quoteAbs :: Subst t a => (a -> ReduceM Term) -> Abs a -> ReduceM Term+      quoteAbs :: Subst a => (a -> ReduceM Term) -> Abs a -> ReduceM Term       quoteAbs q (Abs s t)   = abs !@! quoteString s @@ q t       quoteAbs q (NoAbs s t) = abs !@! quoteString s @@ q (raise 1 t) @@ -198,87 +249,122 @@       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 =+      quoteTerm v = do+        v <- instantiate' v         case unSpine v of           Var n es   ->              let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-             in  var !@! Lit (LitNat noRange $ fromIntegral n) @@ quoteArgs ts+             in  var !@! Lit (LitNat $ fromIntegral n) @@ quoteArgs ts           Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteAbs quoteTerm t           Def x es   -> do-            def <- getConstInfo x-            let d = theDef def-            n <- getDefFreeVars x+            defn <- getConstInfo x+            patlams <- viewTC ePrintingPatternLambdas+            let isSeenPatLam = elem x patlams+            r <- isReconstructed             -- #2220: remember to restore dropped parameters-            qx d @@ list (drop n $ defParameters def ++ map (quoteArg quoteTerm) ts)-            where+            let+              conOrProjPars = defParameters defn r               ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-              qx Function{ funExtLam = Just (ExtLamInfo h nh), funClauses = cs } =-                    extlam !@ list (map (quoteClause . dropArgs (h + nh)) cs)-              qx Function{ funCompiled = Just Fail, funClauses = [cl] } =-                    extlam !@ list [quoteClause $ dropArgs (length (namedClausePats cl) - 1) cl]-              qx _ = def !@! quoteName x-          Con x ci ts -> 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 (Left ()) . (`apply` pars)) cs)+                           @@ list (map (quoteArg quoteTerm) args)+              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 (Left ()) $ cl `apply` pars ]+                           @@ list (drop n $ map (quoteArg quoteTerm) ts)+              qx _ = do+                n <- getDefFreeVars x+                def !@! quoteName x+                     @@ list (drop n $ conOrProjPars ++ map (quoteArg quoteTerm) ts)+            qx (theDef defn)+          Con x ci es | Just ts <- allApplyElims es -> do+            r <- isReconstructed             cDef <- getConstInfo (conName x)             n    <- getDefFreeVars (conName x)-            let args = list $ drop n $ defParameters cDef ++ map (quoteArg quoteTerm) ts+            let args = list $ drop n $ defParameters cDef r ++ map (quoteArg quoteTerm) ts             con !@! quoteConName x @@ args+          Con x ci es -> pure unsupported           Pi t u     -> pi !@  quoteDom quoteType t                             @@ quoteAbs quoteType u           Level l    -> quoteTerm (unlevelWithKit lkit l)           Lit l      -> lit !@ quoteLit l           Sort s     -> sort !@ quoteSort s-          Shared p   -> quoteTerm $ derefPtr p-          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{} -> pure unsupported -- could be exposed at some point but we have to take care+          DontCare u -> quoteTerm u+          Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s -      defParameters :: Definition -> [ReduceM Term]-      defParameters def = map par hiding+      defParameters :: Definition -> Bool -> [ReduceM Term]+      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     = map getHiding $ take np $ telToList tel-          par h      = arg !@ (arginfo !@ quoteHiding h @@ pure relevant) @@ pure unsupported+          hiding     = take np $ telToList tel+          par d      = arg !@ quoteArgInfo (domInfo d)+                           @@ pure unsupported        quoteDefn :: Definition -> ReduceM Term       quoteDefn def =         case theDef def of-          Function{funClauses = cs} ->-            agdaDefinitionFunDef !@ quoteList quoteClause cs+          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-          Record{recConHead = c} ->-            agdaDefinitionRecordDef !@! quoteName (conName c)+          Record{recConHead = c, recFields = fs} ->+            agdaDefinitionRecordDef+              !@! quoteName (conName c)+              @@ quoteList (quoteDom (pure . quoteName)) fs           Axiom{}       -> pure agdaDefinitionPostulate+          DataOrRecSig{} -> pure agdaDefinitionPostulate+          GeneralizableVar{} -> pure agdaDefinitionPostulate  -- TODO: reflect generalizable vars           AbstractDefn{}-> pure agdaDefinitionPostulate           Primitive{primClauses = cs} | not $ null cs ->-            agdaDefinitionFunDef !@ quoteList quoteClause cs+            agdaDefinitionFunDef !@ quoteList (quoteClause (Left ())) cs           Primitive{}   -> pure agdaDefinitionPrimitive-          Constructor{conData = d} ->-            agdaDefinitionDataConstructor !@! quoteName d+          PrimitiveSort{} -> pure agdaDefinitionPrimitive+          Constructor{conData = d, conSrcCon = c} -> do+            q <- getQuantity <$> getConstInfo (conName c)+            agdaDefinitionDataConstructor !@! quoteName d @@ quoteQuantity q -  return $ QuotingKit quoteTerm quoteType quoteClause (quoteDom quoteType) quoteDefn quoteList+  return $ QuotingKit quoteTerm quoteType (quoteDom quoteType) quoteDefn quoteList  quoteString :: String -> Term-quoteString = Lit . LitString noRange+quoteString = Lit . LitString . T.pack  quoteName :: QName -> Term-quoteName x = Lit (LitQName noRange x)+quoteName x = Lit (LitQName x)  quoteNat :: Integer -> Term quoteNat n-  | n >= 0    = Lit (LitNat noRange n)+  | n >= 0    = Lit (LitNat n)   | otherwise = __IMPOSSIBLE__  quoteConName :: ConHead -> Term quoteConName = quoteName . conName -quoteMeta :: AbsolutePath -> MetaId -> Term-quoteMeta file = Lit . LitMeta noRange 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,12 +1,13 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Reconstruct dropped parameters from constructors.  Used by --   with-abstraction to avoid ill-typed abstractions (#745). Note that the---   term in invalid after parameter reconstruction. Parameters need to be+--   term is invalid after parameter reconstruction. Parameters need to be --   dropped again before using it.+ module Agda.TypeChecking.ReconstructParameters where -import Control.Applicative-import Data.Traversable+import Data.Functor ( ($>) )  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -14,20 +15,28 @@  import Agda.TypeChecking.Monad import Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce import Agda.TypeChecking.Telescope import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Datatypes +import Agda.Utils.Either+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Lens import Agda.Utils.Size  import Agda.Utils.Impossible-#include "undefined.h"  reconstructParametersInType :: Type -> TCM Type-reconstructParametersInType a =-  traverse (reconstructParameters (sort $ getSort a)) a+reconstructParametersInType = reconstructParametersInType' defaultAction +reconstructParametersInType' :: Action TCM -> Type -> TCM Type+reconstructParametersInType' act a =+  traverse (reconstructParameters' act (sort $ getSort a)) a+ reconstructParametersInTel :: Telescope -> TCM Telescope reconstructParametersInTel EmptyTel = return EmptyTel reconstructParametersInTel (ExtendTel a tel) = do@@ -36,48 +45,136 @@     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+reconstructParametersInEqView (IdiomType a) = IdiomType <$> reconstructParametersInType a  reconstructParameters :: Type -> Term -> TCM Term-reconstructParameters a v = do-  reportSDoc "tc.with.reconstruct" 30 $-    sep [ text "reconstructing parameters in"-        , nest 2 $ sep [ prettyTCM v <+> text ":", nest 2 $ prettyTCM a ] ]-  v <- checkInternal' (defaultAction{ postAction = reconstruct }) v a-  reportSDoc "tc.with.reconstruct" 30 $-    nest 2 $ text "-->" <+> prettyTCM v+reconstructParameters = reconstructParameters' defaultAction++reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term+reconstructParameters' act a v = do+  reportSDoc "tc.reconstruct" 30 $+    sep [ "reconstructing parameters in"+        , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]+  v <- checkInternal' (reconstructAction' act) v CmpLeq a++  reportSDoc "tc.reconstruct" 30 $+    nest 2 $ "-->" <+> prettyTCM 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-    reconstruct a v = do-      case ignoreSharing v of-        Con h ci vs -> do-          TelV tel a <- telView a-          let under = size tel  -- under-applied when under > 0-          reportSDoc "tc.with.reconstruct" 50 $-            sep [ text "reconstructing"-                , nest 2 $ sep [ prettyTCM v <+> text ":"-                               , nest 2 $ prettyTCM a ] ]-          case ignoreSharing (unEl a) of-            Def d es -> do-              Just n <- defParameters <$> getConstInfo d-              let Just ps = applySubst (strengthenS __IMPOSSIBLE__ under) . take n <$> allApplyElims es-              reportSLn "tc.with.reconstruct" 50 $ show n ++ " parameters"-              -- TODO: the reconstructed parameters are not reconstructed recursively!-              return $ Con h ci (ps ++ vs)-            _ -> __IMPOSSIBLE__-        _        -> return v+    -- @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 []           = 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 (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' (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 (f [])+      reportSDoc "tc.reconstruct" 50 $ "The proj is:" <+> prettyTCM p+      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__ +-- 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 dropPars-  where-    dropPars v =-      case ignoreSharing v of+dropParameters = traverseTermM $+    \case         Con c ci vs -> do           Constructor{ conData = d } <- theDef <$> getConstInfo (conName c)           Just n <- defParameters <$> getConstInfo d           return $ Con c ci $ drop n vs-        _        -> return v+        v@(Def f vs) -> do+          isRelevantProjection f >>= \case+            Nothing -> return v+            Just pr -> return $ applyE (projDropPars pr ProjSystem) vs+        v -> return v
src/full/Agda/TypeChecking/RecordPatterns.hs view
@@ -1,33 +1,34 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Code which replaces pattern matching on record constructors with -- uses of projection functions.  module Agda.TypeChecking.RecordPatterns-  ( translateRecordPatterns-  , translateCompiledClauses+  ( translateCompiledClauses   , translateSplitTree   , recordPatternToProjections+  , recordRHSToCopatterns   ) where -import Control.Applicative-import Control.Arrow (first, second)-import Control.Monad.Fix-import Control.Monad.Reader-import Control.Monad.State+import Control.Arrow          ( first, second )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Reader   ( MonadReader(..), ReaderT(..), runReaderT )+import Control.Monad.State    ( MonadState(..), StateT(..), runStateT ) -import Data.List+import qualified Data.List as List import Data.Maybe import qualified Data.Map as Map-import qualified Data.Traversable as Trav +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@@ -35,17 +36,18 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +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.List-import qualified Agda.Utils.Map as Map-import Agda.Utils.Maybe+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) -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -61,18 +63,25 @@ recordPatternToProjections :: DeBruijnPattern -> TCM [Term -> Term] recordPatternToProjections p =   case p of-    VarP{}       -> return [ \ x -> x ]+    VarP{}       -> return [ id ]     LitP{}       -> typeError $ ShouldBeRecordPattern p     DotP{}       -> typeError $ ShouldBeRecordPattern p     ConP c ci ps -> do-      whenNothing (conPRecord ci) $+      unless (conPRecord ci) $         typeError $ ShouldBeRecordPattern p-      t <- reduce $ fromMaybe __IMPOSSIBLE__ $ conPType ci-      fields <- getRecordTypeFields (unArg t)+      let t = unArg $ fromMaybe __IMPOSSIBLE__ $ conPType ci+      reportSDoc "tc.rec" 45 $ vcat+        [ "recordPatternToProjections: "+        , nest 2 $ "constructor pattern " <+> prettyTCM p <+> " has type " <+> prettyTCM t+        ]+      reportSLn "tc.rec" 70 $ "  type raw: " ++ show t+      fields <- getRecordTypeFields t       concat <$> zipWithM comb (map proj fields) (map namedArg ps)     ProjP{}      -> __IMPOSSIBLE__ -- copattern cannot appear here+    IApplyP{}    -> typeError $ ShouldBeRecordPattern p+    DefP{}       -> typeError $ ShouldBeRecordPattern p   where-    proj p = (`applyE` [Proj ProjSystem $ unArg p])+    proj p = (`applyE` [Proj ProjSystem $ unDom p])     comb :: (Term -> Term) -> DeBruijnPattern -> TCM [Term -> Term]     comb prj p = map (\ f -> f . prj) <$> recordPatternToProjections p @@ -86,11 +95,12 @@ conjColumns :: [[Bool]] -> [Bool] conjColumns =  foldl1 (zipWith (&&)) --- | @insertColumn i a m@ inserts a column before the @i@th column in---   matrix @m@ and fills it with value @a@.-insertColumn :: Int -> a -> [[a]] -> [[a]]-insertColumn i a rows = map ins rows where-  ins row = let (init, last) = splitAt i row in init ++ a : last+-- UNUSED Liang-Ting 2019-07-16+---- | @insertColumn i a m@ inserts a column before the @i@th column in+----   matrix @m@ and fills it with value @a@.+--insertColumn :: Int -> a -> [[a]] -> [[a]]+--insertColumn i a rows = map ins rows where+--  ins row = let (init, last) = splitAt i row in init ++ a : last  {- UNUSED -- | @cutColumn i m@ removes the @i@th column from matrix @m@.@@ -104,229 +114,233 @@ cutColumns i n rows = unzip (map (cutSublist i n) rows) -} --- | @cutSublist i n xs = (xs', ys, xs'')@ cuts out a sublist @ys@---   of width @n@ from @xs@, starting at column @i@.-cutSublist :: Int -> Int -> [a] -> ([a], [a], [a])-cutSublist i n row =-  let (init, rest) = splitAt i row-      (mid , last) = splitAt n rest-  in  (init, mid, last)+-- UNUSED Liang-Ting 2019-07-16+---- | @cutSublist i n xs = (xs', ys, xs'')@ cuts out a sublist @ys@+----   of width @n@ from @xs@, starting at column @i@.+--cutSublist :: Int -> Int -> [a] -> ([a], [a], [a])+--cutSublist i n row =+--  let (init, rest) = splitAt i row+--      (mid , last) = splitAt n rest+--  in  (init, mid, last) -getEtaAndArity :: QName -> TCM (Bool, Nat)-getEtaAndArity c =-  for (getConstructorInfo c) $ \i ->-  case i of-    DataCon n        -> (False, n)-    RecordCon eta fs -> (eta == YesEta, size fs)+getEtaAndArity :: SplitTag -> TCM (Bool, Nat)+getEtaAndArity (SplitCon c) =+  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 :: CompiledClauses -> TCM CompiledClauses-translateCompiledClauses cc = snd <$> loop cc-  where+translateCompiledClauses+  :: forall m. (HasConstInfo m, MonadChange m)+  => 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+    ] -    loop :: CompiledClauses -> TCM ([Bool], CompiledClauses)+  cc <- loop cc+  reportSDoc "tc.cc.record" 20 $ vcat+    [ "translated compiled clauses (no eta record patterns):"+    , nest 2 $ return $ pretty cc+    ]++  -- 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 (repeat True, cc)-      Done xs t -> return (map (const True) xs, cc)+      Fail{}    -> return cc+      Done{}    -> return cc       Case i cs -> loops i cs -    loops :: Arg Int              -- ^ split variable-          -> Case CompiledClauses -- ^ original split tree-          -> TCM ([Bool], CompiledClauses)-    loops i cs@Branches{ projPatterns   = cop+    loops :: Arg Int               -- split variable+          -> Case CompiledClauses  -- original split tree+          -> m CompiledClauses+    loops i cs@Branches{ projPatterns   = comatch                        , conBranches    = conMap+                       , etaBranch      = eta                        , litBranches    = litMap-                       , catchAllBranch = catchAll } = do+                       , fallThrough    = fT+                       , catchallBranch = catchall+                       , lazyMatch      = lazy } = do -      -- recurse on and compute variable status of catch-all clause-      (xssa, catchAll) <- unzipMaybe <$> Trav.mapM loop catchAll-      let xsa = maybe (repeat True) id xssa+      catchall <- traverse loop catchall+      litMap   <- traverse loop litMap+      (conMap, eta) <- do+        let noEtaCase = (, Nothing) <$> (traverse . traverse) loop conMap+            yesEtaCase b ch = (Map.empty,) . Just . (ch,) <$> traverse loop b+        case Map.toList conMap of+              -- This is already an eta match. Still need to recurse though.+              -- This can happen (#2981) when we+              -- 'revisitRecordPatternTranslation' in Rules.Decl, due to+              -- inferred eta.+          _ | Just (ch, b) <- eta -> yesEtaCase b ch+          [(c, b)] | not comatch -> -- possible eta-match+            getConstructorInfo' c >>= \ case+              Just (RecordCon pm YesEta _ar fs) -> yesEtaCase b $+                ConHead c (IsRecord pm) Inductive (map argFromDom fs)+              _ -> noEtaCase+          _ -> noEtaCase+      return $ Case i cs{ conBranches    = conMap+                        , etaBranch      = eta+                        , litBranches    = litMap+                        , fallThrough    = fT+                        , catchallBranch = catchall+                        } -      -- recurse on compute variable status of literal clauses-      (xssl, litMap)   <- Map.unzip <$> Trav.mapM loop litMap-      let xsl = conjColumns (xsa : insertColumn (unArg i) False (Map.elems xssl)) -      -- recurse on constructor clauses-      (ccs, xssc, conMap)    <- Map.unzip3 <$> do-        Trav.forM (Map.mapWithKey (,) conMap) $ \ (c, WithArity ar cc) -> do-          (xs, cc)     <- loop cc-          dataOrRecCon <- do-            isProj <- isProjection c-            case isProj of-              Nothing -> do-                i <- getConstructorInfo c-                case i of-                  DataCon n           -> return $ Left n-                  RecordCon NoEta fs  -> return $ Left (size fs)-                  RecordCon YesEta fs -> return $ Right fs-              Just{}  -> return $ Left 0-          let (isRC, n)   = either (False,) ((True,) . size) dataOrRecCon-              (xs0, rest) = genericSplitAt (unArg i) xs-              (xs1, xs2 ) = genericSplitAt n rest-              -- if all dropped variables (xs1) are virgins and we are record cons.-              -- then new variable x is also virgin-              -- and we can translate away the split-              x           = isRC && and xs1-              -- xs' = updated variables-              xs'         = xs0 ++ x : xs2-              -- get the record fields-              fs          = either __IMPOSSIBLE__ id dataOrRecCon-              -- if x we can translate-              mcc = if x then [replaceByProjections i (map unArg fs) cc] else []+-- | 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 -          when (n /= ar) __IMPOSSIBLE__-          return (mcc, xs', WithArity ar cc)+recordRHSToCopatterns ::+     forall m. (MonadChange m, PureTCM m)+  => Clause+  -> m [Clause]+recordRHSToCopatterns cl0 = do+  reportSLn "tc.inline.con" 40 $ "enter recordRHSToCopatterns" -      -- compute result-      let xs = conjColumns (xsl : Map.elems xssc)-      case concat $ Map.elems ccs of-        -- case: no record pattern was translated-        []   -> return (xs, Case i $ Branches-                  { projPatterns = cop-                  , conBranches = conMap-                  , litBranches = litMap-                  , catchAllBranch = catchAll })+  etaExpandClause cl0 >>= \case -        -- case: translated away one record pattern-        [cc] -> do-                -- Andreas, 2013-03-22-                -- Due to catch-all-expansion this is actually possible:-                -- -- we cannot have a catch-all if we had a record pattern-                -- whenJust catchAll __IMPOSSIBLE__-                -- We just drop the catch-all clause.  This is safe because-                -- for record patterns we have expanded all the catch-alls.-                return (xs, cc) -- mergeCatchAll cc catchAll)+    -- 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 -        -- case: more than one record patterns (impossible)-        _    -> __IMPOSSIBLE__+          -- Only expand constructors labelled @{-# INLINE c #-}@.+      -> inlineConstructor c >>= \case+        Nothing  -> return [cl0]+        Just eta -> do -{- UNUSED-instance Monoid CompiledClauses where-  mempty = __IMPOSSIBLE__-  mappend (Case n c) (Case n' c') | n == n' = Case n $ mappend c c'-  mappend _ _ = __IMPOSSIBLE__+          mt <- traverse reduce mt -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--}--}+          -- If it may change definitional equality,+          -- announce that the translation actually fired.+          unless eta tellDirty --- | @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+          -- Iterate the translation for nested constructor rhss.+          recordRHSsToCopatterns =<< do -      loop :: Int -> CompiledClauses -> CompiledClauses-      loop i cc = case cc of-        Case j cs+            -- Create one clause per projection.+            forM (zip fs vs) $ \ (f, v) -> do -        -- 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+              -- Get the type of the field.+              let inst :: Type -> m (Maybe Type)+                  inst t = fmap thd3 <$> projectTyped v0 t ProjSystem (unArg f) -        -- if j >= i then we shrink j by (n-1)-          | otherwise   -> Case (j <&> \ k -> k - (n-1)) $ fmap (loop i) cs+              let fuse :: Maybe (Arg (Maybe a)) -> Maybe (Arg a)+                  fuse = join . fmap distributeF -        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+              mt' :: Maybe (Arg Type) <- fuse <$> traverse (traverse inst) mt -        Fail -> Fail+              reportSDoc "tc.inline.con" 50 $ vcat+                [ "for field" <+> prettyTCM (unArg f) <+> ": "+                , "  mt  =" <+> prettyTCM mt+                , "  mt' =" <+> prettyTCM mt'+                ] -      loops :: Int -> Case CompiledClauses -> Case CompiledClauses-      loops i Branches{ projPatterns   = cop-                      , conBranches    = conMap-                      , litBranches    = litMap-                      , catchAllBranch = catchAll } =-        Branches{ projPatterns   = cop-                , conBranches    = fmap (\ (WithArity n c) -> WithArity n $ loop (i + n - 1) c) conMap-                , litBranches    = fmap (loop (i - 1)) litMap-                , catchAllBranch = fmap (loop i) catchAll+              -- Make clause ... .f = v+              return cl+                { namedClausePats = ps ++ [ unnamed . ProjP ProjSystem <$> f ]+                , clauseBody      = Just $ unArg v+                , clauseType      = mt'                 }-  in  loop i cc --- | 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-------------------------------------------------------------------------------- | Split tree annotation.-data RecordSplitNode = RecordSplitNode-  { splitCon           :: QName  -- ^ Constructor name 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--+    -- Otherwise: no change.+    _ -> return [cl0] --- | Bottom-up procedure to annotate split tree.-recordSplitTree :: SplitTree -> TCM RecordSplitTree-recordSplitTree t = snd <$> loop t   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 -    loop :: SplitTree -> TCM ([Bool], RecordSplitTree)-    loop t = case t of-      SplittingDone n -> return (replicate n True, SplittingDone n)-      SplitAt i ts    -> do-        (xs, ts) <- loops (unArg i) ts-        return (xs, SplitAt i ts)+-- | Transform definitions returning record expressions to use copatterns+--   instead. This prevents terms from blowing up when reduced.+recordExpressionsToCopatterns+  :: (HasConstInfo m, MonadChange m)+  => CompiledClauses+  -> m CompiledClauses+recordExpressionsToCopatterns = \case+    Case i bs -> Case i <$> traverse recordExpressionsToCopatterns bs+    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+      irrProj <- optIrrelevantProjections <$> pragmaOptions+      getConstructorInfo (conName c) >>= \ case+        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)+                traverse recordExpressionsToCopatterns $ Branches+                  { projPatterns   = True+                  , conBranches    = Map.fromListWith __IMPOSSIBLE__ $+                      zipWith (\ f v -> (unDom f, WithArity 0 $ Done xs v)) fs vs+                  , etaBranch      = Nothing+                  , litBranches    = Map.empty+                  , catchallBranch = Nothing+                  , fallThrough    = Nothing+                  , lazyMatch      = False+                  }+        _ -> return cc+    cc@Done{} -> return cc -    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) = genericSplitAt i xs-              (xs1, xs2)  = genericSplitAt n rest-              x           = isRC && and xs1-              xs'         = xs0 ++ x : xs2-          return (xs, (RecordSplitNode c n x, t))-      return (foldl1 (zipWith (&&)) xss, ts)+---------------------------------------------------------------------------+-- * Record pattern translation for split trees+---------------------------------------------------------------------------  -- | Bottom-up procedure to record-pattern-translate split tree. translateSplitTree :: SplitTree -> TCM SplitTree-translateSplitTree t = snd <$> loop t+translateSplitTree = snd <.> loop   where      -- @loop t = return (xs, t')@ returns the translated split tree @t'@@@ -334,11 +348,11 @@     --   True  = variable will never be split on in @t'@ (virgin variable)     --   False = variable will be spilt on in @t'@     loop :: SplitTree -> TCM ([Bool], SplitTree)-    loop t = case t of+    loop = \case       SplittingDone n ->         -- start with n virgin variables         return (replicate n True, SplittingDone n)-      SplitAt i ts    -> do+      SplitAt i lz ts    -> do         (x, xs, ts) <- loops (unArg i) ts         -- if we case on record constructor, drop case         let t' = if x then@@ -346,11 +360,11 @@                      [(c,t)] -> t                      _       -> __IMPOSSIBLE__                   -- else retain case-                  else SplitAt i ts+                  else SplitAt i lz ts         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@@ -360,8 +374,8 @@           (xs, t) <- loop t           (isRC, n) <- getEtaAndArity c           -- now drop variables from i to i+n-1-          let (xs0, rest) = genericSplitAt i xs-              (xs1, xs2)  = genericSplitAt n rest+          let (xs0, rest) = splitAt i xs+              (xs1, xs2)  = splitAt n rest               -- if all dropped variables are virgins and we are record cons.               -- then new variable x is also virgin               -- and we can translate away the split@@ -376,7 +390,7 @@       -- invariant: if record constructor, then exactly one constructor       if x then unless (rs == [True]) __IMPOSSIBLE__       -- else no record constructor-       else unless (or rs == False) __IMPOSSIBLE__+       else when (or rs) __IMPOSSIBLE__       return (x, conjColumns xss, ts)  -- | @dropFrom i n@ drops arguments @j@  with @j < i + n@ and @j >= i@.@@ -385,11 +399,11 @@   dropFrom :: Int -> Int -> a -> a  instance DropFrom (SplitTree' c) where-  dropFrom i n t = case t of+  dropFrom i n = \case     SplittingDone m -> SplittingDone (m - n)-    SplitAt x@(Arg ai j) ts-      | j >= i + n -> SplitAt (Arg ai $ j - n) $ dropFrom i n ts-      | j < i      -> SplitAt x $ dropFrom i n ts+    SplitAt x@(Arg ai j) lz ts+      | j >= i + n -> SplitAt (Arg ai $ j - n) lz $ dropFrom i n ts+      | j < i      -> SplitAt x lz $ dropFrom i n ts       | otherwise  -> __IMPOSSIBLE__  instance DropFrom (c, SplitTree' c) where@@ -397,373 +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'--      -- 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 dummyDom snd) newTel'-        -- It is important that dummyDom does not mention any variable-        -- (see the definition of reorderTel).-        where-        isDotP n = case 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-      [ text "Original clause:"-      , nest 2 $ inTopContext $ vcat-        [ text "delta =" <+> prettyTCM (clauseTel clause)-        , text "pats  =" <+> text (show $ clausePats clause)-        ]-      , text "Intermediate results:"-      , nest 2 $ vcat-        [ text "ps        =" <+> text (show ps)-        , text "s         =" <+> prettyList (map prettyTCM s)-        , text "cs        =" <+> prettyList (map prettyTCM cs)-        , text "flattenedOldTel =" <+> (text . show) flattenedOldTel-        , text "newTel'   =" <+> (text . show) newTel'-        , text "newPerm   =" <+> prettyTCM newPerm-        ]-      ]--  reportSDoc "tc.lhs.recpat" 20 $ vcat-        [ text "lhsSubst' =" <+> (text . show) lhsSubst'-        , text "lhsSubst  =" <+> (text . show) lhsSubst-        , text "newTel  =" <+> prettyTCM newTel-        ]--  reportSDoc "tc.lhs.recpat" 10 $-    escapeContext (size $ clauseTel clause) $ vcat-      [ text "Translated clause:"-      , nest 2 $ vcat-        [ text "delta =" <+> prettyTCM (clauseTel c)-        , text "ps    =" <+> text (show $ clausePats c)-        , text "body  =" <+> text (show $ clauseBody c)-        , text "body  =" <+> addContext (clauseTel c) (maybe (text "_|_") 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,-            MonadReader TCEnv, MonadState TCState)---- | 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 =-    P.text "(VarPat:" P.<+> P.text (show $ f VarPat) P.<+>-    P.text "DotPat:"  P.<+> P.text (show $ f DotPat) P.<> P.text ")"--instance PrettyTCM (Kind -> Nat) where-  prettyTCM = return . pretty--instance PrettyTCM Change where-  prettyTCM (Left  p) = prettyTCM p-  prettyTCM (Right (f, x, t)) = text "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 = genericLength $ 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-  | Just ConOSystem <- conPRecord 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@VarP{} = removeTree (Leaf p)-translatePattern p@DotP{} = removeTree (Leaf p)-translatePattern p@LitP{} = return (p, [], [])-translatePattern p@ProjP{}= 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 (ConP c ci ps) | Just ConOSystem <- conPRecord 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-      fields <- getRecordTypeFields (unArg t)---      let proj p = \x -> Def (unArg p) [defaultArg x]-      let proj p = (`applyE` [Proj ProjSystem $ unArg p])-      return $ Right $ RecCon t $ zip (map proj fields) ts-recordTree p@(ConP _ ci _) = 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----------------------------------------------------------------------------- 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-                                                (genericDrop (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
@@ -1,131 +1,228 @@-{-# LANGUAGE CPP                      #-} {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Records where --- import Control.Applicative-import Control.Monad+import Prelude hiding (null) -import Data.Function-import Data.List+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 Data.Traversable (traverse)+import qualified Data.HashMap.Strict as HMap  import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Concrete (FieldAssignment'(..), nameFieldA)+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 Agda.TypeChecking.Substitute-import Agda.TypeChecking.Pretty+import qualified Agda.TypeChecking.Monad.Base.Warning as W+import Agda.TypeChecking.Pretty as TCM import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad ()+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 qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.Singleton import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible +---------------------------------------------------------------------------+-- * Tools to build record values++mkCon :: ConHead -> ConInfo -> Args -> Term+mkCon h info args = Con h info (map Apply args)+ -- | Order the fields of a record construction.---   Use the second argument for missing fields.-orderFields :: QName -> a -> [C.Name] -> [(C.Name, a)] -> TCM [a]-orderFields r def xs fs = do-  unlessNull (ys \\ nub ys) $ typeError . DuplicateFields . nub-  unlessNull (ys \\ xs)     $ typeError . TooManyFields r-  -- shouldBeNull (xs \\ ys)     $ TooFewFields r-  return $ order xs fs+orderFields+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).+  -> (Arg C.Name -> a) -- ^ How to fill a missing field.+  -> [Arg C.Name]      -- ^ Field names of the record type.+  -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.+  -> Writer [RecordFieldWarning] [a]           -- ^ Content arranged in official order.+orderFields r fill axs fs = do+  -- reportSDoc "tc.record" 30 $ vcat+  --   [ "orderFields"+  --   , "  official fields: " <+> sep (map pretty xs)+  --   , "  provided fields: " <+> sep (map pretty ys)+  --   ]+  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-    ys = map fst fs+    (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 . fmap (second getRange) -    -- invariant: the first list contains at least the fields of the second list-    order [] [] = []-    order [] _  = __IMPOSSIBLE__-    order (x : xs) ys = case lookup x (assocHoles ys) of-      Just (e, ys') -> e : order xs ys'-      Nothing       -> def : order xs ys+-- | Raise generated 'RecordFieldWarning's as warnings.+warnOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a+warnOnRecordFieldWarnings comp = do+  let (res, ws) = runWriter comp+  mapM_ (warning . RecordFieldWarning) ws+  return res -    assocHoles xs = [ (x, (v, xs')) | ((x, v), xs') <- holes xs ]+-- | Raise generated 'RecordFieldWarning's as errors.+failOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a+failOnRecordFieldWarnings comp = do+  let (res, ws) = runWriter comp+  mapM_ (typeError . recordFieldWarningToError) ws+    -- This will raise the first warning (if any) as error.+  return res +-- | Order the fields of a record construction.+--   Raise generated 'RecordFieldWarning's as warnings.+orderFieldsWarn+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).+  -> (Arg C.Name -> a) -- ^ How to fill a missing field.+  -> [Arg C.Name]      -- ^ Field names of the record type.+  -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.+  -> TCM [a]           -- ^ Content arranged in official order.+orderFieldsWarn r fill axs fs = warnOnRecordFieldWarnings $ orderFields r fill axs fs++-- | Order the fields of a record construction.+--   Raise generated 'RecordFieldWarning's as errors.+orderFieldsFail+  :: forall a . HasRange a+  => QName             -- ^ Name of record type (for error message).+  -> (Arg C.Name -> a) -- ^ How to fill a missing field.+  -> [Arg C.Name]      -- ^ Field names of the record type.+  -> [(C.Name, a)]     -- ^ Provided fields with content in the record expression.+  -> TCM [a]           -- ^ Content arranged in official order.+orderFieldsFail r fill axs fs = failOnRecordFieldWarnings $ orderFields r fill axs fs+ -- | A record field assignment @record{xs = es}@ might not mention all --   visible fields.  @insertMissingFields@ inserts placeholders for --   the missing visible fields and returns the values in order --   of the fields in the record declaration. insertMissingFields-  :: QName                -- ^ Name of record type (for error reporting).+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).   -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.   -> [FieldAssignment' a] -- ^ Given fields.   -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.-  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+  -> Writer [RecordFieldWarning] [NamedArg a]+       -- ^ Given fields enriched by placeholders for missing explicit fields. insertMissingFields r placeholder fs axs = do-  let -- Just field names.-      xs   = map unArg axs   -- Compute the list of given fields, decorated with the ArgInfo from the record def.-  let arg x e =-        case [ a | a <- axs, unArg a == x ] of-          [a] -> unnamed e <$ a-          _   -> defaultNamedArg e -- we only end up here if the field names are bad+  let arg x e = caseMaybe (List.find ((x ==) . unArg) axs) (defaultNamedArg e) $ \ a ->+        nameIfHidden a e <$ a       givenFields = [ (x, Just $ arg x e) | FieldAssignment x e <- fs ]-  -- Compute a list of p[aceholders for the missing visible fields.-  let missingExplicits =-       [ (x, Just $ setOrigin Inserted $ unnamed . placeholder <$> a)-       | a <- filter notHidden axs-       , let x = unArg a-       , x `notElem` map (view nameFieldA) fs-       ]-  -- In es omitted explicit fields are replaced by placeholders-  -- (from missingExplicits). Omitted implicit or instance fields++  -- Omitted explicit fields are filled in with placeholders.+  -- Omitted implicit or instance fields   -- are still left out and inserted later by checkArguments_.-  catMaybes <$> do-    -- Default value @Nothing@ will only be used for missing hidden fields.-    -- These can be ignored as they will be inserted by @checkArguments_@.-    orderFields r Nothing xs $ givenFields ++ missingExplicits+  catMaybes <$> orderFields r fill axs givenFields+  where+    fill :: Arg C.Name -> Maybe (NamedArg a)+    fill ax+      | visible ax = Just $ setOrigin Inserted $ unnamed . placeholder <$> ax+      | otherwise  = Nothing+    -- Andreas, 2017-04-13, issue #2494+    -- We need to put the field names as argument names for hidden arguments.+    -- Otherwise, insertImplicit does not do the right thing.+    nameIfHidden :: Arg C.Name -> c -> Named_ c+    nameIfHidden ax+      | visible ax = unnamed+      | otherwise  = named $ WithOrigin Inserted $ Ranged (getRange ax) $ prettyShow $ unArg ax +-- | A record field assignment @record{xs = es}@ might not mention all+--   visible fields.  @insertMissingFields@ inserts placeholders for+--   the missing visible fields and returns the values in order+--   of the fields in the record declaration.+insertMissingFieldsWarn+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).+  -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.+  -> [FieldAssignment' a] -- ^ Given fields.+  -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.+  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+insertMissingFieldsWarn r placeholder fs axs =+  warnOnRecordFieldWarnings $ insertMissingFields r placeholder fs axs --- | The name of the module corresponding to a record.-recordModule :: QName -> ModuleName-recordModule = mnameFromList . qnameToList+-- | A record field assignment @record{xs = es}@ might not mention all+--   visible fields.  @insertMissingFields@ inserts placeholders for+--   the missing visible fields and returns the values in order+--   of the fields in the record declaration.+insertMissingFieldsFail+  :: forall a . HasRange a+  => QName                -- ^ Name of record type (for error reporting).+  -> (C.Name -> a)        -- ^ Function to generate a placeholder for missing visible field.+  -> [FieldAssignment' a] -- ^ Given fields.+  -> [Arg C.Name]         -- ^ All record field names with 'ArgInfo'.+  -> TCM [NamedArg a]     -- ^ Given fields enriched by placeholders for missing explicit fields.+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 :: QName -> TCM Defn-getRecordDef r = maybe err return =<< isRecord r-  where err = typeError $ ShouldBeRecordType (El Prop $ Def 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. getRecordOfField :: QName -> TCM (Maybe QName) getRecordOfField d = caseMaybeM (isProjection d) (return Nothing) $   \ Projection{ projProper = proper, projFromType = r} ->-    return $ if proper then Just (unArg r) else Nothing+    return $ unArg r <$ proper -- if proper then Just (unArg r) else Nothing  -- | Get the field names of a record.-getRecordFieldNames :: QName -> TCM [Arg C.Name]+getRecordFieldNames :: (HasConstInfo m, ReadTCState m, MonadError TCErr m)+  => QName+  -> m [Dom C.Name] getRecordFieldNames r = recordFieldNames <$> getRecordDef r -recordFieldNames :: Defn -> [Arg 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] findPossibleRecords fields = do-  defs  <- HMap.elems <$> use (stSignature . sigDefinitions)-  idefs <- HMap.elems <$> use (stImports   . sigDefinitions)-  return $ cands defs ++ cands idefs+  defs  <- HMap.elems <$> useTC (stSignature . sigDefinitions)+  idefs <- HMap.elems <$> useTC (stImports   . sigDefinitions)+  scope <- getScope+  return $ filter (`isNameInScope` scope) $ cands defs ++ cands idefs   where     cands defs = [ defName d | d <- defs, possible d ]     possible def =@@ -133,18 +230,17 @@       -- in the fields of record @def@ (if it is a record).       case theDef def of         Record{ recFields = fs } -> Set.isSubsetOf given $-          Set.fromList $ map (nameConcrete . qnameName . unArg) fs+          Set.fromList $ map (nameConcrete . qnameName . unDom) fs         _ -> 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 -> TCM [Arg QName]-getRecordTypeFields t =-  case ignoreSharing $ unEl t of+getRecordTypeFields+  :: Type  -- ^ Record type.  Need not be reduced.+  -> TCM [Dom QName]+getRecordTypeFields t = do+  t <- reduce t  -- Andreas, 2018-03-03, fix for #2989.+  case unEl t of     Def r _ -> do       rDef <- theDef <$> getConstInfo r       case rDef of@@ -154,34 +250,23 @@  -- | Returns the given record type's constructor name (with an empty -- range).-getRecordConstructor :: QName -> TCM 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 :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead+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 :: Type -> TCM (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 :: Type -> TCM (Either (Maybe Type) (QName, Args, Defn))-tryRecordType t = ifBlockedType t (\ _ _ -> return $ Left Nothing) $ \ t -> do-  let no = return $ Left $ Just t-  case ignoreSharing $ unEl t of+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     Def r es -> do       let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es       caseMaybeM (isRecord r) no $ \ def -> return $ Right (r,vs,def)@@ -196,7 +281,7 @@       fallback = return (f, def, proj)   caseMaybe proj fallback $     \ p@Projection{ projProper = proper, projOrig = f' } ->-      if not proper || f == f' then fallback else do+      if isNothing proper || f == f' then fallback else do         def <- getConstInfo f'         return (f', def, isProjection_ $ theDef def) @@ -209,7 +294,7 @@ --   Precondition: @t@ is reduced. -- --   See also: 'Agda.TypeChecking.Datatypes.getConType'-getDefType :: QName -> Type -> TCM (Maybe Type)+getDefType :: PureTCM m => QName -> Type -> m (Maybe Type) getDefType f t = do   -- Andreas, Issue #1973: we need to take the original projection   -- since the parameters from the reduced type t are correct for@@ -222,9 +307,9 @@   -- if @f@ is not a projection (like) function, @a@ is the correct type       fallback = return $ Just a   reportSDoc "tc.deftype" 20 $ vcat-    [ text "definition f = " <> prettyTCM f <+> text ("raw: " ++ show f)-    , text "has type   a = " <> prettyTCM a-    , text "principal  t = " <> prettyTCM t+    [ "definition f =" <+> prettyTCM f <+> text ("  -- raw: " ++ prettyShow f)+    , "has type   a =" <+> prettyTCM a+    , "principal  t =" <+> prettyTCM t     ]   caseMaybe mp fallback $     \ (Projection{ projIndex = n }) -> if n <= 0 then fallback else do@@ -233,7 +318,7 @@                 | otherwise = n - 1       reportSLn "tc.deftype" 20 $ "projIndex    = " ++ show n       -- we get the parameters from type @t@-      case ignoreSharing $ unEl t of+      case unEl t of         Def d es -> do           -- Andreas, 2013-10-22           -- we need to check this @Def@ is fully reduced.@@ -244,10 +329,10 @@             -- now we know it is reduced, we can safely take the parameters             let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es             reportSDoc "tc.deftype" 20 $ vcat-              [ text $ "head d     = " ++ show d-              , text "parameters =" <+> sep (map prettyTCM pars)+              [ 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@@ -256,13 +341,32 @@     failNotDef  = failure "is not a Def."     failure reason = do       reportSDoc "tc.deftype" 25 $ sep-        [ text "Def. " <+> prettyTCM f <+> text " is projection(like)"-        , text "but the type "+        [ "Def. " <+> prettyTCM f <+> " is projection(like)"+        , "but the type "         , 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).@@ -271,32 +375,108 @@ --   In this case, the first result is not a record type. -- --   Precondition: @t@ is reduced.-projectTyped :: Term -> Type -> ProjOrigin -> QName -> TCM (Maybe (Dom Type, Term, Type))+--+projectTyped+  :: PureTCM m+  => Term        -- ^ Head (record value).+  -> Type        -- ^ Its type.+  -> ProjOrigin+  -> QName       -- ^ Projection.+  -> m (Maybe (Dom Type, Term, Type)) projectTyped v t o f = caseMaybeM (getDefType f t) (return Nothing) $ \ tf -> do   ifNotPiType tf (const $ return Nothing) {- else -} $ \ dom b -> do   u <- applyDef o f (argFromDom dom $> v)   return $ Just (dom, u, b `absApp` v) +-- | Typing of an elimination.++data ElimType+  = ArgT (Dom Type)           -- ^ Type of the argument.+  | ProjT+    { projTRec   :: Dom Type  -- ^ The type of the record which is eliminated.+    , projTField :: Type      -- ^ The type of the field.+    }++instance PrettyTCM ElimType where+  prettyTCM (ArgT a)    = prettyTCM a+  prettyTCM (ProjT a b) =+    "." <> parens (prettyTCM a <+> "->" <+> prettyTCM b)++-- | Given a head and its type, compute the types of the eliminations.++typeElims :: Type -> Term -> Elims -> TCM [ElimType]+typeElims a _ [] = return []+typeElims a self (e : es) = do+  case e of+    -- Andrea 02/08/2017: when going from patterns to elims we+    -- generate an Apply elim even for Path types, because we use VarP+    -- for both, so we have to allow for a Path type here.+    Apply v -> ifNotPiOrPathType a __IMPOSSIBLE__ {- else -} $ \ a b -> do+      (ArgT a :) <$> typeElims (absApp b $ unArg v) (self `applyE` [e]) es+    Proj o f -> do+      a <- reduce a+      (dom, self, a) <- fromMaybe __IMPOSSIBLE__ <$> projectTyped self a o f+      (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 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 = do-  cdef <- theDef <$> getConstInfo c-  case cdef 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) ->+    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 (\ d -> recInduction d /= Just CoInductive || not (recRecursive d)) <$> 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 :: Type -> TCM (Maybe (QName, Args))-isEtaRecordType a = case ignoreSharing $ unEl a of+isEtaRecordType :: (HasConstInfo m)+  => Type+  -> m (Maybe (QName, Args))+isEtaRecordType a = case unEl a of   Def d es -> do     let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es     ifM (isEtaRecord d) (return $ Just (d, vs)) (return Nothing)@@ -304,67 +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 c = do-  def <- theDef <$> getConstInfo c-  case def of+--+isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))+isRecordConstructor c = getConstInfo' c >>= \case+  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.-isGeneratedRecordConstructor :: QName -> TCM Bool-isGeneratedRecordConstructor c = do-  def <- theDef <$> getConstInfo c-  case def of-    Constructor{ conData = r } -> do-      def <- theDef <$> getConstInfo r-      case def of-        Record{ recNamedCon = False } -> return True-        _                             -> return False-    _ -> 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 --- | Mark record type as unguarded.---   No eta-expansion.  Projections do not preserve guardedness.-unguardedRecord :: QName -> TCM ()-unguardedRecord q = modifySignature $ updateDefinition q $ updateTheDef $ \case-  r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) False, recRecursive = True }-  _ -> __IMPOSSIBLE__+-- | Turn off eta for unguarded recursive records.+--   Projections do not preserve guardedness.+unguardedRecord :: QName -> PatternOrCopattern -> TCM ()+unguardedRecord q pat = modifyRecEta q \ eta -> setEtaEquality eta $ NoEta pat --- | Mark record type as recursive.+-- | Turn on eta for non-recursive and inductive guarded recursive records,+--   unless user declared otherwise. --   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 { recRecursive = True, recEtaEquality' = eta' }-      where-      eta' | ok, eta == Inferred False, ind /= Just CoInductive = Inferred True-           | otherwise = eta+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 = 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 False }-      | ind /= Just CoInductive ->-      r { recEtaEquality' = Inferred True }-    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---- | Version of @recRecursive@ with proper internal error.-recRecursive_ :: Defn -> Bool-recRecursive_ (Record { recRecursive = b }) = b-recRecursive_ _ = __IMPOSSIBLE__+isRecursiveRecord q =+  getSignature <&> lookupDefinition q <&> fmap theDef <&> \case+    Just (RecordDefn r) -> recRecursive_ r+    _ -> __IMPOSSIBLE__  {- | @etaExpandBoundVar i = (Δ, σ, τ)@ @@ -386,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@@ -394,24 +565,25 @@       l     = size gamma - 1 - i   -- Extract type of @i@th de Bruijn index.   -- Γ = Γ₁, x:a, Γ₂-  let (gamma1, dom@(Dom ai (x, a)) : gamma2) = splitAt l gamma+  let (gamma1, dom@(Dom{domInfo = ai, unDom = (x, a)}) : gamma2) = splitAt l gamma -- TODO:: Defined but not used dom, ai   -- This must be a eta-expandable record type.   let failure = do         reportSDoc "tc.meta.assign.proj" 25 $-          text "failed to eta-expand variable " <+> pretty x <+>-          text " since its type " <+> prettyTCM a <+>-          text " is not a record type"+          "failed to eta-expand variable " <+> pretty x <+>+          " since its type " <+> prettyTCM a <+>+          " is not a record type"         return Nothing-  caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> do-    if not (recEtaEquality def) then return Nothing else 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  = 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   = Con (recConHead def) ConOSystem ys+          u   = mkCon (_recConHead def) ConOSystem ys       -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@           tau0 = consS u $ raiseS m       -- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@@@ -431,7 +603,11 @@           -- Use "f(x)" as variable name for the projection f(x).           s     = prettyShow x           tel'  = mapAbsNames (\ f -> stringToArgName $ argNameToString f ++ "(" ++ s ++ ")") tel-          delta = telFromList $ gamma1 ++ telToList tel' ++ applySubst tau0 gamma2+          delta = telFromList $ gamma1 ++ telToList tel' +++                    telToList (applySubst tau0 $ telFromList gamma2)+                    -- Andreas, 2017-07-29, issue #2644+                    -- We cannot substitute directly into a ListTel like gamma2,+                    -- we have to convert it to a telescope first, otherwise we get garbage.        return (delta, sigma, tau, tel) @@ -459,29 +635,30 @@ curryAt t n = do   -- first, strip the leading n domains (which remain unchanged)   TelV gamma core <- telViewUpTo n t-  case ignoreSharing $ unEl core of+  case unEl core of     -- There should be at least one domain left-    Pi (Dom ai a) b -> do+    Pi (dom@Dom{domInfo = ai, unDom = a}) b -> do       -- Eta-expand @dom@ along @qs@ into a telescope @tel@, computing a substitution.       -- For now, we only eta-expand once.       -- 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-      unless (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  = recFields def+          fs  = map argFromDom $ _recFields def           ys  = zipWith (\ f i -> f $> var i) fs $ downFrom m-          u   = Con (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 $ Dom ai (absName b, a)+          atel = sgTel $ (,) (absName b) <$> dom           uncurry v = teleLam gamma $ teleLam atel $                         raise (n + 1) v `apply` (xs ++ zs)       return (curry, uncurry, t')@@ -501,40 +678,73 @@      where @tel@ is the record telescope instantiated at the parameters @pars@. -}-etaExpandRecord :: QName -> Args -> Term -> TCM (Telescope, Args)+etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m)+  => 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 :: QName -> Args -> Term -> TCM (Telescope, Args)+forceEtaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m)+  => 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 -etaExpandRecord' :: Bool -> QName -> Args -> Term -> TCM (Telescope, Args)+-- | Eta-expand a value at the given record type (must match).+etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m)+  => 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 <- getRecordDef r+  def <- fromMaybe __IMPOSSIBLE__ <$> isRecord r   (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u   return (tel, args) -etaExpandRecord_ :: QName -> Args -> Defn -> Term -> TCM (Telescope, ConHead, ConInfo, Args)+-- | Eta-expand a value at the given eta record type (must match).+etaExpandRecord_ :: HasConstInfo m+  => 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 -etaExpandRecord'_ :: Bool -> QName -> Args -> Defn -> Term -> TCM (Telescope, ConHead, ConInfo, Args)-etaExpandRecord'_ forceEta r pars def u = do-  let Record{ recConHead     = con-            , recFields      = xs-            , recTel         = tel-            } = def-      eta = recEtaEquality def-      tel' = apply tel pars-  unless (eta || forceEta) __IMPOSSIBLE__ -- make sure we do not expand non-eta records (unless forced to)-  case ignoreSharing u of+-- | Eta-expand a value at the given record type (must match).+etaExpandRecord'_ :: HasConstInfo m+  => 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__+  case u of      -- Already expanded.-    Con con_ ci args -> do-      when (con /= con_) $ do+    Con con_ ci es -> do+      let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+      -- Andreas, 2019-10-21, issue #4148+      -- @con == con_@ might fail, but their normal forms should be equal.+      whenNothingM (conName con `sameDef` conName con_) $ do         reportSDoc "impossible" 10 $ vcat-          [ text "etaExpandRecord_: the following two constructors should be identical"-          , nest 2 $ text $ "con  = " ++ show con-          , nest 2 $ text $ "con_ = " ++ show con_+          [ "etaExpandRecord_: the following two constructors should be identical"+          , nest 2 $ text $ "con  = " ++ prettyShow con+          , nest 2 $ text $ "con_ = " ++ prettyShow con_           ]         __IMPOSSIBLE__       return (tel', con, ci, args)@@ -543,12 +753,12 @@     _ -> do       -- Andreas, < 2016-01-18: Note: recFields are always the original projections,       -- thus, we can use them in Proj directly.-      let xs' = for xs $ fmap $ \ x -> u `applyE` [Proj ProjSystem x]+      let xs' = for (map argFromDom xs) $ fmap $ \ x -> u `applyE` [Proj ProjSystem x]       reportSDoc "tc.record.eta" 20 $ vcat-        [ text "eta expanding" <+> prettyTCM u <+> text ":" <+> prettyTCM r+        [ "eta expanding" <+> prettyTCM u <+> ":" <+> prettyTCM r         , nest 2 $ vcat-          [ text "tel' =" <+> prettyTCM tel'-          , text "args =" <+> prettyTCM xs'+          [ "tel' =" <+> prettyTCM tel'+          , "args =" <+> prettyTCM xs'           ]         ]       return (tel', con, ConOSystem, xs')@@ -557,7 +767,7 @@ etaExpandAtRecordType t u = do   (r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType t   (tel, con, ci, args) <- etaExpandRecord_ r pars def u-  return (tel, Con con ci args)+  return (tel, mkCon con ci args)  -- | The fields should be eta contracted already. --@@ -565,104 +775,257 @@ --   or all fields @f@ are the projection @f v@ of the same value @v@, --   but we need at least one relevant field to find the value @v@. -----   TODO: this can be moved out of TCM (but only if ConHead---   stores also the Arg-decoration of the record fields.+--   If all fields are erased, we cannot eta-contract.++--   Andreas, 2019-11-06, issue #4168: eta-contraction all-erased record+--   lead to compilation error.++--   TODO: this can be moved out of TCM.+--   Andreas, 2018-01-28: attempted just that, but Auto does not+--   put the conFields there (it does not run in TCM).+--   If we get rid of Auto, we can do this.  (Tests not involving Auto pass.)+ {-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> TCM Term #-} {-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> ReduceM Term #-} etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term-etaContractRecord r c ci args = do-  Just Record{ recFields = xs } <- isRecord r-  let check :: Arg Term -> Arg QName -> Maybe (Maybe Term)-      check a ax = do-      -- @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-          -- if @a@ is the record field name applied to a single argument-          -- then it passes the check-          (_, Just (_, [])) -> Nothing  -- not a projection-          (_, Just (h, es)) | Proj _o f <- last es, unArg ax == f-                            -> Just $ Just $ h $ init es-          _                 -> Nothing-      fallBack = return (Con c ci args)+etaContractRecord r c ci args = if all (not . usableModality) args then fallBack else do+  RecordData{ _recFields = xs } <- fromMaybe __IMPOSSIBLE__ <$> isRecord r+  reportSDoc "tc.record.eta.contract" 20 $ vcat+    [ "eta contracting record"+    , nest 2 $ vcat+      [ "record type r  =" <+> prettyTCM r+      , "constructor c  =" <+> prettyTCM c+      , "field names xs =" <+> pretty    xs+      , "fields    args =" <+> prettyTCM args+      ]+    ]   case compare (length args) (length xs) of     LT -> fallBack       -- Not fully applied     GT -> __IMPOSSIBLE__ -- Too many arguments. Impossible.     EQ -> do       case zipWithM check args xs of-        Just as -> case [ a | Just a <- as ] of+        Just as -> case catMaybes as of           (a:as) ->             if all (a ==) as               then return a               else fallBack           _ -> fallBack -- just irrelevant terms         _ -> fallBack  -- a Nothing+  where+  fallBack = return (mkCon c ci args)+  check :: Arg Term -> Dom QName -> Maybe (Maybe Term)+  check a ax = do+  -- @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+      -- if @a@ is the record field name applied to a single argument+      -- then it passes the check+      (_, Just (_, [])) -> Nothing  -- not a projection+      (_, Just (h, e0:es0))+        | (es, Proj _o f) <- initLast1 e0 es0+        , 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 :: QName -> Args -> TCM (Either MetaId Bool)-isSingletonRecord r ps = mapRight 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 :: QName -> Args -> TCM (Either MetaId Bool)-isSingletonRecordModuloRelevance r ps = mapRight isJust <$> isSingletonRecord' True r ps+isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m)+  => 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 garbage.-isSingletonRecord' :: Bool -> QName -> Args -> TCM (Either MetaId (Maybe Term))-isSingletonRecord' regardIrrelevance r ps = do-  reportSLn "tc.meta.eta" 30 $ "Is " ++ show r ++ " a singleton record type?"-  def <- getRecordDef r-  emap (Con (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)+--   contains dummy terms.+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 -> TCM (Either MetaId (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 $-      text "isSingletonRecord' checking telescope " <+> prettyTCM tel+      "isSingletonRecord' checking telescope " <+> prettyTCM tel     case tel of-      EmptyTel -> return $ Right $ Just []-      ExtendTel dom tel-        | isIrrelevant dom && regardIrrelevance -> do-          underAbstraction dom tel $ \ tel ->-            emap (Arg (domInfo dom) garbage :) <$> check tel-        | otherwise -> do-          isSing <- isSingletonType' regardIrrelevance $ unDom dom-          case isSing of-            Left mid       -> return $ Left mid-            Right Nothing  -> return $ Right Nothing-            Right (Just v) -> underAbstraction dom tel $ \ tel ->-              emap (Arg (domInfo dom) v :) <$> check tel-  garbage :: Term-  garbage = Sort Prop+      EmptyTel -> yes+      ExtendTel dom tel -> ifM (return regardIrrelevance `and2M` isIrrelevantOrPropM dom)+        {-then-}+          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check rs)+        {-else-} $ do+          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 :: Type -> TCM (Either MetaId (Maybe Term))-isSingletonType = isSingletonType' False+isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term)+isSingletonType t = isSingletonType' False t mempty  -- | Check whether a type has a unique inhabitant (irrelevant parts ignored). --   Can be blocked by a metavar.-isSingletonTypeModuloRelevance :: (MonadTCM tcm) => Type -> tcm (Either MetaId Bool)-isSingletonTypeModuloRelevance t = liftTCM $ do-  mapRight isJust <$> isSingletonType' True t+isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool+isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t mempty -isSingletonType' :: Bool -> Type -> TCM (Either MetaId (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-    ifBlockedType t (\ m _ -> return $ Left m) $ \ t -> do-      res <- isRecordType t-      case res of-        Just (r, ps, def) | recEtaEquality def -> do-          emap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps-        _ -> return $ Right Nothing+    t <- abortIfBlocked t+    addContext tel $ do+      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) --- | Auxiliary function.-emap :: (a -> b) -> Either c (Maybe a) -> Either c (Maybe b)-emap = mapRight . fmap+        -- 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.+isEtaVar :: forall m. PureTCM m => Term -> Type -> m (Maybe Int)+isEtaVar u a = runMaybeT $ isEtaVarG u a Nothing []+  where+    -- Checks whether the term u (of type a) is beta-eta-equivalent to+    -- `Var i es`, and returns i if it is. If the argument mi is `Just i'`,+    -- then i and i' are also required to be equal (else Nothing is returned).+    isEtaVarG :: Term -> Type -> Maybe Int -> [Elim' Int] -> MaybeT m Int+    isEtaVarG u a mi es = do+      (u, a) <- reduce (u, a)+      reportSDoc "tc.lhs" 80 $ "isEtaVarG" <+> nest 2 (vcat+        [ "u  = " <+> prettyTCM u+        , "a  = " <+> prettyTCM a+        , "mi = " <+> text (show mi)+        , "es = " <+> prettyList_ (map (prettyTCM . fmap var) es)+        ])+      case (u, unEl a) of+        (Var i' es', _) -> do+          guard $ mi == (i' <$ mi)+          b <- typeOfBV i'+          areEtaVarElims (var i') b es' es+          return i'+        (_, Def d pars) -> do+          guard =<< do isEtaRecord d+          fs <- map unDom . recFields . theDef <$> getConstInfo d+          is <- forM fs $ \f -> do+            let o = ProjSystem+            (_, _, fa) <- MaybeT $ projectTyped u a o f+            isEtaVarG (u `applyE` [Proj o f]) fa mi (es ++ [Proj o f])+          case (mi, is) of+            (Just i, _)     -> return i+            (Nothing, [])   -> mzero+            (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'+        _ -> mzero++    -- `areEtaVarElims u a es es'` checks whether the given elims es (as applied+    -- to the term u of type a) are beta-eta-equal to either projections or+    -- variables with de Bruijn indices given by es'.+    areEtaVarElims :: Term -> Type -> Elims -> [Elim' Int] -> MaybeT m ()+    areEtaVarElims u a []    []    = return ()+    areEtaVarElims u a []    (_:_) = mzero+    areEtaVarElims u a (_:_) []    = mzero+    areEtaVarElims u a (Proj o f : es) (Proj _ f' : es') = do+      guard $ f == f'+      a       <- reduce a+      (_, _, fa) <- MaybeT $ projectTyped u a o f+      areEtaVarElims (u `applyE` [Proj o f]) fa es es'+    -- These two cases can occur only when we're looking at two different+    -- variables (i.e. one of function type and the other of record type) so+    -- it's definitely not the variable we're looking for (or someone is playing+    -- Jedi mind tricks on us)+    areEtaVarElims u a (Proj{}  : _ ) (Apply _ : _  ) = mzero+    areEtaVarElims u a (Apply _ : _ ) (Proj{}  : _  ) = mzero+    areEtaVarElims u a (Proj{} : _ ) (IApply{} : _  ) = mzero+    areEtaVarElims u a (IApply{} : _ ) (Proj{} : _  ) = mzero+    areEtaVarElims u a (Apply  _ : _ ) (IApply{} : _  ) = mzero+    areEtaVarElims u a (IApply{} : _ ) (Apply  _ : _  ) = mzero+    areEtaVarElims u a (IApply{} : _) (IApply{} : _) = __IMPOSSIBLE__ -- TODO Andrea: not actually impossible, should be done like Apply+    areEtaVarElims u a (Apply v : es) (Apply i : es') = do+      ifNotPiType a (const mzero) $ \dom cod -> do+      _ <- isEtaVarG (unArg v) (unDom dom) (Just $ unArg i) []+      areEtaVarElims (u `apply` [fmap var i]) (cod `absApp` var (unArg i)) es es'+++-- | Replace projection patterns by the original projections.+-- class NormaliseProjP a where   normaliseProjP :: HasConstInfo m => a -> m a @@ -684,5 +1047,7 @@   normaliseProjP p@VarP{}        = return p   normaliseProjP p@DotP{}        = return p   normaliseProjP (ConP c cpi ps) = ConP c cpi <$> normaliseProjP ps+  normaliseProjP (DefP o q ps) = DefP o q <$> normaliseProjP ps   normaliseProjP p@LitP{}        = return p   normaliseProjP (ProjP o d0)    = ProjP o <$> getOriginalProjection d0+  normaliseProjP p@IApplyP{}     = return p
src/full/Agda/TypeChecking/Records.hs-boot view
@@ -1,14 +1,15 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Records where -import Agda.Syntax.Common import Agda.Syntax.Internal 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 :: QName -> TCM [Arg C.Name] etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term-isGeneratedRecordConstructor :: QName -> TCM 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,1276 +1,1784 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE UndecidableInstances     #-}--module Agda.TypeChecking.Reduce where--import Prelude hiding (mapM)-import Control.Monad.Reader hiding (mapM)-import Control.Applicative--import Data.List as List hiding (sort)-import Data.Maybe-import Data.Map (Map)-import Data.Traversable-import Data.Hashable--import Agda.Interaction.Options--import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Scope.Base (Scope)-import Agda.Syntax.Literal--import Agda.TypeChecking.Monad hiding ( underAbstraction_, enterClosure, isInstantiatedMeta-                                      , getConstInfo-                                      , lookupMeta )-import qualified Agda.TypeChecking.Monad as TCM-import Agda.TypeChecking.Monad.Builtin hiding (getPrimitive, constructorForm)-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.EtaContract--import Agda.TypeChecking.Reduce.Monad--import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match-import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match-import {-# SOURCE #-} Agda.TypeChecking.Pretty-import {-# SOURCE #-} Agda.TypeChecking.Rewriting-import {-# SOURCE #-} Agda.TypeChecking.Reduce.Fast--import Agda.Utils.Function-import Agda.Utils.Functor-import Agda.Utils.Monad-import Agda.Utils.HashMap (HashMap)-import Agda.Utils.Size-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible--instantiate :: Instantiate a => a -> TCM a-instantiate = runReduceM . instantiate'--instantiateFull :: InstantiateFull a => a -> TCM a-instantiateFull = runReduceM . instantiateFull'--reduce :: Reduce a => a -> TCM a-reduce = runReduceM . reduce'--reduceB :: Reduce a => a -> TCM (Blocked a)-reduceB = runReduceM . reduceB'--normalise :: Normalise a => a -> TCM a-normalise = runReduceM . normalise'--simplify :: Simplify a => a -> TCM a-simplify = runReduceM . simplify'---- | Meaning no metas left in the instantiation.-isFullyInstantiatedMeta :: MetaId -> TCM Bool-isFullyInstantiatedMeta m = do-  mv <- TCM.lookupMeta m-  case mvInstantiation mv of-    InstV sub v -> null . allMetas <$> instantiateFull (sub, v)-    _ -> return False---- | Instantiate something.---   Results in an open meta variable or a non meta.---   Doesn't do any reduction, and preserves blocking tags (when blocking meta---   is uninstantiated).-class Instantiate t where-    instantiate' :: t -> ReduceM t--instance Instantiate Term where-  instantiate' t@(MetaV x es) = do-    mi <- mvInstantiation <$> lookupMeta x-    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-      Open                             -> return t-      OpenIFS                          -> return t-      BlockedConst _                   -> return t-      PostponedTypeCheckingProblem _ _ -> return t-  instantiate' (Level l) = levelTm <$> instantiate' l-  instantiate' (Sort s) = sortTm <$> instantiate' s-  instantiate' v@Shared{} =-    updateSharedTerm instantiate' v-  instantiate' t = return t--instance Instantiate Level where-  instantiate' (Max as) = levelMax <$> instantiate' as--instance Instantiate PlusLevel where-  instantiate' l@ClosedLevel{} = return l-  instantiate' (Plus n a) = Plus n <$> instantiate' a--instance Instantiate LevelAtom where-  instantiate' l = case l of-    MetaLevel m vs -> do-      v <- instantiate' (MetaV m vs)-      case ignoreSharing v of-        MetaV m vs -> return $ MetaLevel m vs-        _          -> return $ UnreducedLevel v-    UnreducedLevel l -> UnreducedLevel <$> instantiate' l-    _ -> return l--instance Instantiate a => Instantiate (Blocked a) where-  instantiate' v@NotBlocked{} = return v-  instantiate' v@(Blocked x u) = do-    mi <- mvInstantiation <$> lookupMeta x-    case mi of-      InstV{}                        -> notBlocked <$> instantiate' u-      Open                           -> return v-      OpenIFS                        -> return v-      BlockedConst{}                 -> return v-      PostponedTypeCheckingProblem{} -> return v--instance Instantiate Type where-    instantiate' (El s t) = El <$> instantiate' s <*> instantiate' t--instance Instantiate Sort where-  instantiate' s = case s of-    Type l -> levelSort <$> instantiate' l-    _      -> return s--instance Instantiate Elim where-  instantiate' (Apply v) = Apply <$> instantiate' v-  instantiate' (Proj o f)= pure $ Proj o f--instance Instantiate t => Instantiate (Abs t) where-  instantiate' = traverse instantiate'--instance Instantiate t => Instantiate (Arg t) where-    instantiate' = traverse instantiate'--instance Instantiate t => Instantiate (Dom t) where-    instantiate' = traverse instantiate'--instance Instantiate t => Instantiate [t] where-    instantiate' = traverse instantiate'--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--instance Instantiate a => Instantiate (Closure a) where-    instantiate' cl = do-        x <- enterClosure cl instantiate'-        return $ cl { clValue = x }--instance Instantiate Telescope where-  instantiate' EmptyTel = return EmptyTel-  instantiate' (ExtendTel a tel) = ExtendTel <$> instantiate' a <*> instantiate' tel---instantiate' tel = return tel--instance Instantiate Constraint where-  instantiate' (ValueCmp cmp t u v) = do-    (t,u,v) <- instantiate' (t,u,v)-    return $ ValueCmp cmp t u v-  instantiate' (ElimCmp cmp t v as bs) =-    ElimCmp cmp <$> instantiate' t <*> instantiate' v <*> instantiate' as <*> instantiate' bs-  instantiate' (LevelCmp cmp u v)   = uncurry (LevelCmp cmp) <$> instantiate' (u,v)-  instantiate' (TypeCmp cmp a b)    = uncurry (TypeCmp cmp) <$> instantiate' (a,b)-  instantiate' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp)  <$> instantiate' (tela,telb)-  instantiate' (SortCmp cmp a b)    = uncurry (SortCmp cmp) <$> instantiate' (a,b)-  instantiate' (Guarded c pid)      = Guarded <$> instantiate' c <*> pure pid-  instantiate' (UnBlock m)          = return $ UnBlock m-  instantiate' (FindInScope m b args) = FindInScope m b <$> mapM instantiate' args-  instantiate' (IsEmpty r t)        = IsEmpty r <$> instantiate' t-  instantiate' (CheckSizeLtSat t)   = CheckSizeLtSat <$> instantiate' t--instance Instantiate e => Instantiate (Map k e) where-    instantiate' = traverse instantiate'--instance Instantiate Candidate where-  instantiate' (Candidate u t eti ov) = Candidate <$> instantiate' u <*> instantiate' t <*> pure eti <*> pure ov--instance Instantiate EqualityView where-  instantiate' (OtherType t)            = OtherType-    <$> instantiate' t-  instantiate' (EqualityType s eq l t a b) = EqualityType-    <$> instantiate' s-    <*> return eq-    <*> instantiate' l-    <*> instantiate' t-    <*> instantiate' a-    <*> instantiate' b-------------------------------------------------------------------------------- * Reduction to weak head normal form.-------------------------------------------------------------------------------- | Case on whether a term is blocked on a meta (or is a meta).---   That means it can change its shape when the meta is instantiated.-ifBlocked :: MonadTCM tcm =>  Term -> (MetaId -> Term -> tcm a) -> (Term -> tcm a) -> tcm a-ifBlocked t blocked unblocked = do-  t <- liftTCM $ reduceB t-  case ignoreSharing <$> t of-    Blocked m _              -> blocked m (ignoreBlocking t)-    NotBlocked _ (MetaV m _) -> blocked m (ignoreBlocking t)-    NotBlocked{}             -> unblocked (ignoreBlocking t)---- | Case on whether a type is blocked on a meta (or is a meta).-ifBlockedType :: MonadTCM tcm => Type -> (MetaId -> Type -> tcm a) -> (Type -> tcm a) -> tcm a-ifBlockedType (El s t) blocked unblocked =-  ifBlocked t (\ m v -> blocked m $ El s v) (\ v -> unblocked $ El s v)--class Reduce t where-    reduce'  :: t -> ReduceM t-    reduceB' :: t -> ReduceM (Blocked t)--    reduce'  t = ignoreBlocking <$> reduceB' t-    reduceB' t = notBlocked <$> reduce' t--instance Reduce Type where-    reduce'  (El s t) = El s <$> reduce' t-    reduceB' (El s t) = fmap (El s) <$> reduceB' t--instance Reduce Sort where-    reduce' s = {-# SCC "reduce'<Sort>" #-}-      ifNotM hasUniversePolymorphism (red s) $ {- else -} red =<< instantiateFull' s-      where-        red s = do-          s <- instantiate' s-          case s of-            DLub s1 s2 -> do-              s <- dLub <$> reduce' s1 <*> reduce' s2-              case s of-                DLub{}  -> return s-                _       -> reduce' s   -- TODO: not so nice-            Prop       -> return s-            Type s'    -> levelSort <$> reduce' s'-            Inf        -> return Inf-            SizeUniv   -> return SizeUniv--instance Reduce Elim where-  reduce' (Apply v) = Apply <$> reduce' v-  reduce' (Proj o f)= pure $ Proj o f--instance Reduce Level where-  reduce'  (Max as) = levelMax <$> mapM reduce' as-  reduceB' (Max as) = fmap levelMax . traverse id <$> traverse reduceB' as--instance Reduce PlusLevel where-  reduceB' l@ClosedLevel{} = return $ notBlocked l-  reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l--instance Reduce LevelAtom where-  reduceB' l = case l of-    MetaLevel m vs   -> fromTm (MetaV m vs)-    NeutralLevel r v -> return $ NotBlocked r $ NeutralLevel r v-    BlockedLevel m v ->-      ifM (isInstantiatedMeta m) (fromTm v) (return $ Blocked m $ BlockedLevel m v)-    UnreducedLevel v -> fromTm v-    where-      fromTm v = do-        bv <- reduceB' v-        let v = ignoreBlocking bv-        case ignoreSharing <$> bv of-          NotBlocked r (MetaV m vs) -> return $ NotBlocked r $ MetaLevel m vs-          Blocked m _               -> return $ Blocked m    $ BlockedLevel m v-          NotBlocked r _            -> return $ NotBlocked r $ NeutralLevel r v---instance (Subst t a, Reduce a) => Reduce (Abs a) where-  reduce' b@(Abs x _) = Abs x <$> underAbstraction_ b reduce'-  reduce' (NoAbs x v) = NoAbs x <$> reduce' v---- Lists are never blocked-instance Reduce t => Reduce [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!?-                 _          -> traverse reduce' a--    reduceB' t = traverse id <$> traverse reduceB' t--instance Reduce t => Reduce (Dom t) where-    reduce' = traverse reduce'-    reduceB' t = traverse id <$> traverse reduceB' t---- Tuples are never blocked-instance (Reduce a, Reduce b) => Reduce (a,b) where-    reduce' (x,y)  = (,) <$> reduce' x <*> reduce' y--instance (Reduce a, Reduce b,Reduce c) => Reduce (a,b,c) where-    reduce' (x,y,z) = (,,) <$> reduce' x <*> reduce' y <*> reduce' z--instance Reduce Term where-  reduceB' = {-# SCC "reduce'<Term>" #-} maybeFastReduceTerm--maybeFastReduceTerm :: Term -> ReduceM (Blocked Term)-maybeFastReduceTerm v = do-  let tryFast = case v of-                  Def{} -> True-                  Con{} -> True-                  _     -> False-  if not tryFast then slowReduceTerm v-                 else do-    s <- optSharing   <$> commandLineOptions-    allowed <- asks envAllowedReductions-    let notAll = delete NonTerminatingReductions allowed /= allReductions-    if s || notAll then slowReduceTerm v else fastReduce (elem NonTerminatingReductions allowed) v--slowReduceTerm :: Term -> ReduceM (Blocked Term)-slowReduceTerm v = do-    v <- instantiate' v-    let done = return $ notBlocked v-    case v of---    Andreas, 2012-11-05 not reducing meta args does not destroy anything---    and seems to save 2% sec on the standard library---      MetaV x args -> notBlocked . MetaV x <$> reduce' args-      MetaV x es -> done-      Def f es   -> unfoldDefinitionE False reduceB' (Def f []) f es-      Con c ci args -> do-          -- Constructors can reduce' when they come from an-          -- instantiated module.-          v <- unfoldDefinition False reduceB' (Con c ci []) (conName c) args-          traverse reduceNat v-      Sort s   -> fmap sortTm <$> reduceB' s-      Level l  -> ifM (elem LevelReductions <$> asks envAllowedReductions)-                    {- then -} (fmap levelTm <$> reduceB' l)-                    {- else -} done-      Pi _ _   -> done-      Lit _    -> done-      Var _ _  -> done-      Lam _ _  -> done-      DontCare _ -> done-      Shared{}   -> updateSharedTermF reduceB' v-    where-      -- NOTE: reduceNat can traverse the entire term.-      reduceNat v@Shared{} = updateSharedTerm reduceNat v-      reduceNat v@(Con c ci []) = do-        mz  <- getBuiltin' builtinZero-        case v of-          _ | Just v == mz  -> return $ Lit $ LitNat (getRange c) 0-          _                 -> return v-      reduceNat v@(Con c ci [a]) | notHidden a && isRelevant a = do-        ms  <- fmap ignoreSharing <$> getBuiltin' builtinSuc-        case v of-          _ | Just (Con c ci []) == ms -> inc <$> reduce' (unArg a)-          _                         -> return v-          where-            inc w = case ignoreSharing w of-              Lit (LitNat r n) -> Lit (LitNat (fuseRange c r) $ n + 1)-              _                -> Con c ci [defaultArg w]-      reduceNat v = return v---- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion--- need also to instantiate metas, see Issue 826.-unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim)-unfoldCorecursionE (Proj o p)           = notBlocked . Proj o <$> getOriginalProjection p-unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) <$>-  unfoldCorecursion v--unfoldCorecursion :: Term -> ReduceM (Blocked Term)-unfoldCorecursion v = do-  v <- instantiate' v-  case compressPointerChain v of-    Def f es -> unfoldDefinitionE True unfoldCorecursion (Def f []) f es-    v@(Shared p) ->-      case derefPtr p of-        Def{} -> updateSharedFM unfoldCorecursion v-        _     -> slowReduceTerm v-    _ -> slowReduceTerm v---- | If the first argument is 'True', then a single delayed clause may--- be unfolded.-unfoldDefinition ::-  Bool -> (Term -> ReduceM (Blocked Term)) ->-  Term -> QName -> Args -> ReduceM (Blocked Term)-unfoldDefinition unfoldDelayed keepGoing v f args =-  unfoldDefinitionE unfoldDelayed keepGoing v f (map Apply args)--unfoldDefinitionE ::-  Bool -> (Term -> ReduceM (Blocked Term)) ->-  Term -> QName -> Elims -> ReduceM (Blocked Term)-unfoldDefinitionE unfoldDelayed keepGoing v f es = do-  r <- unfoldDefinitionStep unfoldDelayed v f es-  case r of-    NoReduction v    -> return v-    YesReduction _ v -> keepGoing v--unfoldDefinition' ::-  Bool -> (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-  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 =-  {-# SCC "reduceDef" #-} do-  info <- getConstInfo f-  rewr <- getRewriteRulesFor f-  allowed <- asks envAllowedReductions-  let def = theDef info-      v   = v0 `applyE` es-      -- Non-terminating functions-      -- (i.e., those that failed the termination check)-      -- and delayed definitions-      -- are not unfolded unless explicitely permitted.-      dontUnfold =-        (defNonterminating info && notElem NonTerminatingReductions allowed)-        || (defDelayed info == Delayed && not unfoldDelayed)-      copatterns =-        case def of-          Function{funCopatternLHS = b} -> b-          _                             -> False-  case def of-    Constructor{conSrcCon = c} ->-      noReduction $ notBlocked $ Con (c `withRangeOf` f) ConOSystem [] `applyE` es-    Primitive{primAbstr = ConcreteDef, primName = x, primClauses = cls} -> do-      pf <- fromMaybe __IMPOSSIBLE__ <$> getPrimitive' x-      if FunctionReductions `elem` allowed-        then reducePrimitive x v0 f es pf dontUnfold-                             cls (defCompiled info) rewr-        else noReduction $ notBlocked v-    _  -> do-      if FunctionReductions `elem` allowed ||-         (isJust (isProjection_ def) && ProjectionReductions `elem` allowed) || -- includes projection-like-         (isInlineFun def && InlineReductions `elem` allowed) ||-         (copatterns && CopatternReductions `elem` allowed)-        then-          reduceNormalE v0 f (map notReduced es) dontUnfold-                       (defClauses info) (defCompiled info) rewr-        else noReduction $ notBlocked v  -- Andrea(s), 2014-12-05 OK?--  where-    noReduction    = return . NoReduction-    yesReduction s = return . YesReduction s-    reducePrimitive x v0 f es pf dontUnfold cls mcc rewr-      | genericLength es < ar-                  = noReduction $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied-      | otherwise = {-# SCC "reducePrimitive" #-} do-          let (es1,es2) = genericSplitAt ar es-              args1     = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es1-          r <- primFunImplementation pf args1-          case r of-            NoReduction args1' -> do-              let es1' = map (fmap Apply) args1'-              if null cls then do-                noReduction $ applyE (Def f []) <$> do-                  traverse id $-                    map mredToBlocked es1' ++ map notBlocked es2-               else-                reduceNormalE v0 f (es1' ++ map notReduced es2) dontUnfold cls mcc rewr-            YesReduction simpl v -> yesReduction simpl $ v `applyE` es2-      where-          ar  = primFunArity pf-          mredToBlocked :: MaybeReduced a -> Blocked a-          mredToBlocked (MaybeRed NotReduced  x) = notBlocked x-          mredToBlocked (MaybeRed (Reduced b) x) = x <$ b--    reduceNormalE :: Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> ReduceM (Reduced (Blocked Term) Term)-    reduceNormalE v0 f es dontUnfold def mcc rewr = {-# SCC "reduceNormal" #-} do-      case (def,rewr) of-        _ | dontUnfold -> defaultResult -- non-terminating or delayed-        ([],[])        -> defaultResult -- no definition for head-        (cls,rewr)     -> appDefE_ f v0 cls mcc rewr es-      where defaultResult = noReduction $ NotBlocked AbsurdMatch vfull-            vfull         = v0 `applyE` map ignoreReduced es---- | Reduce a non-primitive definition if it is a copy linking to another def.-reduceDefCopy :: QName -> Elims -> TCM (Reduced () Term)-reduceDefCopy f es = do-  info <- TCM.getConstInfo f-  rewr <- TCM.getRewriteRulesFor f-  if (defCopy info) then reduceDef_ info rewr f es else return $ NoReduction ()-  where-    reduceDef_ :: Definition -> RewriteRules -> QName -> Elims -> TCM (Reduced () Term)-    reduceDef_ info rewr f es = do-      let v0   = Def f []-          cls  = (defClauses info)-          mcc  = (defCompiled info)-      if (defDelayed info == Delayed) || (defNonterminating info)-       then return $ NoReduction ()-       else do-          ev <- runReduceM $ appDefE_ f v0 cls mcc rewr $ map notReduced es-          case ev of-            YesReduction simpl t -> return $ YesReduction simpl t-            NoReduction{}        -> return $ NoReduction ()---- | Reduce simple (single clause) definitions.-reduceHead :: Term -> TCM (Blocked Term)-reduceHead = runReduceM . reduceHead'--reduceHead' :: Term -> ReduceM (Blocked Term)-reduceHead' v = do -- ignoreAbstractMode $ do-  -- Andreas, 2013-02-18 ignoreAbstractMode leads to information leakage-  -- see Issue 796--  -- first, possibly rewrite literal v to constructor form-  v <- constructorForm v-  traceSDoc "tc.inj.reduce" 30 (text "reduceHead" <+> prettyTCM v) $ do-  case ignoreSharing v of-    Def f es -> do--      abstractMode <- envAbstractMode <$> ask-      isAbstract <- treatAbstractly f-      traceSLn "tc.inj.reduce" 50 (-        "reduceHead: we are in " ++ show abstractMode++ "; " ++ show f ++-        " is treated " ++ if isAbstract then "abstractly" else "concretely"-        ) $ do-      let v0  = Def f []-          red = unfoldDefinitionE False reduceHead' v0 f es-      def <- theDef <$> getConstInfo f-      case def of-        -- Andreas, 2012-11-06 unfold aliases (single clause terminating functions)-        -- see test/succeed/Issue747-        -- 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-          traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++ show f ++ " is Function") $ do-          red-        Datatype{ dataClause = Just _ } -> red-        Record{ recClause = Just _ }    -> red-        _                               -> return $ notBlocked v-    _ -> return $ notBlocked v---- | Apply a definition using the compiled clauses, or fall back to---   ordinary clauses if no compiled clauses exist.-appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef_ f v0 cls mcc rewr args = appDefE_ f v0 cls mcc rewr $ map (fmap Apply) args--appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE_ f v0 cls mcc rewr args =-  local (\ e -> e { envAppDef = Just f }) $-  maybe (appDefE' v0 cls rewr args)-        (\cc -> appDefE v0 cc rewr args) mcc----- | Apply a defined function to it's arguments, using the compiled clauses.---   The original term is the first argument applied to the third.-appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef v cc rewr args = appDefE v cc rewr $ map (fmap Apply) args--appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE v cc rewr es = do-  r <- matchCompiledE cc es-  case r of-    YesReduction simpl t -> return $ YesReduction simpl t-    NoReduction es'      -> rewrite (void es') 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--appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE' v cls rewr es = goCls cls $ map ignoreReduced es-  where-    goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)-    goCls cl es = do-      case cl of-        -- Andreas, 2013-10-26  In case of an incomplete match,-        -- we just do not reduce.  This allows adding single function-        -- clauses after they have been type-checked, to type-check-        -- 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 ()) v rewr es-        cl : cls -> do-          let pats = namedClausePats cl-              body = clauseBody cl-              npats = length pats-              nvars = size $ clauseTel cl-          -- if clause is underapplied, skip to next clause-          if length es < npats then goCls cls es else do-            let (es0, es1) = splitAt npats es-            (m, es0) <- matchCopatterns pats es0-            es <- return $ es0 ++ es1-            case m of-              No         -> goCls cls es-              DontKnow b -> rewrite b v rewr es-              Yes simpl vs -- vs is the subst. for the variables bound in body-                | Just w <- body -> do -- clause has body?-                    -- TODO: let matchPatterns also return the reduced forms-                    -- of the original arguments!-                    -- Andreas, 2013-05-19 isn't this done now?-                    let sigma = buildSubstitution __IMPOSSIBLE__ nvars vs-                    return $ YesReduction simpl $ applySubst sigma w `applyE` es1-                | otherwise     -> rewrite (NotBlocked AbsurdMatch ()) v rewr es--instance Reduce a => Reduce (Closure a) where-    reduce' cl = do-        x <- enterClosure cl reduce'-        return $ cl { clValue = x }--instance Reduce Telescope where-  reduce' EmptyTel          = return EmptyTel-  reduce' (ExtendTel a tel) = ExtendTel <$> reduce' a <*> reduce' tel--instance Reduce Constraint where-  reduce' (ValueCmp cmp t u v) = do-    (t,u,v) <- reduce' (t,u,v)-    return $ ValueCmp cmp t u v-  reduce' (ElimCmp cmp t v as bs) =-    ElimCmp cmp <$> reduce' t <*> reduce' v <*> reduce' as <*> reduce' bs-  reduce' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> reduce' (u,v)-  reduce' (TypeCmp cmp a b)     = uncurry (TypeCmp cmp) <$> reduce' (a,b)-  reduce' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp)  <$> reduce' (tela,telb)-  reduce' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> reduce' (a,b)-  reduce' (Guarded c pid)       = Guarded <$> reduce' c <*> pure pid-  reduce' (UnBlock m)           = return $ UnBlock m-  reduce' (FindInScope m b cands) = FindInScope m b <$> mapM reduce' cands-  reduce' (IsEmpty r t)         = IsEmpty r <$> reduce' t-  reduce' (CheckSizeLtSat t)    = CheckSizeLtSat <$> reduce' t--instance Reduce e => Reduce (Map k e) where-    reduce' = traverse reduce'--instance Reduce Candidate where-  reduce' (Candidate u t eti ov) = Candidate <$> reduce' u <*> reduce' t <*> pure eti <*> pure ov--instance Reduce EqualityView where-  reduce' (OtherType t)            = OtherType-    <$> reduce' t-  reduce' (EqualityType s eq l t a b) = EqualityType-    <$> reduce' s-    <*> return eq-    <*> reduce' l-    <*> reduce' t-    <*> reduce' a-    <*> reduce' b-------------------------------------------------------------------------------- * Simplification-------------------------------------------------------------------------------- | Only unfold definitions if this leads to simplification---   which means that a constructor/literal pattern is matched.-class Simplify t where-  simplify' :: t -> ReduceM t--instance Simplify Term where-  simplify' v = do-    v <- instantiate' v-    case v of-      Def f vs   -> do-        let keepGoing simp v = return (simp, notBlocked v)-        (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs-        traceSDoc "tc.simplify'" 20 (-          text ("simplify': unfolding definition returns " ++ show simpl)-            <+> prettyTCM (ignoreBlocking v)) $ do-        case simpl of-          YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@-          NoSimplification  -> Def f <$> simplify' vs-      MetaV x vs -> MetaV x  <$> simplify' vs-      Con c ci vs-> Con c ci <$> simplify' vs-      Sort s     -> sortTm   <$> simplify' s-      Level l    -> levelTm  <$> simplify' l-      Pi a b     -> Pi       <$> simplify' a <*> simplify' b-      Lit l      -> return v-      Var i vs   -> Var i    <$> simplify' vs-      Lam h v    -> Lam h    <$> simplify' v-      DontCare v -> dontCare <$> simplify' v-      Shared{}   -> updateSharedTerm simplify' v--simplifyBlocked' :: Simplify t => Blocked t -> ReduceM t-simplifyBlocked' (Blocked _ t) = return t-simplifyBlocked' (NotBlocked _ t) = simplify' t  -- Andrea(s), 2014-12-05 OK?--instance Simplify Type where-    simplify' (El s t) = El <$> simplify' s <*> simplify' t--instance Simplify Elim where-  simplify' (Apply v) = Apply <$> simplify' v-  simplify' (Proj o f)= pure $ Proj o f--instance Simplify Sort where-    simplify' s = do-      case s of-        DLub s1 s2 -> dLub <$> simplify' s1 <*> simplify' s2-        Type s     -> levelSort <$> simplify' s-        Prop       -> return s-        Inf        -> return s-        SizeUniv   -> return s--instance Simplify Level where-  simplify' (Max as) = levelMax <$> simplify' as--instance Simplify PlusLevel where-  simplify' l@ClosedLevel{} = return l-  simplify' (Plus n l) = Plus n <$> simplify' l--instance Simplify LevelAtom where-  simplify' l = do-    l <- instantiate' l-    case l of-      MetaLevel m vs   -> MetaLevel m <$> simplify' vs-      BlockedLevel m v -> BlockedLevel m <$> simplify' v-      NeutralLevel r v -> NeutralLevel r <$> simplify' v -- ??-      UnreducedLevel v -> UnreducedLevel <$> simplify' v -- ??--instance (Subst t a, Simplify a) => Simplify (Abs a) where-    simplify' a@(Abs x _) = Abs x <$> underAbstraction_ a simplify'-    simplify' (NoAbs x v) = NoAbs x <$> simplify' v--instance Simplify t => Simplify (Arg t) where-    simplify' = traverse simplify'--instance Simplify t => Simplify (Named name t) where-    simplify' = traverse simplify'--instance Simplify t => Simplify (Dom t) where-    simplify' = traverse simplify'--instance Simplify t => Simplify [t] where-    simplify' = traverse simplify'--instance Simplify e => Simplify (Map k e) where-    simplify' = traverse simplify'--instance Simplify a => Simplify (Maybe a) where-    simplify' = traverse simplify'--instance (Simplify a, Simplify b) => Simplify (a,b) where-    simplify' (x,y) = (,) <$> simplify' x <*> simplify' y--instance (Simplify a, Simplify b, Simplify c) => Simplify (a,b,c) where-    simplify' (x,y,z) =-        do  (x,(y,z)) <- simplify' (x,(y,z))-            return (x,y,z)--instance Simplify a => Simplify (Closure a) where-    simplify' cl = do-        x <- enterClosure cl simplify'-        return $ cl { clValue = x }--instance (Subst t a, Simplify a) => Simplify (Tele a) where-  simplify' EmptyTel        = return EmptyTel-  simplify' (ExtendTel a b) = uncurry ExtendTel <$> simplify' (a, b)--instance Simplify ProblemConstraint where-  simplify' (PConstr pid c) = PConstr pid <$> simplify' c--instance Simplify Constraint where-  simplify' (ValueCmp cmp t u v) = do-    (t,u,v) <- simplify' (t,u,v)-    return $ ValueCmp cmp t u v-  simplify' (ElimCmp cmp t v as bs) =-    ElimCmp cmp <$> simplify' t <*> simplify' v <*> simplify' as <*> simplify' bs-  simplify' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> simplify' (u,v)-  simplify' (TypeCmp cmp a b)     = uncurry (TypeCmp cmp) <$> simplify' (a,b)-  simplify' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp) <$> simplify' (tela,telb)-  simplify' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> simplify' (a,b)-  simplify' (Guarded c pid)       = Guarded <$> simplify' c <*> pure pid-  simplify' (UnBlock m)           = return $ UnBlock m-  simplify' (FindInScope m b cands) = FindInScope m b <$> mapM simplify' cands-  simplify' (IsEmpty r t)         = IsEmpty r <$> simplify' t-  simplify' (CheckSizeLtSat t)    = CheckSizeLtSat <$> simplify' t--instance Simplify Bool where-  simplify' = return---- UNUSED--- instance Simplify ConPatternInfo where---   simplify' (ConPatternInfo mr mt) = ConPatternInfo mr <$> simplify' mt---- UNUSED--- instance Simplify Pattern where---   simplify' p = case p of---     VarP _       -> return p---     LitP _       -> return p---     ConP c ci ps -> ConP c <$> simplify' ci <*> simplify' ps---     DotP v       -> DotP <$> simplify' v---     ProjP _      -> return p--instance Simplify DisplayForm where-  simplify' (Display n ps v) = Display n <$> simplify' ps <*> return v--instance Simplify Candidate where-  simplify' (Candidate u t eti ov) = Candidate <$> simplify' u <*> simplify' t <*> pure eti <*> pure ov--instance Simplify EqualityView where-  simplify' (OtherType t)            = OtherType-    <$> simplify' t-  simplify' (EqualityType s eq l t a b) = EqualityType-    <$> simplify' s-    <*> return eq-    <*> simplify' l-    <*> simplify' t-    <*> simplify' a-    <*> simplify' b-------------------------------------------------------------------------------- * Normalisation------------------------------------------------------------------------------class Normalise t where-    normalise' :: t -> ReduceM t--instance Normalise Sort where-    normalise' s = do-      s <- reduce' s-      case s of-        DLub s1 s2 -> dLub <$> normalise' s1 <*> normalise' s2-        Prop       -> return s-        Type s     -> levelSort <$> normalise' s-        Inf        -> return Inf-        SizeUniv   -> return SizeUniv--instance Normalise Type where-    normalise' (El s t) = El <$> normalise' s <*> normalise' t--instance Normalise Term where-    normalise' = ignoreBlocking <.> (reduceB' >=> traverse normaliseArgs)-      where-        normaliseArgs :: Term -> ReduceM Term-        normaliseArgs v = case v of-                Var n vs    -> Var n <$> normalise' vs-                Con c ci vs -> Con c ci <$> normalise' vs-                Def f vs    -> Def f <$> normalise' vs-                MetaV x vs  -> MetaV x <$> normalise' vs-                Lit _       -> return v-                Level l     -> levelTm <$> normalise' l-                Lam h b     -> Lam h <$> normalise' b-                Sort s      -> sortTm <$> normalise' s-                Pi a b      -> uncurry Pi <$> normalise' (a,b)-                Shared{}    -> updateSharedTerm normalise' v-                DontCare _  -> return v--instance Normalise Elim where-  normalise' (Apply v) = Apply <$> normalise' v-  normalise' (Proj o f)= pure $ Proj o f--instance Normalise Level where-  normalise' (Max as) = levelMax <$> normalise' as--instance Normalise PlusLevel where-  normalise' l@ClosedLevel{} = return l-  normalise' (Plus n l) = Plus n <$> normalise' l--instance Normalise LevelAtom where-  normalise' l = do-    l <- reduce' l-    case l of-      MetaLevel m vs   -> MetaLevel m <$> normalise' vs-      BlockedLevel m v -> BlockedLevel m <$> normalise' v-      NeutralLevel r v -> NeutralLevel r <$> normalise' v-      UnreducedLevel{} -> __IMPOSSIBLE__    -- I hope--instance (Subst t a, Normalise a) => Normalise (Abs a) where-    normalise' a@(Abs x _) = Abs x <$> underAbstraction_ a normalise'-    normalise' (NoAbs x v) = NoAbs x <$> normalise' v--instance Normalise t => Normalise (Arg t) where-    normalise' a | isIrrelevant a = return a -- Andreas, 2012-04-02: Do not normalize irrelevant terms!?-                | otherwise                       = traverse normalise' a--instance Normalise t => Normalise (Named name t) where-    normalise' = traverse normalise'--instance Normalise t => Normalise (Dom t) where-    normalise' = traverse normalise'--instance Normalise t => Normalise [t] where-    normalise' = traverse normalise'--instance (Normalise a, Normalise b) => Normalise (a,b) where-    normalise' (x,y) = (,) <$> normalise' x <*> normalise' y--instance (Normalise a, Normalise b, Normalise c) => Normalise (a,b,c) where-    normalise' (x,y,z) =-        do  (x,(y,z)) <- normalise' (x,(y,z))-            return (x,y,z)--instance Normalise a => Normalise (Closure a) where-    normalise' cl = do-        x <- enterClosure cl normalise'-        return $ cl { clValue = x }--instance (Subst t a, Normalise a) => Normalise (Tele a) where-  normalise' EmptyTel        = return EmptyTel-  normalise' (ExtendTel a b) = uncurry ExtendTel <$> normalise' (a, b)--instance Normalise ProblemConstraint where-  normalise' (PConstr pid c) = PConstr pid <$> normalise' c--instance Normalise Constraint where-  normalise' (ValueCmp cmp t u v) = do-    (t,u,v) <- normalise' (t,u,v)-    return $ ValueCmp cmp t u v-  normalise' (ElimCmp cmp t v as bs) =-    ElimCmp cmp <$> normalise' t <*> normalise' v <*> normalise' as <*> normalise' bs-  normalise' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> normalise' (u,v)-  normalise' (TypeCmp cmp a b)     = uncurry (TypeCmp cmp) <$> normalise' (a,b)-  normalise' (TelCmp a b cmp tela telb) = uncurry (TelCmp a b cmp) <$> normalise' (tela,telb)-  normalise' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> normalise' (a,b)-  normalise' (Guarded c pid)       = Guarded <$> normalise' c <*> pure pid-  normalise' (UnBlock m)           = return $ UnBlock m-  normalise' (FindInScope m b cands) = FindInScope m b <$> mapM normalise' cands-  normalise' (IsEmpty r t)         = IsEmpty r <$> normalise' t-  normalise' (CheckSizeLtSat t)    = CheckSizeLtSat <$> normalise' t--instance Normalise Bool where-  normalise' = return--instance Normalise Int where-  normalise' = return--instance Normalise Char where-  normalise' = return--instance Normalise ConPatternInfo where-  normalise' (ConPatternInfo mr mt) = ConPatternInfo mr <$> normalise' mt--instance Normalise DBPatVar where-  normalise' = return--instance Normalise a => Normalise (Pattern' a) where-  normalise' p = case p of-    VarP x       -> VarP <$> normalise' x-    LitP _       -> return p-    ConP c mt ps -> ConP c <$> normalise' mt <*> normalise' ps-    DotP v       -> DotP <$> normalise' v-    ProjP{}      -> return p--instance Normalise DisplayForm where-  normalise' (Display n ps v) = Display n <$> normalise' ps <*> return v--instance Normalise e => Normalise (Map k e) where-    normalise' = traverse normalise'--instance Normalise a => Normalise (Maybe a) where-    normalise' = traverse normalise'--instance Normalise Candidate where-  normalise' (Candidate u t eti ov) = Candidate <$> normalise' u <*> normalise' t <*> pure eti <*> pure ov--instance Normalise EqualityView where-  normalise' (OtherType t)            = OtherType-    <$> normalise' t-  normalise' (EqualityType s eq l t a b) = EqualityType-    <$> normalise' s-    <*> return eq-    <*> normalise' l-    <*> normalise' t-    <*> normalise' a-    <*> normalise' b-------------------------------------------------------------------------------- * Full instantiation-------------------------------------------------------------------------------- STALE: Full instantiatiation = normalisation [ instantiate' / reduce' ]--- How can we express this? We need higher order classes!---- | @instantiateFull'@ 'instantiate's metas everywhere (and recursively)---   but does not 'reduce'.-class InstantiateFull t where-    instantiateFull' :: t -> ReduceM t--instance InstantiateFull Name where-    instantiateFull' = return--instance InstantiateFull Sort where-    instantiateFull' s = do-        s <- instantiate' s-        case s of-            Type n     -> levelSort <$> instantiateFull' n-            Prop       -> return s-            DLub s1 s2 -> dLub <$> instantiateFull' s1 <*> instantiateFull' s2-            Inf        -> return s-            SizeUniv   -> return s--instance (InstantiateFull a) => InstantiateFull (Type' a) where-    instantiateFull' (El s t) =-      El <$> instantiateFull' s <*> instantiateFull' t--instance InstantiateFull Term where-    instantiateFull' v = etaOnce =<< do -- Andreas, 2010-11-12 DONT ETA!! eta-reduction breaks subject reduction--- but removing etaOnce now breaks everything-      v <- instantiate' v-      case v of-          Var n vs    -> Var n <$> instantiateFull' vs-          Con c ci vs -> Con c ci <$> instantiateFull' vs-          Def f vs    -> Def f <$> instantiateFull' vs-          MetaV x vs  -> MetaV x <$> instantiateFull' vs-          Lit _       -> return v-          Level l     -> levelTm <$> instantiateFull' l-          Lam h b     -> Lam h <$> instantiateFull' b-          Sort s      -> sortTm <$> instantiateFull' s-          Pi a b      -> uncurry Pi <$> instantiateFull' (a,b)-          Shared{}    -> updateSharedTerm instantiateFull' v-          DontCare v  -> dontCare <$> instantiateFull' v--instance InstantiateFull Level where-  instantiateFull' (Max as) = levelMax <$> instantiateFull' as--instance InstantiateFull PlusLevel where-  instantiateFull' l@ClosedLevel{} = return l-  instantiateFull' (Plus n l) = Plus n <$> instantiateFull' l--instance InstantiateFull LevelAtom where-  instantiateFull' l = case l of-    MetaLevel m vs -> do-      v <- instantiateFull' (MetaV m vs)-      case ignoreSharing v of-        MetaV m vs -> return $ MetaLevel m vs-        _          -> return $ UnreducedLevel v-    NeutralLevel r v -> NeutralLevel r <$> instantiateFull' v-    BlockedLevel m v ->-      ifM (isInstantiatedMeta m)-          (UnreducedLevel <$> instantiateFull' v)-          (BlockedLevel m <$> instantiateFull' v)-    UnreducedLevel v -> UnreducedLevel <$> instantiateFull' v--instance InstantiateFull Substitution where-  instantiateFull' sigma =-    case sigma of-      IdS                  -> return IdS-      EmptyS               -> return EmptyS-      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--instance InstantiateFull Bool where-    instantiateFull' = return--instance InstantiateFull Int where-    instantiateFull' = return--instance InstantiateFull ConPatternInfo where-  instantiateFull' (ConPatternInfo mr mt) = ConPatternInfo mr <$> instantiateFull' mt--instance InstantiateFull DBPatVar where-    instantiateFull' = return--instance InstantiateFull a => InstantiateFull (Pattern' a) where-    instantiateFull' (VarP x)       = VarP <$> instantiateFull' x-    instantiateFull' (DotP t)       = DotP <$> instantiateFull' t-    instantiateFull' (ConP n mt ps) = ConP n <$> instantiateFull' mt <*> instantiateFull' ps-    instantiateFull' l@LitP{}       = return l-    instantiateFull' p@ProjP{}      = return p--instance (Subst t a, InstantiateFull a) => InstantiateFull (Abs a) where-    instantiateFull' a@(Abs x _) = Abs x <$> underAbstraction_ a instantiateFull'-    instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a--instance InstantiateFull t => InstantiateFull (Arg t) where-    instantiateFull' = traverse instantiateFull'--instance InstantiateFull t => InstantiateFull (Named name t) where-    instantiateFull' = traverse instantiateFull'--instance InstantiateFull t => InstantiateFull (Dom t) where-    instantiateFull' = traverse instantiateFull'--instance InstantiateFull t => InstantiateFull [t] where-    instantiateFull' = traverse instantiateFull'--instance (InstantiateFull a, InstantiateFull b) => InstantiateFull (a,b) where-    instantiateFull' (x,y) = (,) <$> instantiateFull' x <*> instantiateFull' y--instance (InstantiateFull a, InstantiateFull b, InstantiateFull c) => InstantiateFull (a,b,c) where-    instantiateFull' (x,y,z) =-        do  (x,(y,z)) <- instantiateFull' (x,(y,z))-            return (x,y,z)--instance InstantiateFull a => InstantiateFull (Closure a) where-    instantiateFull' cl = do-        x <- enterClosure cl instantiateFull'-        return $ cl { clValue = x }--instance InstantiateFull ProblemConstraint where-  instantiateFull' (PConstr p c) = PConstr p <$> instantiateFull' c--instance InstantiateFull Constraint where-  instantiateFull' c = case c of-    ValueCmp cmp t u v -> do-      (t,u,v) <- instantiateFull' (t,u,v)-      return $ ValueCmp cmp t u v-    ElimCmp cmp t v as bs ->-      ElimCmp cmp <$> instantiateFull' t <*> instantiateFull' v <*> instantiateFull' as <*> instantiateFull' bs-    LevelCmp cmp u v    -> uncurry (LevelCmp cmp) <$> instantiateFull' (u,v)-    TypeCmp cmp a b     -> uncurry (TypeCmp cmp) <$> instantiateFull' (a,b)-    TelCmp a b cmp tela telb -> uncurry (TelCmp a b cmp) <$> instantiateFull' (tela,telb)-    SortCmp cmp a b     -> uncurry (SortCmp cmp) <$> instantiateFull' (a,b)-    Guarded c pid       -> Guarded <$> instantiateFull' c <*> pure pid-    UnBlock m           -> return $ UnBlock m-    FindInScope m b cands -> FindInScope m b <$> mapM instantiateFull' cands-    IsEmpty r t         -> IsEmpty r <$> instantiateFull' t-    CheckSizeLtSat t    -> CheckSizeLtSat <$> instantiateFull' t--instance (InstantiateFull a) => InstantiateFull (Elim' a) where-  instantiateFull' (Apply v) = Apply <$> instantiateFull' v-  instantiateFull' (Proj o f)= pure $ Proj o f--instance InstantiateFull e => InstantiateFull (Map k e) where-    instantiateFull' = traverse instantiateFull'--instance InstantiateFull e => InstantiateFull (HashMap k e) where-    instantiateFull' = traverse instantiateFull'--instance InstantiateFull ModuleName where-    instantiateFull' = return--instance InstantiateFull Scope where-    instantiateFull' = return--instance InstantiateFull Signature where-  instantiateFull' (Sig a b c) = uncurry3 Sig <$> instantiateFull' (a, b, c)--instance InstantiateFull Section where-  instantiateFull' (Section tel) = Section <$> instantiateFull' tel--instance (Subst t a, InstantiateFull a) => InstantiateFull (Tele a) where-  instantiateFull' EmptyTel = return EmptyTel-  instantiateFull' (ExtendTel a b) = uncurry ExtendTel <$> instantiateFull' (a, b)--instance InstantiateFull Char where-    instantiateFull' = return--instance InstantiateFull Definition where-    instantiateFull' (Defn rel x t pol occ df i c inst copy ma d) = do-      (t, df, d) <- instantiateFull' (t, df, d)-      return $ Defn rel x t pol occ df i c inst copy ma d--instance InstantiateFull NLPat where-  instantiateFull' (PVar x y z) = return $ PVar x y z-  instantiateFull' (PWild)    = return PWild-  instantiateFull' (PDef x y) = PDef <$> instantiateFull' x <*> instantiateFull' y-  instantiateFull' (PLam x y) = PLam x <$> instantiateFull' y-  instantiateFull' (PPi x y)  = PPi <$> instantiateFull' x <*> instantiateFull' y-  instantiateFull' (PBoundVar x y) = PBoundVar x <$> instantiateFull' y-  instantiateFull' (PTerm x)  = PTerm <$> instantiateFull' x--instance InstantiateFull NLPType where-  instantiateFull' (NLPType l a) = NLPType-    <$> instantiateFull' l-    <*> instantiateFull' a--instance InstantiateFull RewriteRule where-  instantiateFull' (RewriteRule q gamma f ps rhs t) =-    RewriteRule q-      <$> instantiateFull' gamma-      <*> pure f-      <*> instantiateFull' ps-      <*> instantiateFull' rhs-      <*> instantiateFull' t--instance InstantiateFull a => InstantiateFull (Open a) where-  instantiateFull' (OpenThing n a) = OpenThing n <$> instantiateFull' a--instance InstantiateFull a => InstantiateFull (Local a) where-  instantiateFull' = traverseF instantiateFull'--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' (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)--instance InstantiateFull Defn where-    instantiateFull' d = case d of-      Axiom{} -> return d-      AbstractDefn -> return d-      Function{ funClauses = cs, funCompiled = cc, funInv = inv } -> do-        (cs, cc, inv) <- instantiateFull' (cs, cc, inv)-        return $ d { funClauses = cs, funCompiled = cc, funInv = inv }-      Datatype{ dataSort = s, dataClause = cl } -> do-        s  <- instantiateFull' s-        cl <- instantiateFull' cl-        return $ d { dataSort = s, dataClause = cl }-      Record{ recClause = cl, recTel = tel } -> do-        cl  <- instantiateFull' cl-        tel <- instantiateFull' tel-        return $ d { recClause = cl, recTel = tel }-      Constructor{} -> return d-      Primitive{ primClauses = cs } -> do-        cs <- instantiateFull' cs-        return $ d { primClauses = cs }--instance InstantiateFull FunctionInverse where-  instantiateFull' NotInjective = return NotInjective-  instantiateFull' (Inverse inv) = Inverse <$> instantiateFull' inv--instance InstantiateFull a => InstantiateFull (WithArity a) where-  instantiateFull' (WithArity n a) = WithArity n <$> instantiateFull' a--instance InstantiateFull a => InstantiateFull (Case a) where-  instantiateFull' (Branches cop cs ls m) =-    Branches cop-      <$> instantiateFull' cs-      <*> instantiateFull' ls-      <*> instantiateFull' m--instance InstantiateFull CompiledClauses where-  instantiateFull' Fail        = return Fail-  instantiateFull' (Done m t)  = Done m <$> instantiateFull' t-  instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs--instance InstantiateFull Clause where-    instantiateFull' (Clause r tel ps b t catchall) =-       Clause r <$> instantiateFull' tel-       <*> instantiateFull' ps-       <*> instantiateFull' b-       <*> instantiateFull' t-       <*> return catchall--instance InstantiateFull Interface where-    instantiateFull' (Interface h ms mod scope inside-                               sig display b hsImports hsImportsUHC hsCode highlighting pragmas patsyns) =-        Interface h ms mod scope inside-            <$> instantiateFull' sig-            <*> instantiateFull' display-            <*> instantiateFull' b-            <*> return hsImports-            <*> return hsImportsUHC-            <*> return hsCode-            <*> return highlighting-            <*> return pragmas-            <*> return patsyns--instance InstantiateFull a => InstantiateFull (Builtin a) where-    instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t-    instantiateFull' (Prim x)   = Prim <$> instantiateFull' x--instance InstantiateFull QName where-  instantiateFull' = return--instance InstantiateFull a => InstantiateFull (Maybe a) where-  instantiateFull' = mapM instantiateFull'--instance InstantiateFull Candidate where-  instantiateFull' (Candidate u t eti ov) =-    Candidate <$> instantiateFull' u <*> instantiateFull' t <*> pure eti <*> pure ov--instance InstantiateFull EqualityView where-  instantiateFull' (OtherType t)            = OtherType-    <$> instantiateFull' t-  instantiateFull' (EqualityType s eq l t a b) = EqualityType-    <$> instantiateFull' s-    <*> return eq-    <*> instantiateFull' l+{-# LANGUAGE NondecreasingIndentation #-}++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.Except ( MonadError(..) )++import Data.List ( intercalate )+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Foldable+import Data.Traversable+import Data.HashMap.Strict (HashMap)+import qualified Data.Set as Set++import Agda.Interaction.Options++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 (isPropM)+import Agda.TypeChecking.Monad hiding ( enterClosure, constructorForm )+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.EtaContract++import Agda.TypeChecking.Reduce.Monad++import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match+import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match+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.List1 (List1)+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Size+import Agda.Utils.Tuple+import qualified Agda.Utils.SmallSet as SmallSet++import Agda.Utils.Impossible++instantiate :: (Instantiate a, MonadReduce m) => a -> m a+instantiate = liftReduce . instantiate'++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'++-- Reduce a term and also produce a blocker signifying when+-- this reduction should be retried.+reduceWithBlocker :: (Reduce a, IsMeta a, MonadReduce m) => a -> m (Blocker, a)+reduceWithBlocker a = ifBlocked a+  (\b a' -> return (b, a'))+  (\_ a' -> return (neverUnblock, a'))++{-# INLINE normalise #-}+normalise :: (Normalise a, MonadReduce m) => a -> m a+normalise = liftReduce . normalise'++-- 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+  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+  where block = unblockOnAll $ foldMap (Set.singleton . blocker) bs+        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+  where block = case foldMap blocker bs of+                  [] -> alwaysUnblock -- no blockers+                  bs -> unblockOnAny $ Set.fromList bs+        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+--   is uninstantiated).+class Instantiate t where+  instantiate' :: t -> ReduceM t++  default instantiate' :: (t ~ f a, Traversable f, Instantiate a) => t -> ReduceM t+  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)++instance Instantiate t => Instantiate (Abs t)+instance Instantiate t => Instantiate (Arg t)+instance Instantiate t => Instantiate (Elim' t)+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) = ifPredicateDoesNotHoldFor x (return t) $ do+    blocking <- view stInstantiateBlocking <$> getTCState++    m <- lookupMeta x+    case m of+      Just (Left rmv) -> cont (rmvInstantiation rmv)++      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++instance Instantiate t => Instantiate (Type' t) where+  instantiate' (El s t) = El <$> instantiate' s <*> instantiate' t++instance Instantiate Level where+  instantiate' (Max m as) = levelMax m <$> instantiate' as++-- Use Traversable instance+instance Instantiate t => Instantiate (PlusLevel' t)++instance Instantiate a => Instantiate (Blocked a) where+  instantiate' v@NotBlocked{} = return v+  instantiate' v@(Blocked b u) = instantiate' b >>= \ case+    b | b == alwaysUnblock -> notBlocked <$> instantiate' u+      | otherwise          -> return $ Blocked b u++instance Instantiate Blocker where+  instantiate' (UnblockOnAll bs) = unblockOnAll . Set.fromList <$> mapM instantiate' (Set.toList bs)+  instantiate' (UnblockOnAny bs) = unblockOnAny . Set.fromList <$> mapM instantiate' (Set.toList bs)+  instantiate' b@(UnblockOnMeta x) =+    ifM (isInstantiatedMeta x) (return alwaysUnblock) (return b)+  instantiate' (UnblockOnProblem pi) =+    ifM (isProblemSolved pi) (return alwaysUnblock) (return $ UnblockOnProblem pi)+  instantiate' b@UnblockOnDef{} = return b++instance Instantiate Sort where+  instantiate' = \case+    MetaS x es -> instantiate' (MetaV x es) >>= \case+      Sort s'      -> return s'+      MetaV x' es' -> return $ MetaS x' es'+      Def d es'    -> return $ DefS d es'+      _            -> __IMPOSSIBLE__+    s -> return s++instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where+    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+        x <- enterClosure cl instantiate'+        return $ cl { clValue = x }++instance Instantiate Constraint where+  instantiate' (ValueCmp cmp t u v) = do+    (t,u,v) <- instantiate' (t,u,v)+    return $ ValueCmp cmp t u v+  instantiate' (ValueCmpOnFace cmp p t u v) = do+    ((p,t),u,v) <- instantiate' ((p,t),u,v)+    return $ ValueCmpOnFace cmp p t u v+  instantiate' (ElimCmp cmp fs t v as bs) =+    ElimCmp cmp fs <$> instantiate' t <*> instantiate' v <*> instantiate' as <*> instantiate' bs+  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 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+  instantiate' (HasBiggerSort a)    = HasBiggerSort <$> instantiate' a+  instantiate' (HasPTSRule a b)     = uncurry HasPTSRule <$> instantiate' (a,b)+  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 cc ms mod t) = flip (UsableAtModality cc) mod <$> instantiate' ms <*> instantiate' t++instance Instantiate CompareAs where+  instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a+  instantiate' AsSizes       = return AsSizes+  instantiate' AsTypes       = return AsTypes++instance Instantiate Candidate where+  instantiate' (Candidate q u t ov) = Candidate q <$> instantiate' u <*> instantiate' t <*> pure ov++instance Instantiate EqualityView where+  instantiate' (OtherType t)            = OtherType+    <$> instantiate' t+  instantiate' (IdiomType t)            = IdiomType+    <$> instantiate' t+  instantiate' (EqualityType r s eq l t a b) = EqualityType r+    <$> instantiate' s+    <*> return eq+    <*> mapM instantiate' l+    <*> instantiate' t+    <*> instantiate' a+    <*> instantiate' b++---------------------------------------------------------------------------+-- * Reduction to weak head normal form.+---------------------------------------------------------------------------++-- | Is something (an elimination of) a meta variable?+--   Does not perform any reductions.++class IsMeta a where+  isMeta :: a -> Maybe MetaId++instance IsMeta Term where+  isMeta (MetaV m _) = Just m+  isMeta _           = Nothing++instance IsMeta a => IsMeta (Sort' a) where+  isMeta (MetaS m _) = Just m+  isMeta _           = Nothing++instance IsMeta a => IsMeta (Type'' t a) where+  isMeta = isMeta . unEl++instance IsMeta a => IsMeta (Elim' a) where+  isMeta Proj{}    = Nothing+  isMeta IApply{}  = Nothing+  isMeta (Apply a) = isMeta a++instance IsMeta a => IsMeta (Arg a) where+  isMeta = isMeta . unArg++instance IsMeta a => IsMeta (Level' a) where+  isMeta (Max 0 [l]) = isMeta l+  isMeta _           = Nothing++instance IsMeta a => IsMeta (PlusLevel' a) where+  isMeta (Plus 0 l)  = isMeta l+  isMeta _           = Nothing++instance IsMeta CompareAs where+  isMeta (AsTermsOf a) = isMeta a+  isMeta AsSizes       = Nothing+  isMeta AsTypes       = Nothing++-- | Case on whether a term is blocked on a meta (or is a meta).+--   That means it can change its shape when the meta is instantiated.+ifBlocked+  :: (Reduce t, IsMeta t, MonadReduce m)+  => t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a+ifBlocked t blocked unblocked = do+  t <- reduceB t+  case t of+    Blocked m t     -> blocked m t+    NotBlocked nb t -> case isMeta t of -- #4899: MetaS counts as NotBlocked at the moment+      Just m    -> blocked (unblockOnMeta m) t+      Nothing   -> unblocked nb t++-- | Throw pattern violation if blocked or a meta.+abortIfBlocked :: (MonadReduce m, MonadBlock m, IsMeta t, Reduce t) => t -> m t+abortIfBlocked t = ifBlocked t (const . patternViolation) (const return)++isBlocked+  :: (Reduce t, IsMeta t, MonadReduce m)+  => 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)++  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+    -- 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 -> 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+  reduce' (Proj o f)= pure $ Proj o f+  reduce' (IApply x y v) = IApply <$> reduce' x <*> reduce' y <*> reduce' v++instance Reduce Level where+  reduce'  (Max m as) = levelMax m <$> mapM reduce' as+  reduceB' (Max m as) = fmap (levelMax m) . blockAny <$> traverse reduceB' as++instance Reduce PlusLevel where+  reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l++instance (Subst a, Reduce a) => Reduce (Abs a) where+  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++    reduceB' t = traverse id <$> traverse reduceB' t++instance Reduce t => Reduce (Dom t) where+    reduce' = traverse reduce'+    reduceB' t = traverse id <$> traverse reduceB' t++instance (Reduce a, Reduce b) => Reduce (a,b) where+    reduce' (x,y)  = (,) <$> reduce' x <*> reduce' y+    reduceB' (x,y) = do+      x <- reduceB' x+      y <- reduceB' y+      let blk = void x `mappend` void y+          xy  = (ignoreBlocking x , ignoreBlocking y)+      return $ blk $> xy++instance (Reduce a, Reduce b,Reduce c) => Reduce (a,b,c) where+    reduce' (x,y,z) = (,,) <$> reduce' x <*> reduce' y <*> reduce' z+    reduceB' (x,y,z) = do+      x <- reduceB' x+      y <- reduceB' y+      z <- reduceB' z+      let blk = void x `mappend` void y `mappend` void z+          xyz = (ignoreBlocking x , ignoreBlocking y , ignoreBlocking z)+      return $ blk $> xyz++reduceIApply :: ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term)+reduceIApply = reduceIApply' reduceB'++reduceIApply' :: (Term -> ReduceM (Blocked Term)) -> ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term)+reduceIApply' red d (IApply x y r : es) = do+  view <- intervalView'+  r <- reduceB' r+  -- We need to propagate the blocking information so that e.g.+  -- we postpone "someNeutralPath ?0 = a" rather than fail.+  case view (ignoreBlocking r) of+   IZero -> red (applyE x es)+   IOne  -> red (applyE y es)+   _     -> fmap (<* r) (reduceIApply' red d es)+reduceIApply' red d (_ : es) = reduceIApply' red d es+reduceIApply' _   d [] = d++instance Reduce DeBruijnPattern where+  reduceB' (DotP o v) = fmap (DotP o) <$> reduceB' v+  reduceB' p          = return $ notBlocked p++instance Reduce Term where+  reduceB' = {-# SCC "reduce'<Term>" #-} maybeFastReduceTerm++shouldTryFastReduce :: ReduceM Bool+shouldTryFastReduce = optFastReduce <$> pragmaOptions++maybeFastReduceTerm :: Term -> ReduceM (Blocked Term)+maybeFastReduceTerm v = do+  let tryFast = case v of+                  Def{}   -> True+                  Con{}   -> True+                  MetaV{} -> True+                  _       -> False+  if not tryFast then slowReduceTerm v+                 else+    case v of+      MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)+      _         -> maybeFast v+  where+    isOpen x = isOpenMeta <$> lookupMetaInstantiation x+    maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)++slowReduceTerm :: Term -> ReduceM (Blocked Term)+slowReduceTerm v = do+    v <- instantiate' v+    let done | MetaV x _ <- v = return $ blocked x v+             | otherwise      = return $ notBlocked v+        iapp = reduceIApply done+    case v of+--    Andreas, 2012-11-05 not reducing meta args does not destroy anything+--    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 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 reduceB' (Con c ci []) (conName c) es+          traverse reduceNat v+      Sort s   -> done+      Level l  -> ifM (SmallSet.member LevelReductions <$> asksTC envAllowedReductions)+                    {- then -} (fmap levelTm <$> reduceB' l)+                    {- else -} done+      Pi _ _   -> done+      Lit _    -> done+      Var _ es  -> iapp es+      Lam _ _  -> done+      DontCare _ -> done+      Dummy{}    -> done+    where+      -- NOTE: reduceNat can traverse the entire term.+      reduceNat v@(Con c ci []) = do+        mz  <- getBuiltin' builtinZero+        case v of+          _ | Just v == mz  -> return $ Lit $ LitNat 0+          _                 -> return v+      reduceNat v@(Con c ci [Apply a]) | visible a && isRelevant a = do+        ms  <- getBuiltin' builtinSuc+        case v of+          _ | Just (Con c ci []) == ms -> inc <$> reduce' (unArg a)+          _                         -> return v+          where+            inc = \case+              Lit (LitNat n) -> Lit $ LitNat $ n + 1+              w              -> Con c ci [Apply $ defaultArg w]+      reduceNat v = return v++-- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion+-- need also to instantiate metas, see Issue 826.+unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim)+unfoldCorecursionE (Proj o p)           = notBlocked . Proj o <$> getOriginalProjection p+unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) <$>+  unfoldCorecursion v+unfoldCorecursionE (IApply x y r) = do -- TODO check if this makes sense+   [x,y,r] <- mapM unfoldCorecursion [x,y,r]+   return $ IApply <$> x <*> y <*> r++unfoldCorecursion :: Term -> ReduceM (Blocked Term)+unfoldCorecursion v = do+  v <- instantiate' v+  case v of+    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 ::+  (Term -> ReduceM (Blocked Term)) ->+  Term -> QName -> Args -> ReduceM (Blocked Term)+unfoldDefinition keepGoing v f args =+  unfoldDefinitionE keepGoing v f (map Apply args)++unfoldDefinitionE ::+  (Term -> ReduceM (Blocked Term)) ->+  Term -> QName -> Elims -> ReduceM (Blocked Term)+unfoldDefinitionE keepGoing v f es = do+  r <- unfoldDefinitionStep v f es+  case r of+    NoReduction v    -> return v+    YesReduction _ v -> keepGoing v++unfoldDefinition' ::+  (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) ->+  Term -> QName -> Elims -> ReduceM (Simplification, Blocked Term)+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 :: 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+  rewr <- instantiateRewriteRules =<< getRewriteRulesFor f+  allowed <- asksTC envAllowedReductions+  prp <- runBlocked $ isPropM $ defType info+  defOk <- shouldReduceDef f+  let def = theDef info+      v   = v0 `applyE` es+      -- Non-terminating functions+      -- (i.e., those that failed the termination check)+      -- and delayed definitions+      -- are not unfolded unless explicitly permitted.+      dontUnfold = or+        [ defNonterminating info && SmallSet.notMember NonTerminatingReductions allowed+        , defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed+        , prp == Right True+        , isIrrelevant info+        , not defOk+        ]+      copatterns = defCopatternLHS info+  case def of+    Constructor{conSrcCon = c} -> do+      let hd = Con (c `withRangeOf` f) ConOSystem+      rewrite (NotBlocked ReallyNotBlocked ()) hd rewr es+    Primitive{primAbstr = ConcreteDef, primName = x, primClauses = cls} -> do+      pf <- fromMaybe __IMPOSSIBLE__ <$> getPrimitive' x+      if FunctionReductions `SmallSet.member` allowed+        then reducePrimitive x v0 f es pf dontUnfold+                             cls (defCompiled info) rewr+        else noReduction $ notBlocked v+    PrimitiveSort{ primSortSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es++    _  -> do+      if or+          [ RecursiveReductions `SmallSet.member` allowed+          , isJust (isProjection_ def) && ProjectionReductions `SmallSet.member` allowed+              -- Includes projection-like and irrelevant projections.+              -- Note: irrelevant projections lead to @dontUnfold@ and+              -- so are not actually unfolded.+          , isInlineFun def && InlineReductions `SmallSet.member` allowed+          , definitelyNonRecursive_ def && or+            [ copatterns && CopatternReductions `SmallSet.member` allowed+            , FunctionReductions `SmallSet.member` allowed+            ]+          ]+        then+          reduceNormalE v0 f (map notReduced es) dontUnfold+                       (defClauses info) (defCompiled info) rewr+        else noReduction $ notBlocked v  -- Andrea(s), 2014-12-05 OK?++  where+    noReduction    = return . NoReduction+    yesReduction s = return . YesReduction s+    reducePrimitive x v0 f es pf dontUnfold cls mcc rewr+      | length es < ar+                  = noReduction $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied+      | otherwise = {-# SCC "reducePrimitive" #-} do+          let (es1,es2) = splitAt ar es+              args1     = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es1+          r <- primFunImplementation pf args1 (length es2)+          case r of+            NoReduction args1' -> do+              let es1' = map (fmap Apply) args1'+              if null cls && null rewr then do+                noReduction $ applyE (Def f []) <$> do+                  blockAll $ map mredToBlocked es1' ++ map notBlocked es2+               else+                reduceNormalE v0 f (es1' ++ map notReduced es2) dontUnfold cls mcc rewr+            YesReduction simpl v -> yesReduction simpl $ v `applyE` es2+      where+          ar  = primFunArity pf++          mredToBlocked :: IsMeta t => MaybeReduced t -> Blocked t+          mredToBlocked (MaybeRed NotReduced  e) = notBlocked e+          mredToBlocked (MaybeRed (Reduced b) e) = e <$ b++    reduceNormalE :: Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> ReduceM (Reduced (Blocked Term) Term)+    reduceNormalE v0 f es dontUnfold def mcc rewr = {-# SCC "reduceNormal" #-} do+      traceSDoc "tc.reduce" 90 ("reduceNormalE v0 =" <+> pretty v0) $ do+      case (def,rewr) of+        _ | dontUnfold -> traceSLn "tc.reduce" 90 "reduceNormalE: don't unfold (non-terminating or delayed)" $+                          defaultResult -- non-terminating or delayed+        ([],[])        -> traceSLn "tc.reduce" 90 "reduceNormalE: no clauses or rewrite rules" $ do+          -- no definition for head+          (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+          return ev+      where+      defaultResult = noReduction $ NotBlocked ReallyNotBlocked vfull+      vfull         = v0 `applyE` map ignoreReduced es+      debugReduce ev = verboseS "tc.reduce" 90 $ do+        case ev of+          NoReduction v -> do+            reportSDoc "tc.reduce" 90 $ vcat+              [ "*** tried to reduce " <+> pretty f+              , "    es =  " <+> sep (map (pretty . ignoreReduced) es)+              -- , "*** tried to reduce " <+> pretty vfull+              , "    stuck on" <+> pretty (ignoreBlocking v)+              ]+          YesReduction _simpl v -> do+            reportSDoc "tc.reduce"  90 $ "*** reduced definition: " <+> pretty f+            reportSDoc "tc.reduce"  95 $ "    result" <+> pretty v++-- | Specialized version to put in boot file.+reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)+reduceDefCopyTCM = reduceDefCopy++-- | Reduce a non-primitive definition if it is a copy linking to another def.+reduceDefCopy :: forall m. PureTCM m => QName -> Elims -> m (Reduced () Term)+reduceDefCopy f es = do+  info <- getConstInfo f+  case theDef info of+    _ | not $ defCopy info     -> return $ NoReduction ()+    Constructor{conSrcCon = c} -> return $ YesReduction YesSimplification (Con c ConOSystem es)+    _                          -> reduceDef_ info f es+  where+    reduceDef_ :: Definition -> QName -> Elims -> m (Reduced () Term)+    reduceDef_ info f es = case defClauses info of+      [cl] -> do  -- proper copies always have a single clause+        let v0 = Def f [] -- TODO: could be Con+            ps    = namedClausePats cl+            nargs = length es+            -- appDefE_ cannot handle underapplied functions, so we eta-expand here if that's the+            -- case. We use this function to compute display forms from module applications and in+            -- that case we don't always have saturated applications.+            (lam, es') = (unlamView xs, newes)+              where+                etaArgs [] _ = []+                etaArgs (p : ps) []+                  | VarP _ x <- namedArg p = Arg (getArgInfo p) (dbPatVarName x) : etaArgs ps []+                  | otherwise              = []+                etaArgs (_ : ps) (_ : es) = etaArgs ps es+                xs  = etaArgs ps es+                n   = length xs+                newes = raise n es ++ [ Apply $ var i <$ x | (i, x) <- zip (downFrom n) xs ]+        if defNonterminating info+         then return $ NoReduction ()+         else do+            ev <- liftReduce $ appDefE_ f v0 [cl] Nothing mempty $ map notReduced es'+            case ev of+              YesReduction simpl t -> return $ YesReduction simpl (lam t)+              NoReduction{}        -> return $ NoReduction ()+      []    -> return $ NoReduction ()  -- copies of generalizable variables have no clauses (and don't need unfolding)+      _:_:_ -> __IMPOSSIBLE__++-- | Reduce simple (single clause) definitions.+reduceHead :: PureTCM m => Term -> m (Blocked Term)+reduceHead v = do -- ignoreAbstractMode $ do+  -- Andreas, 2013-02-18 ignoreAbstractMode leads to information leakage+  -- see Issue 796++  -- first, possibly rewrite literal v to constructor form+  v <- constructorForm v+  traceSDoc "tc.inj.reduce" 30 (ignoreAbstractMode $ "reduceHead" <+> prettyTCM v) $ do+  case v of+    Def f es -> do++      abstractMode <- envAbstractMode <$> askTC+      isAbstract <- not <$> hasAccessibleDef f+      traceSLn "tc.inj.reduce" 50 (+        "reduceHead: we are in " ++ show abstractMode ++ "; " ++ prettyShow f +++        " is treated " ++ if isAbstract then "abstractly" else "concretely"+        ) $ do+      let v0  = Def f []+          red = liftReduce $ unfoldDefinitionE reduceHead v0 f es+      def <- theDef <$> getConstInfo f+      case def of+        -- Andreas, 2012-11-06 unfold aliases (single clause terminating functions)+        -- see test/succeed/Issue747+        -- We restrict this to terminating functions to not make the+        -- type checker loop here on non-terminating functions.+        -- see test/fail/TerminationInfiniteRecord+        Function{ funClauses = [ _ ], funTerminates = Just True } -> do+          traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++ prettyShow f ++ " is Function") $ do+          red+        Datatype{ dataClause = Just _ } -> red+        Record{ recClause = Just _ }    -> red+        _                               -> return $ notBlocked v+    _ -> return $ notBlocked v++-- | 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+  case v of+    _ | 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+        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++-- | Apply a definition using the compiled clauses, or fall back to+--   ordinary clauses if no compiled clauses exist.+appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)+appDef_ f v0 cls mcc rewr args = appDefE_ f v0 cls mcc rewr $ map (fmap Apply) args++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)+        (\cc -> appDefE v0 cc rewr args) mcc+++-- | Apply a defined function to it's arguments, using the compiled clauses.+--   The original term is the first argument applied to the third.+appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)+appDef v cc rewr args = appDefE v cc rewr $ map (fmap Apply) args++appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE v cc rewr es = do+  traceSDoc "tc.reduce" 90 ("appDefE v = " <+> pretty v) $ do+  r <- matchCompiledE cc es+  case r of+    YesReduction simpl t -> return $ YesReduction simpl t+    NoReduction es'      -> rewrite (void es') (applyE v) rewr (ignoreBlocking es')++-- | Apply a defined function to it's arguments, using the original clauses.+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' :: 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)+    goCls cl es = do+      case cl of+        -- Andreas, 2013-10-26  In case of an incomplete match,+        -- we just do not reduce.  This allows adding single function+        -- clauses after they have been type-checked, to type-check+        -- the remaining clauses (see Issue 907).+        -- Andrea(s), 2014-12-05:  We return 'MissingClauses' here, since this+        -- is the most conservative reason.+        [] -> do+          f <- fromMaybe __IMPOSSIBLE__ <$> asksTC envAppDef+          rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es+        cl : cls -> do+          let pats = namedClausePats cl+              body = clauseBody cl+              npats = length pats+              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+              -- 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!+                    -- Andreas, 2013-05-19 isn't this done now?+                    let sigma = buildSubstitution impossible nvars vs+                    return $ YesReduction simpl $ applySubst sigma w `applyE` es1+                | otherwise     -> rewrite (NotBlocked AbsurdMatch ()) (applyE v) rewr es++instance Reduce a => Reduce (Closure a) where+    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+  reduce' (ExtendTel a tel) = ExtendTel <$> reduce' a <*> reduce' tel++instance Reduce Constraint where+  reduce' (ValueCmp cmp t u v) = do+    (t,u,v) <- reduce' (t,u,v)+    return $ ValueCmp cmp t u v+  reduce' (ValueCmpOnFace cmp p t u v) = do+    ((p,t),u,v) <- reduce' ((p,t),u,v)+    return $ ValueCmpOnFace cmp p t u v+  reduce' (ElimCmp cmp fs t v as bs) =+    ElimCmp cmp fs <$> reduce' t <*> reduce' v <*> reduce' as <*> reduce' bs+  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 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+  reduce' (HasBiggerSort a)     = HasBiggerSort <$> reduce' a+  reduce' (HasPTSRule a b)      = uncurry HasPTSRule <$> reduce' (a,b)+  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 cc ms mod t) = flip (UsableAtModality cc) mod <$> reduce' ms <*> reduce' t++instance Reduce CompareAs where+  reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a+  reduce' AsSizes       = return AsSizes+  reduce' AsTypes       = return AsTypes++instance Reduce e => Reduce (Map k e) where+  reduce' = traverse reduce'++instance Reduce Candidate where+  reduce' (Candidate q u t ov) = Candidate q <$> reduce' u <*> reduce' t <*> pure ov++instance Reduce EqualityView where+  reduce' (OtherType t)            = OtherType+    <$> reduce' t+  reduce' (IdiomType t)            = IdiomType+    <$> reduce' t+  reduce' (EqualityType r s eq l t a b) = EqualityType r+    <$> reduce' s+    <*> return eq+    <*> mapM reduce' l+    <*> reduce' t+    <*> reduce' a+    <*> reduce' b++instance Reduce t => Reduce (IPBoundary' t) where+  reduce' = traverse reduce'+  reduceB' = fmap sequenceA . traverse reduceB'++---------------------------------------------------------------------------+-- * Simplification+---------------------------------------------------------------------------++-- | Only unfold definitions if this leads to simplification+--   which means that a constructor/literal pattern is matched.+--   We include reduction of IApply patterns, as `p i0` is akin to+--   matcing on the `i0` constructor of interval.+class Simplify t where+  simplify' :: t -> ReduceM t++  default simplify' :: (t ~ f a, Traversable f, Simplify a) => t -> ReduceM t+  simplify' = traverse simplify'++-- boring instances:++instance Simplify t => Simplify [t]+instance Simplify t => Simplify (Map k t)+instance Simplify t => Simplify (Maybe t)+instance Simplify t => Simplify (Strict.Maybe t)++instance Simplify t => Simplify (Arg t)+instance Simplify t => Simplify (Elim' t)+instance Simplify t => Simplify (Named name t)+instance Simplify t => Simplify (IPBoundary' t)++instance (Simplify a, Simplify b) => Simplify (a,b) where+    simplify' (x,y) = (,) <$> simplify' x <*> simplify' y++instance (Simplify a, Simplify b, Simplify c) => Simplify (a,b,c) where+    simplify' (x,y,z) =+        do  (x,(y,z)) <- simplify' (x,(y,z))+            return (x,y,z)++instance Simplify Bool where+  simplify' = return++-- interesting instances:++instance Simplify Term where+  simplify' v = do+    v <- instantiate' v+    let iapp es m = ignoreBlocking <$> reduceIApply' (fmap notBlocked . simplify') (notBlocked <$> m) es+    case v of+      Def f vs   -> iapp vs $ do+        let keepGoing simp v = return (simp, notBlocked v)+        (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+      MetaV x vs -> iapp vs $ MetaV x  <$> simplify' vs+      Con c ci vs-> iapp vs $ Con c ci <$> simplify' vs+      Sort s     -> Sort     <$> simplify' s+      Level l    -> levelTm  <$> simplify' l+      Pi a b     -> Pi       <$> simplify' a <*> simplify' b+      Lit l      -> return v+      Var i vs   -> iapp vs $ Var i    <$> simplify' vs+      Lam h v    -> Lam h    <$> simplify' v+      DontCare v -> dontCare <$> simplify' v+      Dummy{}    -> return v++simplifyBlocked' :: Simplify t => Blocked t -> ReduceM t+simplifyBlocked' (Blocked _ t) = return t+simplifyBlocked' (NotBlocked _ t) = simplify' t  -- Andrea(s), 2014-12-05 OK?++instance Simplify t => Simplify (Type' t) where+    simplify' (El s t) = El <$> simplify' s <*> simplify' t++instance Simplify Sort where+    simplify' s = do+      case s of+        PiSort a s1 s2 -> piSort <$> simplify' a <*> simplify' s1 <*> simplify' s2+        FunSort s1 s2 -> funSort <$> simplify' s1 <*> simplify' s2+        UnivSort s -> univSort <$> simplify' s+        Univ u s   -> Univ u <$> simplify' s+        Inf _ _    -> return 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++instance Simplify Level where+  simplify' (Max m as) = levelMax m <$> simplify' as++instance Simplify PlusLevel where+  simplify' (Plus n l) = Plus n <$> simplify' l++instance (Subst a, Simplify a) => Simplify (Abs a) where+    simplify' a@(Abs x _) = Abs x <$> underAbstraction_ a simplify'+    simplify' (NoAbs x v) = NoAbs x <$> simplify' v++instance Simplify t => Simplify (Dom t) where+    simplify' = traverse simplify'++instance Simplify a => Simplify (Closure a) where+    simplify' cl = do+        x <- enterClosure cl simplify'+        return $ cl { clValue = x }++instance (Subst a, Simplify a) => Simplify (Tele a) where+  simplify' EmptyTel        = return EmptyTel+  simplify' (ExtendTel a b) = uncurry ExtendTel <$> simplify' (a, b)++instance Simplify ProblemConstraint where+  simplify' (PConstr pid unblock c) = PConstr pid unblock <$> simplify' c++instance Simplify Constraint where+  simplify' (ValueCmp cmp t u v) = do+    (t,u,v) <- simplify' (t,u,v)+    return $ ValueCmp cmp t u v+  simplify' (ValueCmpOnFace cmp p t u v) = do+    ((p,t),u,v) <- simplify' ((p,t),u,v)+    return $ ValueCmp cmp (AsTermsOf t) u v+  simplify' (ElimCmp cmp fs t v as bs) =+    ElimCmp cmp fs <$> simplify' t <*> simplify' v <*> simplify' as <*> simplify' bs+  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 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+  simplify' (HasBiggerSort a)     = HasBiggerSort <$> simplify' a+  simplify' (HasPTSRule a b)      = uncurry HasPTSRule <$> simplify' (a,b)+  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 cc ms mod t) = flip (UsableAtModality cc) mod <$> simplify' ms <*> simplify' t++instance Simplify CompareAs where+  simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a+  simplify' AsSizes       = return AsSizes+  simplify' AsTypes       = return AsTypes++-- UNUSED+-- instance Simplify ConPatternInfo where+--   simplify' (ConPatternInfo mr mt) = ConPatternInfo mr <$> simplify' mt++-- UNUSED+-- instance Simplify Pattern where+--   simplify' p = case p of+--     VarP _       -> return p+--     LitP _       -> return p+--     ConP c ci ps -> ConP c <$> simplify' ci <*> simplify' ps+--     DotP v       -> DotP <$> simplify' v+--     ProjP _      -> return p++instance Simplify DisplayForm where+  simplify' (Display n ps v) = Display n <$> simplify' ps <*> return v++instance Simplify Candidate where+  simplify' (Candidate q u t ov) = Candidate q <$> simplify' u <*> simplify' t <*> pure ov++instance Simplify EqualityView where+  simplify' (OtherType t)            = OtherType+    <$> simplify' t+  simplify' (IdiomType t)            = IdiomType+    <$> simplify' t+  simplify' (EqualityType r s eq l t a b) = EqualityType r+    <$> simplify' s+    <*> return eq+    <*> mapM simplify' l+    <*> simplify' t+    <*> simplify' a+    <*> simplify' b++---------------------------------------------------------------------------+-- * Normalisation+---------------------------------------------------------------------------++class Normalise t where+  normalise' :: t -> ReduceM t++  default normalise' :: (t ~ f a, Traversable f, Normalise a) => t -> ReduceM t+  normalise' = traverse normalise'++-- 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)++-- Arg not included since we do not normalize irrelevant subterms+-- 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++instance (Normalise a, Normalise b, Normalise c) => Normalise (a,b,c) where+    normalise' (x,y,z) =+        do  (x,(y,z)) <- normalise' (x,(y,z))+            return (x,y,z)++instance Normalise Bool where+  normalise' = return++instance Normalise Char where+  normalise' = return++instance Normalise Int where+  normalise' = return++instance Normalise DBPatVar where+  normalise' = return++-- interesting instances:++instance Normalise Sort where+    normalise' s = do+      s <- reduce' s+      case s of+        PiSort a s1 s2 -> piSort <$> normalise' a <*> normalise' s1 <*> normalise' s2+        FunSort s1 s2 -> funSort <$> normalise' s1 <*> normalise' s2+        UnivSort s -> univSort <$> normalise' s+        Univ u s   -> Univ u <$> normalise' s+        Inf _ _    -> return 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++instance Normalise t => Normalise (Type' t) where+    normalise' (El s t) = El <$> normalise' s <*> normalise' t++instance Normalise Term where+    normalise' v = ifM shouldTryFastReduce (fastNormalise v) (slowNormaliseArgs =<< reduce' v)++slowNormaliseArgs :: Term -> ReduceM Term+slowNormaliseArgs = \case+  Var n vs    -> Var n      <$> normalise' vs+  Con c ci vs -> Con c ci   <$> normalise' vs+  Def f vs    -> Def f      <$> normalise' vs+  MetaV x vs  -> MetaV x    <$> normalise' vs+  v@(Lit _)   -> return v+  Level l     -> levelTm    <$> normalise' l+  Lam h b     -> Lam h      <$> normalise' b+  Sort s      -> Sort       <$> normalise' s+  Pi a b      -> uncurry Pi <$> normalise' (a, b)+  v@DontCare{}-> return v+  v@Dummy{}   -> return v++-- Note: not the default instance for Elim' since we do something special for Arg.+instance Normalise t => Normalise (Elim' t) where+  normalise' (Apply v) = Apply <$> normalise' v  -- invokes Normalise Arg here+  normalise' (Proj o f)= pure $ Proj o f+  normalise' (IApply x y v) = IApply <$> normalise' x <*> normalise' y <*> normalise' v++instance Normalise Level where+  normalise' (Max m as) = levelMax m <$> normalise' as++instance Normalise PlusLevel where+  normalise' (Plus n l) = Plus n <$> normalise' l++instance (Subst a, Normalise a) => Normalise (Abs a) where+    normalise' a@(Abs x _) = Abs x <$> underAbstraction_ a normalise'+    normalise' (NoAbs x v) = NoAbs x <$> normalise' v++instance Normalise t => Normalise (Arg t) where+    normalise' a+      | isIrrelevant a = return a -- Andreas, 2012-04-02: Do not normalize irrelevant terms!?+      | otherwise      = traverse normalise' a++instance Normalise t => Normalise (Dom t) where+    normalise' = traverse normalise'++instance Normalise a => Normalise (Closure a) where+    normalise' cl = do+        x <- enterClosure cl normalise'+        return $ cl { clValue = x }++instance (Subst a, Normalise a) => Normalise (Tele a) where+  normalise' EmptyTel        = return EmptyTel+  normalise' (ExtendTel a b) = uncurry ExtendTel <$> normalise' (a, b)++instance Normalise ProblemConstraint where+  normalise' (PConstr pid unblock c) = PConstr pid unblock <$> normalise' c++instance Normalise Constraint where+  normalise' (ValueCmp cmp t u v) = do+    (t,u,v) <- normalise' (t,u,v)+    return $ ValueCmp cmp t u v+  normalise' (ValueCmpOnFace cmp p t u v) = do+    ((p,t),u,v) <- normalise' ((p,t),u,v)+    return $ ValueCmpOnFace cmp p t u v+  normalise' (ElimCmp cmp fs t v as bs) =+    ElimCmp cmp fs <$> normalise' t <*> normalise' v <*> normalise' as <*> normalise' bs+  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 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+  normalise' (HasBiggerSort a)     = HasBiggerSort <$> normalise' a+  normalise' (HasPTSRule a b)      = uncurry HasPTSRule <$> normalise' (a,b)+  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 cc ms mod t) = flip (UsableAtModality cc) mod <$> normalise' ms <*> normalise' t++instance Normalise CompareAs where+  normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a+  normalise' AsSizes       = return AsSizes+  normalise' AsTypes       = return AsTypes++instance Normalise ConPatternInfo where+  normalise' i = normalise' (conPType i) <&> \ t -> i { conPType = t }++instance Normalise a => Normalise (Pattern' a) where+  normalise' p = case p of+    VarP o x     -> VarP o <$> normalise' x+    LitP{}       -> return p+    ConP c mt ps -> ConP c <$> normalise' mt <*> normalise' ps+    DefP o q ps  -> DefP o q <$> normalise' ps+    DotP o v     -> DotP o <$> normalise' v+    ProjP{}      -> return p+    IApplyP o t u x -> IApplyP o <$> normalise' t <*> normalise' u <*> normalise' x++instance Normalise DisplayForm where+  normalise' (Display n ps v) = Display n <$> normalise' ps <*> return v++instance Normalise Candidate where+  normalise' (Candidate q u t ov) = Candidate q <$> normalise' u <*> normalise' t <*> pure ov++instance Normalise EqualityView where+  normalise' (OtherType t)            = OtherType+    <$> normalise' t+  normalise' (IdiomType t)            = IdiomType+    <$> normalise' t+  normalise' (EqualityType r s eq l t a b) = EqualityType r+    <$> normalise' s+    <*> return eq+    <*> mapM normalise' l+    <*> normalise' t+    <*> normalise' a+    <*> normalise' b++---------------------------------------------------------------------------+-- * Full instantiation+---------------------------------------------------------------------------++-- | @instantiateFull'@ 'instantiate's metas everywhere (and recursively)+--   but does not 'reduce'.+class InstantiateFull t where+  instantiateFull' :: t -> ReduceM t++  default instantiateFull' :: (t ~ f a, Traversable f, InstantiateFull a) => t -> ReduceM t+  instantiateFull' = traverse instantiateFull'++-- 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)+instance InstantiateFull t => InstantiateFull (Strict.Maybe t)++instance InstantiateFull t => InstantiateFull (Arg t)+instance InstantiateFull t => InstantiateFull (Elim' t)+instance InstantiateFull t => InstantiateFull (Named name t)+instance InstantiateFull t => InstantiateFull (WithArity t)+instance InstantiateFull t => InstantiateFull (IPBoundary' t)++-- Tuples:++instance (InstantiateFull a, InstantiateFull b) => InstantiateFull (a,b) where+    instantiateFull' (x,y) = (,) <$> instantiateFull' x <*> instantiateFull' y++instance (InstantiateFull a, InstantiateFull b, InstantiateFull c) => InstantiateFull (a,b,c) where+    instantiateFull' (x,y,z) =+        do  (x,(y,z)) <- instantiateFull' (x,(y,z))+            return (x,y,z)++instance (InstantiateFull a, InstantiateFull b, InstantiateFull c, InstantiateFull d) => InstantiateFull (a,b,c,d) where+    instantiateFull' (x,y,z,w) =+        do  (x,(y,z,w)) <- instantiateFull' (x,(y,z,w))+            return (x,y,z,w)++-- Base types:++instance InstantiateFull Bool where+    instantiateFull' = return++instance InstantiateFull Char where+    instantiateFull' = return++instance InstantiateFull Int where+    instantiateFull' = return++instance InstantiateFull ModuleName where+    instantiateFull' = return++instance InstantiateFull Name where+    instantiateFull' = return++instance InstantiateFull QName where+  instantiateFull' = return++instance InstantiateFull Scope where+    instantiateFull' = return++instance InstantiateFull ConHead where+  instantiateFull' = return++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+            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++instance InstantiateFull t => InstantiateFull (Type' t) where+    instantiateFull' (El s t) =+      El <$> instantiateFull' s <*> instantiateFull' t++instance InstantiateFull Term where+    instantiateFull' = instantiate' >=> recurse >=> etaOnce+      -- Andreas, 2010-11-12 DONT ETA!? eta-reduction breaks subject reduction+      -- but removing etaOnce now breaks everything+      where+        recurse = \case+          Var n vs    -> Var n <$> instantiateFull' vs+          Con c ci vs -> Con c ci <$> instantiateFull' vs+          Def f vs    -> Def f <$> instantiateFull' vs+          MetaV x vs  -> MetaV x <$> instantiateFull' vs+          v@Lit{}     -> return v+          Level l     -> levelTm <$> instantiateFull' l+          Lam h b     -> Lam h <$> instantiateFull' b+          Sort s      -> Sort <$> instantiateFull' s+          Pi a b      -> uncurry Pi <$> instantiateFull' (a,b)+          DontCare v  -> dontCare <$> instantiateFull' v+          v@Dummy{}   -> return v++instance InstantiateFull Level where+  instantiateFull' (Max m as) = levelMax m <$> instantiateFull' as++instance InstantiateFull PlusLevel where+  instantiateFull' (Plus n l) = Plus n <$> instantiateFull' l++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 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 }++instance InstantiateFull a => InstantiateFull (Pattern' a) where+    instantiateFull' (VarP o x)     = VarP o <$> instantiateFull' x+    instantiateFull' (DotP o t)     = DotP o <$> instantiateFull' t+    instantiateFull' (ConP n mt ps) = ConP n <$> instantiateFull' mt <*> instantiateFull' ps+    instantiateFull' (DefP o q ps) = DefP o q <$> instantiateFull' ps+    instantiateFull' l@LitP{}       = return l+    instantiateFull' p@ProjP{}      = return p+    instantiateFull' (IApplyP o t u x) = IApplyP o <$> instantiateFull' t <*> instantiateFull' u <*> instantiateFull' x++instance (Subst a, InstantiateFull a) => InstantiateFull (Abs a) where+    instantiateFull' a@(Abs x _) = Abs x <$> underAbstraction_ a instantiateFull'+    instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a++instance (InstantiateFull t, InstantiateFull e) => InstantiateFull (Dom' t e) where+    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) =+    OpenThing checkpoint+    <$> (instantiateFull' =<< prune checkpoints)+    <*> pure modl+    <*> instantiateFull' t+    where+      -- Ulf, 2021-11-17, #5544+      --  Remove checkpoints that are no longer in scope, since they can+      --  mention functions that deadcode elimination will get rid of.+      prune cps = do+        inscope <- viewTC eCheckpoints+        return $ cps `Map.intersection` inscope++instance InstantiateFull a => InstantiateFull (Closure a) where+    instantiateFull' cl = do+        x <- enterClosure cl instantiateFull'+        return $ cl { clValue = x }++instance InstantiateFull ProblemConstraint where+  instantiateFull' (PConstr p u c) = PConstr p u <$> instantiateFull' c++instance InstantiateFull Constraint where+  instantiateFull' = \case+    ValueCmp cmp t u v -> do+      (t,u,v) <- instantiateFull' (t,u,v)+      return $ ValueCmp cmp t u v+    ValueCmpOnFace cmp p t u v -> do+      ((p,t),u,v) <- instantiateFull' ((p,t),u,v)+      return $ ValueCmpOnFace cmp p t u v+    ElimCmp cmp fs t v as bs ->+      ElimCmp cmp fs <$> instantiateFull' t <*> instantiateFull' v <*> instantiateFull' as <*> instantiateFull' bs+    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 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+    HasBiggerSort a     -> HasBiggerSort <$> instantiateFull' a+    HasPTSRule a b      -> uncurry HasPTSRule <$> instantiateFull' (a,b)+    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 cc ms mod t -> flip (UsableAtModality cc) mod <$> instantiateFull' ms <*> instantiateFull' t++instance InstantiateFull CompareAs where+  instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a+  instantiateFull' AsSizes       = return AsSizes+  instantiateFull' AsTypes       = return AsTypes++instance InstantiateFull Signature where+  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++instance (Subst a, InstantiateFull a) => InstantiateFull (Tele a) where+  instantiateFull' EmptyTel = return EmptyTel+  instantiateFull' (ExtendTel a b) = uncurry ExtendTel <$> instantiateFull' (a, b)++instance InstantiateFull Definition where+    instantiateFull' def@Defn{ defType = t ,defDisplay = df, theDef = d } = do+      (t, df, d) <- instantiateFull' (t, df, d)+      return $ def{ defType = t, defDisplay = df, theDef = d }++instance InstantiateFull NLPat where+  instantiateFull' (PVar x y) = return $ PVar x y+  instantiateFull' (PDef x y) = PDef <$> instantiateFull' x <*> instantiateFull' y+  instantiateFull' (PLam x y) = PLam x <$> instantiateFull' y+  instantiateFull' (PPi x y)  = PPi <$> instantiateFull' x <*> instantiateFull' y+  instantiateFull' (PSort x)  = PSort <$> instantiateFull' x+  instantiateFull' (PBoundVar x y) = PBoundVar x <$> instantiateFull' y+  instantiateFull' (PTerm x)  = PTerm <$> instantiateFull' x++instance InstantiateFull NLPType where+  instantiateFull' (NLPType s a) = NLPType+    <$> instantiateFull' s+    <*> instantiateFull' a++instance InstantiateFull NLPSort where+  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 top) =+    RewriteRule q+      <$> instantiateFull' gamma+      <*> pure f+      <*> instantiateFull' ps+      <*> 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 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)++instance InstantiateFull Defn where+    instantiateFull' d = case d of+      Axiom{} -> return d+      DataOrRecSig{} -> return d+      GeneralizableVar{} -> return d+      AbstractDefn d -> AbstractDefn <$> instantiateFull' d+      Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam } -> do+        (cs, cc, cov, inv) <- instantiateFull' (cs, cc, cov, inv)+        extLam <- instantiateFull' extLam+        return $ d { funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam }+      Datatype{ dataSort = s, dataClause = cl } -> do+        s  <- instantiateFull' s+        cl <- instantiateFull' cl+        return $ d { dataSort = s, dataClause = cl }+      Record{ recClause = cl, recTel = tel } -> do+        cl  <- instantiateFull' cl+        tel <- instantiateFull' tel+        return $ d { recClause = cl, recTel = tel }+      Constructor{} -> return d+      Primitive{ primClauses = cs } -> do+        cs <- instantiateFull' cs+        return $ d { primClauses = cs }+      PrimitiveSort{} -> return d++instance InstantiateFull ExtLamInfo where+  instantiateFull' e@(ExtLamInfo { extLamSys = sys}) = do+    sys <- instantiateFull' sys+    return $ e { extLamSys = sys}++instance InstantiateFull System where+  instantiateFull' (System tel sys) = System <$> instantiateFull' tel <*> instantiateFull' sys++instance InstantiateFull FunctionInverse where+  instantiateFull' NotInjective = return NotInjective+  instantiateFull' (Inverse inv) = Inverse <$> instantiateFull' inv++instance InstantiateFull a => InstantiateFull (Case a) where+  instantiateFull' (Branches cop cs eta ls m b lz) =+    Branches cop+      <$> instantiateFull' cs+      <*> instantiateFull' eta+      <*> instantiateFull' ls+      <*> instantiateFull' m+      <*> pure b+      <*> pure lz++instance InstantiateFull CompiledClauses where+  instantiateFull' (Fail xs)   = return $ Fail xs+  instantiateFull' (Done m t)  = Done m <$> instantiateFull' t+  instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs++instance InstantiateFull Clause where+    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 recursive+       <*> return unreachable+       <*> return ell+       <*> return wm++instance InstantiateFull Instantiation where+  instantiateFull' (Instantiation a b) =+    Instantiation a <$> instantiateFull' b++instance InstantiateFull (Judgement MetaId) where+  instantiateFull' (HasType a b c) =+    HasType a b <$> instantiateFull' c+  instantiateFull' (IsSort a b) =+    IsSort a <$> instantiateFull' b++instance InstantiateFull RemoteMetaVariable where+  instantiateFull' (RemoteMetaVariable a b c) = RemoteMetaVariable+    <$> instantiateFull' a+    <*> return b+    <*> instantiateFull' c++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) =+    Candidate q <$> instantiateFull' u <*> instantiateFull' t <*> pure ov++instance InstantiateFull EqualityView where+  instantiateFull' (OtherType t)            = OtherType+    <$> instantiateFull' t+  instantiateFull' (IdiomType t)            = IdiomType+    <$> instantiateFull' t+  instantiateFull' (EqualityType r s eq l t a b) = EqualityType r+    <$> instantiateFull' s+    <*> return eq+    <*> mapM instantiateFull' l     <*> instantiateFull' t     <*> instantiateFull' a     <*> instantiateFull' b
+ src/full/Agda/TypeChecking/Reduce.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Reduce where++import Agda.Syntax.Internal (Term, Elims, QName)+import Agda.TypeChecking.Monad.Base (TCM, Reduced)++reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)
src/full/Agda/TypeChecking/Reduce/Fast.hs view
@@ -1,534 +1,1473 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE BangPatterns        #-}--{-|--This module contains an optimised implementation of the reduction algorithm-from 'Agda.TypeChecking.Reduce' and 'Agda.TypeChecking.CompiledClause.Match'.-It runs roughly an order of magnitude faster than the original implementation.--The differences are the following:--- Only applies when we don't have --sharing and when all reductions are-  allowed.--  This means we can skip a number of checks that would otherwise be performed-  at each reduction step.--- Does not track whether simplifications were made.--  This information is only used when trying to simplify terms, so the-  simplifier runs the slow implementation.--- Precomputes primZero and primSuc.--  Since all the functions involved in reduction are implemented in this module-  in a single where block, we can look up zero and suc once instead of once for-  each reduction step.--- Run outside ReduceM--  ReduceM is already just a plain reader monad, but pulling out the environment-  and doing all reduction non-monadically saves a significant amount of time.--- Memoise getConstInfo.--  A big chunk of the time during reduction is spent looking up definitions in-  the signature. Any long-running reduction will use only a handful definitions-  though, so memoising getConstInfo is a big win.--- Optimised case trees.--  Since we memoise getConstInfo we can do some preprocessing of the-  definitions, returning a 'CompactDef' instead of a 'Definition'. In-  particular we streamline the case trees used for matching in a few ways:--    - Drop constructor arity information.-    - Use NameId instead of QName as map keys.-    - Special branch for natural number successor.--  None of these changes would make sense to incorporate into the actual case-  trees. The first two loses information that we need in other places and the-  third would complicate a lot of code working with case trees.--- Optimised parallel substitution.--  When substituting arguments into function bodies we always have a complete-  (a term for every free variable) parallel substitution. We run an specialised-  substitution for this case that falls back to normal substitution when it-  hits a binder.---}-module Agda.TypeChecking.Reduce.Fast-  ( fastReduce ) where--import Control.Applicative-import Control.Monad.Reader--import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Traversable (traverse)--import System.IO.Unsafe-import Data.IORef--import Agda.Syntax.Internal-import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Literal--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce as R-import Agda.TypeChecking.Rewriting (rewrite)-import Agda.TypeChecking.Reduce.Monad as RedM-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Monad.Builtin hiding (constructorForm)-import Agda.TypeChecking.CompiledClause.Match--import Agda.Interaction.Options--import Agda.Utils.Maybe-import Agda.Utils.Memo-import Agda.Utils.Function-import Agda.Utils.Functor--#include "undefined.h"-import Agda.Utils.Impossible---- Compact definitions -------------------------------------------------------- This is what the memoised getConstInfo returns. We essentially pick out only the--- information needed for fast reduction from the definition.--data CompactDef =-  CompactDef { cdefDelayed        :: Bool-             , cdefNonterminating :: Bool-             , cdefDef            :: CompactDefn-             , cdefRewriteRules   :: RewriteRules-             }--data CompactDefn-  = CFun  { cfunCompiled  :: FastCompiledClauses, cfunProjection :: Maybe QName }-  | CCon  { cconSrcCon    :: ConHead }-  | CForce  -- ^ primForce-  | CTyCon  -- ^ Datatype or record type. Need to know this for primForce.-  | COther  -- ^ In this case we fall back to slow reduction--compactDef :: Maybe ConHead -> Maybe ConHead -> Maybe QName -> Definition -> RewriteRules -> ReduceM CompactDef-compactDef z s pf def rewr = do-  cdefn <--    case theDef def of-      _ | Just (defName def) == pf -> pure CForce-      Constructor{conSrcCon = c} -> pure CCon{cconSrcCon = c}-      Function{funCompiled = Just cc, funClauses = _:_, funProjection = proj} ->-        pure CFun{ cfunCompiled   = fastCompiledClauses z s cc-                 , cfunProjection = projOrig <$> proj }-      Datatype{dataClause = Nothing} -> pure CTyCon-      Record{recClause = Nothing} -> pure CTyCon-      _ -> pure COther-  return $-    CompactDef { cdefDelayed        = defDelayed def == Delayed-               , cdefNonterminating = defNonterminating def-               , cdefDef            = cdefn-               , cdefRewriteRules   = rewr-               }---- Faster case trees --------------------------------------------------------data FastCase c = FBranches-  { fprojPatterns   :: Bool-    -- ^ We are constructing a record here (copatterns).-    --   'conBranches' lists projections.-  , fconBranches    :: Map NameId c-    -- ^ Map from constructor (or projection) names to their arity-    --   and the case subtree.  (Projections have arity 0.)-  , fsucBranch      :: Maybe c-  , flitBranches    :: Map Literal c-    -- ^ Map from literal to case subtree.-  , fcatchAllBranch :: Maybe c-    -- ^ (Possibly additional) catch-all clause.-  }---- | Case tree with bodies.--data FastCompiledClauses-  = FCase Int (FastCase FastCompiledClauses)-    -- ^ @Case n bs@ stands for a match on the @n@-th argument-    -- (counting from zero) with @bs@ as the case branches.-    -- If the @n@-th argument is a projection, we have only 'conBranches'-    -- with arity 0.-  | FDone [Arg ArgName] Term-    -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding-    --   and name suggestions for the free variables. This is needed to build-    --   lambdas on the right hand side for partial applications which can-    --   still reduce.-  | FFail-    -- ^ Absurd case.--type FastStack = [(FastCompiledClauses, MaybeReducedElims, Elims -> Elims)]--fastCompiledClauses :: Maybe ConHead -> Maybe ConHead -> CompiledClauses -> FastCompiledClauses-fastCompiledClauses z s cc =-  case cc of-    Fail              -> FFail-    Done xs b         -> FDone xs b-    Case (Arg _ n) bs -> FCase n (fastCase z s bs)--fastCase :: Maybe ConHead -> Maybe ConHead -> Case CompiledClauses -> FastCase FastCompiledClauses-fastCase z s (Branches proj con lit wild) =-  FBranches-    { fprojPatterns   = proj-    , fconBranches    = Map.mapKeysMonotonic (nameId . qnameName) $ fmap (fastCompiledClauses z s . content) con-    , fsucBranch      = fmap (fastCompiledClauses z s . content) $ flip Map.lookup con . conName =<< s-    , flitBranches    = fmap (fastCompiledClauses z s) lit-    , fcatchAllBranch = fmap (fastCompiledClauses z s) wild }--{-# INLINE lookupCon #-}-lookupCon :: QName -> FastCase c -> Maybe c-lookupCon c (FBranches _ cons _ _ _) = Map.lookup (nameId $ qnameName c) cons---- QName memo ---------------------------------------------------------------{-# NOINLINE memoQName #-}-memoQName :: (QName -> a) -> (QName -> a)-memoQName f = unsafePerformIO $ do-  tbl <- newIORef Map.empty-  return (unsafePerformIO . f' tbl)-  where-    f' tbl x = do-      let i = nameId (qnameName x)-      m <- readIORef tbl-      case Map.lookup i m of-        Just y  -> return y-        Nothing -> do-          let y = f x-          writeIORef tbl (Map.insert i y m)-          return y---- Faster substitution -------------------------------------------------------- Precondition: All free variables of the term are assigned values in the--- list.--- Reverts to normal substitution if it hits a binder or other icky stuff (like--- levels). It's strict in the shape of the result to avoid creating huge--- thunks for accumulator arguments.-strictSubst :: Bool -> [Term] -> Term -> Term-strictSubst strict us-  | not strict = applySubst rho-  | otherwise  = go 0-  where-    rho = parallelS us-    go k v =-      case v of-        Var x es-          | x < k     -> Var x $! map' (goE k) es-          | otherwise -> applyE (raise k $ us !! (x - k)) $! map' (goE k) es-        Def f es -> defApp f [] $! map' (goE k) es-        Con c ci vs -> Con c ci $! map' (mapArg' $ go k) vs-        Lam i b  -> Lam i $! goAbs k b-        Lit{}    -> v-        _        -> applySubst (liftS k rho) v--    goE k (Apply v) = Apply $! mapArg' (go k) v-    goE _ p         = p--    goAbs k (Abs   x v) = Abs   x $! go (k + 1) v-    goAbs k (NoAbs x v) = NoAbs x $! go k v--map' :: (a -> b) -> [a] -> [b]-map' f []       = []-map' f (x : xs) = ((:) $! f x) $! map' f xs--mapArg' :: (a -> b) -> Arg a -> Arg b-mapArg' f (Arg i x) = Arg i $! f x----- Fast reduction ------------------------------------------------------------- | First argument: allow non-terminating reductions.-fastReduce :: Bool -> Term -> ReduceM (Blocked Term)-fastReduce allowNonTerminating v = do-  let name (Con c _ _) = c-      name _         = __IMPOSSIBLE__-  z  <- fmap name <$> getBuiltin' builtinZero-  s  <- fmap name <$> getBuiltin' builtinSuc-  pf <- fmap primFunName <$> getPrimitive' "primForce"-  rwr <- optRewriting <$> pragmaOptions-  constInfo <- unKleisli $ \f -> do-    info <- getConstInfo f-    rewr <- getRewriteRulesFor f-    compactDef z s pf info rewr-  ReduceM $ \ env -> reduceTm env (memoQName constInfo) allowNonTerminating rwr z s v--unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)-unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env--reduceTm :: ReduceEnv -> (QName -> CompactDef) -> Bool -> Bool -> Maybe ConHead -> Maybe ConHead -> Term -> Blocked Term-reduceTm env !constInfo allowNonTerminating hasRewriting zero suc = reduceB' 0-  where-    -- Force substitutions every nth step to avoid memory leaks. Doing it in-    -- every is too expensive (issue 2215).-    strictEveryNth = 1000--    runReduce m = unReduceM m env-    conNameId = nameId . qnameName . conName-    isZero =-      case zero of-        Nothing -> const False-        Just z  -> (conNameId z ==) . conNameId--    isSuc  =-      case suc of-        Nothing -> const False-        Just s  -> (conNameId s ==) . conNameId--    reduceB' steps v =-      case v of-        Def f es -> unfoldDefinitionE steps False reduceB' (Def f []) f es-        Con c ci vs ->-          -- Constructors can reduce' when they come from an-          -- instantiated module.-          case unfoldDefinition steps False reduceB' (Con c ci []) (conName c) vs of-            NotBlocked r v -> NotBlocked r $ reduceNat v-            b              -> b-        Lit{} -> done-        Var{} -> done-        _     -> runReduce (slowReduceTerm v)-      where-        done = notBlocked v--        reduceNat v@(Con c ci [])-          | isZero c = Lit $ LitNat (getRange c) 0-        reduceNat v@(Con c ci [a])-          | isSuc c  = inc . ignoreBlocking $ reduceB' 0 (unArg a)-          where-            inc (Lit (LitNat r n)) = Lit (LitNat noRange $ n + 1)-            inc w                  = Con c ci [defaultArg w]-        reduceNat v = v--    originalProjection :: QName -> QName-    originalProjection q =-      case cdefDef $ constInfo q of-        CFun{ cfunProjection = Just p } -> p-        _                               -> __IMPOSSIBLE__--    -- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion-    -- need also to instantiate metas, see Issue 826.-    unfoldCorecursionE :: Elim -> Blocked Elim-    unfoldCorecursionE (Proj o p)           = notBlocked $ Proj o $ originalProjection p-    unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) $-      unfoldCorecursion 0 v--    unfoldCorecursion :: Int -> Term -> Blocked Term-    unfoldCorecursion steps (Def f es) = unfoldDefinitionE steps True unfoldCorecursion (Def f []) f es-    unfoldCorecursion steps v          = reduceB' steps v--    -- | If the first argument is 'True', then a single delayed clause may-    -- be unfolded.-    unfoldDefinition ::-      Int -> Bool -> (Int -> Term -> Blocked Term) ->-      Term -> QName -> Args -> Blocked Term-    unfoldDefinition steps unfoldDelayed keepGoing v f args =-      unfoldDefinitionE steps unfoldDelayed keepGoing v f (map Apply args)--    unfoldDefinitionE ::-      Int -> Bool -> (Int -> Term -> Blocked Term) ->-      Term -> QName -> Elims -> Blocked Term-    unfoldDefinitionE steps unfoldDelayed keepGoing v f es =-      case unfoldDefinitionStep steps unfoldDelayed (constInfo f) v f es of-        NoReduction v    -> v-        YesReduction _ v -> (keepGoing $! steps + 1) v--    unfoldDefinitionStep :: Int -> Bool -> CompactDef -> Term -> QName -> Elims -> Reduced (Blocked Term) Term-    unfoldDefinitionStep steps unfoldDelayed CompactDef{cdefDelayed = delayed, cdefNonterminating = nonterm, cdefDef = def, cdefRewriteRules = rewr} v0 f es =-      let v = v0 `applyE` es-          -- Non-terminating functions-          -- (i.e., those that failed the termination check)-          -- and delayed definitions-          -- are not unfolded unless explicitely permitted.-          dontUnfold =-               (not allowNonTerminating && nonterm)-            || (not unfoldDelayed       && delayed)-      in case def of-        CCon{cconSrcCon = c} ->-          if hasRewriting then-            runReduce $ rewrite (notBlocked ()) (Con c ConOSystem []) rewr es-          else-            NoReduction $ notBlocked $ Con c ConOSystem [] `applyE` es-        CFun{cfunCompiled = cc} ->-          reduceNormalE steps v0 f (map notReduced es) dontUnfold cc-        CForce -> reduceForce unfoldDelayed v0 f es-        CTyCon -> if hasRewriting then-                    runReduce $ rewrite (notBlocked ()) v0 rewr es-                  else-                    NoReduction $ notBlocked v-        COther -> runReduce $ R.unfoldDefinitionStep unfoldDelayed v0 f es-      where-        yesReduction = YesReduction NoSimplification--        reduceForce :: Bool -> Term -> QName -> Elims -> Reduced (Blocked Term) Term-        reduceForce unfoldDelayed v0 pf (Apply a : Apply b : Apply s : Apply t : Apply u : Apply f : es) =-          case reduceB' 0 (unArg u) of-            ub@Blocked{}        -> noGo ub-            ub@(NotBlocked _ u)-              | isWHNF u  -> yesReduction $ unArg f `applyE` (Apply (defaultArg u) : es)-              | otherwise -> noGo ub-          where-            noGo ub = NoReduction $ ub <&> \ u -> Def pf (Apply a : Apply b : Apply s : Apply t : Apply (defaultArg u) : Apply f : es)--            isWHNF u = case u of-              Lit{}      -> True-              Con{}      -> True-              Lam{}      -> True-              Pi{}       -> True-              Sort{}     -> True-              Level{}    -> True-              DontCare{} -> True-              MetaV{}    -> False-              Var{}      -> False-              Def q _    -> isTyCon q-              Shared{}   -> __IMPOSSIBLE__--            isTyCon q =-              case cdefDef $ constInfo q of-                CTyCon -> True-                _      -> False--        -- TODO: partially applied to u-        reduceForce unfoldDelayed v0 pf es = runReduce $ R.unfoldDefinitionStep unfoldDelayed v0 f es--        reduceNormalE :: Int -> Term -> QName -> [MaybeReduced Elim] -> Bool -> FastCompiledClauses -> Reduced (Blocked Term) Term-        reduceNormalE steps v0 f es dontUnfold cc-          | dontUnfold = defaultResult  -- non-terminating or delayed-          | otherwise  =-            case match' steps f [(cc, es, id)] of-              YesReduction s u -> YesReduction s u-              NoReduction es'  -> if hasRewriting then-                                    runReduce $ rewrite (void es') v0 rewr (ignoreBlocking es')-                                  else-                                    NoReduction $ applyE v0 <$> es'-          where defaultResult = if hasRewriting then-                                  runReduce $ rewrite (NotBlocked AbsurdMatch ()) v0 rewr (map ignoreReduced es)-                                else-                                  NoReduction $ NotBlocked AbsurdMatch vfull-                vfull         = v0 `applyE` map ignoreReduced es--        match' :: Int -> QName -> FastStack -> Reduced (Blocked Elims) Term-        match' steps f ((c, es, patch) : stack) =-          let no blocking es = NoReduction $ blocking $ patch $ map ignoreReduced es-              yes t          = yesReduction t--          in case c of--            -- impossible case-            FFail -> no (NotBlocked AbsurdMatch) es--            -- done matching-            FDone xs t-              -- common case: exact number of arguments-              | m == n    -> {-# SCC match'Done #-} yes $ doSubst es t-              -- if the function was partially applied, return a lambda-              | m < n     -> yes $ doSubst es $ foldr lam t (drop m xs)-              -- otherwise, just apply instantiation to body-              -- apply the result to any extra arguments-              | otherwise -> yes $ doSubst es0 t `applyE` map ignoreReduced es1-              where-                n = length xs-                m = length es-                useStrictSubst = rem steps strictEveryNth == 0-                doSubst es t = strictSubst useStrictSubst (reverse $ map (unArg . argFromElim . ignoreReduced) es) t-                (es0, es1) = splitAt n es-                lam x t    = Lam (argInfo x) (Abs (unArg x) t)--            -- splitting on the @n@th elimination-            FCase n bs -> {-# SCC "match'Case" #-}-              case splitAt n es of-                -- if the @n@th elimination is not supplied, no match-                (_, []) -> no (NotBlocked Underapplied) es-                -- if the @n@th elimination is @e0@-                (es0, MaybeRed red e0 : es1) ->-                  -- get the reduced form of @e0@-                  let eb = case red of-                             Reduced b  -> e0 <$ b-                             NotReduced -> unfoldCorecursionE e0-                      e = ignoreBlocking eb-                      -- 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) (fcatchAllBranch bs)-                      -- If our argument is @Lit l@, we push @litFrame l@ onto the stack.-                      litFrame l stack =-                        case Map.lookup l (flitBranches bs) of-                          Nothing -> stack-                          Just cc -> (cc, es0 ++ es1, patchLit) : stack-                      -- If our argument (or its constructor form) is @Con c ci vs@-                      -- we push @conFrame c ci vs@ onto the stack.-                      conFrame c ci vs stack =-                        case lookupCon (conName c) bs of-                          Nothing -> stack-                          Just cc -> ( cc-                                     , es0 ++ map (MaybeRed NotReduced . Apply) vs ++ es1-                                     , patchCon c ci (length vs)-                                     ) : stack--                      sucFrame n stack =-                        case fsucBranch bs of-                          Nothing -> stack-                          Just cc -> (cc, es0 ++ [v] ++ es1, patchCon (fromJust suc) ConOSystem 1)-                                     : stack-                        where v = MaybeRed (Reduced $ notBlocked ()) $ Apply $ defaultArg $ Lit $ LitNat noRange n--                      -- If our argument is @Proj p@, we push @projFrame p@ onto the stack.-                      projFrame p stack =-                        case lookupCon p bs of-                          Nothing -> stack-                          Just cc -> (cc, es0 ++ es1, patchLit) : stack-                      -- The new patch function restores the @n@th argument to @v@:-                      -- In case we matched a literal, just put @v@ back.-                      patchLit es = patch (es0 ++ [e] ++ es1)-                        where (es0, es1) = splitAt n es-                      -- In case we matched constructor @c@ with @m@ arguments,-                      -- contract these @m@ arguments @vs@ to @Con c ci vs@.-                      patchCon c ci m es = patch (es0 ++ [Con c ci vs <$ e] ++ es2)-                        where (es0, rest) = splitAt n es-                              (es1, es2)  = splitAt m rest-                              vs          = map argFromElim es1-                  -- Now do the matching on the @n@ths argument:-                  in case eb of-                    Blocked x _       -> no (Blocked x) es'-                    NotBlocked blk elim ->-                      case elim of-                        Apply (Arg info v) ->-                          case v of-                            MetaV x _ -> no (Blocked x) es'--                            -- In case of a natural number literal, try also its constructor form-                            Lit l@(LitNat r n) ->-                              let cFrame stack-                                    | n > 0                  = sucFrame (n - 1) stack-                                    | n == 0, Just z <- zero = conFrame z ConOSystem [] stack-                                    | otherwise              = stack-                              in match' steps f $ litFrame l $ cFrame $ catchAllFrame stack--                            Lit l    -> match' steps f $ litFrame l    $ catchAllFrame stack-                            Con c ci vs -> match' steps f $ conFrame c ci vs $ catchAllFrame $ stack--                            -- Otherwise, we are stuck.  If we were stuck before,-                            -- we keep the old reason, otherwise we give reason StuckOn here.-                            _ -> no (NotBlocked $ stuckOn elim blk) es'--                        -- In case of a projection, push the projFrame-                        Proj _ p -> match' steps f $ projFrame p stack---        -- If we reach the empty stack, then pattern matching was incomplete-        match' _ f [] = {- new line here since __IMPOSSIBLE__ does not like the ' in match' -}-          runReduce $-            traceSLn "impossible" 10-              ("Incomplete pattern matching when applying " ++ show f)-              __IMPOSSIBLE__+{-# LANGUAGE PatternGuards #-}++{-|++This module implements the Agda Abstract Machine used for compile-time reduction. It's a+call-by-need environment machine with an implicit heap maintained using 'STRef's. See the 'AM' type+below for a description of the machine.++Some other tricks that improves performance:++- Memoise getConstInfo.++  A big chunk of the time during reduction is spent looking up definitions in the signature. Any+  long-running reduction will use only a handful definitions though, so memoising getConstInfo is a+  big win.++- Optimised case trees.++  Since we memoise getConstInfo we can do some preprocessing of the definitions, returning a+  'CompactDef' instead of a 'Definition'. In particular we streamline the case trees used for+  matching in a few ways:++    - Drop constructor arity information.+    - Use NameId instead of QName as map keys.+    - Special branch for natural number successor.++  None of these changes would make sense to incorporate into the actual case trees. The first two+  loses information that we need in other places and the third would complicate a lot of code+  working with case trees.++  'CompactDef' also has a special representation for built-in/primitive+  functions that can be implemented as pure functions from 'Literal's.++-}+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.Map.Strict as MapS+import qualified Data.IntSet as IntSet+import qualified Data.List as List+import Data.Semigroup ((<>))+import Data.Text (Text)+import qualified Data.Text as T++import System.IO.Unsafe (unsafePerformIO)+import Data.IORef+import Data.STRef+import Data.Char++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Monad hiding (Closure(..))+import Agda.TypeChecking.Reduce as R+import Agda.TypeChecking.Rewriting (rewrite)+import Agda.TypeChecking.Substitute++import Agda.Interaction.Options++import Agda.Utils.CallStack ( withCurrentCallStack )+import Agda.Utils.Char+import Agda.Utils.Float+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null (empty)+import Agda.Utils.Functor+import Agda.Syntax.Common.Pretty+import Agda.Utils.Size+import Agda.Utils.Zipper+import qualified Agda.Utils.SmallSet as SmallSet++import Agda.Utils.Impossible++import Debug.Trace++-- * Compact definitions++-- This is what the memoised getConstInfo returns. We essentially pick out only the+-- information needed for fast reduction from the definition.++data CompactDef =+  CompactDef { cdefNonterminating :: Bool+             , cdefUnconfirmed    :: Bool+             , cdefDef            :: CompactDefn+             , cdefRewriteRules   :: RewriteRules+             }++data CompactDefn+  = CFun  { cfunCompiled  :: FastCompiledClauses, cfunProjection :: Maybe QName }+  | CCon  { cconSrcCon :: ConHead, cconArity :: Int }+  | CForce   -- ^ primForce+  | CErase   -- ^ primErase+  | CTyCon   -- ^ Datatype or record type. Need to know this for primForce.+  | CAxiom   -- ^ Axiom or abstract defn+  | CPrimOp Int ([Literal] -> Term) (Maybe FastCompiledClauses)+            -- ^ Literals in reverse argument order+  | COther  -- ^ In this case we fall back to slow reduction++data BuiltinEnv = BuiltinEnv+  { bZero, bSuc, bTrue, bFalse, bRefl :: Maybe ConHead+  , bPrimForce, bPrimErase  :: Maybe QName }++-- | Compute a 'CompactDef' from a regular definition.+compactDef :: BuiltinEnv -> Definition -> RewriteRules -> ReduceM CompactDef+compactDef bEnv def rewr = do++  -- WARNING: don't use isPropM here because it relies on reduction,+  -- which causes an infinite loop.+  let isPrp = isProp $ getSort $ defType 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+      _ | not allowReduce -> pure CAxiom+      _ | Just (defName def) == bPrimForce bEnv   -> pure CForce+      _ | Just (defName def) == bPrimErase bEnv ->+          case telView' (defType def) of+            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 <$> either (const Nothing) Just proj }+      Function{funClauses = []}      -> pure CAxiom+      Function{}                     -> pure COther -- Incomplete definition+      Datatype{dataClause = Nothing} -> pure CTyCon+      Record{recClause = Nothing}    -> pure CTyCon+      Datatype{}                     -> pure COther -- TODO+      Record{}                       -> pure COther -- TODO+      Axiom{}                        -> pure CAxiom+      DataOrRecSig{}                 -> pure CAxiom+      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 (==)++          -- Word64+          PrimWord64ToNat              -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)+          PrimWord64FromNat            -> mkPrim 1 $ \ [LitNat a]    -> word (fromIntegral a)++          -- Levels+          -- "primLevelZero"              -- levels are not literals+          -- "primLevelSuc"               -- levels are not literals+          -- "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+          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)+          -- "primIntToFloat"             -- integers are not literals+          -- "primFloatRound"             -- integers and maybe are not literals+          -- "primFloatFloor"             -- integers and maybe are not literals+          -- "primFloatCeiling"           -- integers and maybe are not literals+          -- "primFloatToRatio"           -- integers and sigma are not literals+          -- "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)++          -- 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)++          -- 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)++          -- "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)+          -- "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)++          _                            -> pure COther+        where+          fcc = fastCompiledClauses bEnv <$> cc+          mkPrim n op = pure $ CPrimOp n op fcc++          divAux k m n j = k + div (max 0 $ n + m - j) (m + 1)+          modAux k m n j | n > j     = mod (n - j - 1) (m + 1)+                         | otherwise = k + n++          ~(Just true)  = bTrue  bEnv <&> \ c -> Con c ConOSystem []+          ~(Just false) = bFalse bEnv <&> \ c -> Con c ConOSystem []++          bool   a = if a then true else false+          nat    a = Lit . LitNat    $! a+          word   a = Lit . LitWord64 $! a+          float  a = Lit . LitFloat  $! a+          text   a = Lit . LitString $! a+          string a = text (T.pack a)+          char   a = Lit . LitChar   $! a++          -- Remember reverse order!+          natOp f [LitNat a, LitNat b] = nat (f b a)+          natOp _ _ = __IMPOSSIBLE__++          natOp4 f [LitNat a, LitNat b, LitNat c, LitNat d] = nat (f d c b a)+          natOp4 _ _ = __IMPOSSIBLE__++          natRel f [LitNat a, LitNat b] = bool (f b a)+          natRel _ _ = __IMPOSSIBLE__++          floatFun f [LitFloat a] = float (f a)+          floatFun _ _ = __IMPOSSIBLE__++          floatOp f [LitFloat a, LitFloat b] = float (f b a)+          floatOp _ _ = __IMPOSSIBLE__++          floatPred f [LitFloat a] = bool (f a)+          floatPred _ _ = __IMPOSSIBLE__++          floatRel f [LitFloat a, LitFloat b] = bool (f b a)+          floatRel _ _ = __IMPOSSIBLE__++          charFun f [LitChar a] = char (f a)+          charFun _ _ = __IMPOSSIBLE__++          charPred f [LitChar a] = bool (f a)+          charPred _ _ = __IMPOSSIBLE__++          charRel f [LitChar a, LitChar b] = bool (f b a)+          charRel _ _ = __IMPOSSIBLE__++  return $+    CompactDef { cdefNonterminating = defNonterminating def+               , cdefUnconfirmed    = defTerminationUnconfirmed def+               , cdefDef            = cdefn+               , cdefRewriteRules   = if allowReduce then rewr else []+               }++-- Faster case trees ------------------------------------------------------++data FastCase c = FBranches+  { fprojPatterns   :: Bool+    -- ^ We are constructing a record here (copatterns).+    --   'conBranches' lists projections.+  , fconBranches    :: Map NameId c+    -- ^ Map from constructor (or projection) names to their arity+    --   and the case subtree.  (Projections have arity 0.)+  , fsucBranch      :: Maybe c+  , flitBranches    :: Map Literal c+    -- ^ Map from literal to case subtree.+  , fcatchallBranch :: Maybe c+    -- ^ (Possibly additional) catch-all clause.+  , ffallThrough    :: Bool+    -- ^ (if True) In case of non-canonical argument use catchallBranch.+  }++--UNUSED Liang-Ting Chen 2019-07-16+--noBranches :: FastCase a+--noBranches = FBranches{ fprojPatterns   = False+--                      , fconBranches    = Map.empty+--                      , fsucBranch      = Nothing+--                      , flitBranches    = Map.empty+--                      , fcatchallBranch = Nothing+--                      , ffallThrough    = False }++-- | Case tree with bodies.++data FastCompiledClauses+  = FCase Int (FastCase FastCompiledClauses)+    -- ^ @Case n bs@ stands for a match on the @n@-th argument+    -- (counting from zero) with @bs@ as the case branches.+    -- If the @n@-th argument is a projection, we have only 'conBranches'+    -- with arity 0.+  | FEta Int [Arg QName] FastCompiledClauses (Maybe FastCompiledClauses)+    -- ^ Match on record constructor. Can still have a catch-all though. Just+    --   contains the fields, not the actual constructor.+  | FDone [Arg ArgName] Term+    -- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding+    --   and name suggestions for the free variables. This is needed to build+    --   lambdas on the right hand side for partial applications which can+    --   still reduce.+  | FFail+    -- ^ Absurd case.++fastCompiledClauses :: BuiltinEnv -> CompiledClauses -> FastCompiledClauses+fastCompiledClauses bEnv cc =+  case cc of+    Fail{}            -> FFail+    Done xs b         -> FDone xs b+    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)++fastCase :: BuiltinEnv -> Case CompiledClauses -> FastCase FastCompiledClauses+fastCase env (Branches proj con _ lit wild fT _) =+  FBranches+    { fprojPatterns   = proj+    , 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 }+  where+    stripSuc | Just c <- bSuc env = Map.delete (conName c)+             | otherwise          = id+++{-# INLINE lookupCon #-}+lookupCon :: QName -> FastCase c -> Maybe c+lookupCon c (FBranches _ cons _ _ _ _) = Map.lookup (nameId $ qnameName c) cons++-- QName memo -------------------------------------------------------------++{-# NOINLINE memoQName #-}+memoQName :: (QName -> a) -> (QName -> a)+memoQName f = unsafePerformIO $ do+  tbl <- newIORef Map.empty+  return (unsafePerformIO . f' tbl)+  where+    f' tbl x = do+      let i = nameId (qnameName x)+      m <- readIORef tbl+      case Map.lookup i m of+        Just y  -> return y+        Nothing -> do+          let y = f x+          writeIORef tbl (Map.insert i y m)+          return y++-- * Fast reduction++data Normalisation = WHNF | NF+  deriving (Eq)++-- | The entry point to the reduction machine.+fastReduce :: Term -> ReduceM (Blocked Term)+fastReduce = fastReduce' WHNF++fastNormalise :: Term -> ReduceM Term+fastNormalise v = ignoreBlocking <$> fastReduce' NF v++fastReduce' :: Normalisation -> Term -> ReduceM (Blocked Term)+fastReduce' norm v = do+  tcState <- getTCState+  let name (Con c _ _) = c+      name _         = __IMPOSSIBLE__++      -- 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+  constInfo <- unKleisli $ \f -> do+    info <- getConstInfo f+    rewr <- if rwr then instantiateRewriteRules =<< getRewriteRulesFor f+                   else return []+    compactDef bEnv info rewr+  ReduceM $ \ redEnv -> reduceTm redEnv bEnv (memoQName constInfo) norm v++-- * Closures++-- | The abstract machine represents terms as closures containing a 'Term', an environment, and a+--   spine of eliminations. Note that the environment doesn't necessarily bind all variables in the+--   term. The variables in the context in which the abstract machine is started are free in+--   closures. The 'IsValue' argument tracks whether the closure is in weak-head normal form.+data Closure s = Closure IsValue Term (Env s) (Spine s)+                 -- ^ The environment applies to the 'Term' argument. The spine contains closures+                 --   with their own environments.++-- | Used to track if a closure is @Unevaluated@ or a @Value@ (in weak-head normal form), and if so+--   why it cannot reduce further.+data IsValue = Value Blocked_ | Unevaled++-- | The spine is a list of eliminations. Application eliminations contain pointers.+type Spine s = [Elim' (Pointer s)]++isValue :: Closure s -> IsValue+isValue (Closure isV _ _ _) = isV++setIsValue :: IsValue -> Closure s -> Closure s+setIsValue isV (Closure _ t env spine) = Closure isV t env spine++-- | Apply a closure to a spine of eliminations. Note that this does not preserve the 'IsValue'+--   field.+clApply :: Closure s -> Spine s -> Closure s+clApply c [] = c+clApply (Closure _ t env es) es' = Closure Unevaled t env (es <> es')++-- | Apply a closure to a spine, preserving the 'IsValue' field. Use with care, since usually+--   eliminations do not preserve the value status.+clApply_ :: Closure s -> Spine s -> Closure s+clApply_ c [] = c+clApply_ (Closure b t env es) es' = Closure b t env (es <> es')++-- * Pointers and thunks++-- | Spines and environments contain pointers to closures to enable call-by-need evaluation.+data Pointer s = Pure (Closure s)+                 -- ^ Not a pointer. Used for closures that do not need to be shared to avoid+                 --   unnecessary updates.+               | Pointer {-# UNPACK #-} !(STPointer s)+                 -- ^ An actual pointer is an 'STRef' to a 'Thunk'. The thunk is set to 'BlackHole'+                 --   during the evaluation of its contents to make debugging loops easier.++type STPointer s = STRef s (Thunk (Closure s))++-- | A thunk is either a black hole or contains a value.+data Thunk a = BlackHole | Thunk a+  deriving (Functor)++derefPointer :: Pointer s -> ST s (Thunk (Closure s))+derefPointer (Pure x)      = return (Thunk x)+derefPointer (Pointer ptr) = readSTRef ptr++-- | In most cases pointers that we dereference do not contain black holes.+derefPointer_ :: Pointer s -> ST s (Closure s)+derefPointer_ ptr =+  derefPointer ptr <&> \case+    Thunk cl  -> cl+    BlackHole -> __IMPOSSIBLE__+++-- | Only use for debug printing!+unsafeDerefPointer :: Pointer s -> Thunk (Closure s)+unsafeDerefPointer (Pure x)    = Thunk x+unsafeDerefPointer (Pointer p) = unsafePerformIO (unsafeSTToIO (readSTRef p))++readPointer :: STPointer s -> ST s (Thunk (Closure s))+readPointer = readSTRef++storePointer :: STPointer s -> Closure s -> ST s ()+storePointer ptr !cl = writeSTRef ptr (Thunk cl)+    -- Note the strict match. To prevent leaking memory in case of unnecessary updates.++blackHole :: STPointer s -> ST s ()+blackHole ptr = writeSTRef ptr BlackHole++-- | Create a thunk. If the closure is a naked variable we can reuse the pointer from the+--   environment to avoid creating long pointer chains.+createThunk :: Closure s -> ST s (Pointer s)+createThunk (Closure _ (Var x []) env spine)+  | null spine, Just p <- lookupEnv x env = return p+createThunk cl = Pointer <$> newSTRef (Thunk cl)++-- | Create a thunk that is not shared or updated.+pureThunk :: Closure s -> Pointer s+pureThunk = Pure++-- * Environments++-- | The environment of a closure binds pointers to deBruijn indicies.+newtype Env s = Env [Pointer s]++emptyEnv :: Env s+emptyEnv = Env []+--UNUSED Liang-Ting Chen 2019-07-16+--isEmptyEnv :: Env s -> Bool+--isEmptyEnv (Env xs) = null xs++envSize :: Env s -> Int+envSize (Env xs) = length xs++envToList :: Env s -> [Pointer s]+envToList (Env xs) = xs++extendEnv :: Pointer s -> Env s -> Env s+extendEnv p (Env xs) = Env (p : xs)++-- | Unsafe.+lookupEnv_ :: Int -> Env s -> Pointer s+lookupEnv_ i (Env e) = indexWithDefault __IMPOSSIBLE__ e i++-- Andreas, 2018-11-12, which isn't this just Agda.Utils.List.!!! ?+lookupEnv :: Int -> Env s -> Maybe (Pointer s)+lookupEnv i e | i < n     = Just (lookupEnv_ i e)+              | otherwise = Nothing+  where n = envSize e++-- * The Agda Abstract Machine++-- | The abstract machine state has two states 'Eval' and 'Match' that determine what the machine is+--   currently working on: evaluating a closure in the Eval state and matching a spine against a+--   case tree in the Match state. Both states contain a 'ControlStack' of continuations for what to+--   do next. The heap is maintained implicitly using 'STRef's, hence the @s@ parameter.+data AM s = Eval (Closure s) !(ControlStack s)+            -- ^ Evaluate the given closure (the focus) to weak-head normal form. If the 'IsValue'+            --   field of the closure is 'Value' we look at the control stack for what to do. Being+            --   strict in the control stack is important! We can spend a lot of steps with+            --   unevaluated closures (where we update, but don't look at the control stack). For+            --   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+            --   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+--   case of a stuck match.+data MatchStack s = [CatchallFrame s] :> Closure s+infixr 2 :>, >:++(>:) :: CatchallFrame s -> MatchStack s -> MatchStack s+(>:) c (cs :> cl) = c : cs :> cl+-- Previously written as:+--   c >: cs :> cl = c : cs :> cl+--+-- However, some versions/tools fail to parse infix data constructors properly.+-- For example, stylish-haskell@0.9.2.1 fails with the following error:+--   Language.Haskell.Stylish.Parse.parseModule: could not parse+--   src/full/Agda/TypeChecking/Reduce/Fast.hs: ParseFailed (SrcLoc+--   "<unknown>.hs" 625 1) "Parse error in pattern: "+--+-- 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,+                        --   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+                        --   the value of the pattern variables at the point of the catch-all.++-- An Elim' with a hole.+data ElimZipper a = ApplyCxt ArgInfo+                  | IApplyType a a | IApplyFst a a | IApplySnd a a+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Zipper (ElimZipper a) where+  type Carrier (ElimZipper a) = Elim' a+  type Element (ElimZipper a) = a++  firstHole (Apply arg)    = Just (unArg arg, ApplyCxt (argInfo arg))+  firstHole (IApply a x y) = Just (a, IApplyType x y)+  firstHole Proj{}         = Nothing++  plugHole x (ApplyCxt i)     = Apply (Arg i x)+  plugHole a (IApplyType x y) = IApply a x y+  plugHole x (IApplyFst a y)  = IApply a x y+  plugHole y (IApplySnd a x)  = IApply a x y++  nextHole a (IApplyType x y) = Right (x, IApplyFst a y)+  nextHole x (IApplyFst a y)  = Right (y, IApplySnd a x)+  nextHole y (IApplySnd a x)  = Left (IApply a x y)+  nextHole x c@ApplyCxt{}     = Left (plugHole x c)++-- | A spine with a single hole for a pointer.+type SpineContext s = ComposeZipper (ListZipper (Elim' (Pointer s)))+                                    (ElimZipper (Pointer s))++-- | Control frames are continuations that act on value closures.+data ControlFrame s = CaseK QName ArgInfo (FastCase FastCompiledClauses) (Spine s) (Spine s) (MatchStack s)+                        -- ^ @CaseK f i bs spine0 spine1 stack@. Pattern match on the focus (with+                        --   arg info @i@) using the @bs@ case tree. @f@ is the name of the function+                        --   doing the matching, and @spine0@ and @spine1@ are the values bound to+                        --   the pattern variables to the left and right (respectively) of the+                        --   focus. The match stack contains catch-all cases we need to consider if+                        --   this match fails.+                    | ArgK (Closure s) (SpineContext s)+                        -- ^ @ArgK cl cxt@. Used when computing full normal forms. The closure is+                        --   the head and the context is the spine with the current focus removed.+                    | NormaliseK+                        -- ^ Indicates that the focus should be evaluated to full normal form.+                    | ForceK QName (Spine s) (Spine s)+                        -- ^ @ForceK f spine0 spine1@. Evaluating @primForce@ of the focus. @f@ is+                        --   the name of @primForce@ and is used to build the result if evaluation+                        --   gets stuck. @spine0@ are the level and type arguments and @spine1@+                        --   contains (if not empty) the continuation and any additional+                        --   eliminations.+                    | EraseK QName (Spine s) (Spine s) (Spine s) (Spine s)+                        -- ^ @EraseK f spine0 spine1 spine2 spine3@. Evaluating @primErase@. The+                        --   first contains the level and type arguments. @spine1@ and @spine2@+                        --   contain at most one argument between them. If in @spine1@ it's the+                        --   value closure of the first argument to be compared and if in @spine2@+                        --   it's the unevaluated closure of the second argument.+                        --   @spine3@ contains the proof of equality we are erasing. It is passed+                        --   around but never actually inspected.+                    | NatSucK Integer+                        -- ^ @NatSucK n@. Add @n@ to the focus. If the focus computes to a natural+                        --   number literal this returns a new literal, otherwise it constructs @n@+                        --   calls to @suc@.+                    | PrimOpK QName ([Literal] -> Term) [Literal] [Pointer s] (Maybe FastCompiledClauses)+                        -- ^ @PrimOpK f op lits es cc@. Evaluate the primitive function @f@ using+                        --   the Haskell function @op@. @op@ gets a list of literal values in+                        --   reverse order for the arguments of @f@ and computes the result as a+                        --   term. The already computed arguments (in reverse order) are @lits@ and+                        --   @es@ are the arguments that should be computed after the current focus.+                        --   In case of built-in functions with corresponding Agda implementations,+                        --   @cc@ contains the case tree.+                    | UpdateThunk [STPointer s]+                        -- ^ @UpdateThunk ps@. Update the pointers @ps@ with the value of the+                        --   current focus.+                    | ApplyK (Spine s)+                        -- ^ @ApplyK spine@. Apply the current focus to the eliminations in @spine@.+                        --   This is used when a thunk needs to be updated with a partial+                        --   application of a function.++-- * Compilation and decoding++-- | The initial abstract machine state. Wrap the term to be evaluated in an empty closure. Note+--   that free variables of the term are treated as constants by the abstract machine. If computing+--   full normal form we start off the control stack with a 'NormaliseK' continuation.+compile :: Normalisation -> Term -> AM s+compile nf t = Eval (Closure Unevaled t emptyEnv []) [NormaliseK | nf == NF]++decodePointer :: Pointer s -> ST s Term+decodePointer p = decodeClosure_ =<< derefPointer_ p++-- | Note: it's important to be lazy in the spine and environment when decoding. Hence the+--   'unsafeInterleaveST' here and in 'decodeEnv', and the special version of 'parallelS' in+--   'decodeClosure'.+decodeSpine :: Spine s -> ST s Elims+decodeSpine spine = unsafeInterleaveST $ (traverse . traverse) decodePointer spine++decodeEnv :: Env s -> ST s [Term]+decodeEnv env = unsafeInterleaveST $ traverse decodePointer (envToList env)++decodeClosure_ :: Closure s -> ST s Term+decodeClosure_ = ignoreBlocking <.> decodeClosure++-- | Turning an abstract machine closure back into a term. This happens in three cases:+--    * when reduction is finished and we return the weak-head normal term to the outside world.+--    * when the abstract machine encounters something it cannot handle and falls back to the slow+--      reduction engine+--    * when there are rewrite rules to apply+decodeClosure :: Closure s -> ST s (Blocked Term)+decodeClosure (Closure isV t env spine) = do+    vs <- decodeEnv env+    es <- decodeSpine spine+    return $ applyE (applySubst (parS vs) t) es <$ b+  where+    parS = foldr (:#) IdS  -- parallelS is too strict+    b    = case isV of+             Value b  -> b+             Unevaled -> notBlocked ()  -- only when falling back to slow reduce in which case the+                                        -- blocking tag is immediately discarded++-- | Turn a list of internal syntax eliminations into a spine. This builds closures and allocates+--   thunks for all the 'Apply' elims.+elimsToSpine :: Env s -> Elims -> ST s (Spine s)+elimsToSpine env es = do+    spine <- mapM thunk es+    forceSpine spine `seq` return spine+  where+    -- Need to be strict in mkClosure to avoid memory leak+    forceSpine = foldl (\ () -> forceEl) ()+    forceEl (Apply (Arg _ (Pure Closure{}))) = ()+    forceEl (Apply (Arg _ (Pointer{})))      = ()+    forceEl _                                = ()++    -- We don't preserve free variables of closures (in the sense of their+    -- decoding), since we freely add things to the spines.+    unknownFVs = setFreeVariables unknownFreeVariables++    thunk (Apply (Arg i t)) = Apply . Arg (unknownFVs i) <$> createThunk (closure (getFreeVariables i) t)+    thunk (Proj o f)        = return (Proj o f)+    thunk (IApply a x y)    = IApply <$> mkThunk a <*> mkThunk x <*> mkThunk y+      where mkThunk = createThunk . closure UnknownFVs++    -- Going straight for a value for literals is mostly to make debug traces+    -- less verbose and doesn't really buy anything performance-wise.+    closure _ t@Lit{} = Closure (Value $ notBlocked ()) t emptyEnv []+    closure fv t      = env' `seq` Closure Unevaled t env' []+      where env' = trimEnvironment fv env++-- | Trim unused entries from an environment. Currently only trims closed terms for performance+--   reasons.+trimEnvironment :: FreeVariables -> Env s -> Env s+trimEnvironment UnknownFVs env = env+trimEnvironment (KnownFVs fvs) env+  | IntSet.null fvs = emptyEnv+    -- Environment trimming is too expensive (costs 50% on some benchmarks), and while it does make+    -- some cases run in constant instead of linear space you need quite contrived examples to+    -- notice the effect.+  | otherwise       = env -- Env $ trim 0 $ envToList env+  where+    -- Important: strict enough that the trimming actually happens+    trim _ [] = []+    trim i (p : ps)+      | IntSet.member i fvs = (p :)             $! trim (i + 1) ps+      | otherwise           = (unusedPointer :) $! trim (i + 1) ps++-- | Build an environment for a body with some given free variables from a spine of arguments.+--   Returns a triple containing+--    * the left-over variable names (in case of partial application)+--    * the environment+--    * the remaining spine (in case of over-application)+buildEnv :: [Arg String] -> Spine s -> ([Arg String], Env s, Spine s)+buildEnv xs spine = go xs spine emptyEnv+  where+    go [] sp env = ([], env, sp)+    go xs0@(x : xs) sp env =+      case sp of+        []           -> (xs0, env, sp)+        Apply c : sp -> go xs sp (unArg c `extendEnv` env)+        IApply x y r : sp -> go xs sp (r `extendEnv` env)+        _            -> __IMPOSSIBLE__++unusedPointerString :: Text+unusedPointerString = T.pack (show (withCurrentCallStack Impossible))++unusedPointer :: Pointer s+unusedPointer = Pure (Closure (Value $ notBlocked ())+                     (Lit (LitString unusedPointerString)) emptyEnv [])++-- * Running the abstract machine++-- | Evaluating a term in the abstract machine. It gets the type checking state and environment in+--   the 'ReduceEnv' argument, some precomputed built-in mappings in 'BuiltinEnv', the memoised+--   '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 -> Term -> Blocked Term+reduceTm rEnv bEnv !constInfo normalisation =+    compileAndRun . traceDoc "-- fast reduce --"+  where+    -- Helpers to get information from the ReduceEnv.+    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+    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)+    iview          = runReduce intervalView'++    runReduce :: ReduceM a -> a+    runReduce m = unReduceM m rEnv++    -- Debug output. Taking care that we only look at the verbosity level once.+    hasVerb tag lvl = unReduceM (hasVerbosity tag lvl) rEnv+    doDebug = hasVerb "tc.reduce.fast" 110+    traceDoc :: Doc -> a -> a+    traceDoc+      | doDebug   = trace . show+      | otherwise = const id++    -- Checking for built-in zero and suc+    BuiltinEnv{ bZero = zero, bSuc = suc, bRefl = refl0 } = bEnv+    conNameId = nameId . qnameName . conName+    isZero = case zero of+               Nothing -> const False+               Just z  -> (conNameId z ==) . conNameId+    isSuc  = case suc of+               Nothing -> const False+               Just s  -> (conNameId s ==) . conNameId++    -- If there's a non-standard equality (for instance doubly-indexed) we fall back to slow reduce+    -- for primErase and "unbind" refl.+    refl = refl0 >>= \ c -> if cconArity (cdefDef $ constInfo $ conName c) == 0+                            then Just c else Nothing++    -- The entry point of the machine.+    compileAndRun :: Term -> Blocked Term+    compileAndRun t = runST (runAM (compile normalisation t))++    -- Run the machine in a given state. Prints the state if the right verbosity level is active.+    runAM :: AM s -> ST s (Blocked Term)+    runAM = if doDebug then \ s -> trace (prettyShow s) (runAM' s)+                       else runAM'++    -- The main function. This is where the stuff happens!+    runAM' :: AM s -> ST s (Blocked Term)++    -- Base case: The focus is a value closure and the control stack is empty. Decode and return.+    runAM' (Eval cl@(Closure Value{} _ _ _) []) = decodeClosure cl++    -- Unevaluated closure: inspect the term and take the appropriate action. For instance,+    --  - Change to the 'Match' state if a definition+    --  - 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" #-}+      case t of++        -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an+        -- argument and pushing the appropriate control frame for primitive functions. Fall back to+        -- slow reduce for unsupported definitions.+        Def f [] ->+          evalIApplyAM spine ctrl $+          let CompactDef{ cdefNonterminating = nonterm+                        , cdefUnconfirmed    = unconf+                        , cdefDef            = def } = constInfo f+          in case def of+            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)+            CForce | (spine0, Apply v : spine1) <- splitAt 4 spine ->+              evalPointerAM (unArg v) [] (ForceK f spine0 spine1 : ctrl)+            CForce -> runAM done -- partially applied+            CErase | (spine0, Apply v : spine1 : spine2) <- splitAt 2 spine ->+              evalPointerAM (unArg v) [] (EraseK f spine0 [] [spine1] spine2 : ctrl)+            CErase -> runAM done -- partially applied+            CPrimOp n op cc | length spine == n,                      -- PrimOps can't be over-applied. They don't+                              Just (v : vs) <- allApplyElims spine -> -- return functions or records.+              evalPointerAM (unArg v) [] (PrimOpK f op [] (map unArg vs) cc : ctrl)+            CPrimOp{} -> runAM done  -- partially applied+            COther    -> fallbackAM s++        -- Case: zero. Return value closure with literal 0.+        Con c i [] | isZero c ->+          runAM (evalTrueValue (Lit (LitNat 0)) emptyEnv spine ctrl)++        -- Case: suc. Suc is strict in its argument to make sure we return a literal whenever+        -- possible. Push a 'NatSucK' frame on the control stack and evaluate the argument.+        Con c i [] | isSuc c, Apply v : _ <- spine ->+          evalPointerAM (unArg v) [] (sucCtrl ctrl)++        -- Case: constructor. Perform beta reduction if projected from, otherwise return a value.+        Con c i []+          -- Constructors of types in Prop are not representex as+          -- CCon, so this match might fail!+          | CCon{cconSrcCon = c', cconArity = ar} <- cdefDef (constInfo (conName c)) ->+            evalIApplyAM spine ctrl $+            case splitAt ar spine of+              (args, Proj _ p : spine')+                  -> evalPointerAM (unArg arg) spine' ctrl  -- Andreas #2170: fit argToDontCare here?!+                where+                  fields    = map unArg $ conFields c+                  Just n    = List.elemIndex p fields+                  Apply arg = args !! n+              _ -> rewriteAM (evalTrueValue (Con c' i []) env spine ctrl)+          | otherwise -> runAM done++        -- Case: variable. Look up the variable in the environment and evaluate the resulting+        -- pointer. If the variable is not in the environment it's a free variable and we adjust the+        -- deBruijn index appropriately.+        Var x []   ->+          evalIApplyAM spine ctrl $+          case lookupEnv x env of+            Nothing -> runAM (evalValue (notBlocked ()) (Var (x - envSize env) []) emptyEnv spine ctrl)+            Just p  -> evalPointerAM p spine ctrl++        -- Case: lambda. Perform the beta reduction if applied. Otherwise it's a value.+        Lam h b ->+          case spine of+            [] -> runAM done+            elim : spine' ->+              case b of+                Abs   _ b -> runAM (evalClosure b (getArg elim `extendEnv` env) spine' ctrl)+                NoAbs _ b -> runAM (evalClosure b env spine' ctrl)+          where+            getArg (Apply v)      = unArg v+            getArg (IApply _ _ v) = v+            getArg Proj{}         = __IMPOSSIBLE__++        -- Case: values. Literals and function types are already in weak-head normal form.+        -- We throw away the environment for literals mostly to make debug printing less verbose.+        -- And we know the spine is empty since literals cannot be applied or projected.+        Lit{} -> runAM (evalTrueValue t emptyEnv [] ctrl)+        Pi{}  -> runAM done+        DontCare{} -> runAM done++        -- Case: non-empty spine. If the focused term has a non-empty spine, we shift the+        -- eliminations onto the spine.+        Def f   es -> shiftElims (Def f   []) emptyEnv env es+        Con c i es -> shiftElims (Con c i []) emptyEnv env es+        Var x   es -> shiftElims (Var x   []) env      env es++        -- Case: metavariable. If it's instantiated evaluate the value. Meta instantiations are open+        -- terms with a specified list of free variables. buildEnv constructs the appropriate+        -- environment for the closure. Avoiding shifting spines for open metas+        -- save a bit of performance.+        MetaV m es -> evalIApplyAM spine ctrl $+          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 (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.+        Level{}    -> fallbackAM s+        Sort{}     -> fallbackAM s+        Dummy{}    -> fallbackAM s++      where done = Eval (mkValue (notBlocked ()) cl) ctrl+            shiftElims t env0 env es = do+              spine' <- elimsToSpine env es+              runAM (evalClosure t env0 (spine' <> spine) ctrl)++    -- If the current focus is a value closure, we look at the control stack.++    -- Case NormaliseK: The focus is a weak-head value that should be fully normalised.+    runAM' s@(Eval cl@(Closure b t env spine) (NormaliseK : ctrl)) =+      case t of+        Def _   [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+        Con _ _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+        Var _   [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl+        MetaV _ [] -> normaliseArgsAM (Closure b t emptyEnv []) spine ctrl++        Lit{} -> runAM done++        -- We might get these from fallbackAM+        Def f   es -> shiftElims (Def f   []) emptyEnv env es+        Con c i es -> shiftElims (Con c i []) emptyEnv env es+        Var x   es -> shiftElims (Var x   []) env      env es+        MetaV m es -> shiftElims (MetaV m []) emptyEnv env es++        _ -> fallbackAM s -- fallbackAM knows about NormaliseK++      where done = Eval (mkValue (notBlocked ()) cl) ctrl+            shiftElims t env0 env es = do+              spine' <- elimsToSpine env es+              runAM (Eval (Closure b t env0 (spine' <> spine)) (NormaliseK : ctrl))++    -- Case: ArgK: We successfully normalised an argument. Start on the next argument, or if there+    -- isn't one we're done.+    runAM' (Eval cl (ArgK cl0 cxt : ctrl)) =+      case nextHole (pureThunk cl) cxt of+        Left spine      -> runAM (Eval (clApply_ cl0 spine) ctrl)+        Right (p, cxt') -> evalPointerAM p [] (NormaliseK : ArgK cl0 cxt' : ctrl)++    -- Case: NatSucK m++    -- If literal add m to the literal,+    runAM' (Eval cl@(Closure Value{} (Lit (LitNat n)) _ _) (NatSucK m : ctrl)) =+      runAM (evalTrueValue (Lit $! LitNat $! m + n) emptyEnv [] ctrl)++    -- otherwise apply 'suc' m times.+    runAM' (Eval cl (NatSucK m : ctrl)) =+        runAM (Eval (mkValue (notBlocked ()) $ plus m cl) ctrl)+      where+        plus 0 cl = cl+        plus n cl =+          trueValue (Con (fromMaybe __IMPOSSIBLE__ suc) ConOSystem []) emptyEnv $+                     Apply (defaultArg arg) : []+          where arg = pureThunk (plus (n - 1) cl)++    -- Case: PrimOpK++    -- If literal apply the primitive function if no more arguments, otherwise+    -- store the literal in the continuation and evaluate the next argument.+    runAM' (Eval (Closure _ (Lit a) _ _) (PrimOpK f op vs es cc : ctrl)) =+      case es of+        []      -> runAM (evalTrueValue (op (a : vs)) emptyEnv [] ctrl)+        e : es' -> evalPointerAM e [] (PrimOpK f op (a : vs) es' cc : ctrl)++    -- If not a literal we use the case tree if there is one, otherwise we are stuck.+    runAM' (Eval cl@(Closure (Value blk) _ _ _) (PrimOpK f _ vs es mcc : ctrl)) =+      case mcc of+        Nothing -> rewriteAM (Eval stuck ctrl)+        Just cc -> runAM (Match f cc spine ([] :> notstuck) ctrl)+      where+        p         = pureThunk cl+        lits      = map (pureThunk . litClos) (reverse vs)+        spine     = fmap (Apply . defaultArg) $ lits <> [p] <> es+        stuck     = Closure (Value blk) (Def f []) emptyEnv spine+        notstuck  = Closure Unevaled    (Def f []) emptyEnv spine+        litClos l = trueValue (Lit l) emptyEnv []++    -- Case: ForceK. Here we need to check if the argument is a canonical form (i.e. not a variable+    -- or stuck function call) and if so apply the function argument to the value. If it's not+    -- canonical we are stuck.+    runAM' (Eval arg@(Closure (Value blk) t _ _) (ForceK pf spine0 spine1 : ctrl))+      | isCanonical t =+        case spine1 of+          Apply k : spine' ->+            evalPointerAM (unArg k) (elim : spine') ctrl+          [] -> -- Partial application of primForce to canonical argument, return λ k → k arg.+            runAM (evalTrueValue (lam (defaultArg "k") $ Var 0 [Apply $ defaultArg $ Var 1 []])+                                 (argPtr `extendEnv` emptyEnv) [] ctrl)+          _ -> __IMPOSSIBLE__+      | otherwise = rewriteAM (Eval stuck ctrl)+      where+        argPtr = pureThunk arg+        elim   = Apply (defaultArg argPtr)+        spine' = spine0 <> [elim] <> spine1+        stuck  = Closure (Value blk) (Def pf []) emptyEnv spine'++        isCanonical = \case+          Lit{}      -> True+          Con{}      -> True+          Lam{}      -> True+          Pi{}       -> True+          Sort{}     -> True+          Level{}    -> True+          DontCare{} -> True+          Dummy{}    -> False+          MetaV{}    -> False+          Var{}      -> False+          Def q _  -- Type constructors (data/record) are considered canonical for 'primForce'.+            | CTyCon <- cdefDef (constInfo q) -> True+            | otherwise                       -> False++    -- Case: EraseK. We evaluate both arguments to values, then do a simple check for the easy+    -- cases and otherwise fall back to slow reduce.+    runAM' (Eval cl2@(Closure Value{} arg2 _ _) (EraseK f spine0 [Apply p1] _ spine3 : ctrl)) = do+      cl1@(Closure _ arg1 _ sp1) <- derefPointer_ (unArg p1)+      case (arg1, arg2) of+        (Lit l1, Lit l2) | l1 == l2, isJust refl ->+          runAM (evalTrueValue (Con (fromJust refl) ConOSystem []) emptyEnv [] ctrl)+        _ ->+          let spine = spine0 ++ map (Apply . hide . defaultArg . pureThunk) [cl1, cl2] ++ spine3 in+          fallbackAM (evalClosure (Def f []) emptyEnv spine ctrl)+    runAM' (Eval cl1@(Closure Value{} _ _ _) (EraseK f spine0 [] [Apply p2] spine3 : ctrl)) =+      evalPointerAM (unArg p2) [] (EraseK f spine0 [Apply $ hide $ defaultArg $ pureThunk cl1] [] spine3 : ctrl)+    runAM' (Eval _ (EraseK{} : _)) =+      __IMPOSSIBLE__++    -- Case: UpdateThunk. Write the value to the pointers in the UpdateThunk frame.+    runAM' (Eval cl@(Closure Value{} _ _ _) (UpdateThunk ps : ctrl)) =+      mapM_ (`storePointer` cl) ps >> runAM (Eval cl ctrl)++    -- Case: ApplyK. Application after thunk update. Add the spine from the control frame to the+    -- closure.+    runAM' (Eval cl@(Closure Value{} _ _ _) (ApplyK spine : ctrl)) =+      runAM (Eval (clApply cl spine) ctrl)++    -- 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+    -- 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" #-}+      case blk of+        Blocked{} | null [()|Con{} <- [t]] -> stuck -- we might as well check the blocking tag first+        _ -> case t of+          -- Case: suc constructor+          Con c ci [] | isSuc c -> matchSuc $ matchCatchall $ failedMatch f stack ctrl++          -- Case: constructor+          Con c ci [] -> matchCon c ci (length spine) $ matchCatchall $ failedMatch f stack ctrl++          -- Case: non-empty elims. We can get here from a fallback (which builds a value without+          -- shifting arguments onto spine)+          Con c ci es -> do+            spine' <- elimsToSpine env es+            runAM (evalValue blk (Con c ci []) emptyEnv (spine' <> spine) ctrl0)+          -- Case: natural number literals. Literal natural number patterns are translated to+          -- suc-matches, so there is no need to try matchLit.+          Lit (LitNat 0) -> matchLitZero  $ matchCatchall $ failedMatch f stack ctrl+          Lit (LitNat n) -> matchLitSuc n $ matchCatchall $ failedMatch f stack ctrl++          -- Case: literal+          Lit l -> matchLit l $ matchCatchall $ failedMatch f stack ctrl++          -- Case: hcomp+          Def q [] | isJust $ lookupCon q bs -> matchCon' q (length spine) $ matchCatchall $ failedMatch f stack ctrl+          Def q es | isJust $ lookupCon q bs -> do+            spine' <- elimsToSpine env es+            runAM (evalValue blk (Def q []) emptyEnv (spine' <> spine) ctrl0)++          -- Case: not constructor or literal. In this case we are stuck.+          _ -> stuck+      where+        -- If ffallThrough is set we take the catch-all (if any) rather than being stuck. I think+        -- this happens for partial functions with --cubical (@saizan: is this true?).+        stuck | ffallThrough bs = matchCatchall reallyStuck+              | otherwise       = reallyStuck++        reallyStuck = do+            -- Compute new reason for being stuck. See Agda.Syntax.Internal.stuckOn for the logic.+            blk' <- case blk of+                      Blocked{}      -> return blk+                      NotBlocked r _ -> decodeClosure_ cl <&> \ v -> NotBlocked (stuckOn (Apply $ Arg i v) r) ()+            stuckMatch blk' stack ctrl++        -- This the spine at this point in the matching. A catch-all match doesn't change the spine.+        catchallSpine = spine0 <> [Apply $ Arg i p] <> spine1+          where p = pureThunk cl -- cl is already a value so no need to thunk it.++        -- 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+          Nothing -> 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+        -- letting you chain a bunch if maybe matches in if-then-elseif fashion.+        (m `ifJust` f) z = maybe z f m++        -- Matching constructor: Switch to the Match state, inserting the constructor arguments in+        -- the spine between spine0 and spine1.+        matchCon c ci ar = matchCon' (conName c) ar+        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 ->+          runAM (Match f cc catchallSpine stack ctrl)++        -- Matching literal: Switch to the Match state. There are no arguments to add to the spine.+        matchLit l = Map.lookup l (flitBranches bs) `ifJust` \ cc ->+          runAM (Match f cc (spine0 <> spine1) catchallStack ctrl)++        -- Matching a 'suc' constructor: Insert the argument in the spine.+        matchSuc = fsucBranch bs `ifJust` \ cc ->+            runAM (Match f cc (spine0 <> spine <> spine1) catchallStack ctrl)++        -- Matching a non-zero natural number literal: Subtract one from the literal and+        -- insert it in the spine for the Match state.+        matchLitSuc n = fsucBranch bs `ifJust` \ cc ->+            runAM (Match f cc (spine0 <> [Apply $ defaultArg arg] <> spine1) catchallStack ctrl)+          where n'  = n - 1+                arg = pureThunk $ trueValue (Lit $ LitNat n') emptyEnv []++        -- Matching a literal 0. Simply calls matchCon with the zero constructor.+        matchLitZero = matchCon (fromMaybe __IMPOSSIBLE__ zero) ConOSystem 0+                            -- If we have a nat literal we have builtin zero.++    -- Case: Match state. Here we look at the case tree and take the appropriate action:+    --   - FFail: stuck+    --   - FDone: evaluate body+    --   - FEta: eta expand argument+    --   - FCase on projection: pick corresponding branch and keep matching+    --   - FCase on argument: push CaseK frame on control stack and evaluate argument+    runAM' (Match f cc spine stack ctrl) = {-# SCC "runAM.Match" #-}+      case cc of+        -- Absurd match. You can get here for open terms.+        FFail -> stuckMatch (NotBlocked AbsurdMatch ()) stack ctrl++        -- Matching complete. Compute the environment for the body and switch to the Eval state.+        FDone xs body -> do+            -- Don't ask me why, but not being strict in the spine causes a memory leak.+            let (zs, env, !spine') = buildEnv xs spine+            runAM (Eval (Closure Unevaled (lams zs body) env spine') ctrl)++        -- A record pattern match. This does not block evaluation (since that would violate eta+        -- equality), so in this case we replace the argument with its projections in the spine and+        -- keep matching.+        FEta n fs cc ca ->+          case splitAt n spine of                           -- Question: add lambda here? doesn't+            (_, [])                    -> 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.+              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+              runAM (Match f cc spine' stack' ctrl)+            _ -> __IMPOSSIBLE__++        -- Split on nth elimination in the spine. Can be either a regular split or a copattern+        -- split.+        FCase n bs ->+          case splitAt n spine of+            -- If the nth elimination is not given, we're stuck.+            (_, []) -> done Underapplied+            -- Apply elim: push the current match on the control stack and evaluate the argument+            (spine0, Apply e : spine1) ->+              evalPointerAM (unArg e) [] $ CaseK f (argInfo e) bs spine0 spine1 stack : ctrl+            -- Projection elim: in this case we must be in a copattern split and find the projection+            -- in the case tree and keep going. If it's not there it might be because it's not the+            -- original projection (issue #2265). If so look up the original projection instead.+            -- That _really_ should be there since copattern splits cannot be partial. Except of+            -- course, the user might still have written a partial function so we should check+            -- partialDefs before throwing an impossible (#3012).+            (spine0, Proj o p : spine1) ->+              case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of+                Nothing+                  | 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)+            (_, IApply{} : _) -> __IMPOSSIBLE__ -- Paths cannot be defined by pattern matching+      where done why = stuckMatch (NotBlocked why ()) stack ctrl++    -- 'evalPointerAM p spine ctrl'. Evaluate the closure pointed to by 'p' applied to 'spine' with+    -- the control stack 'ctrl'. If 'p' points to an unevaluated thunk, a 'BlackHole' is written to+    -- the pointer and an 'UpdateThunk' frame is pushed to the control stack. In this case the+    -- application to the spine has to be deferred until after the update through an 'ApplyK' frame.+    evalPointerAM :: Pointer s -> Spine s -> ControlStack s -> ST s (Blocked Term)+    evalPointerAM (Pure cl)   spine ctrl = runAM (Eval (clApply cl spine) ctrl)+    evalPointerAM (Pointer p) spine ctrl = readPointer p >>= \ case+      BlackHole -> __IMPOSSIBLE__+      Thunk cl@(Closure Unevaled _ _ _) | callByNeed -> do+        blackHole p+        runAM (Eval cl $ updateThunkCtrl p $ [ApplyK spine | not (null spine)] ++ ctrl)+      Thunk cl -> runAM (Eval (clApply cl spine) ctrl)++    -- 'evalIApplyAM spine ctrl fallback' checks if any 'IApply x y r' has a canonical 'r' (i.e. 0 or 1),+    -- in that case continues evaluating 'x' or 'y' with the rest of 'spine' and same 'ctrl'.+    -- If no such 'IApply' is found we continue with 'fallback'.+    evalIApplyAM :: Spine s -> ControlStack s -> ST s (Blocked Term) -> ST s (Blocked Term)+    evalIApplyAM es ctrl fallback = go es+      where+        -- written as a worker/wrapper to possibly trigger some+        -- specialization wrt fallback+        go []                  = fallback+        go (IApply x y r : es) = do+          br <- evalPointerAM r [] []+          case iview $ ignoreBlocking br of+            IZero -> evalPointerAM x es ctrl+            IOne  -> evalPointerAM y es ctrl+            _     -> (<* br) <$> go es+        go (e : es) = go es++    -- Normalise the spine and apply the closure to the result. The closure must be a value closure.+    normaliseArgsAM :: Closure s -> Spine s -> ControlStack s -> ST s (Blocked Term)+    normaliseArgsAM cl []    ctrl = runAM (Eval cl ctrl)  -- nothing to do+    normaliseArgsAM cl spine ctrl =+      case firstHole spine of -- v Only projections, nothing to do. Note clApply_ and not clApply (or we'd loop)+        Nothing       -> runAM (Eval (clApply_ cl spine) ctrl)+        Just (p, cxt) -> evalPointerAM p [] (NormaliseK : ArgK cl cxt : ctrl)++    -- Fall back to slow reduction. This happens if we encounter a definition that's not supported+    -- by the machine (like a primitive function that does not work on literals), or a term that is+    -- not supported (Level and Sort at the moment). In this case we decode the current+    -- focus to a 'Term', call slow reduction and pack up the result in a value closure. If the top+    -- of the control stack is a 'NormaliseK' and the focus is a value closure (i.e. already in+    -- weak-head normal form) we call 'slowNormaliseArgs' and pop the 'NormaliseK' frame. Otherwise+    -- we use 'slowReduceTerm' to compute a weak-head normal form.+    fallbackAM :: AM s -> ST s (Blocked Term)+    fallbackAM (Eval c ctrl) = do+        v <- decodeClosure_ c+        runAM (mkValue $ runReduce $ slow v)+      where mkValue b = evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl'+            (slow, ctrl') = case ctrl of+              NormaliseK : ctrl'+                | Value{} <- isValue c -> (notBlocked <.> slowNormaliseArgs, ctrl')+              _                        -> (slowReduceTerm, ctrl)+    fallbackAM _ = __IMPOSSIBLE__++    -- 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)+      | null rewr = runAM s+      | otherwise = traceDoc ("R" <+> pretty s) $ do+        v0 <- decodeClosure_ (Closure Unevaled t env [])+        es <- decodeSpine spine+        case runReduce (rewrite blk (applyE v0) rewr es) of+          NoReduction b    -> runAM (evalValue (() <$ b) (ignoreBlocking b) emptyEnv [] ctrl)+          YesReduction _ v -> runAM (evalClosure v emptyEnv [] ctrl)+      where rewr = case t of+                     Def f []   -> rewriteRules f+                     Con c _ [] -> rewriteRules (conName c)+                     _          -> __IMPOSSIBLE__+    rewriteAM _ =+      __IMPOSSIBLE__++    -- Add a NatSucK frame to the control stack. Pack consecutive suc's into a single frame.+    sucCtrl :: ControlStack s -> ControlStack s+    sucCtrl (NatSucK !n : ctrl) = NatSucK (n + 1) : ctrl+    sucCtrl               ctrl  = NatSucK 1 : ctrl++    -- Add a UpdateThunk frame to the control stack. Pack consecutive updates into a single frame.+    updateThunkCtrl :: STPointer s -> ControlStack s -> ControlStack s+    updateThunkCtrl p (UpdateThunk ps : ctrl) = UpdateThunk (p : ps) : ctrl+    updateThunkCtrl p                   ctrl  = UpdateThunk [p] : 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+    -- 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 ([] :> cl) ctrl+        -- Bad work-around for #3870: don't fail hard during instance search.+      | 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)+    evalValue b t env spine = Eval (Closure (Value b) t env spine)+    evalTrueValue           = evalValue $ notBlocked ()+    trueValue t env spine   = Closure (Value $ notBlocked ()) t env spine+    mkValue b               = setIsValue (Value b)++    -- Building lambdas+    lams :: [Arg String] -> Term -> Term+    lams xs t = foldr lam t xs++    lam :: Arg String -> Term -> Term+    lam x t = Lam (argInfo x) (Abs (unArg x) t)++-- Pretty printing --------------------------------------------------------++instance Pretty a => Pretty (FastCase a) where+  prettyPrec p (FBranches _cop cs suc ls m _) =+    mparens (p > 0) $ vcat (prettyMap_ cs ++ prettyMap_ ls ++ prSuc suc ++ prC m)+    where+      prC Nothing = []+      prC (Just x) = ["_ ->" <?> pretty x]++      prSuc Nothing  = []+      prSuc (Just x) = ["suc ->" <?> pretty x]++instance Pretty FastCompiledClauses where+  pretty (FDone xs t) = ("done" <+> prettyList xs) <?> prettyPrec 10 t+  pretty FFail        = "fail"+  pretty (FEta n _ cc ca) =+    text ("eta " ++ show n ++ " of") <?>+      vcat ("{} ->" <?> pretty cc :+            [ "_ ->" <?> pretty cc | Just cc <- [ca] ])+  pretty (FCase n bs) | fprojPatterns bs =+    sep [ text $ "project " ++ show n+        , nest 2 $ pretty bs+        ]+  pretty (FCase n bs) =+    text ("case " ++ show n ++ " of") <?> pretty bs++instance Pretty a => Pretty (Thunk a) where+  prettyPrec _ BlackHole  = "<BLACKHOLE>"+  prettyPrec p (Thunk cl) = prettyPrec p cl++instance Pretty (Pointer s) where+  prettyPrec p = prettyPrec p . unsafeDerefPointer++instance Pretty (Closure s) where+  prettyPrec _ (Closure Value{} (Lit (LitString unused)) _ _)+    | unused == unusedPointerString = "_"+  prettyPrec p (Closure isV t env spine) =+    mparens (p > 9) $ fsep [ text tag+                           , nest 2 $ prettyPrec 10 t+                           , nest 2 $ prettyList $ zipWith envEntry [0..] (envToList env)+                           , nest 2 $ prettyList spine ]+      where envEntry i c = text ("@" ++ show i ++ " =") <+> pretty c+            tag = case isV of Value{} -> "V"; Unevaled -> "E"++instance Pretty (AM s) where+  prettyPrec p (Eval cl ctrl)  = prettyPrec p cl <?> prettyList ctrl+  prettyPrec p (Match f cc sp stack ctrl) =+    mparens (p > 9) $ sep [ "M" <+> pretty f+                          , nest 2 $ prettyList sp+                          , nest 2 $ prettyPrec 10 cc+                          , nest 2 $ pretty stack+                          , nest 2 $ prettyList ctrl ]++instance Pretty (CatchallFrame s) where+  pretty Catchall{} = "Catchall"++instance Pretty (MatchStack s) where+  pretty ([] :> _) = empty+  pretty (ca :> _) = prettyList ca++instance Pretty (ControlFrame s) where+  prettyPrec p (CaseK f _ _ _ _ mc)       = mparens (p > 9) $ ("CaseK" <+> pretty (qnameName f)) <?> pretty mc+  prettyPrec p (ForceK _ spine0 spine1)   = mparens (p > 9) $ "ForceK" <?> prettyList (spine0 <> spine1)+  prettyPrec p (EraseK _ sp0 sp1 sp2 sp3) = mparens (p > 9) $ sep [ "EraseK"+                                                                  , nest 2 $ prettyList sp0+                                                                  , nest 2 $ prettyList sp1+                                                                  , nest 2 $ prettyList sp2+                                                                  , nest 2 $ prettyList sp3 ]+  prettyPrec _ (NatSucK n)              = text ("+" ++ show n)+  prettyPrec p (PrimOpK f _ vs cls _)   = mparens (p > 9) $ sep [ "PrimOpK" <+> pretty f+                                                                , nest 2 $ prettyList vs+                                                                , nest 2 $ prettyList cls ]+  prettyPrec p (UpdateThunk ps)         = mparens (p > 9) $ "UpdateThunk" <+> text (show (length ps))+  prettyPrec p (ApplyK spine)           = mparens (p > 9) $ "ApplyK" <?> prettyList spine+  prettyPrec p NormaliseK               = "NormaliseK"+  prettyPrec p (ArgK cl _)              = mparens (p > 9) $ sep [ "ArgK" <+> prettyPrec 10 cl ]
src/full/Agda/TypeChecking/Reduce/Fast.hs-boot view
@@ -1,8 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Reduce.Fast where  import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base -fastReduce :: Bool -> Term -> ReduceM (Blocked Term)+fastReduce    :: Term -> ReduceM (Blocked Term)+fastNormalise :: Term -> ReduceM Term 
src/full/Agda/TypeChecking/Reduce/Monad.hs view
@@ -1,182 +1,106 @@-{-# LANGUAGE CPP              #-}-+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Reduce.Monad   ( constructorForm   , enterClosure-  , underAbstraction_   , getConstInfo-  , isInstantiatedMeta-  , lookupMeta-  , traceSLn, traceSDoc   , askR, applyWhenVerboseS   ) where  import Prelude hiding (null) -import Control.Arrow ((***), first, second)-import Control.Applicative hiding (empty)-import Control.Monad.Reader- import qualified Data.Map as Map import Data.Maybe-import Data.Monoid -import Debug.Trace import System.IO.Unsafe -import Agda.Syntax.Common-import Agda.Syntax.Position+import Agda.Syntax.Common.Pretty () --instance only import Agda.Syntax.Internal-import Agda.TypeChecking.Monad hiding-  ( enterClosure, underAbstraction_, underAbstraction, addCtx, mkContextEntry,-    isInstantiatedMeta, verboseS, reportSDoc, reportSLn, typeOfConst, lookupMeta )-import Agda.TypeChecking.Monad.Builtin hiding ( constructorForm )++import Agda.TypeChecking.Monad hiding (enterClosure, constructorForm) import Agda.TypeChecking.Substitute-import Agda.Interaction.Options -import qualified Agda.Utils.HashMap as HMap import Agda.Utils.Lens+import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty -#include "undefined.h"-import Agda.Utils.Impossible--gets :: (TCState -> a) -> ReduceM a-gets f = f . redSt <$> ReduceM ask--useR :: Lens' a TCState -> ReduceM a-useR l = gets (^.l)--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 <- gets $ stPersistentOptions . stPersistentState-    return $ cl{ optPragmaOptions = p }- 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 :: Term -> ReduceM Term+constructorForm :: HasBuiltins m => Term -> m Term constructorForm v = do   mz <- getBuiltin' builtinZero   ms <- getBuiltin' builtinSuc   return $ fromMaybe v $ constructorForm' mz ms v -enterClosure :: Closure a -> (a -> ReduceM b) -> ReduceM b-enterClosure (Closure sig env scope pars x) f = localR (mapRedEnvSt inEnv inState) (f x)-  where-    inEnv   e = env { envAllowDestructiveUpdate = envAllowDestructiveUpdate e }+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.+  f -> localR (mapRedEnvSt inEnv inState) (f x)+    where+    inEnv   e = env     inState s =       -- TODO: use the signature here? would that fix parts of issue 118?-      set stScope scope $ set stModuleParameters pars s+      set stScope scope $ set stModuleCheckpoints cps s -withFreshR :: HasFresh i => (i -> ReduceM a) -> ReduceM a+withFreshR :: (ReadTCState m, HasFresh i) => (i -> m a) -> m a withFreshR f = do-  s <- gets id+  s <- getTCState   let (i, s') = nextFresh s-  localR (mapRedSt $ const s') (f i)--withFreshName :: Range -> ArgName -> (Name -> ReduceM a) -> ReduceM a-withFreshName r s k = withFreshR $ \i -> k (mkName r i s)--withFreshName_ :: ArgName -> (Name -> ReduceM a) -> ReduceM a-withFreshName_ = withFreshName noRange--mkContextEntry :: Dom (Name, Type) -> (ContextEntry -> ReduceM a) -> ReduceM a-mkContextEntry x k = withFreshR $ \i -> k (Ctx i x)--addCtx :: Name -> Dom Type -> ReduceM a -> ReduceM a-addCtx x a ret = do-  ctx <- asks $ map (nameConcrete . fst . unDom . ctxEntry) . envContext-  let x' = head $ filter (notTaken ctx) $ iterate nextName x-  mkContextEntry ((x',) <$> a) $ \ce ->-    local (\e -> e { envContext = ce : envContext e }) ret-      -- let-bindings keep track of own their context-  where-    notTaken xs x = isNoName x || nameConcrete x `notElem` xs+  withTCState (const s') (f i) -underAbstraction :: Subst t a => Dom Type -> Abs a -> (a -> ReduceM b) -> ReduceM b-underAbstraction _ (NoAbs _ v) f = f v-underAbstraction t a f =-  withFreshName_ (realName $ absName a) $ \x -> addCtx x t $ f (absBody a)-  where-    realName s = if isNoName s then "x" else s+instance MonadAddContext ReduceM where+  withFreshName r s k = withFreshR $ \i -> k (mkName r i s) -underAbstraction_ :: Subst t a => Abs a -> (a -> ReduceM b) -> ReduceM b-underAbstraction_ = underAbstraction dummyDom+  addCtx = defaultAddCtx -lookupMeta :: MetaId -> ReduceM MetaVariable-lookupMeta i = fromMaybe __IMPOSSIBLE__ . Map.lookup i <$> useR stMetaStore+  addLetBinding' = defaultAddLetBinding' -isInstantiatedMeta :: MetaId -> ReduceM Bool-isInstantiatedMeta i = do-  mv <- lookupMeta i-  return $ case mvInstantiation mv of-    InstV{} -> True-    _       -> False+  updateContext rho f ret = withFreshR $ \ chkpt ->+    localTC (\e -> e { envContext = f $ envContext e+                     , envCurrentCheckpoint = chkpt+                     , envCheckpoints = Map.insert chkpt IdS $+                                          fmap (applySubst rho) (envCheckpoints e)+                     }) ret+        -- let-bindings keep track of own their context --- | Run a computation if a certain verbosity level is activated.------   Precondition: The level must be non-negative.-verboseS :: VerboseKey -> Int -> ReduceM () -> ReduceM ()-verboseS k n action = whenM (hasVerbosity k n) action+instance MonadDebug ReduceM where --- | Apply a function if a certain verbosity level is activated.------   Precondition: The level must be non-negative.-{-# SPECIALIZE applyWhenVerboseS :: VerboseKey -> Int -> (ReduceM a -> ReduceM a) -> ReduceM a-> ReduceM a #-}-applyWhenVerboseS :: HasOptions m => VerboseKey -> Int -> (m a -> m a) -> m a -> m a-applyWhenVerboseS k n f a = ifM (hasVerbosity k n) (f a) a+  traceDebugMessage k n s cont = do+    ReduceEnv env st _ <- askR+    unsafePerformIO $ do+      _ <- runTCM env st $ displayDebugMessage k n s+      return $ cont -traceSDoc :: VerboseKey -> Int -> TCM Doc -> ReduceM a -> ReduceM a-traceSDoc k n doc = applyWhenVerboseS k n $ \ cont -> do-  ReduceEnv env st <- askR-  -- return $! unsafePerformIO $ do print . fst =<< runTCM env st doc-  trace (show $ fst $ unsafePerformIO $ runTCM env st doc) cont+  formatDebugMessage k n d = do+    ReduceEnv env st _ <- askR+    unsafePerformIO $ do+      (s , _) <- runTCM env st $ formatDebugMessage k n d+      return $ return s --- traceSDoc :: VerboseKey -> Int -> TCM Doc -> ReduceM a -> ReduceM a--- traceSDoc k n doc = verboseS k n $ ReduceM $ do---   ReduceEnv env st <- ask---   -- return $! unsafePerformIO $ do print . fst =<< runTCM env st doc---   trace (show $ fst $ unsafePerformIO $ runTCM env st doc) $ return ()+#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 -{-# SPECIALIZE traceSLn :: VerboseKey -> Int -> String -> ReduceM a -> ReduceM a #-}-traceSLn :: HasOptions m => VerboseKey -> Int -> String -> m a -> m a-traceSLn k n s = applyWhenVerboseS k n (trace s)+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting  instance HasConstInfo ReduceM where-  getRewriteRulesFor = defaultGetRewriteRulesFor (gets id)-  getConstInfo q = ReduceM $ \(ReduceEnv env st) ->-    let defs  = st^.(stSignature . sigDefinitions)-        idefs = st^.(stImports . sigDefinitions)-    in case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of-        []  -> trace ("Unbound name: " ++ show q ++ " " ++ showQNameId q) __IMPOSSIBLE__-        [d] -> mkAbs env d-        ds  -> trace ("Ambiguous name: " ++ show q) __IMPOSSIBLE__-    where-      mkAbs env d-        | treatAbstractly' q' env = fromMaybe err $ makeAbstract d-        | otherwise               = d-        where-          err = trace ("Not in scope: " ++ show q) __IMPOSSIBLE__-          q' = case theDef d of-            -- Hack to make abstract constructors work properly. The constructors-            -- live in a module with the same name as the datatype, but for 'abstract'-            -- purposes they're considered to be in the same module as the datatype.-            Constructor{} -> dropLastModule q-            _                 -> q+  getRewriteRulesFor = defaultGetRewriteRulesFor+  getConstInfo' q = do+    ReduceEnv env st _ <- askR+    defaultGetConstInfo st env q -          dropLastModule q@QName{ qnameModule = m } =-            q{ qnameModule = mnameFromList $ ifNull (mnameToList m) __IMPOSSIBLE__ init }+instance PureTCM ReduceM where
src/full/Agda/TypeChecking/Rewriting.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP               #-}+{-# LANGUAGE NondecreasingIndentation #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -6,13 +6,13 @@ -- --   The user specifies a relation symbol by the pragma --   @---       {-# BUILTIN REWRITE rel #-}+--       {-\# BUILTIN REWRITE rel \#-} --   @ --   where @rel@ should be of type @Δ → (lhs rhs : A) → Set i@. -- --   Then the user can add rewrite rules by the pragma --   @---       {-# REWRITE q #-}+--       {-\# REWRITE q \#-} --   @ --   where @q@ should be a closed term of type @Γ → rel us lhs rhs@. --@@ -45,49 +45,49 @@  import Prelude hiding (null) -import Control.Applicative hiding (empty)-import Control.Monad-import Control.Monad.Reader (local, asks)+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT ) -import Data.Foldable ( Foldable, foldMap )+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.Monoid+import Data.Set (Set)+import qualified Data.Set as Set  import Agda.Interaction.Options +import Agda.Syntax.Abstract.Name 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-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy-import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Conversion+import qualified Agda.TypeChecking.Positivity.Occurrence as Pos import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Rewriting.Confluence import Agda.TypeChecking.Rewriting.NonLinMatch-import qualified Agda.TypeChecking.Reduce.Monad as Red+import Agda.TypeChecking.Rewriting.NonLinPattern+import Agda.TypeChecking.Warnings  import Agda.Utils.Functor-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Singleton+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size-import Agda.Utils.Lens-import qualified Agda.Utils.HashMap as HMap+import qualified Agda.Utils.SmallSet as SmallSet -#include "undefined.h" import Agda.Utils.Impossible+import Agda.Utils.Either  requireOptionRewriting :: TCM () requireOptionRewriting =@@ -100,23 +100,17 @@ verifyBuiltinRewrite :: Term -> Type -> TCM () verifyBuiltinRewrite v t = do   requireOptionRewriting-  let failure reason = typeError . GenericDocError =<< sep-       [ prettyTCM v <+> text " does not have the right type for a rewriting relation"-       , reason-       ]   caseMaybeM (relView t)-    (failure $ text "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 $ text "because its two final arguments are not both visible."-    case ignoreSharing (unEl core) of+    unless (visible a && visible b) $ typeError $ IncorrectTypeForRewriteRelation v FinalTwoArgumentsNotVisible+    case unEl core of       Sort{}   -> return ()       Con{}    -> __IMPOSSIBLE__       Level{}  -> __IMPOSSIBLE__       Lam{}    -> __IMPOSSIBLE__       Pi{}     -> __IMPOSSIBLE__-      Shared{} -> __IMPOSSIBLE__-      _ -> failure $ text "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@@ -138,335 +132,348 @@     let [a, b] = fmap snd <$> lastTwo     return $ Just $ RelView tel delta a b core --- | Add @q : Γ → rel us lhs rhs@ as rewrite rule+-- | Check the given rewrite rules and add them to the signature.+addRewriteRules :: [QName] -> TCM ()+addRewriteRules qs = do++  -- Check the rewrite rules+  rews <- mapMaybeM checkRewriteRule qs++  -- Add rewrite rules to the signature+  forM_ rews $ \rew -> do+    let f = rewHead rew+        matchables = getMatchables rew+    reportSDoc "rewriting" 10 $+      "adding rule" <+> prettyTCM (rewName rew) <+>+      "to the definition of" <+> prettyTCM f+    reportSDoc "rewriting" 30 $ "matchable symbols: " <+> prettyTCM matchables+    modifySignature $ addRewriteRulesFor f [rew] matchables++  -- 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) $+      forM_ (nubOn id $ map rewHead rews) sortRulesOfSymbol+    checkConfluenceOfRules confChk rews+    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 --   @---   to the signature where @B = A[us/Δ]@.+--   where @B = A[us/Δ]@. --   Remember that @rel : Δ → A → A → Set i@, so --   @rel us : (lhs rhs : A[us/Δ]) → Set i@.-addRewriteRule :: QName -> TCM ()-addRewriteRule q = do-  requireOptionRewriting-  Def rel _ <- primRewrite+--   Returns the checked rewrite rule to be added to the signature.+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-      [ text "Rewrite rule from function "-      , prettyTCM q-      , text " 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 = -- line break for CPP-        fromMaybe __IMPOSSIBLE__ relV-  reportSDoc "rewriting" 30 $ do-    text "rewrite relation at type " <+> do-      inTopContext $ prettyTCM (telFromList delta) <+> text " |- " <+> 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 $ do-    text "attempting to add rewrite rule of type " <+> do-      prettyTCM gamma1 <+> text " |- " <+> do-        addContext gamma1 $ prettyTCM core-  let failureWrongTarget = typeError . GenericDocError =<< hsep-        [ prettyTCM q , text " does not target rewrite relation" ]-  let failureMetas       = typeError . GenericDocError =<< hsep-        [ prettyTCM q , text " is not a legal rewrite rule, since it contains unsolved meta variables" ]-  let failureNotDefOrCon = typeError . GenericDocError =<< hsep-        [ prettyTCM q , text " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]-  let failureFreeVars xs = typeError . GenericDocError =<< hsep-        [ prettyTCM q , text " 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 = typeError . GenericDocError =<< hsep-        [ prettyTCM q , text " is not a legal rewrite rule" ]+  reportSDoc "rewriting" 30 $ vcat+    [ "attempting to add rewrite rule of type "+    , prettyTCM gamma1+    , " |- " <+> do addContext gamma1 $ prettyTCM core+    ]+  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 ignoreSharing $ unEl core of-    Def rel' es@(_:_:_) | rel == rel' -> do+  case unEl core of+    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.           n  = size vs           (us, [lhs, rhs]) = splitAt (n - 2) vs       unless (size delta == size us) __IMPOSSIBLE__-      b <- instantiateFull $ applySubst (parallelS $ reverse us) a+      lhs <- instantiateFull lhs+      rhs <- instantiateFull rhs+      b   <- instantiateFull $ applySubst (parallelS $ reverse us) a        gamma0 <- getContextTelescope       gamma1 <- instantiateFull gamma1       let gamma = gamma0 `abstract` gamma1 -      unless (null $ allMetas (telToList gamma1)) $ do-        reportSDoc "rewriting" 30 $ text "metas in gamma1: " <+> text (show $ allMetas $ 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.+      lhs <- modifyAllowedReductions (const $ SmallSet.singleton InlineReductions) $ reduce lhs -      -- Find head symbol f of the lhs and its arguments.-      (f , hd , es) <- case ignoreSharing lhs of-        Def f es -> return (f , Def f , es)+      -- Find head symbol f of the lhs, its type, its parameters (in case of a constructor), and its arguments.+      (f , hd , t , pars , es) <- case lhs of+        Def f es -> do+          def <- getConstInfo f+          checkAxFunOrCon f def+          return (f , Def f , defType def , [] , es)         Con c ci vs -> do-          let hd = Con c ci . fromMaybe __IMPOSSIBLE__ . allApplyElims-          return (conName c , hd  , map Apply vs)-        _        -> failureNotDefOrCon+          let hd = Con c ci+          ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c $ unDom b+          pars <- addContext gamma1 $ checkParametersAreGeneral c pars+          return (conName c , hd , t , pars , vs)+        _ -> do+          reportSDoc "rewriting.rule.check" 30 $ hsep+            [ "LHSNotDefinitionOrConstructor: ", prettyTCM lhs ]+          illegalRule LHSNotDefinitionOrConstructor -      rew <- addContext gamma1 $ do-        -- Normalize lhs args: we do not want to match redexes.-        es <- etaContract =<< normalise es-        checkNoLhsReduction f (hd es)+      ifNotAlreadyAdded f $ do -        -- Normalize rhs: might be more efficient.-        rhs <- etaContract =<< normalise rhs-        unless (null $ allMetas (es, rhs, b)) $ do-          reportSDoc "rewriting" 30 $ text "metas in lhs: " <+> text (show $ allMetas es)-          reportSDoc "rewriting" 30 $ text "metas in rhs: " <+> text (show $ allMetas rhs)-          reportSDoc "rewriting" 30 $ text "metas in b  : " <+> text (show $ allMetas b)-          failureMetas-        ps <- patternFrom Relevant 0 es+      addContext gamma1 $ do++        checkNoLhsReduction f hd es++        ps <- fromRightM failureBlocked $ lift $+          catchPatternErr (pure . Left) $+            Right <$> patternFrom relevant 0 (t , Def f) es+         reportSDoc "rewriting" 30 $-          text "Pattern generated from lhs: " <+> prettyTCM (PDef f ps)+          "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) -        -- check that FV(rhs) ⊆ nlPatVars(lhs)-        let freeVars  = usedArgs gamma1 `IntSet.union` allFreeVars (ps,rhs)-            boundVars = nlPatVars ps-        reportSDoc "rewriting" 40 $-          text "variables bound by the pattern: " <+> text (show boundVars)-        reportSDoc "rewriting" 40 $-          text "variables free in the rewrite rule: " <+> text (show freeVars)+        -- We need to check two properties on the variables used in the rewrite rule+        -- 1. For actually being able to apply the rewrite rule, we need+        --    that all variables that occur in the rule (on the left or the right)+        --    are bound in a pattern position on the left.+        -- 2. To preserve soundness, we need that all the variables that are used+        --    in the *proof* of the rewrite rule are bound in the lhs.+        --    For rewrite rules on constructors, we consider parameters to be bound+        --    even though they don't appear in the lhs, since they can be reconstructed.+        --    For postulated or abstract rewrite rules, we consider all arguments+        --    as 'used' (see #5238).+        let boundVars = nlPatVars ps+            freeVars  = allFreeVars (ps,rhs)+            allVars   = IntSet.fromList $ downFrom $ size gamma+            usedVars  = case theDef def of+              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 $+          "variables free in the rewrite rule: " <+> text (show freeVars)+        reportSDoc "rewriting" 70 $+          "variables used by the rewrite rule: " <+> text (show usedVars)         unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars+        unlessNull (usedVars IntSet.\\ (boundVars `IntSet.union` IntSet.fromList pars)) failureFreeVars -        return $ RewriteRule q gamma f ps rhs (unDom b)+        reportSDoc "rewriting" 70 $+          "variables bound in (erased) parameter position: " <+> text (show pars)+        unlessNull (boundVars `IntSet.intersection` IntSet.fromList pars) failureNonLinearPars -      reportSDoc "rewriting" 10 $-        text "considering rewrite rule " <+> prettyTCM rew-      reportSDoc "rewriting" 60 $-        text "considering rewrite rule" <+> text (show rew)+        top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+        let rew = RewriteRule q gamma f ps rhs (unDom b) False top -      -- NO LONGER WORKS:-      -- -- Check whether lhs can be rewritten with itself.-      -- -- Otherwise, there are unbound variables in either gamma or rhs.-      -- addContext gamma $-      --   unlessM (isJust <$> runReduceM (rewriteWith (Just b) lhs rew)) $-      --     failureFreeVars+        reportSDoc "rewriting" 10 $ vcat+          [ "checked rewrite rule" , prettyTCM rew ]+        reportSDoc "rewriting" 90 $ vcat+          [ "checked rewrite rule" , text (show rew) ] -      -- Add rewrite rule gamma ⊢ lhs ↦ rhs : b for f.-      addRewriteRules f [rew]+        return rew -    _ -> failureWrongTarget+    _ -> illegalRule DoesNotTargetRewriteRelation+   where-    checkNoLhsReduction :: QName -> Term -> TCM ()-    checkNoLhsReduction f v = do-      v' <- normalise v-      unless (v == v') $ do-        reportSDoc "rewriting" 20 $ text "v  = " <+> text (show v)-        reportSDoc "rewriting" 20 $ text "v' = " <+> text (show v')-        -- Andreas, 2016-06-01, issue 1997-        -- A reason for a reduction of the lhs could be that-        -- the rewrite rule has already been added.-        -- In this case, we want a nicer error message.-        checkNotAlreadyAdded f-        typeError . GenericDocError =<< fsep-          [ prettyTCM q <+> text " is not a legal rewrite rule, since the left-hand side "-          , prettyTCM v <+> text " reduces to " <+> prettyTCM v' ]+    illegalRule :: IllegalRewriteRuleReason -> MaybeT TCM a+    illegalRule reason = do+      lift $ warning $ IllegalRewriteRule q reason+      mzero -    checkNotAlreadyAdded :: QName -> TCM ()-    checkNotAlreadyAdded f = do+    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 :: MaybeT TCM a+          fail = do+            reportSDoc "rewriting" 20 $ "v  = " <+> text (show v)+            reportSDoc "rewriting" 20 $ "v' = " <+> text (show 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   <- lift $ computeElimHeadType f es es'+        pol <- getPolarity' CmpEq f+        ok  <- lift $ dontAssignMetas $ tryConversion $+                 compareElims pol [] a (Def f []) es es'+        unless ok fail++    checkAxFunOrCon :: QName -> Definition -> MaybeT TCM ()+    checkAxFunOrCon f def = case theDef def of+      Axiom{}        -> 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?+      Datatype{}     -> illegalHead+      Record{}       -> illegalHead+      DatatypeDefn{} -> illegalHead+      RecordDefn{}   -> illegalHead+      DataOrRecSig{} -> illegalHead+      PrimitiveSort{}-> illegalHead+      GeneralizableVar{} -> __IMPOSSIBLE__++      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-      when (any ((q ==) . rewName) rews) $-        typeError . GenericDocError =<< do-          text "Rewrite rule " <+> prettyTCM q <+> text " has already been added"+      case List.find ((q ==) . rewName) rews of+        Just rew -> illegalRule DuplicateRewriteRule+        Nothing -> cont -    usedArgs :: Telescope -> IntSet-    usedArgs tel = IntSet.fromList $ map unDom $ usedIxs+    usedArgs :: Definition -> IntSet+    usedArgs def = IntSet.fromList $ map snd $ usedIxs       where-        n = size tel-        allIxs = zipWith ($>) (flattenTel tel) (downFrom n)-        usedIxs = filter (not . unused . getRelevance) allIxs-        unused UnusedArg{} = True-        unused _           = False+        occs = defArgOccurrences def+        allIxs = zip occs $ downFrom $ size occs+        usedIxs = filter (used . fst) allIxs+        used Pos.Unused = False+        used _          = True --- | Append rewrite rules to a definition.-addRewriteRules :: QName -> RewriteRules -> TCM ()-addRewriteRules f rews = do-  reportSDoc "rewriting" 10 $ text "rewrite rule ok, adding it to the definition of " <+> prettyTCM f-  let matchables = getMatchables rews-  reportSDoc "rewriting" 30 $ text "matchable symbols: " <+> prettyTCM matchables-  modifySignature $ addRewriteRulesFor f rews matchables-  --rules <- getRewriteRulesFor f-  --reportSDoc "rewriting" 20 $ vcat-  --  [ text "rewrite rules for " <+> prettyTCM f <+> text ":"-  --  , vcat (map prettyTCM rules)-  --  ]+    checkParametersAreGeneral :: ConHead -> Args -> MaybeT TCM [Int]+    checkParametersAreGeneral c vs = do+        is <- loop vs+        unless (fastDistinct is) $ errorNotGeneral+        return is+      where+        loop []       = return []+        loop (v : vs) = case unArg v of+          Var i [] -> (i :) <$> loop vs+          _        -> errorNotGeneral --- | Sledgehammer approach to local rewrite rules. Rebind them after each---   left-hand side (which scrambles the context).-rebindLocalRewriteRules :: TCM ()-rebindLocalRewriteRules = do-  current <- currentModule-  ruleMap <- use $ stSignature . sigRewriteRules-  let isLocal r = m == current || m `isSubModuleOf` current-        where m = qnameModule $ rewName r-      ruleMap' = HMap.map (filter (not . isLocal)) ruleMap-      locals = map rewName $ filter isLocal $ concat $ map reverse $ HMap.elems ruleMap-  stSignature . sigRewriteRules .= ruleMap'-  mapM_ addRewriteRule locals+        errorNotGeneral :: MaybeT TCM a+        errorNotGeneral = illegalRule $ ConstructorParametersNotGeneral c vs --- | @rewriteWith t f es rew@---   tries to rewrite @f es : t@ with @rew@, returning the reduct if successful.-rewriteWith :: Maybe Type-            -> Term+-- | @rewriteWith t f es rew@ where @f : t@+--   tries to rewrite @f es@ with @rew@, returning the reduct if successful.+rewriteWith :: Type+            -> (Elims -> Term)             -> RewriteRule             -> Elims             -> ReduceM (Either (Blocked Term) Term)-rewriteWith mt v rew@(RewriteRule q gamma _ ps rhs b) es = do-  Red.traceSDoc "rewriting" 75 (sep-    [ text "attempting to rewrite term " <+> prettyTCM (v `applyE` es)-    , text " with rule " <+> prettyTCM rew+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+    [ "{ attempting to rewrite term " <+> prettyTCM (hd es)+    , " having head " <+> prettyTCM (hd []) <+> " of type " <+> prettyTCM t+    , " with rule " <+> prettyTCM rew     ]) $ do-    result <- nonLinMatch gamma ps es-    case result of-      Left block -> return $ Left $ block $> v `applyE` es -- TODO: remember reductions-      Right sub  -> do-        let v' = applySubst sub rhs-        Red.traceSDoc "rewriting" 70 (sep-          [ text "rewrote " <+> prettyTCM (v `applyE` es)-          , text " to " <+> prettyTCM v'-          ]) $ return $ Right v'--    {- OLD CODE:-    -- Freeze all metas, remember which one where not frozen before.-    -- This ensures that we do not instantiate metas while matching-    -- on the rewrite lhs.-    ms <- freezeMetas-    res <- tryConversion' $ do--      -- Create new metas for the lhs variables of the rewriting rule.-      xs <- newTelMeta gamma-      let sigma        = parallelS $ map unArg xs-          (lhs', rhs', b') = applySubst sigma (lhs, rhs, b)-      -- Unify type and term with type and lhs of rewrite rule.-      whenJust mt $ \ t -> leqType t b'-      local (\ e -> e {envCompareBlocked = True}) $ equalTerm b' lhs' v-      -- Check that all variables have been solved for.-      unlessM (isInstantiatedMeta xs) $ do-        reportSDoc "rewriting" 20 $ text "lhs variables solved with: " <+> do-          sep $ map prettyTCM xs-        -- The following error is caught immediately by tryConversion.-        typeError $ GenericError $ "free variables not bound by left hand side"-      return rhs'--    -- Thaw metas that were frozen by a call to this function.-    unfreezeMetas' (`elem` ms)-    return res-}+  traceSDoc "rewriting.rewrite" 90 (sep+    [ "raw: attempting to rewrite term " <+> (text . show) (hd es)+    , " having head " <+> (text . show) (hd []) <+> " of type " <+> (text . show) t+    , " with rule " <+> (text . show) rew+    ]) $ do+  result <- nonLinMatch gamma (t,hd) ps es+  case result of+    Left block -> traceSDoc "rewriting.rewrite" 50 "}" $+      return $ Left $ block $> hd es -- TODO: remember reductions+    Right sub  -> do+      let v' = applySubst sub rhs+      traceSDoc "rewriting.rewrite" 50 (sep+        [ "rewrote " <+> prettyTCM (hd es)+        , " to " <+> prettyTCM v' <+> "}"+        ]) $ do+      return $ Right v'  -- | @rewrite b v rules es@ tries to rewrite @v@ applied to @es@ with the --   rewrite rules @rules@. @b@ is the default blocking tag.-rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)-rewrite block v rules es = do+rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewrite block hd rules es = do   rewritingAllowed <- optRewriting <$> pragmaOptions-  if (rewritingAllowed && not (null rules)) then-    loop block rules =<< instantiateFull' es+  if (rewritingAllowed && not (null rules)) then do+    (_ , t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])+    loop block t rules =<< instantiateFull' es -- TODO: remove instantiateFull?   else-    return $ NoReduction (block $> v `applyE` es)+    return $ NoReduction (block $> hd es)   where-    loop :: Blocked_ -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)-    loop block [] es = return $ NoReduction $ block $> v `applyE` es-    loop block (rew:rews) es+    loop :: Blocked_ -> Type -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+    loop block t [] es =+      traceSDoc "rewriting.rewrite" 20 (sep+        [ "failed to rewrite " <+> prettyTCM (hd es)+        , "blocking tag" <+> text (show block)+        ]) $ do+      return $ NoReduction $ block $> hd es+    loop block t (rew:rews) es      | let n = rewArity rew, length es >= n = do           let (es1, es2) = List.genericSplitAt n es-          result <- rewriteWith Nothing v rew es1+          result <- rewriteWith t hd rew es1           case result of-            Left (Blocked m u)    -> loop (block `mappend` Blocked m ()) rews es-            Left (NotBlocked _ _) -> loop block rews es+            Left (Blocked m u)    -> loop (block `mappend` Blocked m ()) t rews es+            Left (NotBlocked _ _) -> loop block t rews es             Right w               -> return $ YesReduction YesSimplification $ w `applyE` es2-     | otherwise = loop (block `mappend` NotBlocked Underapplied ()) rews es------------------------------------------------------------------------------ * Auxiliary functions---------------------------------------------------------------------------class NLPatVars a where-  nlPatVars :: a -> IntSet--instance (Foldable f, NLPatVars a) => NLPatVars (f a) where-  nlPatVars = foldMap nlPatVars--instance NLPatVars NLPType where-  nlPatVars (NLPType l a) = nlPatVars l `IntSet.union` nlPatVars a--instance NLPatVars NLPat where-  nlPatVars p =-    case p of-      PVar _ i _ -> singleton i-      PDef _ es -> nlPatVars es-      PWild     -> empty-      PLam _ p' -> nlPatVars $ unAbs p'-      PPi a b   -> nlPatVars a `IntSet.union` nlPatVars (unAbs b)-      PBoundVar _ es -> nlPatVars es-      PTerm{}   -> empty--rewArity :: RewriteRule -> Int-rewArity = length . rewPats---- | Erase the CtxId's of rewrite rules-class KillCtxId a where-  killCtxId :: a -> a--instance (Functor f, KillCtxId a) => KillCtxId (f a) where-  killCtxId = fmap killCtxId--instance KillCtxId RewriteRule where-  killCtxId rule@RewriteRule{ rewPats = ps } = rule{ rewPats = killCtxId ps }--instance KillCtxId NLPType where-  killCtxId (NLPType l a) = NLPType (killCtxId l) (killCtxId a)--instance KillCtxId NLPat where-  killCtxId p = case p of-    PVar _ i bvs   -> PVar Nothing i bvs-    PWild          -> p-    PDef f es      -> PDef f $ killCtxId es-    PLam i x       -> PLam i $ killCtxId x-    PPi a b        -> PPi (killCtxId a) (killCtxId b)-    PBoundVar i es -> PBoundVar i $ killCtxId es-    PTerm _        -> p---- | Get all symbols that a rewrite rule matches against-class GetMatchables a where-  getMatchables :: a -> [QName]--instance (Foldable f, GetMatchables a) => GetMatchables (f a) where-  getMatchables = foldMap getMatchables--instance GetMatchables NLPat where-  getMatchables p =-    case p of-      PVar _ _ _     -> empty-      PWild          -> empty-      PDef f _       -> singleton f-      PLam _ x       -> empty-      PPi a b        -> empty-      PBoundVar i es -> empty-      PTerm _        -> empty -- should be safe (I hope)--instance GetMatchables RewriteRule where-  getMatchables = getMatchables . rewPats---- Only computes free variables that are not bound (i.e. those in a PTerm)-instance Free' NLPat c where-  freeVars' p = case p of-    PVar _ _ _ -> mempty-    PWild -> mempty-    PDef _ es -> freeVars' es-    PLam _ u -> freeVars' u-    PPi a b -> freeVars' (a,b)-    PBoundVar _ es -> freeVars' es-    PTerm t -> freeVars' t+     | otherwise = loop (block `mappend` NotBlocked Underapplied ()) t rews es -instance Free' NLPType c where-  freeVars' (NLPType l a) =-    ifM ((IgnoreNot ==) <$> asks feIgnoreSorts)-      {- then -} (freeVars' (l, a))-      {- else -} (freeVars' a)+    rewArity :: RewriteRule -> Int+    rewArity = length . rewPats
src/full/Agda/TypeChecking/Rewriting.hs-boot view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rewriting where  import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base  verifyBuiltinRewrite :: Term -> Type -> TCM ()-rewrite :: Blocked_ -> Term -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)+rewrite :: Blocked_ -> (Elims -> Term) -> RewriteRules -> Elims -> ReduceM (Reduced (Blocked Term) Term)
+ src/full/Agda/TypeChecking/Rewriting/Clause.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Rewriting.Clause where++import Data.Maybe++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Position++import Agda.TypeChecking.Monad++import Agda.Utils.Functor+import Agda.Utils.Impossible+import Agda.Utils.Monad+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, 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+    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 :: (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++  default toNLPat+    :: ( ToNLPat a' b', Functor f, a ~ f a', b ~ f b')+    => a -> b+  toNLPat = fmap toNLPat++instance ToNLPat a b => ToNLPat [a] [b] where+instance ToNLPat a b => ToNLPat (Dom a) (Dom b) where+instance ToNLPat a b => ToNLPat (Elim' a) (Elim' b) where+instance ToNLPat a b => ToNLPat (Abs a) (Abs b) where++instance ToNLPat (Arg DeBruijnPattern) (Elim' NLPat) where+  toNLPat (Arg ai p) = case p of+    VarP _ x        -> app $ PVar (dbPatVarIndex x) []+    DotP _ u        -> app $ PTerm u+    ConP c _ ps     -> app $ PDef (conName c) $ toNLPat ps+    LitP o l        -> app $ PTerm $ Lit l+    ProjP o f       -> Proj o f+    IApplyP _ u v x -> IApply (PTerm u) (PTerm v) $ PVar (dbPatVarIndex x) []+    DefP _ f ps     -> app $ PDef f $ toNLPat ps++    where+      app = Apply . Arg ai++instance ToNLPat (NamedArg DeBruijnPattern) (Elim' NLPat) where+  toNLPat = toNLPat . fmap namedThing
+ src/full/Agda/TypeChecking/Rewriting/Confluence.hs view
@@ -0,0 +1,938 @@+{-# LANGUAGE NondecreasingIndentation #-}++-- | Checking local or global confluence of rewrite rules.+--+-- For checking LOCAL CONFLUENCE of a given rewrite rule @f ps ↦ v@,+-- we construct critical pairs involving this as the main rule by+-- searching for:+--+-- 1. *Different* rules @f ps' ↦ ...@ where @ps@ and @ps'@ can be+--    unified.+--+-- 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₁ <-- f us --> v₂@, which+-- should satisfy @v₁ = v₂@.+--+-- For checking GLOBAL CONFLUENCE, we check the following two+-- properties:+--+-- 1. For any two left-hand sides of the rewrite rules that overlap+--    (either at the root position or at a subterm), the most general+--    unifier of the two left-hand sides is again a left-hand side of+--    a rewrite rule. For example, if there are two rules @suc m + n =+--    suc (m + n)@ and @m + suc n = suc (m + n)@, then there should+--    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+--    @u => v@, we should have another single-step parallel unfolding+--    @v => w@.+++module Agda.TypeChecking.Rewriting.Confluence+  ( checkConfluenceOfRules+  , checkConfluenceOfClauses+  , sortRulesOfSymbol+  ) where++import Control.Applicative+import Control.Arrow ((***))+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Reader ( MonadReader(..), asks, runReaderT )++import Data.Either+import Data.Function ( on )+import Data.Functor ( ($>) )+import qualified Data.HashMap.Strict as HMap+import Data.List ( elemIndex , tails )+import Data.Set (Set)+import qualified Data.Set as Set++import Agda.Interaction.Options ( ConfluenceCheck(..) )++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars++import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Conversion.Pure+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Free+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.Constraint+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rewriting.Clause+import Agda.TypeChecking.Rewriting.NonLinMatch+import Agda.TypeChecking.Rewriting.NonLinPattern+import Agda.TypeChecking.Sort+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings++import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Impossible+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null (unlessNullM)+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size++-- | 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)+  modifySignature $ setMatchableSymbols f $ concat matchables+  let hasRules g = not . null <$> getRewriteRulesFor g+  forM_ (zip rews matchables) $ \(rew,ms) ->+    unlessNullM (filterM hasRules ms) $ \_ -> do+      checkConfluenceOfRules confChk [rew]++-- | 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++  -- Global confluence: we need to check the triangle property for each rewrite+  -- rule of each head symbol as well as rules that match on them+  when (confChk == GlobalConfluenceCheck) $ do+    let getSymbols rew = let f = rewHead rew in+         (Set.insert f) . defMatchable <$> getConstInfo f+    allSymbols <- Set.toList . Set.unions <$> traverse getSymbols rews+    forM_ allSymbols $ \f -> do+      rewsf <- getAllRulesFor f+      forM_ rewsf $ \rew -> do+        reportSDoc "rewriting.confluence.triangle" 10 $+          "(re)checking triangle property for rule" <+> prettyTCM (rewName rew)+        checkTrianglePropertyForRule rew++  forM_ (tails rews) $ listCase (return ()) $ \rew rewsRest -> do++  reportSDoc "rewriting.confluence" 10 $+    "Checking confluence of rule" <+> prettyTCM (rewName rew)+  reportSDoc "rewriting.confluence" 30 $+    "Checking confluence of rule" <+> prettyTCM rew++  let f   = rewHead rew+      qs  = rewPats rew+      tel = rewContext rew+  def <- getConstInfo f+  (fa , hdf) <- addContext tel $ makeHead def (rewType rew)++  reportSDoc "rewriting.confluence" 30 $ addContext tel $+    "Head symbol" <+> prettyTCM (hdf []) <+> "of rewrite rule has type" <+> prettyTCM fa++  -- Step 1: check other rewrite rules that overlap at top position+  forMM_ (getAllRulesFor f) $ \ rew' -> do+    unless (any (sameRuleName rew') (rew:rewsRest) ||+            (rewFromClause rew && rewFromClause rew')) $+      checkConfluenceTop hdf rew rew'+  reportSDoc "rewriting.confluence" 30 $ "Finished step 1 of confluence check of rule" <+> prettyTCM (rewName rew)++  -- Step 2: check other rewrite rules that overlap with a subpattern+  -- of this rewrite rule+  es <- nlPatToTerm qs+  forMM_ (addContext tel $ allHolesList (fa, hdf) es) $ \ hole -> do+    let g   = ohHeadName hole+        hdg = ohHead hole+    reportSDoc "rewriting.confluence" 40 $+      "Found hole with head symbol" <+> prettyTCM g+    rews' <- getAllRulesFor g+    forM_ rews' $ \rew' -> do+      unless (any (sameRuleName rew') rewsRest) $+        checkConfluenceSub hdf hdg rew rew' hole+  reportSDoc "rewriting.confluence" 30 $ "Finished step 2 of confluence check of rule" <+> prettyTCM (rewName rew)++  -- Step 3: check other rewrite rules that have a subpattern which+  -- overlaps with this rewrite rule+  forM_ (defMatchable def) $ \ g -> do+    reportSDoc "rewriting.confluence" 40 $+      "Symbol" <+> prettyTCM g <+> "has rules that match on" <+> prettyTCM f+    forMM_ (getAllRulesFor g) $ \ rew' -> do+      unless (any (sameRuleName rew') rewsRest) $ do+        es' <- nlPatToTerm (rewPats rew')+        let tel' = rewContext rew'+        def' <- getConstInfo g+        (ga , hdg) <- addContext tel' $ makeHead def' (rewType rew')+        forMM_ (addContext tel' $ allHolesList (ga , hdg) es') $ \ hole -> do+          let f' = ohHeadName hole+          when (f == f') $ checkConfluenceSub hdg hdf rew' rew hole+  reportSDoc "rewriting.confluence" 30 $ "Finished step 3 of confluence check of rule" <+> prettyTCM (rewName rew)++  where++    -- Check confluence of two rewrite rules that have the same head symbol,+    -- e.g. @f ps --> a@ and @f ps' --> b@.+    checkConfluenceTop :: (Elims -> Term) -> RewriteRule -> RewriteRule -> TCM ()+    checkConfluenceTop hd rew1 rew2 =+      traceCall (CheckConfluence (rewName rew1) (rewName rew2)) $+      localTCStateSavingWarnings $ do++        sub1 <- makeMetaSubst $ rewContext rew1+        sub2 <- makeMetaSubst $ rewContext rew2++        let f    = rewHead rew1 -- == rewHead rew2+            a1   = applySubst sub1 $ rewType rew1+            a2   = applySubst sub2 $ rewType rew2++        es1 <- applySubst sub1 <$> nlPatToTerm (rewPats rew1)+        es2 <- applySubst sub2 <$> nlPatToTerm (rewPats rew2)++        reportSDoc "rewriting.confluence" 30 $ vcat+          [ "checkConfluenceTop" <+> prettyTCM (rewName rew1) <+> prettyTCM (rewName rew2)+          , "  f    = " <+> prettyTCM f+          , "  ctx1 = " <+> prettyTCM (rewContext rew1)+          , "  ctx2 = " <+> prettyTCM (rewContext rew2)+          , "  es1  = " <+> prettyTCM es1+          , "  es2  = " <+> prettyTCM es2+          ]++        -- Make sure we are comparing eliminations with the same arity+        -- (see #3810).+        let n = min (size es1) (size es2)+            (es1' , es1r) = splitAt n es1+            (es2' , es2r) = splitAt n es2+            esr           = es1r ++ es2r++            lhs1 = hd $ es1' ++ esr+            lhs2 = hd $ es2' ++ esr++            -- Use type of rewrite rule with the most eliminations+            a | null es1r = a2+              | otherwise = a1++        reportSDoc "rewriting.confluence" 20 $ sep+          [ "Considering potential critical pair at top-level: "+          , nest 2 $ prettyTCM $ lhs1, " =?= "+          , nest 2 $ prettyTCM $ lhs2 , " : " , nest 2 $ prettyTCM a+          ]++        maybeCriticalPair <- tryUnification lhs1 lhs2 $ do+          -- Unify the left-hand sides of both rewrite rules+          fa   <- defType <$> getConstInfo f+          fpol <- getPolarity' CmpEq f+          onlyReduceTypes $+            compareElims fpol [] fa (hd []) es1' es2'++          -- Get the rhs of both rewrite rules (after unification). In+          -- case of different arities, add additional arguments from+          -- one side to the other side.+          let rhs1 = applySubst sub1 (rewRHS rew1) `applyE` es2r+              rhs2 = applySubst sub2 (rewRHS rew2) `applyE` es1r++          return (rhs1 , rhs2)++        whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hd (es1' ++ esr))++    -- Check confluence between two rules that overlap at a subpattern,+    -- e.g. @f ps[g qs] --> a@ and @g qs' --> b@.+    checkConfluenceSub :: (Elims -> Term) -> (Elims -> Term) -> RewriteRule -> RewriteRule -> OneHole Elims -> TCM ()+    checkConfluenceSub hdf hdg rew1 rew2 hole0 = do+      reportSDoc "rewriting.confluence" 100 $ "foo 2" <+> prettyTCM (rewName rew1) <+> prettyTCM (rewName rew2)+      traceCall (CheckConfluence (rewName rew1) (rewName rew2)) $ localTCStateSavingWarnings $ do++        reportSDoc "rewriting.confluence" 20 $+          "Checking confluence of rules" <+> prettyTCM (rewName rew1) <+>+          "and" <+> prettyTCM (rewName rew2) <+> "at subpattern position"++        sub1 <- makeMetaSubst $ rewContext rew1++        let bvTel0     = ohBoundVars hole0+            k          = size bvTel0+            b0         = applySubst (liftS k sub1) $ ohType hole0+            g          = ohHeadName hole0+            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.+        hole1 <- addContext bvTel0 $+          forceEtaExpansion b0 (hdg es0) $ drop (size es0) qs2++        verboseS "rewriting.confluence.eta" 30 $+          unless (size es0 == size qs2) $+          addContext bvTel0 $+          reportSDoc "rewriting.confluence.eta" 30 $ vcat+            [ "forceEtaExpansion result:"+            , nest 2 $ "bound vars: " <+> prettyTCM (ohBoundVars hole1)+            , nest 2 $ "hole contents: " <+> addContext (ohBoundVars hole1) (prettyTCM $ ohContents hole1)+            ]++        let hole      = hole1 `composeHole` hole0+            g         = ohHeadName hole -- == rewHead rew2+            es'       = ohElims hole+            bvTel     = ohBoundVars hole+            plug      = ohPlugHole hole++        sub2 <- addContext bvTel $ makeMetaSubst $ rewContext rew2++        let es1 = applySubst (liftS (size bvTel) sub1) es'+        es2 <- applySubst sub2 <$> nlPatToTerm (rewPats rew2)++        -- Make sure we are comparing eliminations with the same arity+        -- (see #3810). Because we forced eta-expansion of es1, we+        -- know that it is at least as long as es2.+        when (size es1 < size es2) __IMPOSSIBLE__+        let n = size es2+            (es1' , es1r) = splitAt n es1++        let lhs1 = applySubst sub1 $ hdf $ plug $ hdg es1+            lhs2 = applySubst sub1 $ hdf $ plug $ hdg $ es2 ++ es1r+            a    = applySubst sub1 $ rewType rew1++        reportSDoc "rewriting.confluence" 20 $ sep+          [ "Considering potential critical pair at subpattern: "+          , nest 2 $ prettyTCM $ lhs1 , " =?= "+          , nest 2 $ prettyTCM $ lhs2 , " : " , nest 2 $ prettyTCM a+          ]++        maybeCriticalPair <- tryUnification lhs1 lhs2 $ do+          -- Unify the subpattern of the first rewrite rule with the lhs+          -- of the second one+          ga   <- defType <$> getConstInfo g+          gpol <- getPolarity' CmpEq g+          onlyReduceTypes $ addContext bvTel $+            compareElims gpol [] ga (hdg []) es1' es2++          -- Right-hand side of first rewrite rule (after unification)+          let rhs1 = applySubst sub1 $ rewRHS rew1++          -- Left-hand side of first rewrite rule, with subpattern+          -- rewritten by the second rewrite rule+          let w = applySubst sub2 (rewRHS rew2) `applyE` es1r+          reportSDoc "rewriting.confluence" 30 $ sep+            [ "Plugging hole with w = "+            , nest 2 $ addContext bvTel $ prettyTCM w+            ]+          let rhs2 = applySubst sub1 $ hdf $ plug w++          return (rhs1 , rhs2)++        whenJust maybeCriticalPair $ uncurry (checkCriticalPair a hdf (applySubst sub1 $ plug $ hdg es1))++    checkCriticalPair+      :: Type     -- Type of the critical pair+      -> (Elims -> Term)  -- Head of lhs+      -> Elims            -- Eliminations of lhs+      -> Term     -- First reduct+      -> Term     -- Second reduct+      -> TCM ()+    checkCriticalPair a hd es rhs1 rhs2 = do++      (a,es,rhs1,rhs2) <- instantiateFull (a,es,rhs1,rhs2)++      let ms = Set.toList $ allMetas singleton $ (a,es,rhs1,rhs2)++      reportSDoc "rewriting.confluence" 30 $ sep+        [ "Abstracting over metas: "+        , prettyList_ (map (text . show) ms)+        ]+      (gamma , (a,es,rhs1,rhs2)) <- fromMaybe __IMPOSSIBLE__ <$>+        abstractOverMetas ms (a,es,rhs1,rhs2)++      addContext gamma $ reportSDoc "rewriting.confluence" 10 $ sep+        [ "Found critical pair: "+        , nest 2 $ prettyTCM (hd es)+        , " ---> " , nest 2 $ prettyTCM rhs1+        , " =?= " , nest 2 $ prettyTCM rhs2+        , " : " , nest 2 $ prettyTCM a ]+      reportSDoc "rewriting.confluence" 30 $ do+        gamma <- instantiateFull gamma+        sep [ "Context of critical pair: "+            , nest 2 $ prettyTCM gamma ]++      addContext gamma $ case confChk of++        -- Local confluence check: check that critical pair has a+        -- common reduct.+        LocalConfluenceCheck -> do+            dontAssignMetas $ noConstraints $ equalTerm a rhs1 rhs2+          `catchError` \case+            TypeError _ s err -> do+              prettyErr <- withTCState (const s) $ prettyTCM err+              warning $ RewriteNonConfluent (hd es) rhs1 rhs2 prettyErr+            err           -> throwError err++        -- Global confluence check: enforce that MGU is again the LHS+        -- of a rewrite rule (actual global confluence then follows+        -- from the triangle property which was checked before).+        GlobalConfluenceCheck -> do+          (f, t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])++          let checkEqualLHS :: RewriteRule -> TCM Bool+              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 $+                      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+                    return ok+              allDistinctVars :: [(Term,Dom Type)] -> TCM Bool+              allDistinctVars us = do+                us' <- filterM (not <.> isIrrelevantOrPropM . snd) us+                mis <- traverse (\(u,a) -> isEtaVar u (unDom a)) $ us'+                case sequence mis of+                  Just is -> return $ fastDistinct is+                  Nothing -> return False++          rews <- getAllRulesFor f+          let sameRHS = onlyReduceTypes $ pureEqualTerm a rhs1 rhs2+          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+      u  <- nlPatToTerm $ PDef f ps+      -- First element in the list is the "best reduct" @ρ(u)@+      (rhou,vs) <- fromMaybe __IMPOSSIBLE__ . uncons <$> allParallelReductions u+      reportSDoc "rewriting.confluence" 40 $ ("rho(" <> prettyTCM u <> ") =") <+> prettyTCM rhou+      reportSDoc "rewriting.confluence" 40 $ ("S(" <> prettyTCM u <> ") =") <+> prettyList_ (map prettyTCM vs)+      -- If present, last element is always equal to u+      caseMaybe (initLast vs) (return ()) $ \(vs',u') -> do+        unless (u == u') __IMPOSSIBLE__+        forM_ vs' $ \v -> unlessM (checkParallelReductionStep b v rhou) $+          warning $ RewriteMissingRule u v rhou++    checkParallelReductionStep :: Type -> Term -> Term -> TCM Bool+    checkParallelReductionStep a u w = do+      reportSDoc "rewriting.confluence.global" 30 $ fsep+        [ "Global confluence: checking if" , prettyTCM u+        , "reduces to" , prettyTCM w , "in one parallel step." ]+      anyListT (parReduce u) $ \v -> do+        reportSDoc "rewriting.confluence.global" 30 $ fsep+          [ prettyTCM u , " reduces to " , prettyTCM v+          ]+        eq <- onlyReduceTypes $ pureEqualTerm a v w+        when eq $ reportSDoc "rewriting.confluence.global" 30 $ fsep+          [ "  which is equal to" , prettyTCM w+          ]+        return eq+++sortRulesOfSymbol :: QName -> TCM ()+sortRulesOfSymbol f = do+    -- 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]+    sortRules rs = do+      ordPairs <- deleteLoops . Set.fromList . map (rewName *** rewName) <$>+        filterM (uncurry $ flip moreGeneralLHS) [(r1,r2) | r1 <- rs, r2 <- rs]+      let perm = fromMaybe __IMPOSSIBLE__ $+                   topoSort (\r1 r2 -> (rewName r1,rewName r2) `Set.member` ordPairs) rs+      reportSDoc "rewriting.confluence.sort" 50 $ "sorted rules: " <+>+        prettyList_ (map (prettyTCM . rewName) $ permute perm rs)+      return $ permute perm rs++    moreGeneralLHS :: PureTCM m => RewriteRule -> RewriteRule -> m Bool+    moreGeneralLHS r1 r2+      | sameRuleName r1 r2       = return False+      | rewHead r1 /= rewHead r2 = return False+      | otherwise                = addContext (rewContext r2) $ do+          def <- getConstInfo $ rewHead r1+          (t, hd) <- makeHead def (rewType r2)+          (vs :: Elims) <- nlPatToTerm $ rewPats r2+          res <- isRight <$> onlyReduceTypes (nonLinMatch (rewContext r1) (t, hd) (rewPats r1) vs)+          when res $ reportSDoc "rewriting.confluence.sort" 55 $+            "the lhs of " <+> prettyTCM (rewName r1) <+>+            "is more general than the lhs of" <+> prettyTCM (rewName r2)+          return res++    deleteLoops :: Ord a => Set (a,a) -> Set (a,a)+    deleteLoops xs = Set.filter (\(x,y) -> not $ (y,x) `Set.member` xs) xs++makeHead :: PureTCM m => Definition -> Type -> m (Type , Elims -> Term)+makeHead def a = case theDef def of+  Constructor{ conSrcCon = ch } -> do+    ca <- snd . fromMaybe __IMPOSSIBLE__ <$> getFullyAppliedConType ch a+    return (ca , Con ch ConOSystem)+  -- 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 = Right proj } -> do+    let f          = projOrig proj+        r          = unArg $ projFromType proj+    rtype <- defType <$> getConstInfo r+    TelV ptel _ <- telView rtype+    n <- getContextSize+    let pars :: Args+        pars = raise (n - size ptel) $ teleArgs ptel+    ftype <- defType def `piApplyM` pars+    return (ftype , Def f)+  _ -> return (defType def , Def $ defName def)++sameRuleName :: RewriteRule -> RewriteRule -> Bool+sameRuleName = (==) `on` rewName++-- | Get both clauses and rewrite rules for the given symbol+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+--   telescope by fresh metavariables.+makeMetaSubst :: (MonadMetaSolver m) => Telescope -> m Substitution+makeMetaSubst gamma = parallelS . reverse . map unArg <$> newTelMeta gamma++computingOverlap :: (MonadTCEnv m) => m a -> m a+computingOverlap = locallyTC eConflComputingOverlap $ const True++-- | Try to run the TCM action, return @Just x@ if it succeeds with+--   result @x@ or @Nothing@ if it throws a type error. Abort if there+--   are any constraints.+tryUnification :: Term -> Term -> TCM a -> TCM (Maybe a)+tryUnification lhs1 lhs2 f = computingOverlap (Just <$> f)+  `catchError` \case+    err@TypeError{} -> do+      reportSDoc "rewriting.confluence" 20 $ vcat+        [ "Unification failed with error: "+        , nest 2 $ prettyTCM err+        ]+      return Nothing+    err -> throwError err+  `ifNoConstraints` return $ \pid _ -> do+    cs <- getConstraintsForProblem pid+    prettyCs <- prettyInterestingConstraints cs+    warning $ RewriteMaybeNonConfluent lhs1 lhs2 prettyCs+    return Nothing+++type MonadParallelReduce m =+  ( PureTCM m+  , MonadFresh NameId m+  )++-- | List all possible single-step parallel reductions of the given term.+allParallelReductions :: (MonadParallelReduce m, ParallelReduce a) => a -> m [a]+allParallelReductions = sequenceListT . parReduce++-- | Single-step parallel reduction of a given term.+--   The monad 'm' can be instantiated in multiple ways:+--   * Use 'MaybeT TCM' to get the "optimal reduct" obtained by+--     applying rewrite rules eagerly.+--   * Use 'ListT TCM' to obtain all possible one-step parallel+--     reductions.+class ParallelReduce a where+  parReduce :: (MonadParallelReduce m, MonadPlus m) => a -> m a++  default parReduce+    :: ( MonadParallelReduce m, MonadPlus m+       , Traversable f, a ~ f b, ParallelReduce b)+    => a -> m a+  parReduce = traverse parReduce++-- | Compute possible one-step reductions by applying a rewrite rule+--   at the top-level and reducing all subterms in the position of a+--   variable of the rewrite rule in parallel.+topLevelReductions :: (MonadParallelReduce m, MonadPlus m) => (Elims -> Term) -> Elims -> m Term+topLevelReductions hd es = do+  reportSDoc "rewriting.parreduce" 30 $ "topLevelReductions" <+> prettyTCM (hd es)+  -- 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)+  reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: trying rule" <+> prettyTCM q+  -- Don't reduce if underapplied+  guard $ length es >= length ps+  let (es0 , es1) = splitAt (length ps) es+  onlyReduceTypes (nonLinMatch gamma (t,hd) ps es0) >>= \case+    -- Matching failed: no reduction+    Left block -> empty+    -- Matching succeeded+    Right sub -> do+      let vs = map (lookupS sub) $ [0..(size gamma-1)]+      sub' <- parallelS <$> parReduce vs+      es1' <- parReduce es1+      let w = (applySubst sub' rhs) `applyE` es1'+      reportSDoc "rewriting.parreduce" 50 $ "topLevelReductions: rewrote" <+> prettyTCM (hd es) <+> "to" <+> prettyTCM w+      return w++instance ParallelReduce Term where+  parReduce = \case+    -- Interesting cases+    (Def f es) -> (topLevelReductions (Def f) es) <|> (Def f <$> parReduce es)+    (Con c ci es) -> (topLevelReductions (Con c ci) es) <|> (Con c ci <$> parReduce es)++    -- Congruence cases+    Lam i u  -> Lam i <$> parReduce u+    Var x es -> Var x <$> parReduce es+    Pi a b   -> Pi    <$> parReduce a <*> parReduce b+    Sort s   -> Sort  <$> parReduce s++    -- Base cases+    u@Lit{}      -> return u+    u@Level{}    -> return u -- TODO: is this fine?+    u@DontCare{} -> return u+    u@Dummy{}    -> return u -- not __IMPOSSIBLE__ because of presence of Dummy+                             -- parameters for rewrite rules on constructors.++    -- Impossible cases+    MetaV{}    -> __IMPOSSIBLE__++instance ParallelReduce Sort where+  parReduce = pure -- TODO: is this fine?++instance ParallelReduce a => ParallelReduce (Arg a) where+instance ParallelReduce a => ParallelReduce (Dom a) where+instance ParallelReduce a => ParallelReduce (Type' a) where+instance ParallelReduce a => ParallelReduce [a] where++instance ParallelReduce a => ParallelReduce (Elim' a) where+  parReduce (Apply u)  = Apply <$> parReduce u+  parReduce e@Proj{}   = pure e+  parReduce e@IApply{} = pure e -- TODO++instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where+  parReduce = mapAbstraction __DUMMY_DOM__ parReduce+++-- | Given metavariables ms and some x, construct a telescope Γ and+--   replace all occurrences of the given metavariables in @x@ by+--   normal variables from Γ. Returns @Nothing@ if metas have cyclic+--   dependencies.+abstractOverMetas :: (MetasToVars a) => [MetaId] -> a -> TCM (Maybe (Telescope, a))+abstractOverMetas ms x = do++  -- Sort metas in dependency order+  forMM (dependencySortMetas ms) $ \ms' -> do++    -- Get types and suggested names of metas+    as <- forM ms' getMetaType+    ns <- forM ms' getMetaNameSuggestion++    -- Construct telescope (still containing the metas)+    let n     = size ms'+        gamma = unflattenTel' n ns $ map defaultDom as++    -- Replace metas by variables+    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.+data OneHole a = OneHole+  { ohBoundVars :: Telescope     -- Telescope of bound variables at the hole+  , ohType      :: Type          -- Type of the term in the hole+  , ohPlugHole  :: Term -> a     -- Plug the hole with some term+  , ohHead      :: Elims -> Term -- The head symbol of the term in the hole+  , ohElims     :: Elims         -- The eliminations of the term in the hole+  } deriving (Functor)++ohHeadName :: OneHole a -> QName+ohHeadName oh = case ohHead oh [] of+  Def f _   -> f+  Con c _ _ -> conName c+  _         -> __IMPOSSIBLE__++ohContents :: OneHole a -> Term+ohContents oh = ohHead oh $ ohElims oh++-- | The trivial hole+idHole :: Type -> Term -> OneHole Term+idHole a = \case+  Def f es    -> OneHole EmptyTel a id (Def f) es+  Con c ci es -> OneHole EmptyTel a id (Con c ci) es+  _           -> __IMPOSSIBLE__++-- | Plug a hole with another hole+composeHole :: OneHole Term -> OneHole a -> OneHole a+composeHole inner outer = OneHole+  { ohBoundVars = ohBoundVars outer `abstract` ohBoundVars inner+  , ohType      = ohType inner+  , ohPlugHole  = ohPlugHole outer . ohPlugHole inner+  , ohHead      = ohHead inner+  , ohElims     = ohElims inner+  }++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+--   decompositions @p = p'[(f ps)/x]@.+class (TermSubst p, Free p) => AllHoles p where+  allHoles :: (Alternative m, PureTCM m) => TypeOf p -> p -> m (OneHole p)++allHoles_+  :: ( Alternative m , PureTCM m , AllHoles p , TypeOf p ~ () )+  => p -> m (OneHole p)+allHoles_ = allHoles ()++allHolesList+  :: ( PureTCM m , AllHoles p)+  => TypeOf p -> p -> m [OneHole p]+allHolesList a = sequenceListT . allHoles a++-- | Given a term @v : a@ and eliminations @es@, force eta-expansion+--   of @v@ to match the structure (Apply/Proj) of the eliminations.+--+--   Examples:+--+--   1. @v : _A@ and @es = [$ w]@: this will instantiate+--      @_A := (x : _A1) → _A2@ and return the @OneHole Term@+--      @λ x → [v x]@.+--+--   2. @v : _A@ and @es = [.fst]@: this will instantiate+--      @_A := _A1 × _A2@ and return the @OneHole Term@+--      @([v .fst]) , (v .snd)@.+forceEtaExpansion :: Type -> Term -> [Elim' a] -> TCM (OneHole Term)+forceEtaExpansion a v [] = return $ idHole a v+forceEtaExpansion a v (e:es) = case e of++  Apply (Arg i w) -> do++    -- Force a to be a pi type+    reportSDoc "rewriting.confluence.eta" 40 $ fsep+      [ "Forcing" , prettyTCM v , ":" , prettyTCM a , "to take one more argument" ]+    dom <- defaultArgDom i <$> newTypeMeta_+    cod <- addContext dom $ newTypeMeta_+    equalType a $ mkPi (("x",) <$> dom) cod++    -- Construct body of eta-expansion+    let body = raise 1 v `apply` [Arg i $ var 0]++    -- Continue with remaining eliminations+    addContext dom $ ohAddBV "x" dom . fmap (Lam i . mkAbs "x") <$>+      forceEtaExpansion cod body es++  Proj o f -> do++    -- Force a to be the right record type for projection by f+    reportSDoc "rewriting.confluence.eta" 40 $ fsep+      [ "Forcing" , prettyTCM v , ":" , prettyTCM a , "to be projectible by" , prettyTCM f ]+    r <- fromMaybe __IMPOSSIBLE__ <$> getRecordOfField f+    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 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++    -- Get type of field corresponding to f+    ~(Just (El _ (Pi b c))) <- getDefType f =<< reduce a+    let fa = c `absApp` v++    -- Continue with remaining eliminations+    fmap fUpdate <$> forceEtaExpansion fa fContent es++  IApply{} -> __IMPOSSIBLE__ -- Not yet implemented++-- Instances for @AllHoles@++instance AllHoles p => AllHoles (Arg p) where+  allHoles a x = fmap (x $>) <$> allHoles (unDom a) (unArg x)++instance AllHoles p => AllHoles (Dom p) where+  allHoles a x = fmap (x $>) <$> allHoles a (unDom x)++instance AllHoles (Abs Term) where+  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+  allHoles dom a = addContext (absName a , dom) $+    ohAddBV (absName a) dom . fmap (mkAbs $ absName a) <$>+      allHoles_ (absBody a)++instance AllHoles Elims where+  allHoles (a,hd) [] = empty+  allHoles (a,hd) (e:es) = do+    reportSDoc "rewriting.confluence.hole" 65 $ fsep+      [ "Head symbol" , prettyTCM (hd []) , ":" , prettyTCM a+      , "is eliminated by" , prettyTCM e+      ]+    case e of+      Apply x -> do+        ~(Pi b c) <- unEl <$> reduce a+        let a'  = c `absApp` unArg x+            hd' = hd . (e:)+        (fmap ((:es) . Apply) <$> allHoles b x)+         <|> (fmap (e:) <$> allHoles (a' , hd') es)+      Proj o f -> do+        ~(Just (El _ (Pi b c))) <- getDefType f =<< reduce a+        let a' = c `absApp` hd []+        hd' <- applyE <$> applyDef o f (argFromDom b $> hd [])+        fmap (e:) <$> allHoles (a' , hd') es+      IApply x y u -> empty -- TODO: support --confluence-check + --cubical++instance AllHoles Type where+  allHoles _ (El s a) = workOnTypes $+    fmap (El s) <$> allHoles (sort s) a++instance AllHoles Term where+  allHoles a u = do+    reportSDoc "rewriting.confluence.hole" 60 $ fsep+      [ "Getting holes of term" , prettyTCM u , ":" , prettyTCM a ]+    case u of+      Var i es       -> do+        ai <- typeOfBV i+        fmap (Var i) <$> allHoles (ai , Var i) es+      Lam i u        -> do+        ~(Pi b c) <- unEl <$> reduce a+        fmap (Lam i) <$> allHoles (b,c) u+      Lit l          -> empty+      v@(Def f es)   -> do+        fa <- defType <$> getConstInfo f+        pure (idHole a v)+         <|> (fmap (Def f) <$> allHoles (fa , Def f) es)+      v@(Con c ci es) -> do+        ca <- snd . fromMaybe __IMPOSSIBLE__ <$> do+          getFullyAppliedConType c =<< reduce a+        pure (idHole a v)+         <|> (fmap (Con c ci) <$> allHoles (ca , Con c ci) es)+      Pi a b         ->+        (fmap (\a -> Pi a b) <$> allHoles_ a) <|>+        (fmap (\b -> Pi a b) <$> allHoles a b)+      Sort s         -> fmap Sort <$> allHoles_ s+      Level l        -> fmap Level <$> allHoles_ l+      MetaV{}        -> __IMPOSSIBLE__+      DontCare{}     -> empty+      Dummy{}        -> empty++instance AllHoles Sort where+  allHoles _ = \case+    Univ u l     -> fmap (Univ u) <$> allHoles_ l+    Inf _ _      -> empty+    SizeUniv     -> empty+    LockUniv     -> empty+    LevelUniv    -> empty+    IntervalUniv -> empty+    PiSort{}     -> __IMPOSSIBLE__+    FunSort{}    -> __IMPOSSIBLE__+    UnivSort{}   -> __IMPOSSIBLE__+    MetaS{}      -> __IMPOSSIBLE__+    DefS f es    -> do+      fa <- defType <$> getConstInfo f+      fmap (DefS f) <$> allHoles (fa , Def f) es+    DummyS{}     -> empty++instance AllHoles Level where+  allHoles _ (Max n ls) = fmap (Max n) <$> allHoles_ ls++instance AllHoles [PlusLevel] where+  allHoles _ []     = empty+  allHoles _ (l:ls) =+    (fmap (:ls) <$> allHoles_ l)+    <|> (fmap (l:) <$> allHoles_ ls)++instance AllHoles PlusLevel where+  allHoles _ (Plus n l) = do+    la <- levelType'+    fmap (Plus n) <$> allHoles la l+++-- | Convert metavariables to normal variables. Warning: doesn't+--   convert sort metas.+class MetasToVars a where+  metasToVars+    :: (MonadReader (MetaId -> Maybe Nat) m , HasBuiltins m)+    => a -> m a++  default metasToVars+    :: ( MetasToVars a', Traversable f, a ~ f a'+       , MonadReader (MetaId -> Maybe Nat) m , HasBuiltins m)+    => a -> m a+  metasToVars = traverse metasToVars++instance MetasToVars a => MetasToVars [a] where+instance MetasToVars a => MetasToVars (Arg a) where+instance MetasToVars a => MetasToVars (Dom a) where+instance MetasToVars a => MetasToVars (Elim' a) where++instance MetasToVars a => MetasToVars (Abs a) where+  metasToVars (Abs   i x) = Abs i   <$> local (fmap succ .) (metasToVars x)+  metasToVars (NoAbs i x) = NoAbs i <$> metasToVars x++instance MetasToVars Term where+  metasToVars = \case+    Var i es   -> Var i    <$> metasToVars es+    Lam i u    -> Lam i    <$> metasToVars u+    Lit l      -> pure (Lit l)+    Def f es   -> Def f    <$> metasToVars es+    Con c i es -> Con c i  <$> metasToVars es+    Pi a b     -> Pi       <$> metasToVars a <*> metasToVars b+    Sort s     -> Sort     <$> metasToVars s+    Level l    -> Level    <$> metasToVars l+    MetaV x es -> asks ($ x) >>= \case+      Just i   -> Var i    <$> metasToVars es+      Nothing  -> MetaV x  <$> metasToVars es+    DontCare u -> DontCare <$> metasToVars u+    Dummy s es -> Dummy s  <$> metasToVars es++instance MetasToVars Type where+  metasToVars (El s t) = El <$> metasToVars s <*> metasToVars t++instance MetasToVars Sort where+  metasToVars = \case+    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+    MetaS x es -> MetaS x  <$> metasToVars es+    DefS f es  -> DefS f   <$> metasToVars es+    DummyS s   -> pure $ DummyS s++instance MetasToVars Level where+  metasToVars (Max n ls) = Max n <$> metasToVars ls++instance MetasToVars PlusLevel where+  metasToVars (Plus n x) = Plus n <$> metasToVars x++instance MetasToVars a => MetasToVars (Tele a) where+  metasToVars EmptyTel = pure EmptyTel+  metasToVars (ExtendTel a tel) = ExtendTel <$> metasToVars a <*> metasToVars tel++instance (MetasToVars a, MetasToVars b) => MetasToVars (a,b) where+  metasToVars (x,y) = (,) <$> metasToVars x <*> metasToVars y++instance (MetasToVars a, MetasToVars b, MetasToVars c) => MetasToVars (a,b,c) where+  metasToVars (x,y,z) = (,,) <$> metasToVars x <*> metasToVars y <*> metasToVars z++instance (MetasToVars a, MetasToVars b, MetasToVars c, MetasToVars d) => MetasToVars (a,b,c,d) where+  metasToVars (x,y,z,w) = (,,,) <$> metasToVars x <*> metasToVars y <*> metasToVars z <*> metasToVars w
src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP                      #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE UndecidableInstances     #-}  {- |  Non-linear matching of the lhs of a rewrite rule against a       neutral term.@@ -24,43 +24,35 @@  import Prelude hiding (null, sequence) -import Control.Arrow (first, second)-import Control.Monad.State--import Debug.Trace-import System.IO.Unsafe--#if __GLASGOW_HASKELL__ <= 708-import Data.Foldable ( foldMap )-#endif+import Control.Applicative  ( Alternative )+import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT )+import Control.Monad.State  ( MonadState, StateT, runStateT )  import Data.Maybe-import Data.Traversable (Traversable,traverse) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import Data.List (elemIndex)-import Data.Monoid  import Agda.Syntax.Common-import qualified Agda.Syntax.Common as C import Agda.Syntax.Internal -import Agda.TypeChecking.EtaContract-import Agda.TypeChecking.Free-import Agda.TypeChecking.Level (levelView', unLevel, reallyUnLevelView, subLevel)-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (primLevelSuc, primLevelMax)+import Agda.TypeChecking.Conversion.Pure (pureEqualTermB)+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Free.Reduce+import Agda.TypeChecking.Irrelevance (isPropM)+import Agda.TypeChecking.Level+import Agda.TypeChecking.Monad hiding (constructorForm) import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records (isRecordConstructor)+import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope (permuteTel)+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Primitive.Cubical.Base  import Agda.Utils.Either-import Agda.Utils.Except+import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -68,113 +60,27 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Singleton import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible --- | Turn a term into a non-linear pattern, treating the---   free variables as pattern variables.---   The first argument indicates the relevance we are working under: if this---   is Irrelevant, then we construct a pattern that never fails to match.---   The second argument is the number of bound variables (from pattern lambdas). -class PatternFrom a b where-  patternFrom :: Relevance -> Int -> a -> TCM b--instance (PatternFrom a b) => PatternFrom [a] [b] where-  patternFrom r k = traverse $ patternFrom r k--instance (PatternFrom a b) => PatternFrom (Arg a) (Arg b) where-  patternFrom r k u = let r' = r `composeRelevance` getRelevance u-                      in  traverse (patternFrom r' k) u--instance (PatternFrom a NLPat) => PatternFrom (Elim' a) (Elim' NLPat) where-  patternFrom r k (Apply u) = let r' = r `composeRelevance` getRelevance u-                              in  Apply <$> traverse (patternFrom r' k) u-  patternFrom r k (Proj o f) = return $ Proj o f--instance (PatternFrom a b) => PatternFrom (Dom a) (Dom b) where-  patternFrom r k = traverse $ patternFrom r k--instance PatternFrom Type NLPType where-  patternFrom r k a = NLPType <$> patternFrom r k (getSort a)-                              <*> patternFrom r k (unEl a)--instance PatternFrom Sort NLPat where-  patternFrom r k s = do-    s <- reduce s-    let done = return PWild-    case s of-      Type l   -> patternFrom Irrelevant k (Level l)-      Prop     -> done-      Inf      -> done-      SizeUniv -> done-      DLub _ _ -> done--instance PatternFrom Term NLPat where-  patternFrom r k v = do-    v <- unLevel =<< reduce v-    let done = if isIrrelevant r then-                 return PWild-               else-                 return $ PTerm v-    case ignoreSharing v of-      Var i es-       | i < k     -> PBoundVar i <$> patternFrom r k es-       | otherwise -> do-         -- The arguments of `var i` should be distinct bound variables-         -- in order to build a Miller pattern-         let mbvs = mfilter fastDistinct $ forM es $ \e -> do-                      e <- isApplyElim e-                      case ignoreSharing $ unArg e of-                        Var j [] | j < k -> Just $ e $> j-                        _                -> Nothing-         case mbvs of-           Just bvs -> do-             let i' = i-k-                 allBoundVars = IntSet.fromList (downFrom k)-                 ok = not (isIrrelevant r) ||-                      IntSet.fromList (map unArg bvs) == allBoundVars-             -- Pattern variables are labeled with their context id, because they-             -- can only be instantiated once they're no longer bound by the-             -- context (see Issue 1652).-             id <- (!! i') <$> getContextId-             if ok then return (PVar (Just id) i' bvs) else done-           Nothing -> done-      Lam i t  -> PLam i <$> patternFrom r k t-      Lit{}    -> done-      Def f es | isIrrelevant r -> done-      Def f es -> do-        Def lsuc [] <- ignoreSharing <$> primLevelSuc-        Def lmax [] <- ignoreSharing <$> primLevelMax-        case es of-          [x]     | f == lsuc -> done-          [x , y] | f == lmax -> done-          _                   -> PDef f <$> patternFrom r k es-      Con c ci vs | isIrrelevant r -> do-        mr <- isRecordConstructor (conName c)-        case mr of-          Just (_, def) | recEtaEquality def ->-            PDef (conName c) <$> patternFrom r k (Apply <$> vs)-          _ -> done-      Con c ci vs -> PDef (conName c) <$> patternFrom r k (Apply <$> vs)-      Pi a b | isIrrelevant r -> done-      Pi a b   -> PPi <$> patternFrom r k a <*> patternFrom r k b-      Sort s   -> done-      Level l  -> __IMPOSSIBLE__-      DontCare{} -> return PWild-      MetaV{}    -> __IMPOSSIBLE__-      Shared{}   -> __IMPOSSIBLE__--instance (PatternFrom a b) => PatternFrom (Abs a) (Abs b) where-  patternFrom r k (Abs name x)   = Abs name   <$> patternFrom r (k+1) x-  patternFrom r k (NoAbs name x) = NoAbs name <$> patternFrom r k x- -- | Monad for non-linear matching.-type NLM = ExceptT Blocked_ (StateT NLMState ReduceM)+newtype NLM a = NLM { unNLM :: ExceptT Blocked_ (StateT NLMState ReduceM) a }+  deriving ( Functor, Applicative, Monad, MonadFail+           , Alternative, MonadPlus+           , MonadError Blocked_, MonadState NLMState+           , HasBuiltins, HasConstInfo, HasOptions, ReadTCState+           , MonadTCEnv, MonadReduce, MonadAddContext, MonadDebug+           , PureTCM+           ) +instance MonadBlock NLM where+  patternViolation b = throwError $ Blocked b ()+  catchPatternErr h f = catchError f $ \case+    Blocked b _      -> h b+    err@NotBlocked{} -> throwError err+ data NLMState = NLMState   { _nlmSub   :: Sub   , _nlmEqs   :: PostponedEquations@@ -182,53 +88,41 @@  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} -liftRed :: ReduceM a -> NLM a-liftRed = lift . lift--instance HasOptions NLM where-  pragmaOptions      = liftRed pragmaOptions-  commandLineOptions = liftRed commandLineOptions--runNLM :: NLM () -> ReduceM (Either Blocked_ NLMState)+runNLM :: (MonadReduce m) => NLM () -> m (Either Blocked_ NLMState) runNLM nlm = do-  (ok,out) <- runStateT (runExceptT nlm) empty+  (ok,out) <- liftReduce $ runStateT (runExceptT $ unNLM nlm) empty   case ok of     Left block -> return $ Left block     Right _    -> return $ Right out -traceSDocNLM :: VerboseKey -> Int -> TCM Doc -> NLM a -> NLM a-traceSDocNLM k n doc = applyWhenVerboseS k n $ \ cont -> do-  ReduceEnv env st <- liftRed askR-  trace (show $ fst $ unsafePerformIO $ runTCM env st doc) cont- matchingBlocked :: Blocked_ -> NLM () matchingBlocked = throwError --- | Add substitution @i |-> v@ to result of matching.-tellSub :: Relevance -> Int -> Term -> NLM ()-tellSub r i v = do+-- | Add substitution @i |-> v : a@ to result of matching.+tellSub :: Relevance -> Int -> Type -> Term -> NLM ()+tellSub r i a v = do   old <- IntMap.lookup i <$> use nlmSub   case old of     Nothing -> nlmSub %= IntMap.insert i (r,v)     Just (r',v')       | isIrrelevant r  -> return ()       | isIrrelevant r' -> nlmSub %= IntMap.insert i (r,v)-      | otherwise       -> whenJustM (liftRed $ equal v v') matchingBlocked+      | otherwise       -> whenJustM (equal a v v') matchingBlocked -tellEq :: Telescope -> Telescope -> Term -> Term -> NLM ()-tellEq gamma k u v =-  traceSDocNLM "rewriting" 60 (sep-               [ text "adding equality between" <+> addContext (gamma `abstract` k) (prettyTCM u)-               , text " and " <+> addContext k (prettyTCM v) ]) $ do-  nlmEqs %= (PostponedEquation k u v:)+tellEq :: Telescope -> Context -> Type -> Term -> Term -> NLM ()+tellEq gamma k a u v = do+  traceSDoc "rewriting.match" 30 (sep+               [ "adding equality between" <+> addContext gamma (addContext k $ prettyTCM u)+               , " and " <+> addContext k (prettyTCM v) ]) $ do+  nlmEqs %= (PostponedEquation k a u v:)  type Sub = IntMap (Relevance, Term) @@ -236,7 +130,8 @@ --   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.   }@@ -248,276 +143,325 @@ 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+        -> 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 a b => Match [a] [b] where-  match r gamma k ps vs-    | length ps == length vs = zipWithM_ (match r gamma k) ps vs-    | otherwise              = matchingBlocked $ NotBlocked ReallyNotBlocked ()- instance Match a b => Match (Arg a) (Arg b) where-  match r gamma k p v = let r' = r `composeRelevance` getRelevance p-                        in  match r' gamma k (unArg p) (unArg v)+  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 a b => Match (Elim' a) (Elim' b) where-  match r gamma k p v =-   case (p, v) of-     (Apply p, Apply v) -> let r' = r `composeRelevance` getRelevance p-                           in  match r' gamma k p v-     (Proj _ x, Proj _ y) -> if x == y then return () else-                             traceSDocNLM "rewriting" 80 (sep-                               [ text "mismatch between projections " <+> prettyTCM x-                               , text " and " <+> prettyTCM y ]) mzero-     (Apply{}, Proj{} ) -> __IMPOSSIBLE__-     (Proj{} , Apply{}) -> __IMPOSSIBLE__+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 (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+      Pi a b -> do+        match r gamma k a p v+        let t'  = absApp b (unArg v)+            hd' = hd . (Apply v:)+        match r gamma k (t',hd') ps vs+      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+      PathType s q l b _u _v -> do+        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:)+        match r gamma k (t',hd') ps vs+      t -> traceSDoc "rewriting.match" 20+        ("interval application at non-pi type (possible non-confluence?) " <+> prettyTCM (pathUnview t)) mzero++    (Proj o f, Proj o' f') | f == f' -> do+      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{} ) -> no+    (Proj{} , Apply{}) -> no++    (IApply{} , _    ) -> __IMPOSSIBLE__ -- TODO+    (_ , IApply{}    ) -> __IMPOSSIBLE__ -- TODO+ instance Match a b => Match (Dom a) (Dom b) where-  match r gamma k p v = match r gamma k (C.unDom p) (C.unDom v)+  match r gamma k t p v = match r gamma k t (unDom p) (unDom v)  instance Match NLPType Type where-  match r gamma k (NLPType lp p) (El s a) = match r gamma k lp s >> match r gamma k p a+  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 NLPat Sort where-  match r gamma k p s = case (p , s) of-    (PWild , _     ) -> return ()-    (p     , Type l) -> match Irrelevant gamma k p l-    _                -> matchingBlocked $ NotBlocked ReallyNotBlocked ()+instance Match NLPSort Sort where+  match r gamma k _ p s = do+    bs <- addContext k $ reduceB s+    let b = void bs+        s = ignoreBlocking bs+        yes = return ()+        no  = matchingBlocked $ NotBlocked ReallyNotBlocked ()+    traceSDoc "rewriting.match" 30 (sep+      [ "matching pattern " <+> addContext gamma (addContext k $ prettyTCM p)+      , "  with sort      " <+> addContext k (prettyTCM s) ]) $ do+    case (p , s) of+      (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 -instance (Match a b, RaiseNLP a, Subst t2 b) => Match (Abs a) (Abs b) where-  match r gamma k (Abs n p) (Abs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) p v-  match r gamma k (Abs n p) (NoAbs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) p (raise 1 v)-  match r gamma k (NoAbs n p) (Abs _ v) = match r gamma (ExtendTel dummyDom (Abs n k)) (raiseNLP 1 p) v-  match r gamma k (NoAbs _ p) (NoAbs _ v) = match r gamma k p v+      -- blocked cases+      (_ , UnivSort{}) -> matchingBlocked b+      (_ , PiSort{}  ) -> matchingBlocked b+      (_ , FunSort{} ) -> matchingBlocked b+      (_ , MetaS m _ ) -> matchingBlocked $ blocked_ m +      -- all other cases do not match+      (_ , _) -> no+ instance Match NLPat Level where-  match r gamma k p l = match r gamma k p =<< liftRed (reallyUnLevelView l)+  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 NLPat Term where-  match r gamma k p v = do-    vb <- liftRed $ reduceB' v+  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 vb-        v = ignoreBlocking vb-        prettyPat  = addContext (gamma `abstract` k) (prettyTCM (raisePatVars n p))-        prettyTerm = addContext k (prettyTCM v)-    traceSDocNLM "rewriting" 100 (sep-      [ text "matching" <+> prettyPat-      , text "with" <+> prettyTerm]) $ do+        b = void vbt+        (v,t) = ignoreBlocking vbt+        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+    traceSDoc "rewriting.match" 30 (sep+      [ "matching pattern " <+> prettyPat+      , "  with term      " <+> prettyTerm+      , "  of type        " <+> prettyType ]) $ do+    traceSDoc "rewriting.match" 80 (vcat+      [ "  raw pattern:  " <+> text (show p)+      , "  raw term:     " <+> text (show v)+      , "  raw type:     " <+> text (show t) ]) $ do+    traceSDoc "rewriting.match" 70 (vcat+      [ "pattern vars:   " <+> prettyTCM gamma+      , "bound vars:     " <+> prettyTCM k ]) $ do     let yes = return ()-        no msg =-          traceSDocNLM "rewriting" 80 (sep-            [ text "mismatch between" <+> prettyPat-            , text " and " <+> prettyTerm-            , msg ]) $ matchingBlocked b-        block b' =-          traceSDocNLM "rewriting" 80 (sep-            [ text "matching blocked on meta"-            , text (show b) ]) $ matchingBlocked (b `mappend` b')+        no msg = if isIrrelevant r then yes else do+          traceSDoc "rewriting.match" 10 (sep+            [ "mismatch between" <+> prettyPat+            , " and " <+> prettyTerm+            , " of type " <+> prettyType+            , msg ]) $ do+          traceSDoc "rewriting.match" 30 (sep+            [ "blocking tag from reduction: " <+> text (show b) ]) $ do+          matchingBlocked b+        block b' = if isIrrelevant r then yes else do+          traceSDoc "rewriting.match" 10 (sep+            [ "matching blocked on meta"+            , text (show b') ]) $ do+          traceSDoc "rewriting.match" 30 (sep+            [ "blocking tag from reduction: " <+> text (show b') ]) $ do+          matchingBlocked (b `mappend` b')+        maybeBlock = \case+          MetaV m es -> matchingBlocked $ blocked_ m+          _          -> no ""     case p of-      PWild  -> yes-      PVar id i bvs -> do-        -- If the variable is still bound by the current context, we cannot-        -- instantiate it so it has to match on the nose (see Issue 1652).-        ctx <- zip <$> getContextNames <*> getContextId-        traceSDocNLM "rewriting" 90 (text "Current context:" <+> (prettyTCM ctx)) $ do-        cid <- getContextId-        case (maybe Nothing (\i -> elemIndex i cid) id) of-          Just j -> if v == var (j+n)-                    then tellSub r i (var j)-                    else no (text $ "(CtxId = " ++ show id ++ ")")-          Nothing -> do-            let allowedVars :: IntSet-                allowedVars = IntSet.fromList (map unArg bvs)-                isBadVar :: Int -> Bool-                isBadVar i = i < n && not (i `IntSet.member` allowedVars)-                perm :: Permutation-                perm = Perm n $ reverse $ map unArg $ bvs-                tel :: Telescope-                tel = permuteTel perm k-            ok <- liftRed $ reallyFree isBadVar v-            case ok of-              Left b         -> block b-              Right Nothing  -> no (text "")-              Right (Just v) -> tellSub r i $ teleLam tel $ renameP __IMPOSSIBLE__ perm v-      PDef f ps -> do-        v <- liftRed $ constructorForm =<< unLevel v-        case ignoreSharing v 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 vars+            badVars :: IntSet+            badVars = IntSet.difference (IntSet.fromList (downFrom n)) allowedVars+            perm :: Permutation+            perm = Perm n $ reverse vars+            tel :: Telescope+            tel = permuteContext perm k+        ok <- addContext k $ reallyFree badVars v+        case ok of+          Left b         -> block b+          Right Nothing  -> no ""+          Right (Just v) ->+            let t' = telePi  tel $ renameP impossible perm t+                v' = teleLam tel $ renameP impossible perm v+            in tellSub r (i-n) t' v'++      PDef f ps -> traceSDoc "rewriting.match" 60 ("matching a PDef: " <+> prettyTCM f) $ do+        v <- addContext k $ constructorForm =<< unLevel v+        case v of           Def f' es-            | f == f'   -> match r gamma k ps es-          Con c _ vs-            | f == conName c -> match r gamma k ps (Apply <$> vs)-            | otherwise -> do -- @c@ may be a record constructor-                mr <- liftRed $ isRecordConstructor (conName c)-                case mr of-                  Just (_, def) | recEtaEquality def -> do-                    let fs = recFields def-                        qs = map (fmap $ \f -> PDef f (ps ++ [Proj ProjSystem f])) fs-                    match r gamma k qs vs-                  _ -> no (text "")-          Lam i u -> do-            let pbody = PDef f (raiseNLP 1 ps ++ [Apply $ Arg i $ PTerm (var 0)])-                body  = absBody u-            match r gamma (ExtendTel dummyDom (Abs (absName u) k)) pbody body-          MetaV m es -> do-            matchingBlocked $ Blocked m ()-          v' -> do -- @f@ may be a record constructor as well-            mr <- liftRed $ isRecordConstructor f-            case mr of-              Just (_, def) | recEtaEquality def -> do-                let fs  = recFields def-                    ws  = map (fmap $ \f -> v `applyE` [Proj ProjSystem f]) fs-                    qs = fromMaybe __IMPOSSIBLE__ $ allApplyElims ps-                match r gamma k qs ws-              _ -> no (text "")-      PLam i p' -> do-        let body = Abs (absName p') $ raise 1 v `apply` [Arg i (var 0)]-        match r gamma k p' body-      PPi pa pb  -> case ignoreSharing v of-        Pi a b -> match r gamma k pa a >> match r gamma k pb b-        MetaV m es -> matchingBlocked $ Blocked m ()-        _ -> no (text "")-      PBoundVar i ps -> case ignoreSharing v of-        Var i' es | i == i' -> match r gamma k ps es-        Con c _ vs -> do -- @c@ may be a record constructor-          mr <- liftRed $ isRecordConstructor (conName c)-          case mr of-            Just (_, def) | recEtaEquality def -> do-              let fs = recFields def-                  qs = map (fmap $ \f -> PBoundVar i (ps ++ [Proj ProjSystem f])) fs-              match r gamma k qs vs-            _ -> no (text "")-        Lam info u -> do-          let pbody = PBoundVar i (raiseNLP 1 ps ++ [Apply $ Arg info $ PTerm (var 0)])-              body  = absBody u-          match r gamma (ExtendTel dummyDom (Abs (absName u) k)) pbody body-        MetaV m es -> matchingBlocked $ Blocked m ()-        _ -> no (text "")-      PTerm u -> tellEq gamma k u v+            | f == f'   -> do+                ft <- addContext k $ defType <$> getConstInfo f+                match r gamma k (ft , Def f) ps es+          Con c ci vs+            | f == conName c -> do+                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' <- 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)@.+            RecordDefn def <- addContext k $ theDef <$> getConstInfo d+            (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v+            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' <- 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+          k' <- extendContext k (absName b) a+          match r gamma k' () (absBody pb) (absBody b)+        v -> maybeBlock v+      PSort ps -> case v of+        Sort s -> match r gamma k () ps s+        v -> maybeBlock v+      PBoundVar i ps -> case v of+        Var i' es | i == i' -> do+          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 ]+              body  = raise 1 v `apply` [ Arg ai $ var 0 ]+          k' <- extendContext k (absName b) a+          match r gamma k' (absBody b) pbody body+        _ | Just (d, pars) <- etaRecord -> do+          RecordDefn def <- addContext k $ theDef <$> getConstInfo d+          (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v+          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 (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 normalizing 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 normalized version of the given--- term) or `Left b` if the problem is blocked on a meta.-reallyFree :: (Reduce a, Normalise a, Free' a FreeVars)-           => (Int -> Bool) -> a -> ReduceM (Either Blocked_ (Maybe a))-reallyFree f v = do-    let xs = getVars v-    if null (stronglyRigidVars xs) && null (unguardedVars xs)-    then do-      if null (weaklyRigidVars xs) && null (flexibleVars xs)-         && null (irrelevantVars xs)-      then return $ Right $ Just v-      else do-        bv <- normaliseB' v-        let b  = void bv-            v  = ignoreBlocking bv-            xs = getVars v-            b' = foldMap (foldMap $ \m -> Blocked m ()) $ flexibleVars xs-        if null (stronglyRigidVars xs) && null (unguardedVars xs)-           && null (weaklyRigidVars xs) && null (irrelevantVars xs)-        then if null (flexibleVars xs)-             then return $ Right $ Just v-             else return $ Left $ b `mappend` b'-        else return $ Right Nothing-    else return $ Right Nothing-  where-    getVars v = runFree (\var@(i,_) -> if f i then singleton var else empty) IgnoreNot v+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 =-  prependS __IMPOSSIBLE__ (map val [0 .. size gamma-1]) EmptyS+  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 -checkPostponedEquations :: Substitution -> PostponedEquations -> ReduceM (Maybe Blocked_)+{-# SPECIALIZE checkPostponedEquations :: Substitution -> PostponedEquations -> TCM (Maybe Blocked_) #-}+checkPostponedEquations :: PureTCM m+                        => Substitution -> PostponedEquations -> m (Maybe Blocked_) checkPostponedEquations sub eqs = forM' eqs $-  \ (PostponedEquation k lhs rhs) -> equal (applySubst (liftS (size k) sub) lhs) rhs+  \ (PostponedEquation k a lhs rhs) -> do+      let lhs' = applySubst (liftS (size k) sub) lhs+      traceSDoc "rewriting.match" 30 (sep+        [ "checking postponed equality between" , addContext k (prettyTCM lhs')+        , " and " , addContext k (prettyTCM rhs) ]) $ do+      addContext k $ equal a lhs' rhs  -- main function-nonLinMatch :: (Match a b) => Telescope -> a -> b -> ReduceM (Either Blocked_ Substitution)-nonLinMatch gamma p v = do-  let no msg b = traceSDoc "rewriting" 80 (sep-                   [ text "matching failed during" <+> text msg-                   , text "blocking: " <+> text (show b) ]) $ return (Left b)-  caseEitherM (runNLM $ match Relevant gamma EmptyTel p v) (no "matching") $ \ s -> do-    let sub = makeSubstitution gamma $ s^.nlmSub-        eqs = s^.nlmEqs-    traceSDoc "rewriting" 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+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 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 --- | Untyped βη-equality, does not handle things like empty record types.+-- | 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)---- TODO: implement a type-directed, lazy version of this function.-equal :: Term -> Term -> ReduceM (Maybe Blocked_)-equal u v = do-  (u, v) <- etaContract =<< normalise' (u, v)-  let ok    = u == v-      metas = allMetas (u, v)-      block = caseMaybe (headMaybe metas)-                (NotBlocked ReallyNotBlocked ())-                (\m -> Blocked m ())-  if ok then return Nothing else-    traceSDoc "rewriting" 80 (sep-      [ text "mismatch between " <+> prettyTCM u-      , text " and " <+> prettyTCM v-      ]) $ return $ Just block---- | Normalise the given term but also preserve blocking tags---   TODO: implement a more efficient version of this.-normaliseB' :: (Reduce t, Normalise t) => t -> ReduceM (Blocked t)-normaliseB' = normalise' >=> reduceB'---- | Raise (bound) variables in a NLPat--class RaiseNLP a where-  raiseNLPFrom :: Int -> Int -> a -> a--  raiseNLP :: Int -> a -> a-  raiseNLP = raiseNLPFrom 0--instance RaiseNLP a => RaiseNLP [a] where-  raiseNLPFrom c k = fmap $ raiseNLPFrom c k--instance RaiseNLP a => RaiseNLP (Maybe a) where-  raiseNLPFrom c k = fmap $ raiseNLPFrom c k--instance RaiseNLP a => RaiseNLP (Arg a) where-  raiseNLPFrom c k = fmap $ raiseNLPFrom c k--instance RaiseNLP a => RaiseNLP (Elim' a) where-  raiseNLPFrom c k = fmap $ raiseNLPFrom c k--instance RaiseNLP a => RaiseNLP (Dom a) where-  raiseNLPFrom c k = fmap $ raiseNLPFrom c k--instance RaiseNLP NLPType where-  raiseNLPFrom c k (NLPType l a) =-    NLPType (raiseNLPFrom c k l) (raiseNLPFrom c k a)--instance RaiseNLP a => RaiseNLP (Abs a) where-  raiseNLPFrom c k (Abs i p)   = Abs i   $ raiseNLPFrom (c+1) k p-  raiseNLPFrom c k (NoAbs i p) = NoAbs i $ raiseNLPFrom c     k p+equal :: PureTCM m => Type -> Term -> Term -> m (Maybe Blocked_)+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+      [ "mismatch between " <+> prettyTCM u+      , " and " <+> prettyTCM v+      ]) $ do+    return $ Just $ NotBlocked ReallyNotBlocked () -instance RaiseNLP NLPat where-  raiseNLPFrom c k p = case p of-    PVar id i bvs -> let raise j = if j < c then j else j + k-                     in PVar id i $ map (fmap raise) bvs-    PWild  -> p-    PDef f ps -> PDef f $ raiseNLPFrom c k ps-    PLam i q -> PLam i $ raiseNLPFrom c k q-    PPi a b -> PPi (raiseNLPFrom c k a) (raiseNLPFrom c k b)-    PBoundVar i ps -> let j = if i < c then i else i + k-                      in PBoundVar j $ raiseNLPFrom c k ps-    PTerm u -> PTerm $ raiseFrom c k u+-- | Utility function for getting the name and type of a head term (i.e. a+--   `Def` or `Con` with no arguments)+getTypedHead :: PureTCM m => Term -> m (Maybe (QName, Type))+getTypedHead = \case+  Def f []   -> Just . (f,) . defType <$> getConstInfo f+  Con (ConHead { conName = c }) _ [] -> do+    -- Andreas, 2018-09-08, issue #3211:+    -- discount module parameters for constructor heads+    vs <- freeVarsToApply c+    -- Jesper, 2020-06-17, issue #4755: add dummy arguments in+    -- case we don't have enough parameters+    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
@@ -0,0 +1,414 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++{- | Various utility functions dealing with the non-linear, higher-order+     patterns used for rewrite rules.+-}++module Agda.TypeChecking.Rewriting.NonLinPattern where++import Prelude hiding ( null )++import Control.Monad.Reader ( asks )++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++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 (isPropM)+import Agda.TypeChecking.Level+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Primitive.Cubical.Base++import Agda.Utils.Functor+import Agda.Utils.Impossible+import Agda.Utils.List+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Singleton+import Agda.Utils.Size++-- | Turn a term into a non-linear pattern, treating the+--   free variables as pattern variables.+--   The first argument indicates the relevance we are working under: if this+--   is Irrelevant, then we construct a pattern that never fails to match.+--   The second argument is the number of bound variables (from pattern lambdas).+--   The third argument is the type of the term.++class PatternFrom a b where+  patternFrom :: Relevance -> Int -> TypeOf a -> a -> TCM b++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 Elims [Elim' NLPat] where+  patternFrom r k (t,hd) = \case+    [] -> return []+    (Apply u : es) -> do+      (a, b) <- assertPi t+      p   <- patternFrom r k a 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+      (s, q, l, b, u, v) <- assertPath t+      let t' = El s $ unArg b `apply` [ defaultArg 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+      (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 a b) => PatternFrom (Dom a) (Dom b) where+  patternFrom r k t = traverse $ patternFrom r k t++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+  patternFrom r k _ s = do+    s <- abortIfBlocked s+    case s of+      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__+      MetaS{}  -> __IMPOSSIBLE__+      DefS{}   -> __IMPOSSIBLE__+      DummyS s -> do+        reportS "impossible" 10+          [ "patternFrom: hit dummy sort with content:"+          , s+          ]+        __IMPOSSIBLE__++instance PatternFrom Level NLPat where+  patternFrom r k _ l = do+    t <- levelType+    v <- reallyUnLevelView l+    patternFrom r k t v++instance PatternFrom Term NLPat where+  patternFrom r0 k t v = do+    t <- abortIfBlocked t+    etaRecord <- isEtaRecordType t+    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+      ]+    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)+        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+       -- The arguments of `var i` should be distinct bound variables+       -- in order to build a Miller pattern+       | Just vs <- allApplyElims es -> do+           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+           case sequence mbvs of+             Just bvs | fastDistinct bvs -> do+               let allBoundVars = IntSet.fromList (downFrom k)+                   ok = not (isIrrelevant r) ||+                        IntSet.fromList (map unArg bvs) == allBoundVars+               if ok then return (PVar i bvs) else done+             _ -> done+       | otherwise -> done+      (_ , _ ) | Just (d, pars) <- etaRecord -> do+        RecordDefn def <- theDef <$> getConstInfo d+        (tel, c, ci, vs) <- etaExpandRecord_ d pars def v+        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+        Def lsuc [] <- primLevelSuc+        Def lmax [] <- primLevelMax+        case es of+          [x]     | f == lsuc -> done+          [x , y] | f == lmax -> done+          _                   -> do+            ft <- defType <$> getConstInfo f+            PDef f <$> patternFrom r k (ft , Def f) es+      (_ , Con c ci vs) | isIrrelevant r -> done+      (_ , 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)+        return $ PPi pa (Abs (absName b) pb)+      (_ , Sort s)     -> PSort <$> patternFrom r k () s+      (_ , Level l)    -> __IMPOSSIBLE__+      (_ , DontCare{}) -> __IMPOSSIBLE__+      (_ , MetaV m _)  -> __IMPOSSIBLE__+      (_ , Dummy s _)  -> __IMPOSSIBLE_VERBOSE__ s++-- | Convert from a non-linear pattern to a term.++class NLPatToTerm p a where+  nlPatToTerm :: PureTCM m => p -> m a++  default nlPatToTerm ::+    ( NLPatToTerm p' a', Traversable f, p ~ f p', a ~ f a'+    , PureTCM m+    ) => p -> m a+  nlPatToTerm = traverse nlPatToTerm++instance NLPatToTerm p a => NLPatToTerm [p] [a] where+instance NLPatToTerm p a => NLPatToTerm (Arg p) (Arg a) where+instance NLPatToTerm p a => NLPatToTerm (Dom p) (Dom a) where+instance NLPatToTerm p a => NLPatToTerm (Elim' p) (Elim' a) where+instance NLPatToTerm p a => NLPatToTerm (Abs p) (Abs a) where++instance NLPatToTerm Nat Term where+  nlPatToTerm = return . var++instance NLPatToTerm NLPat Term where+  nlPatToTerm = \case+    PVar i xs      -> Var i . map Apply <$> nlPatToTerm xs+    PTerm u        -> return u+    PDef f es      -> (theDef <$> getConstInfo f) >>= \case+      Constructor{ conSrcCon = c } -> Con c ConOSystem <$> nlPatToTerm es+      _                            -> Def f <$> nlPatToTerm es+    PLam i u       -> Lam i <$> nlPatToTerm u+    PPi a b        -> Pi    <$> nlPatToTerm a <*> nlPatToTerm b+    PSort s        -> Sort  <$> nlPatToTerm s+    PBoundVar i es -> Var i <$> nlPatToTerm es++instance NLPatToTerm NLPat Level where+  nlPatToTerm = nlPatToTerm >=> levelView++instance NLPatToTerm NLPType Type where+  nlPatToTerm (NLPType s a) = El <$> nlPatToTerm s <*> nlPatToTerm a++instance NLPatToTerm NLPSort Sort where+  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+  nlPatVarsUnder :: Int -> a -> IntSet++  nlPatVars :: a -> IntSet+  nlPatVars = nlPatVarsUnder 0++instance {-# OVERLAPPABLE #-} (Foldable f, NLPatVars a) => NLPatVars (f a) where+  nlPatVarsUnder k = foldMap $ nlPatVarsUnder k++instance NLPatVars NLPType where+  nlPatVarsUnder k (NLPType l a) = nlPatVarsUnder k (l, a)++instance NLPatVars NLPSort where+  nlPatVarsUnder k = \case+    PUniv _ l   -> nlPatVarsUnder k l+    PInf f n  -> empty+    PSizeUniv -> empty+    PLockUniv -> empty+    PLevelUniv -> empty+    PIntervalUniv -> empty++instance NLPatVars NLPat where+  nlPatVarsUnder k = \case+      PVar i _  -> singleton $ i - k+      PDef _ es -> nlPatVarsUnder k es+      PLam _ p  -> nlPatVarsUnder k p+      PPi a b   -> nlPatVarsUnder k (a, b)+      PSort s   -> nlPatVarsUnder k s+      PBoundVar _ es -> nlPatVarsUnder k es+      PTerm{}   -> empty++instance (NLPatVars a, NLPatVars b) => NLPatVars (a,b) where+  nlPatVarsUnder k (a,b) = nlPatVarsUnder k a `mappend` nlPatVarsUnder k b++instance NLPatVars a => NLPatVars (Abs a) where+  nlPatVarsUnder k = \case+    Abs   _ v -> nlPatVarsUnder (k + 1) v+    NoAbs _ v -> nlPatVarsUnder k v++-- | Get all symbols that a non-linear pattern matches against+class GetMatchables a where+  getMatchables :: a -> [QName]++  default getMatchables :: (Foldable f, GetMatchables a', a ~ f a') => a -> [QName]+  getMatchables = foldMap getMatchables++instance GetMatchables a => GetMatchables [a] where+instance GetMatchables a => GetMatchables (Arg a) where+instance GetMatchables a => GetMatchables (Dom a) where+instance GetMatchables a => GetMatchables (Elim' a) where+instance GetMatchables a => GetMatchables (Abs a) where++instance (GetMatchables a, GetMatchables b) => GetMatchables (a,b) where+  getMatchables (x,y) = getMatchables x ++ getMatchables y++instance GetMatchables NLPat where+  getMatchables p =+    case p of+      PVar _ _       -> empty+      PDef f es      -> singleton f ++ getMatchables es+      PLam _ x       -> getMatchables x+      PPi a b        -> getMatchables (a,b)+      PSort s        -> getMatchables s+      PBoundVar i es -> getMatchables es+      PTerm u        -> getMatchables u++instance GetMatchables NLPType where+  getMatchables = getMatchables . nlpTypeUnEl++instance GetMatchables NLPSort where+  getMatchables = \case+    PUniv _ l -> getMatchables l+    PInf f n  -> empty+    PSizeUniv -> empty+    PLockUniv -> empty+    PLevelUniv -> empty+    PIntervalUniv -> empty++instance GetMatchables Term where+  getMatchables = getDefs' __IMPOSSIBLE__ singleton++instance GetMatchables RewriteRule where+  getMatchables = getMatchables . rewPats++-- | Only computes free variables that are not bound (see 'nlPatVars'),+--   i.e., those in a 'PTerm'.++instance Free NLPat where+  freeVars' = \case+    PVar _ _       -> mempty+    PDef _ es      -> freeVars' es+    PLam _ u       -> freeVars' u+    PPi a b        -> freeVars' (a,b)+    PSort s        -> freeVars' s+    PBoundVar _ es -> freeVars' es+    PTerm t        -> freeVars' t++instance Free NLPType where+  freeVars' (NLPType s a) =+    ifM (asks ((IgnoreNot ==) . feIgnoreSorts))+      {- then -} (freeVars' (s, a))+      {- else -} (freeVars' a)++instance Free NLPSort where+  freeVars' = \case+    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
@@ -0,0 +1,1894 @@+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Application+  ( checkArguments+  , checkArguments_+  , checkApplication+  , inferApplication+  , checkProjAppToKnownPrincipalArg+  , 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
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Rules.Application where++import Data.List.NonEmpty (NonEmpty)++import Agda.Syntax.Common (NamedArg, ProjOrigin)+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad.Base++checkArguments ::+     Comparison+  -> ExpandHidden+  -> A.Expr+  -> [NamedArg A.Expr]+  -> Type+  -> Type+  -> (ArgsCheckState CheckedTarget -> TCM Term)+  -> TCM Term++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.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,608 +1,1047 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.TypeChecking.Rules.Builtin-  ( bindBuiltin-  , bindBuiltinNoDef-  , bindPostulatedName-  , isUntypedBuiltin-  , bindUntypedBuiltin-  ) where--import Control.Applicative hiding (empty)-import Control.Monad-import Control.Monad.Reader (ask)-import Control.Monad.State (get)-import Data.List (find)--import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Abstract.Views as A-import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Position--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.SizedTypes ( builtinSizeHook )--import qualified Agda.TypeChecking.CompiledClause as CC-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.EtaContract-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Rules.Term ( checkExpr , inferExpr )--import {-# SOURCE #-} Agda.TypeChecking.Rules.Builtin.Coinduction-import {-# SOURCE #-} Agda.TypeChecking.Rewriting--import Agda.Utils.Except ( MonadError(catchError) )-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Checking builtin pragmas------------------------------------------------------------------------------builtinPostulate :: TCM Type -> BuiltinDescriptor-builtinPostulate = BuiltinPostulate Relevant--coreBuiltins :: [BuiltinInfo]-coreBuiltins = map (\ (x, z) -> BuiltinInfo x z)-  [ (builtinList               |-> BuiltinData (tset --> tset) [builtinNil, builtinCons])-  , (builtinArg                |-> BuiltinData (tset --> tset) [builtinArgArg])-  , (builtinAbs                |-> BuiltinData (tset --> tset) [builtinAbsAbs])-  , (builtinArgInfo            |-> BuiltinData tset [builtinArgArgInfo])-  , (builtinBool               |-> BuiltinData tset [builtinTrue, builtinFalse])-  , (builtinNat                |-> BuiltinData tset [builtinZero, builtinSuc])-  , (builtinUnit               |-> BuiltinData tset [builtinUnitUnit])  -- actually record, but they are treated the same-  , (builtinAgdaLiteral        |-> BuiltinData tset [builtinAgdaLitNat, builtinAgdaLitFloat,-                                                     builtinAgdaLitChar, builtinAgdaLitString,-                                                     builtinAgdaLitQName, builtinAgdaLitMeta])-  , (builtinAgdaPattern        |-> BuiltinData tset [builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot,-                                                     builtinAgdaPatLit, builtinAgdaPatProj, builtinAgdaPatAbsurd])-  , (builtinAgdaPatVar         |-> BuiltinDataCons (tstring --> tpat))-  , (builtinAgdaPatCon         |-> BuiltinDataCons (tqname --> tlist (targ tpat) --> tpat))-  , (builtinAgdaPatDot         |-> BuiltinDataCons tpat)-  , (builtinAgdaPatLit         |-> BuiltinDataCons (tliteral --> tpat))-  , (builtinAgdaPatProj        |-> BuiltinDataCons (tqname --> tpat))-  , (builtinAgdaPatAbsurd      |-> BuiltinDataCons tpat)-  , (builtinLevel              |-> builtinPostulate tset)-  , (builtinInteger            |-> BuiltinData tset [builtinIntegerPos, builtinIntegerNegSuc])-  , (builtinIntegerPos         |-> BuiltinDataCons (tnat --> tinteger))-  , (builtinIntegerNegSuc      |-> BuiltinDataCons (tnat --> tinteger))-  , (builtinFloat              |-> builtinPostulate tset)-  , (builtinChar               |-> builtinPostulate tset)-  , (builtinString             |-> builtinPostulate tset)-  , (builtinQName              |-> builtinPostulate tset)-  , (builtinAgdaMeta           |-> builtinPostulate tset)-  , (builtinIO                 |-> builtinPostulate (tset --> tset))-  , (builtinAgdaSort           |-> BuiltinData tset [builtinAgdaSortSet, builtinAgdaSortLit, builtinAgdaSortUnsupported])-  , (builtinAgdaTerm           |-> BuiltinData tset-                                     [ builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam-                                     , builtinAgdaTermDef, builtinAgdaTermCon-                                     , builtinAgdaTermPi, builtinAgdaTermSort-                                     , builtinAgdaTermLit, builtinAgdaTermMeta-                                     , builtinAgdaTermUnsupported])-  , builtinAgdaErrorPart       |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName ]-  , builtinAgdaErrorPartString |-> BuiltinDataCons (tstring --> terrorpart)-  , builtinAgdaErrorPartTerm   |-> BuiltinDataCons (tterm --> terrorpart)-  , builtinAgdaErrorPartName   |-> BuiltinDataCons (tqname --> terrorpart)-  , (builtinEquality           |-> BuiltinData (hPi "a" (el primLevel) $-                                                hPi "A" (return $ sort $ varSort 0) $-                                                (El (varSort 1) <$> varM 0) -->-                                                (El (varSort 1) <$> varM 0) -->-                                                return (sort $ varSort 1))-                                               [builtinRefl])-  , (builtinHiding             |-> BuiltinData tset [builtinHidden, builtinInstance, builtinVisible])-    -- Relevance-  , (builtinRelevance          |-> BuiltinData tset [builtinRelevant, builtinIrrelevant])-  , (builtinRelevant           |-> BuiltinDataCons trelevance)-  , (builtinIrrelevant         |-> BuiltinDataCons trelevance)-    -- Associativity-  , builtinAssoc               |-> BuiltinData tset [builtinAssocLeft, builtinAssocRight, builtinAssocNon]-  , builtinAssocLeft           |-> BuiltinDataCons tassoc-  , builtinAssocRight          |-> BuiltinDataCons tassoc-  , builtinAssocNon            |-> BuiltinDataCons tassoc-    -- Precedence-  , builtinPrecedence          |-> BuiltinData tset [builtinPrecRelated, builtinPrecUnrelated]-  , builtinPrecRelated         |-> BuiltinDataCons (tint --> tprec)-  , builtinPrecUnrelated       |-> BuiltinDataCons tprec-    -- Fixity-  , builtinFixity              |-> BuiltinData tset [builtinFixityFixity]-  , builtinFixityFixity        |-> BuiltinDataCons (tassoc --> tprec --> tfixity)-  , (builtinRefl               |-> BuiltinDataCons (hPi "a" (el primLevel) $-                                                    hPi "A" (return $ sort $ varSort 0) $-                                                    hPi "x" (El (varSort 1) <$> varM 0) $-                                                    El (varSort 2) <$> primEquality <#> varM 2 <#> varM 1 <@> varM 0 <@> varM 0))-  , (builtinRewrite           |-> BuiltinUnknown Nothing verifyBuiltinRewrite)-  , (builtinNil                |-> BuiltinDataCons (hPi "A" tset (el (list v0))))-  , (builtinCons               |-> BuiltinDataCons (hPi "A" tset (tv0 --> el (list v0) --> el (list v0))))-  , (builtinZero               |-> BuiltinDataCons tnat)-  , (builtinSuc                |-> BuiltinDataCons (tnat --> tnat))-  , (builtinTrue               |-> BuiltinDataCons tbool)-  , (builtinFalse              |-> BuiltinDataCons tbool)-  , (builtinArgArg             |-> BuiltinDataCons (hPi "A" tset (targinfo --> tv0 --> targ tv0)))-  , (builtinAbsAbs             |-> BuiltinDataCons (hPi "A" tset (tstring  --> tv0 --> tabs tv0)))-  , (builtinArgArgInfo         |-> BuiltinDataCons (thiding --> trelevance --> targinfo))-  , (builtinAgdaTermVar        |-> BuiltinDataCons (tnat --> targs --> tterm))-  , (builtinAgdaTermLam        |-> BuiltinDataCons (thiding --> tabs tterm --> tterm))-  , (builtinAgdaTermExtLam     |-> BuiltinDataCons (tlist tclause --> targs --> tterm))-  , (builtinAgdaTermDef        |-> BuiltinDataCons (tqname --> targs --> tterm))-  , (builtinAgdaTermCon        |-> BuiltinDataCons (tqname --> targs --> tterm))-  , (builtinAgdaTermPi         |-> BuiltinDataCons (targ ttype --> tabs ttype --> tterm))-  , (builtinAgdaTermSort       |-> BuiltinDataCons (tsort --> tterm))-  , (builtinAgdaTermLit        |-> BuiltinDataCons (tliteral --> tterm))-  , (builtinAgdaTermMeta         |-> BuiltinDataCons (tmeta --> targs --> tterm))-  , (builtinAgdaTermUnsupported|-> BuiltinDataCons tterm)-  , (builtinAgdaLitNat    |-> BuiltinDataCons (tnat --> tliteral))-  , (builtinAgdaLitFloat  |-> BuiltinDataCons (tfloat --> tliteral))-  , (builtinAgdaLitChar   |-> BuiltinDataCons (tchar --> tliteral))-  , (builtinAgdaLitString |-> BuiltinDataCons (tstring --> tliteral))-  , (builtinAgdaLitQName  |-> BuiltinDataCons (tqname --> tliteral))-  , (builtinAgdaLitMeta   |-> BuiltinDataCons (tmeta --> tliteral))-  , (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ω-  , (builtinSize               |-> builtinPostulate tSizeUniv)-  , (builtinSizeLt             |-> builtinPostulate (tsize ..--> tSizeUniv))-  , (builtinSizeSuc            |-> builtinPostulate (tsize --> tsize))-  , (builtinSizeInf            |-> builtinPostulate tsize)-  -- postulate max : {i : Size} -> Size< i -> Size< i -> Size< i-  , (builtinSizeMax            |-> builtinPostulate (tsize --> tsize --> tsize))-     -- (hPi "i" tsize $ let a = el $ primSizeLt <@> v0 in (a --> a --> a)))-  , (builtinAgdaSortSet        |-> BuiltinDataCons (tterm --> tsort))-  , (builtinAgdaSortLit        |-> 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)-  , (builtinAgdaClause         |-> BuiltinData tset [builtinAgdaClauseClause, builtinAgdaClauseAbsurd])-  , (builtinAgdaClauseClause   |-> BuiltinDataCons (tlist (targ tpat) --> tterm --> tclause))-  , (builtinAgdaClauseAbsurd   |-> BuiltinDataCons (tlist (targ tpat) --> tclause))-  , (builtinAgdaDefinition            |-> BuiltinData tset [builtinAgdaDefinitionFunDef-                                                           ,builtinAgdaDefinitionDataDef-                                                           ,builtinAgdaDefinitionDataConstructor-                                                           ,builtinAgdaDefinitionRecordDef-                                                           ,builtinAgdaDefinitionPostulate-                                                           ,builtinAgdaDefinitionPrimitive])-  , (builtinAgdaDefinitionFunDef          |-> BuiltinDataCons (tlist tclause --> tdefn))-  , (builtinAgdaDefinitionDataDef         |-> BuiltinDataCons (tnat --> tlist tqname --> tdefn))-  , (builtinAgdaDefinitionDataConstructor |-> BuiltinDataCons (tqname --> tdefn))-  , (builtinAgdaDefinitionRecordDef       |-> BuiltinDataCons (tqname --> tdefn))-  , (builtinAgdaDefinitionPostulate       |-> BuiltinDataCons tdefn)-  , (builtinAgdaDefinitionPrimitive       |-> BuiltinDataCons tdefn)-  , builtinAgdaTCM       |-> builtinPostulate (hPi "a" tlevel $ tsetL 0 --> tsetL 0)-  , builtinAgdaTCMReturn |-> builtinPostulate (hPi "a" tlevel  $-                                               hPi "A" (tsetL 0) $-                                               elV 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMBind   |-> builtinPostulate (hPi "a" tlevel  $ hPi "b" tlevel $-                                               hPi "A" (tsetL 1) $ hPi "B" (tsetL 1) $-                                               tTCM 3 (varM 1) --> (elV 3 (varM 1) --> tTCM 2 (varM 0)) --> tTCM 2 (varM 0))-  , builtinAgdaTCMUnify      |-> builtinPostulate (tterm --> tterm --> tTCM_ primUnit)-  , builtinAgdaTCMTypeError  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist terrorpart --> tTCM 1 (varM 0))-  , builtinAgdaTCMInferType  |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)-  , builtinAgdaTCMCheckType  |-> builtinPostulate (tterm --> ttype --> tTCM_ primAgdaTerm)-  , builtinAgdaTCMNormalise  |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)-  , 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)))-  , builtinAgdaTCMExtendContext |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ 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))-  , builtinAgdaTCMFreshName     |-> builtinPostulate (tstring --> tTCM_ primQName)-  , builtinAgdaTCMDeclareDef    |-> builtinPostulate (targ tqname --> 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))-  , builtinAgdaTCMBlockOnMeta        |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tmeta --> 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))-  ]-  where-        (|->) = (,)--        v0 = varM 0-        v1 = varM 1-        v2 = varM 2-        v3 = varM 3--        tv0,tv1 :: TCM Type-        tv0 = el v0-        tv1 = el v1-        tv2 = el v2-        tv3 = el v3--        arg :: TCM Term -> TCM Term-        arg t = primArg <@> t--        elV x a = El (varSort x) <$> a--        tsetL l    = return $ sort (varSort l)-        tlevel     = el primLevel-        tlist x    = el $ list (fmap unEl x)-        targ x     = el (arg (fmap unEl x))-        tabs x     = el (primAbs <@> fmap unEl x)-        targs      = el (list (arg primAgdaTerm))-        tterm      = el primAgdaTerm-        terrorpart = el primAgdaErrorPart-        tnat       = el primNat-        tint       = el primInteger-        tunit      = el primUnit-        tinteger   = el primInteger-        tfloat     = el primFloat-        tchar      = el primChar-        tstring    = el primString-        tqname     = el primQName-        tmeta      = el primAgdaMeta-        tsize      = El sSizeUniv <$> primSize-        tbool      = el primBool-        thiding    = el primHiding-        trelevance = el primRelevance-        tassoc     = el primAssoc-        tprec      = el primPrecedence-        tfixity    = el primFixity---        tcolors    = el (list primAgdaTerm) -- TODO guilhem-        targinfo   = el primArgInfo-        ttype      = el primAgdaTerm-        tsort      = el primAgdaSort-        tdefn      = el primAgdaDefinition-        tliteral   = el primAgdaLiteral-        tpat       = el primAgdaPattern-        tclause    = el primAgdaClause-        tTCM l a   = elV l (primAgdaTCM <#> varM l <@> a)-        tTCM_ a    = el (primAgdaTCM <#> primLevelZero <@> a)--        verifyPlus plus =-            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do-                let m = var 0-                    n = var 1-                    x + y = plus @@ x @@ y--                -- We allow recursion on any argument-                choice-                    [ do n + zero  == n-                         n + suc m == suc (n + m)-                    , do suc n + m == suc (n + m)-                         zero  + m == m-                    ]--        verifyMinus minus =-            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do-                let m = var 0-                    n = var 1-                    x - y = minus @@ x @@ y--                -- We allow recursion on any argument-                zero  - zero  == zero-                zero  - suc m == zero-                suc n - zero  == suc n-                suc n - suc m == (n - m)--        verifyTimes times = do-            plus <- primNatPlus-            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do-                let m = var 0-                    n = var 1-                    x + y = plus  @@ x @@ y-                    x * y = times @@ x @@ y--                choice-                    [ do n * zero == zero-                         choice [ (n * suc m) == (n + (n * m))-                                , (n * suc m) == ((n * m) + n)-                                ]-                    , do zero * n == zero-                         choice [ (suc n * m) == (m + (n * m))-                                , (suc n * m) == ((n * m) + m)-                                ]-                    ]--        verifyDivSucAux dsAux =-            verify ["k","m","n","j"] $ \(@@) zero suc (==) (===) choice -> do-                let aux k m n j = dsAux @@ k @@ m @@ n @@ j-                    k           = var 0-                    m           = var 1-                    n           = var 2-                    j           = var 3--                aux k m zero    j       == k-                aux k m (suc n) zero    == aux (suc k) m n m-                aux k m (suc n) (suc j) == aux k m n j--        verifyModSucAux dsAux =-            verify ["k","m","n","j"] $ \(@@) zero suc (==) (===) choice -> do-                let aux k m n j = dsAux @@ k @@ m @@ n @@ j-                    k           = var 0-                    m           = var 1-                    n           = var 2-                    j           = var 3--                aux k m zero    j       == k-                aux k m (suc n) zero    == aux zero m n m-                aux k m (suc n) (suc j) == aux (suc k) m n j--        verifyEquals eq =-            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do-            true  <- primTrue-            false <- primFalse-            let x == y = eq @@ x @@ y-                m      = var 0-                n      = var 1-            (zero  == zero ) === true-            (suc n == suc m) === (n == m)-            (suc n == zero ) === false-            (zero  == suc n) === false--        verifyLess leq =-            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do-            true  <- primTrue-            false <- primFalse-            let x < y = leq @@ x @@ y-                m     = var 0-                n     = var 1-            (n     < zero)  === false-            (suc n < suc m) === (n < m)-            (zero  < suc m) === true--        verifyMax maxV = return ()  -- TODO: make max a postulate--        verify xs = verify' primNat primZero primSuc xs--        verify' ::  TCM Term -> TCM Term -> TCM Term ->-                    [String] -> ( (Term -> Term -> Term) -> Term -> (Term -> Term) ->-                                (Term -> Term -> TCM ()) ->-                                (Term -> Term -> TCM ()) ->-                                ([TCM ()] -> TCM ()) -> TCM a) -> TCM a-        verify' pNat pZero pSuc xs f = do-            nat  <- El (mkType 0) <$> pNat-            zero <- pZero-            s    <- pSuc-            let x == y  = noConstraints $ equalTerm nat x y-                -- Andreas: 2013-10-21 I put primBool here on the inside-                -- since some Nat-builtins do not require Bool-builtins-                x === y = do bool <- El (mkType 0) <$> primBool-                             noConstraints $ equalTerm bool x y-                suc n  = s `apply1` n-                choice = foldr1 (\x y -> x `catchError` \_ -> y)-            xs <- mapM freshName_ xs-            addContext (xs, domFromArg $ defaultArg nat) $ f apply1 zero suc (==) (===) choice---inductiveCheck :: String -> Int -> Term -> TCM ()-inductiveCheck b n t = do-    t <- etaContract =<< normalise t-    let err = typeError (NotInductive t)-    case ignoreSharing t of-      Def t _ -> do-        t <- theDef <$> getConstInfo t-        case t of-          Datatype { dataInduction = Inductive-                   , dataCons      = cs-                   }-            | length cs == n -> return ()-            | otherwise ->-              typeError $ GenericError $ unwords-                          [ "The builtin", b-                          , "must be a datatype with", show n-                          , "constructors" ]-          Record { recInduction = ind } | n == 1 && ind /= Just CoInductive -> return ()-          _ -> err-      _ -> err---- | @bindPostulatedName builtin e m@ checks that @e@ is a postulated--- name @q@, and binds the builtin @builtin@ to the term @m q def@,--- where @def@ is the current 'Definition' of @q@.--bindPostulatedName ::-  String -> A.Expr -> (QName -> Definition -> TCM Term) -> TCM ()-bindPostulatedName builtin e m = do-  q   <- getName e-  def <- getConstInfo q-  case theDef def of-    Axiom {} -> bindBuiltinName builtin =<< m q def-    _        -> err-  where-  err = typeError $ GenericError $-          "The argument to BUILTIN " ++ builtin ++-          " must be a postulated name"--  getName (A.Def q)          = return q-  getName (A.ScopedExpr _ e) = getName e-  getName _                  = err--getDef :: Term -> TCM QName-getDef t = do-  t <- etaContract =<< normalise t-  case ignoreSharing t of-    Def d _ -> return d-    _ -> __IMPOSSIBLE__--bindAndSetHaskellType :: String -> String -> Term -> TCM ()-bindAndSetHaskellType b hs t = do-  d <- getDef t-  addHaskellType d hs-  bindBuiltinName b t--bindBuiltinBool :: Term -> TCM ()-bindBuiltinBool = bindAndSetHaskellType builtinBool "Bool"--bindBuiltinInt :: Term -> TCM ()-bindBuiltinInt = bindAndSetHaskellType builtinInteger "Integer"--bindBuiltinNat :: Term -> TCM ()-bindBuiltinNat t = do-  nat <- getDef t-  def <- theDef <$> getConstInfo nat-  case def of-    Datatype { dataCons = [c1, c2] } -> do-      bindBuiltinName builtinNat t-      let getArity c = arity <$> (normalise . defType =<< getConstInfo c)-      [a1, a2] <- mapM getArity [c1, c2]-      let (zero, suc) | a2 > a1   = (c1, c2)-                      | otherwise = (c2, c1)-          tnat = el primNat-          rerange = setRange (getRange nat)-      addHaskellType nat "Integer"-      bindBuiltinInfo (BuiltinInfo builtinZero $ BuiltinDataCons tnat)-                      (A.Con $ AmbQ [rerange zero])-      bindBuiltinInfo (BuiltinInfo builtinSuc  $ BuiltinDataCons (tnat --> tnat))-                      (A.Con $ AmbQ [rerange suc])-    _ -> __IMPOSSIBLE__--bindBuiltinUnit :: Term -> TCM ()-bindBuiltinUnit t = do-  unit <- getDef t-  def <- theDef <$> getConstInfo unit-  case def of-    Record { recFields = [], recConHead = con } -> do-      bindBuiltinName builtinUnit t-      bindBuiltinName builtinUnitUnit (Con con ConOSystem [])-    _ -> genericError "Builtin UNIT must be a singleton record type"--bindBuiltinInfo :: BuiltinInfo -> A.Expr -> TCM ()-bindBuiltinInfo i (A.ScopedExpr scope e) = setScope scope >> bindBuiltinInfo i e-bindBuiltinInfo (BuiltinInfo s d) e = do-    case d of-      BuiltinData t cs -> do-        e' <- checkExpr e =<< t-        let n = length cs-        inductiveCheck s n e'-        case () of-          _ | s == builtinBool    -> bindBuiltinBool e'-            | s == builtinNat     -> bindBuiltinNat e'-            | s == builtinInteger -> bindBuiltinInt e'-            | s == builtinUnit    -> bindBuiltinUnit e'-            | otherwise           -> bindBuiltinName s e'--      BuiltinDataCons t -> do--        let name (Lam h b)  = name (absBody b)-            name (Con c ci _) = Con c ci []-            name (Shared p) = name $ ignoreSharing (derefPtr p)-            name _          = __IMPOSSIBLE__--        e' <- checkExpr e =<< t--        case e of-          A.Con{} -> return ()-          _       -> typeError $ BuiltinMustBeConstructor s e--        let v@(Con h _ []) = name e'-            c = conName h-        when (s == builtinTrue)  $ addHaskellCode c "Bool" "True"-        when (s == builtinFalse) $ addHaskellCode c "Bool" "False"-        bindBuiltinName s v--      BuiltinPrim pfname axioms -> do-        case e of-          A.Def qx -> do--            PrimImpl t pf <- lookupPrimitiveFunction pfname-            v <- checkExpr e t--            axioms v--            info <- getConstInfo qx-            let cls = defClauses info-                a   = defAbstract info-                mcc = defCompiled info-            bindPrimitive pfname $ pf { primFunName = qx }-            addConstant qx $ info { theDef = Primitive a pfname cls mcc }--            -- needed? yes, for checking equations for mul-            bindBuiltinName s v--          _ -> typeError $ GenericError $ "Builtin " ++ s ++ " must be bound to a function"--      BuiltinPostulate rel t -> do-        t' <- t-        e' <- applyRelevanceToContext rel $ checkExpr e t'-        let err = typeError $ GenericError $-                    "The argument to BUILTIN " ++ s ++ " must be a postulated name"-        case e of-          A.Def q -> do-            def <- getConstInfo q-            case theDef def of-              Axiom {} -> do-                builtinSizeHook s q t'-                when (s == builtinChar)   $ addHaskellType q "Char"-                when (s == builtinString) $ addHaskellType q "Data.Text.Text"-                when (s == builtinFloat)  $ addHaskellType q "Double"-                bindBuiltinName s e'-              _        -> err-          _ -> err--      BuiltinUnknown mt f -> do-        (v, t) <- caseMaybe mt (inferExpr e) $ \ tcmt -> do-          t <- tcmt-          (,t) <$> checkExpr e t-        f v t-        bindBuiltinName s v---- | Bind a builtin thing to an expression.-bindBuiltin :: String -> A.Expr -> TCM ()-bindBuiltin b e = do-  unlessM ((0 ==) <$> getContextSize) $ typeError $ BuiltinInParameterisedModule b-  case b of-    _ | b == builtinZero  -> nowNat b-    _ | b == builtinSuc   -> nowNat b-    _ | b == builtinInf   -> bindBuiltinInf e-    _ | b == builtinSharp -> bindBuiltinSharp e-    _ | b == builtinFlat  -> bindBuiltinFlat e-    _ | Just i <- find ((b ==) . builtinName) coreBuiltins -> bindBuiltinInfo i e-    _ -> typeError $ NoSuchBuiltinName b-  where-    nowNat b = warning $ OldBuiltin b builtinNat--isUntypedBuiltin :: String -> Bool-isUntypedBuiltin b = elem b [builtinFromNat, builtinFromNeg, builtinFromString]--bindUntypedBuiltin :: String -> A.Expr -> TCM ()-bindUntypedBuiltin b e =-  case A.unScope e of-    A.Def q  -> bindBuiltinName b (Def q [])-    A.Proj _ (AmbQ [q]) -> bindBuiltinName b (Def q [])-    e        -> genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined unambiguous name"---- | Bind a builtin thing to a new name.-bindBuiltinNoDef :: String -> A.QName -> TCM ()-bindBuiltinNoDef b q = do-  unlessM ((0 ==) <$> getContextSize) $ typeError $ BuiltinInParameterisedModule b-  case lookup b $ map (\ (BuiltinInfo b i) -> (b, i)) coreBuiltins of-    Just (BuiltinPostulate rel mt) -> do-      t <- mt-      addConstant q $ defaultDefn (setRelevance rel defaultArgInfo) q t def-      builtinSizeHook b q t-      bindBuiltinName b $ Def q []-      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)-                , funTerminates = Just True-                }-            | otherwise = Axiom--    Just{}  -> __IMPOSSIBLE__-    Nothing -> __IMPOSSIBLE__ -- typeError $ NoSuchBuiltinName b+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Builtin+  ( bindBuiltin+  , bindBuiltinNoDef+  , builtinKindOfName+  , bindPostulatedName+  , isUntypedBuiltin+  , bindUntypedBuiltin+  ) where++import Prelude hiding (null)++import Control.Monad.Except      ( catchError )+import Control.Monad.Trans.Maybe++import Data.List (find, sortBy)+import Data.Function (on)++import Agda.Interaction.Options.Base++import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base++import Agda.TypeChecking.Monad++import qualified Agda.TypeChecking.CompiledClause as CC+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Constraints ( noConstraints )+import Agda.TypeChecking.Functions+import Agda.TypeChecking.Names+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+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+import Agda.Utils.Size++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Checking builtin pragmas+---------------------------------------------------------------------------++builtinPostulate :: TCM Type -> BuiltinDescriptor+builtinPostulate = BuiltinPostulate relevant++builtinPostulateC :: Cubical -> TCM Type -> BuiltinDescriptor+builtinPostulateC c m =+  builtinPostulate $ requireCubical c >> m++findBuiltinInfo :: BuiltinId -> Maybe BuiltinInfo+findBuiltinInfo b = find ((b ==) . builtinName) coreBuiltins++coreBuiltins :: [BuiltinInfo]+coreBuiltins =+  [ (builtinList                             |-> BuiltinData (tset --> tset) [builtinNil, builtinCons])+  , (builtinArg                              |-> BuiltinData (tset --> tset) [builtinArgArg])+  , (builtinAbs                              |-> BuiltinData (tset --> tset) [builtinAbsAbs])+  , (builtinArgInfo                          |-> BuiltinData tset [builtinArgArgInfo])+  , (builtinBool                             |-> BuiltinData tset [builtinTrue, builtinFalse])+  , (builtinNat                              |-> BuiltinData tset [builtinZero, builtinSuc])+  , (builtinMaybe                            |-> BuiltinData (tset --> tset) [builtinNothing, builtinJust])+  , (builtinSigma                            |-> BuiltinData (runNamesT [] $+                                                              hPi' "la" (el $ cl primLevel) $ \ a ->+                                                              hPi' "lb" (el $ cl primLevel) $ \ b ->+                                                              nPi' "A" (sort . tmSort <$> a) $ \bA ->+                                                              nPi' "B" (el' a bA --> (sort . tmSort <$> b)) $ \bB ->+                                                              ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b))+                                                              )+                                                             [BuiltinSigmaCon])+  , (builtinUnit                             |-> BuiltinData tset [builtinUnitUnit])  -- actually record, but they are treated the same+  , (builtinAgdaLiteral                      |-> BuiltinData tset [builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat,+                                                                   builtinAgdaLitChar, builtinAgdaLitString,+                                                                   builtinAgdaLitQName, builtinAgdaLitMeta])+  , (builtinAgdaPattern                      |-> BuiltinData tset [builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot,+                                                                   builtinAgdaPatLit, builtinAgdaPatProj, builtinAgdaPatAbsurd])+  , (builtinAgdaPatVar                       |-> BuiltinDataCons (tnat --> tpat))+  , (builtinAgdaPatCon                       |-> BuiltinDataCons (tqname --> tlist (targ tpat) --> tpat))+  , (builtinAgdaPatDot                       |-> BuiltinDataCons (tterm --> tpat))+  , (builtinAgdaPatLit                       |-> BuiltinDataCons (tliteral --> tpat))+  , (builtinAgdaPatProj                      |-> BuiltinDataCons (tqname --> tpat))+  , (builtinAgdaPatAbsurd                    |-> BuiltinDataCons (tnat --> tpat))+  , (builtinLevel                            |-> builtinPostulate tLevelUniv)+  , (builtinWord64                           |-> builtinPostulate tset)+  , (builtinInteger                          |-> BuiltinData tset [builtinIntegerPos, builtinIntegerNegSuc])+  , (builtinIntegerPos                       |-> BuiltinDataCons (tnat --> tinteger))+  , (builtinIntegerNegSuc                    |-> BuiltinDataCons (tnat --> tinteger))+  , (builtinFloat                            |-> builtinPostulate tset)+  , (builtinChar                             |-> builtinPostulate tset)+  , (builtinString                           |-> builtinPostulate tset)+  , (builtinQName                            |-> builtinPostulate tset)+  , (builtinAgdaMeta                         |-> builtinPostulate tset)+  , (builtinIO                               |-> builtinPostulate (tset --> tset))+  , (builtinPath                             |-> BuiltinUnknown+                                                             (Just $ requireCubical 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)))+                                                             verifyPath)+  , (builtinPathP                            |-> builtinPostulateC CErased (hPi "a" (el primLevel) $+                                                              nPi "A" (tinterval --> return (sort $ varSort 0)) $+                                                              (El (varSort 1) <$> varM 0 <@> primIZero) -->+                                                              (El (varSort 1) <$> varM 0 <@> primIOne) -->+                                                              return (sort $ varSort 1)))+  , (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 ->+                                                                   el's a (cl primPartial <#> a <@> phi <@> bA) --> (ssort . atomicLevel <$> a)+                                                                  ))+  , (builtinSubIn                            |-> builtinPostulateC CErased (runNamesT [] $+                                                                   hPi' "a" (el $ cl primLevel) $ \ a ->+                                                                   hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+                                                                   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 ()))+  , (builtinIsOne                            |-> builtinPostulateC CErased (tinterval --> return (ssort $ ClosedLevel 0)))+  , (builtinItIsOne                          |-> builtinPostulateC CErased (elSSet $ primIsOne <@> primIOne))+  , (builtinIsOne1                           |-> builtinPostulateC CErased (runNamesT [] $+                                                                   nPi' "i" (cl tinterval) $ \ i ->+                                                                   nPi' "j" (cl tinterval) $ \ j ->+                                                                   nPi' "i1" (elSSet $ cl primIsOne <@> i) $ \ i1 ->+                                                                   (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))+  , (builtinIsOne2                           |-> builtinPostulateC CErased (runNamesT [] $+                                                                   nPi' "i" (cl tinterval) $ \ i ->+                                                                   nPi' "j" (cl tinterval) $ \ j ->+                                                                   nPi' "j1" (elSSet $ cl primIsOne <@> j) $ \ j1 ->+                                                                   (elSSet $ cl primIsOne <@> (cl primIMax <@> i <@> j))))+  , (builtinIsOneEmpty                       |-> builtinPostulateC CErased (runNamesT [] $+                                                                   hPi' "l" (el $ cl primLevel) $ \ l ->+                                                                   hPi' "A" (pPi' "o" (cl primIZero) $ \ _ ->+                                                                                  el' (cl primLevelSuc <@> l) (Sort . tmSort <$> l)) $ \ bA ->+                                                                   pPi' "o" (cl primIZero) (\ o ->+                                                                        el' l $ gApply' defaultIrrelevantArgInfo bA o)))++  , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+                                                                    hPi' "l" (el $ cl primLevel) $ \ a ->+                                                                    hPi' "l'" (el $ cl primLevel) $ \ b ->+                                                                    nPi' "A" (sort . tmSort <$> a) $ \bA ->+                                                                    nPi' "B" (sort . tmSort <$> b) $ \bB ->+                                                                    ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b))+                                                                  ))+                                                                   (const $ const $ return ()))+  , (builtinEquivFun                         |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+                                                                 hPi' "l" (el $ cl primLevel) $ \ a ->+                                                                 hPi' "l'" (el $ cl primLevel) $ \ b ->+                                                                 hPi' "A" (sort . tmSort <$> a) $ \bA ->+                                                                 hPi' "B" (sort . tmSort <$> b) $ \bB ->+                                                                 el' (cl primLevelMax <@> a <@> b) (cl primEquiv <#> a <#> b <@> bA <@> bB) -->+                                                                 (el' a bA --> el' b bB)+                                                               ))+                                                                (const $ const $ return ()))+  , (builtinEquivProof                       |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (+                                                               hPi' "l" (el $ cl primLevel) $ \ la ->+                                                               hPi' "l'" (el $ cl primLevel) $ \ lb ->+                                                               nPi' "A" (sort . tmSort <$> la) $ \ bA ->+                                                               nPi' "B" (sort . tmSort <$> lb) $ \ bB ->+                                                               nPi' "e" (el' (cl primLevelMax <@> la <@> lb)+                                                                             (cl primEquiv <#> la <#> lb <@> bA <@> bB)) $ \ e -> do+                                                               nPi' "b" (el' lb bB) $ \ b -> do+                                                                let f = cl primEquivFun <#> la <#> lb <#> bA <#> bB <@> e+                                                                    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 ->+                                                                  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 [] (+                                                               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+                                                               nPi' "φ" (cl tinterval) $ \ phi -> do+                                                               nPi' "a" (pPi' "o" phi (\ _ -> el' la bA)) $ \ a -> do+                                                               let f = cl primTrans <#> lam "i" (\ _ -> la) <@> e <@> cl primIZero+                                                                   z = ilam "o" $ \ o -> f <@> (a <@> o)+                                                               nPi' "b" (el's lb (cl primSub <#> lb <@> bB <@> phi <@> z)) $ \ b' -> do+                                                               let b = cl primSubOut <#> lb <#> bB <#> phi <#> z <@> b'+                                                                   fiber = el' la+                                                                               (cl primSigma <#> la <#> lb+                                                                                  <@> bA+                                                                                  <@> lam "a" (\ a ->+                                                                                         cl primPath <#> lb <#> bB <@> (f <@> a) <@> b))+                                                               fiber+                                                             ))+                                                              (const $ const $ return ()))+  , (builtinAgdaSort                         |-> BuiltinData tset+                                                   [ builtinAgdaSortSet, builtinAgdaSortLit+                                                   , builtinAgdaSortProp, builtinAgdaSortPropLit+                                                   , builtinAgdaSortInf, builtinAgdaSortUnsupported])+  , (builtinAgdaTerm                         |-> BuiltinData tset+                                                   [ builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam+                                                   , builtinAgdaTermDef, builtinAgdaTermCon+                                                   , builtinAgdaTermPi, builtinAgdaTermSort+                                                   , builtinAgdaTermLit, builtinAgdaTermMeta+                                                   , builtinAgdaTermUnsupported])+  , 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) $+  --                                                             (El (varSort 1) <$> varM 0) -->+  --                                                             (El (varSort 1) <$> varM 0) -->+  --                                                             return (sort $ varSort 1))+  --                                                            [builtinRefl])+  , (builtinHiding                           |-> BuiltinData tset [builtinHidden, builtinInstance, builtinVisible])+    -- Relevance+  , (builtinRelevance                        |-> BuiltinData tset [builtinRelevant, builtinIrrelevant])+  , (builtinRelevant                         |-> BuiltinDataCons trelevance)+  , (builtinIrrelevant                       |-> BuiltinDataCons trelevance)+    -- Quantity+  , (builtinQuantity                         |-> BuiltinData tset [builtinQuantity0, builtinQuantityω])+  , (builtinQuantity0                        |-> BuiltinDataCons tquantity)+  , (builtinQuantityω                        |-> BuiltinDataCons tquantity)+    -- Modality+  , (builtinModality                         |-> BuiltinData tset [builtinModalityConstructor])+  , (builtinModalityConstructor              |-> BuiltinDataCons (trelevance --> tquantity --> tmodality))+    -- Associativity+  , builtinAssoc                             |-> BuiltinData tset [builtinAssocLeft, builtinAssocRight, builtinAssocNon]+  , builtinAssocLeft                         |-> BuiltinDataCons tassoc+  , builtinAssocRight                        |-> BuiltinDataCons tassoc+  , builtinAssocNon                          |-> BuiltinDataCons tassoc+    -- Precedence+  , builtinPrecedence                        |-> BuiltinData tset [builtinPrecRelated, builtinPrecUnrelated]+  , builtinPrecRelated                       |-> BuiltinDataCons (tfloat --> tprec)+  , builtinPrecUnrelated                     |-> BuiltinDataCons tprec+    -- Fixity+  , builtinFixity                            |-> BuiltinData tset [builtinFixityFixity]+  , builtinFixityFixity                      |-> BuiltinDataCons (tassoc --> tprec --> tfixity)+  -- Andreas, 2017-01-12, issue #2386: special handling of builtinEquality+  -- , (builtinRefl                             |-> BuiltinDataCons (hPi "a" (el primLevel) $+  --                                                                 hPi "A" (return $ sort $ varSort 0) $+  --                                                                 hPi "x" (El (varSort 1) <$> varM 0) $+  --                                                                 El (varSort 2) <$> primEquality <#> varM 2 <#> varM 1 <@> varM 0 <@> varM 0))+  , (builtinRewrite                          |-> BuiltinUnknown Nothing verifyBuiltinRewrite)+  , (builtinNil                              |-> BuiltinDataCons (hPi "A" tset (el (list v0))))+  , (builtinCons                             |-> BuiltinDataCons (hPi "A" tset (tv0 --> el (list v0) --> el (list v0))))+  , (builtinNothing                          |-> BuiltinDataCons (hPi "A" tset (el (tMaybe v0))))+  , (builtinJust                             |-> BuiltinDataCons (hPi "A" tset (tv0 --> el (tMaybe v0))))+  , (builtinZero                             |-> BuiltinDataCons tnat)+  , (builtinSuc                              |-> BuiltinDataCons (tnat --> tnat))+  , (builtinTrue                             |-> BuiltinDataCons tbool)+  , (builtinFalse                            |-> BuiltinDataCons tbool)+  , (builtinArgArg                           |-> BuiltinDataCons (hPi "A" tset (targinfo --> tv0 --> targ tv0)))+  , (builtinAbsAbs                           |-> BuiltinDataCons (hPi "A" tset (tstring  --> tv0 --> tabs tv0)))+  , (builtinArgArgInfo                       |-> BuiltinDataCons (thiding --> tmodality --> targinfo))+  , (builtinAgdaTermVar                      |-> BuiltinDataCons (tnat --> targs --> tterm))+  , (builtinAgdaTermLam                      |-> BuiltinDataCons (thiding --> tabs tterm --> tterm))+  , (builtinAgdaTermExtLam                   |-> BuiltinDataCons (tlist tclause --> targs --> tterm))+  , (builtinAgdaTermDef                      |-> BuiltinDataCons (tqname --> targs --> tterm))+  , (builtinAgdaTermCon                      |-> BuiltinDataCons (tqname --> targs --> tterm))+  , (builtinAgdaTermPi                       |-> BuiltinDataCons (targ ttype --> tabs ttype --> tterm))+  , (builtinAgdaTermSort                     |-> BuiltinDataCons (tsort --> tterm))+  , (builtinAgdaTermLit                      |-> BuiltinDataCons (tliteral --> tterm))+  , (builtinAgdaTermMeta                     |-> BuiltinDataCons (tmeta --> targs --> tterm))+  , (builtinAgdaTermUnsupported              |-> BuiltinDataCons tterm)+  , (builtinAgdaLitNat                       |-> BuiltinDataCons (tnat --> tliteral))+  , (builtinAgdaLitWord64                    |-> BuiltinDataCons (tword64 --> tliteral))+  , (builtinAgdaLitFloat                     |-> BuiltinDataCons (tfloat --> tliteral))+  , (builtinAgdaLitChar                      |-> BuiltinDataCons (tchar --> tliteral))+  , (builtinAgdaLitString                    |-> BuiltinDataCons (tstring --> tliteral))+  , (builtinAgdaLitQName                     |-> BuiltinDataCons (tqname --> tliteral))+  , (builtinAgdaLitMeta                      |-> BuiltinDataCons (tmeta --> tliteral))+  , (builtinHidden                           |-> BuiltinDataCons thiding)+  , (builtinInstance                         |-> BuiltinDataCons thiding)+  , (builtinVisible                          |-> BuiltinDataCons thiding)+  , (builtinSizeUniv                         |-> builtinPostulate tsetOmega) -- SizeUniv : Setω+  , (builtinSize                             |-> builtinPostulate tSizeUniv)+  , (builtinSizeLt                           |-> builtinPostulate (tsize ..--> tSizeUniv))+  , (builtinSizeSuc                          |-> builtinPostulate (tsize --> tsize))+  , (builtinSizeInf                          |-> builtinPostulate tsize)+  -- postulate max : {i : Size} -> Size< i -> Size< i -> Size< i+  , (builtinSizeMax                          |-> builtinPostulate (tsize --> tsize --> tsize))+     -- (hPi "i" tsize $ let a = el $ primSizeLt <@> v0 in (a --> a --> a)))+  , (builtinAgdaSortSet                      |-> BuiltinDataCons (tterm --> tsort))+  , (builtinAgdaSortLit                      |-> BuiltinDataCons (tnat --> tsort))+  , (builtinAgdaSortProp                     |-> BuiltinDataCons (tterm --> tsort))+  , (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)+  , (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))+  , (builtinAgdaDefinition                   |-> BuiltinData tset [builtinAgdaDefinitionFunDef+                                                                  ,builtinAgdaDefinitionDataDef+                                                                  ,builtinAgdaDefinitionDataConstructor+                                                                  ,builtinAgdaDefinitionRecordDef+                                                                  ,builtinAgdaDefinitionPostulate+                                                                  ,builtinAgdaDefinitionPrimitive])+  , (builtinAgdaDefinitionFunDef             |-> BuiltinDataCons (tlist tclause --> tdefn))+  , (builtinAgdaDefinitionDataDef            |-> BuiltinDataCons (tnat --> tlist tqname --> tdefn))+  , (builtinAgdaDefinitionDataConstructor    |-> BuiltinDataCons (tqname --> tquantity --> tdefn))+  , (builtinAgdaDefinitionRecordDef          |-> BuiltinDataCons (tqname --> tlist (targ tqname) --> tdefn))+  , (builtinAgdaDefinitionPostulate          |-> BuiltinDataCons tdefn)+  , (builtinAgdaDefinitionPrimitive          |-> BuiltinDataCons tdefn)+  , builtinAgdaTCM                           |-> builtinPostulate (hPi "a" tlevel $ tsetL 0 --> tsetL 0)+  , builtinAgdaTCMReturn                     |-> builtinPostulate (hPi "a" tlevel  $+                                                                   hPi "A" (tsetL 0) $+                                                                   elV 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMBind                       |-> builtinPostulate (hPi "a" tlevel  $ hPi "b" tlevel $+                                                                   hPi "A" (tsetL 1) $ hPi "B" (tsetL 1) $+                                                                   tTCM 3 (varM 1) --> (elV 3 (varM 1) --> tTCM 2 (varM 0)) --> tTCM 2 (varM 0))+  , builtinAgdaTCMUnify                      |-> builtinPostulate (tterm --> tterm --> tTCM_ primUnit)+  , builtinAgdaTCMTypeError                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist terrorpart --> tTCM 1 (varM 0))+  , builtinAgdaTCMInferType                  |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)+  , builtinAgdaTCMCheckType                  |-> builtinPostulate (tterm --> ttype --> tTCM_ primAgdaTerm)+  , builtinAgdaTCMNormalise                  |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)+  , 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 <$> ttelescope))+  , builtinAgdaTCMExtendContext              |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $+                                                                   tstring --> targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMInContext                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 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)+  , 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))+  , 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)++  , 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++        v0 :: TCM Term+        v0 = varM 0++        tv0 :: TCM Type+        tv0 = el v0++        arg :: TCM Term -> TCM Term+        arg t = primArg <@> t++        elV x a = El (varSort x) <$> a++        tsetL l    = return $ sort (varSort l)+        tsetOmega  = return $ sort $ Inf UType 0+        tlevel     = el primLevel+        tlist x    = el $ list (fmap unEl x)+        tmaybe x   = el $ tMaybe (fmap unEl x)+        tpair lx ly x y = el $ primSigma+                            <#> lx+                            <#> ly+                            <@> fmap unEl x+                            <@> (Lam defaultArgInfo . NoAbs "_" <$> fmap unEl y)+        targ x     = el (arg (fmap unEl x))+        tabs x     = el (primAbs <@> fmap unEl x)+        targs      = el (list (arg primAgdaTerm))+        tterm      = el primAgdaTerm+        terrorpart = el primAgdaErrorPart+        tnat       = el primNat+        tword64    = el primWord64+        tinteger   = el primInteger+        tfloat     = el primFloat+        tchar      = el primChar+        tstring    = el primString+        tqname     = el primQName+        tmeta      = el primAgdaMeta+        tblocker   = el primAgdaBlocker+        tsize      = El sSizeUniv <$> primSize+        tbool      = el primBool+        thiding    = el primHiding+        trelevance = el primRelevance+        tquantity  = el primQuantity+        tmodality  = el primModality+        tassoc     = el primAssoc+        tprec      = el primPrecedence+        tfixity    = el primFixity+--        tcolors    = el (list primAgdaTerm) -- TODO guilhem+        targinfo   = el primArgInfo+        ttype      = el primAgdaTerm+        tsort      = el primAgdaSort+        tdefn      = el primAgdaDefinition+        tliteral   = el primAgdaLiteral+        tpat       = el primAgdaPattern+        tclause    = el primAgdaClause+        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 IntervalUniv <$> primInterval++        verifyPlus plus =+            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do+                let m = var 0+                    n = var 1+                    x + y = plus @@ x @@ y++                -- We allow recursion on any argument+                choice+                    [ do n + zero  == n+                         n + suc m == suc (n + m)+                    , do suc n + m == suc (n + m)+                         zero  + m == m+                    ]++        verifyMinus minus =+            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do+                let m = var 0+                    n = var 1+                    x - y = minus @@ x @@ y++                -- We allow recursion on any argument+                zero  - zero  == zero+                zero  - suc m == zero+                suc n - zero  == suc n+                suc n - suc m == (n - m)++        verifyTimes times = do+            plus <- primNatPlus+            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do+                let m = var 0+                    n = var 1+                    x + y = plus  @@ x @@ y+                    x * y = times @@ x @@ y++                choice+                    [ do n * zero == zero+                         choice [ (n * suc m) == (n + (n * m))+                                , (n * suc m) == ((n * m) + n)+                                ]+                    , do zero * n == zero+                         choice [ (suc n * m) == (m + (n * m))+                                , (suc n * m) == ((n * m) + m)+                                ]+                    ]++        verifyDivSucAux dsAux =+            verify ["k","m","n","j"] $ \(@@) zero suc (==) (===) choice -> do+                let aux k m n j = dsAux @@ k @@ m @@ n @@ j+                    k           = var 0+                    m           = var 1+                    n           = var 2+                    j           = var 3++                aux k m zero    j       == k+                aux k m (suc n) zero    == aux (suc k) m n m+                aux k m (suc n) (suc j) == aux k m n j++        verifyModSucAux dsAux =+            verify ["k","m","n","j"] $ \(@@) zero suc (==) (===) choice -> do+                let aux k m n j = dsAux @@ k @@ m @@ n @@ j+                    k           = var 0+                    m           = var 1+                    n           = var 2+                    j           = var 3++                aux k m zero    j       == k+                aux k m (suc n) zero    == aux zero m n m+                aux k m (suc n) (suc j) == aux (suc k) m n j++        verifyEquals eq =+            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do+            true  <- primTrue+            false <- primFalse+            let x == y = eq @@ x @@ y+                m      = var 0+                n      = var 1+            (zero  == zero ) === true+            (suc n == suc m) === (n == m)+            (suc n == zero ) === false+            (zero  == suc n) === false++        verifyLess leq =+            verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do+            true  <- primTrue+            false <- primFalse+            let x < y = leq @@ x @@ y+                m     = var 0+                n     = var 1+            (n     < zero)  === false+            (suc n < suc m) === (n < m)+            (zero  < suc m) === true++        verifyMax maxV = return ()  -- TODO: make max a postulate++        verify xs = verify' primNat primZero primSuc xs++        verify' ::  TCM Term -> TCM Term -> TCM Term ->+                    [String] -> ( (Term -> Term -> Term) -> Term -> (Term -> Term) ->+                                (Term -> Term -> TCM ()) ->+                                (Term -> Term -> TCM ()) ->+                                ([TCM ()] -> TCM ()) -> TCM a) -> TCM a+        verify' pNat pZero pSuc xs f = do+            nat  <- El (mkType 0) <$> pNat+            zero <- pZero+            s    <- pSuc+            let x == y  = noConstraints $ equalTerm nat x y+                -- Andreas: 2013-10-21 I put primBool here on the inside+                -- since some Nat-builtins do not require Bool-builtins+                x === y = do bool <- El (mkType 0) <$> primBool+                             noConstraints $ equalTerm bool x y+                suc n  = s `apply1` n+                choice = foldr1 (\x y -> x `catchError` \_ -> y)+            xs <- mapM freshName_ xs+            addContext (xs, domFromArg $ defaultArg nat) $ f apply1 zero suc (==) (===) choice++        verifyPath :: Term -> Type -> TCM ()+        verifyPath path t = do+          let hlam n t = glam (setHiding Hidden defaultArgInfo) n t+          noConstraints $ equalTerm t path =<< runNamesT [] (+            hlam "l" $ \ l -> hlam "A" $ \ bA -> cl primPathP <#> l <@> lam "i" (\ _ -> bA))++-- | 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 :: BuiltinId -> Int -> Term -> TCM (QName, Definition)+inductiveCheck b n t = do+  caseMaybeM (headSymbol t) no $ \q -> do+      def <- getConstInfo q+      let yes = return (q, def)+      case theDef def of+        Datatype { dataCons = cs }+          | length cs == n -> yes+          | otherwise      -> no+        Record { recInduction = ind } | n == 1 && ind /= Just CoInductive -> yes+        _ -> no+  where+  headSymbol :: Term -> TCM (Maybe QName)+  headSymbol t = reduce t >>= \case+    Def q _ -> return $ Just q+    Lam _ b -> headSymbol $ lazyAbsApp b __DUMMY_TERM__+    _       -> return Nothing++  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 ::+  BuiltinId -> ResolvedName -> (QName -> Definition -> TCM Term) -> TCM ()+bindPostulatedName builtin x m = do+  q   <- getName x+  def <- getConstInfo q+  case theDef def of+    Axiom {} -> bindBuiltinName builtin =<< m q def+    _        -> err+  where+  err :: forall m a. MonadTCError m => m a+  err = typeError $ BuiltinMustBePostulate builtin+  getName = \case+    DefinedName _ d NoSuffix -> return $ anameName d+    _ -> err++addHaskellPragma :: QName -> String -> TCM ()+addHaskellPragma = addPragma ghcBackendName++bindAndSetHaskellCode :: BuiltinId -> String -> Term -> TCM ()+bindAndSetHaskellCode b hs t = do+  d <- fromMaybe __IMPOSSIBLE__ <$> getDef t+  bindBuiltinName b t+  addHaskellPragma d hs++bindBuiltinBool :: Term -> TCM ()+bindBuiltinBool = bindAndSetHaskellCode builtinBool "= type Bool"++-- | Check that we're not trying to bind true and false to the same+-- constructor.+checkBuiltinBool :: TCM ()+checkBuiltinBool = do+  true  <- getBuiltin' builtinTrue+  false <- getBuiltin' builtinFalse+  when (true == false) $+    typeError $ InvalidBuiltin "Cannot bind TRUE and FALSE to the same constructor"++bindBuiltinInt :: Term -> TCM ()+bindBuiltinInt = bindAndSetHaskellCode builtinInteger "= type Integer"++bindBuiltinNat :: Term -> TCM ()+bindBuiltinNat t = do+  bindBuiltinData builtinNat t+  name <- fromMaybe __IMPOSSIBLE__ <$> getDef t+  addHaskellPragma name "= type Integer"++-- | Only use for datatypes with distinct arities of constructors.+--   Binds the constructors together with the datatype.+bindBuiltinData :: BuiltinId -> Term -> TCM ()+bindBuiltinData s t = do+  bindBuiltinName s t+  name <- fromMaybe __IMPOSSIBLE__ <$> getDef t+  Datatype{ dataCons = cs } <- theDef <$> getConstInfo name+  let getArity c = do+        Constructor{ conArity = a } <- theDef <$> getConstInfo c+        return a+      getBuiltinArity (BuiltinDataCons t) = arity <$> t+      getBuiltinArity _ = __IMPOSSIBLE__+      sortByM f xs = map fst . sortBy (compare `on` snd) . zip xs <$> mapM f xs+  -- Order constructurs by arity+  cs <- sortByM getArity cs+  -- Do the same for the builtins+  let bcis = fromMaybe __IMPOSSIBLE__ $ do+        BuiltinData _ bcs <- builtinDesc <$> findBuiltinInfo s+        mapM findBuiltinInfo bcs+  bcis <- sortByM (getBuiltinArity . builtinDesc) bcis+  unless (length cs == length bcis) __IMPOSSIBLE__  -- we already checked this+  zipWithM_ (\ c bci -> bindBuiltinInfo bci (A.Con $ unambiguous $ setRange (getRange name) c)) cs bcis++bindBuiltinUnit :: Term -> TCM ()+bindBuiltinUnit t = do+  unit <- fromMaybe __IMPOSSIBLE__ <$> getDef t+  def <- theDef <$> getConstInfo unit+  case def of+    Record { recFields = [], recConHead = con } -> do+      bindBuiltinName builtinUnit t+      bindBuiltinName builtinUnitUnit (Con con ConOSystem [])+    _ -> typeError $ InvalidBuiltin "Builtin UNIT must be a singleton record type"++bindBuiltinSigma :: Term -> TCM ()+bindBuiltinSigma t = do+  sigma <- fromMaybe __IMPOSSIBLE__ <$> getDef t+  def <- theDef <$> getConstInfo sigma+  case def of+    Record { recFields = [fst,snd], recConHead = con } -> do+      bindBuiltinName builtinSigma t+    _ -> typeError $ InvalidBuiltin "Builtin SIGMA must be a record type with two fields"++-- | Bind BUILTIN EQUALITY and BUILTIN REFL.+bindBuiltinEquality :: ResolvedName -> TCM ()+bindBuiltinEquality x = do+  (v, _t) <- inferExpr (A.nameToExpr x)++  -- Equality needs to be a data type with 1 constructor+  (eq, def) <- inductiveCheck builtinEquality 1 v++  -- 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 = 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 (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+  unless (deBruijnView b == Just 1) no++  -- Get the single constructor.+  case theDef def of+    Datatype { dataCons = [c] } -> do+      bindBuiltinName builtinEquality v++      -- Check type of REFL.  It has to be of the form+      -- pars → (x : A) → Eq ... x x++      -- Check the arguments+      cdef <- getConstInfo c+      TelV conTel conCore <- telView $ defType cdef+      ts <- reduce $ map (unEl . snd . unDom) $ drop (conPars $ theDef cdef) $ telToList conTel+      -- After dropping the parameters, there should be maximally one argument.+      unless (length ts <= 1) wrongRefl+      unless (all ((Just 0 ==) . deBruijnView) ts) wrongRefl++      -- Check the target+      case unEl conCore of+        Def _ es -> do+          let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          (a,b) <- reduce $ fromMaybe __IMPOSSIBLE__ $ last2 vs+          unless (deBruijnView a == Just 0) wrongRefl+          unless (deBruijnView b == Just 0) wrongRefl+          bindBuiltinName builtinRefl (Con (ConHead c IsData Inductive []) ConOSystem [])+        _ -> __IMPOSSIBLE__+    _ -> typeError $ InvalidBuiltin "Builtin EQUALITY must be a data type with a single constructor"+  where+  wrongRefl = typeError $ InvalidBuiltin "Wrong type of constructor of BUILTIN EQUALITY"++bindBuiltinInfo :: BuiltinInfo -> A.Expr -> TCM ()+bindBuiltinInfo (BuiltinInfo s d) e = do+    case d of+      BuiltinData t cs -> do+        v <- checkExpr e =<< t+        unless (s == builtinUnit) $ do+          void $ inductiveCheck s (length cs) v+        if | s == builtinEquality -> __IMPOSSIBLE__ -- bindBuiltinEquality v+           | s == builtinBool     -> bindBuiltinBool     v+           | s == builtinNat      -> bindBuiltinNat      v+           | s == builtinInteger  -> bindBuiltinInt      v+           | s == builtinUnit     -> bindBuiltinUnit     v+           | s == builtinSigma    -> bindBuiltinSigma    v+           | s == builtinList     -> bindBuiltinData s   v+           | s == builtinMaybe    -> bindBuiltinData s   v+           | otherwise            -> bindBuiltinName s   v++      BuiltinDataCons t -> do++        let name (Lam h b)  = name (absBody b)+            name (Con c ci _) = Con c ci []+            name _          = __IMPOSSIBLE__++        v0 <- checkExpr e =<< t++        case e of+          A.Con{} -> return ()+          _       -> typeError $ BuiltinMustBeConstructor s e++        let v@(Con h _ []) = name v0++        bindBuiltinName s v++        when (s `elem` [builtinFalse, builtinTrue]) checkBuiltinBool++      BuiltinPrim pfname axioms -> do+        case e of+          A.Def qx -> do++            PrimImpl t pf <- lookupPrimitiveFunction pfname+            v <- checkExpr e t++            axioms v++            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+                                                       , primOpaque   = o+                                                       } }++            -- needed? yes, for checking equations for mul+            bindBuiltinName s v++          _ -> typeError $ BuiltinMustBeFunction s++      BuiltinSort{} -> __IMPOSSIBLE__ -- always a "BuiltinNoDef"++      BuiltinPostulate rel t -> do+        t' <- t+        v <- applyRelevanceToContext rel $ checkExpr e t'+        let err = typeError $ BuiltinMustBePostulate s+        case e of+          A.Def q -> do+            def <- getConstInfo q+            case theDef def of+              Axiom {} -> do+                builtinSizeHook s q t'+                -- And compilation pragmas for base types+                when (s == builtinLevel)  $ setConstTranspAxiom q >> addHaskellPragma q "= type ()"+                when (s == builtinChar)   $ setConstTranspAxiom q >> addHaskellPragma q "= type Char"+                when (s == builtinString) $ setConstTranspAxiom q >> addHaskellPragma q "= type Data.Text.Text"+                when (s == builtinFloat)  $ setConstTranspAxiom q >> addHaskellPragma q "= type Double"+                when (s == builtinWord64) $ setConstTranspAxiom q >> addHaskellPragma q "= type MAlonzo.RTE.Word64"+                when (s == builtinPathP)  $ builtinPathPHook q+                bindBuiltinName s v+              _        -> err+          _ -> err++      BuiltinUnknown mt f -> do+        (v, t) <- caseMaybe mt (inferExpr e) $ \ tcmt -> do+          t <- tcmt+          (,t) <$> checkExpr e t+        f v t+        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 =+  modifySignature $ updateDefinition q $ updateTheDef (const $ constTranspAxiom)++builtinPathPHook :: QName -> TCM ()+builtinPathPHook q =+      modifySignature $ updateDefinition q+      $ updateDefPolarity       id+      . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed])++-- | Bind a builtin thing to an expression.+bindBuiltin :: BuiltinId -> ResolvedName -> TCM ()+bindBuiltin b x = do+  unlessM ((0 ==) <$> getContextSize) $ do+    -- Andreas, 2017-11-01, issue #2824+    -- Only raise an error if the name for the builtin is defined in a parametrized module.+    let+      failure :: forall m a. MonadTCError m => m a+      failure = typeError $ BuiltinInParameterisedModule b+    -- Get the non-empty list of AbstractName for x+    xs <- case x of+      VarName{}            -> failure+      DefinedName _ x NoSuffix -> return $ x :| []+      DefinedName _ x Suffix{} -> failure+      FieldName xs         -> return xs+      ConstructorName _ xs -> return xs+      PatternSynResName xs -> failure+      UnknownName          -> failure+    -- For ambiguous names, we check all of their definitions:+    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!)+  inTopContext $ do+  if | b == builtinRefl  -> warning $ OldBuiltin b builtinEquality+     | b == builtinZero  -> now builtinNat b+     | b == builtinSuc   -> now builtinNat b+     | b == builtinNil   -> now builtinList b+     | b == builtinCons  -> now builtinList b+     | b == builtinInf   -> bindBuiltinInf x+     | b == builtinSharp -> bindBuiltinSharp x+     | b == builtinFlat  -> bindBuiltinFlat x+     | b == builtinEquality -> bindBuiltinEquality x+     | Just i <- findBuiltinInfo b -> bindBuiltinInfo i (A.nameToExpr x)+     | otherwise -> typeError $ NoSuchBuiltinName (getBuiltinId b)+  where+    now new b = warning $ OldBuiltin b new++isUntypedBuiltin :: BuiltinId -> Bool+isUntypedBuiltin = hasElem [ builtinFromNat, builtinFromNeg, builtinFromString ]++bindUntypedBuiltin :: BuiltinId -> ResolvedName -> TCM ()+bindUntypedBuiltin b = \case+  DefinedName _ x NoSuffix -> bind x+  DefinedName _ x Suffix{} -> wrong+  FieldName (x :| [])  -> bind x+  FieldName (x :| _)   -> amb x+  VarName _x _bnd      -> wrong+  UnknownName          -> wrong+  ConstructorName _ xs -> err xs+  PatternSynResName xs -> err xs+  where+  bind x = bindBuiltinName b (Def (anameName x) [])+  wrong  = typeError $ BuiltinMustBeDef b+  amb x  = genericDocError =<< do text "Name " <+> prettyTCM x <+> text " is ambiguous"+  err (x :| xs1)+    | null xs1  = wrong+    | otherwise = amb x++-- | Bind a builtin thing to a new name.+--+-- 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 :: BuiltinId -> A.QName -> TCM ()+bindBuiltinNoDef b q = inTopContext $ do+  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+      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+      -- Finally, bind the BUILTIN in the environment.+      bindBuiltinName b $ Def q []+      where+        -- Andreas, 2015-02-14+        -- Special treatment of SizeUniv, should maybe be a primitive.+        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++    Just (BuiltinPrim name axioms) -> do+      PrimImpl t pf <- lookupPrimitiveFunction name+      bindPrimitive name $ pf { primFunName = q }+      let v   = Def q []+          def = Primitive { primAbstr    = ConcreteDef+                          , primName     = name+                          , primClauses  = []+                          , primInv      = NotInjective+                          , primCompiled = Just (CC.Done [] $ Def q [])+                          , primOpaque   = TransparentDef+                          }+      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+      erasure <- optErasure <$> pragmaOptions+      let+        ch = ConHead q IsData Inductive []+        def = Constructor+              { conPars   = 0   -- Andrea TODO: fix zeros+              , conArity  = 0+              , conSrcCon = ch+              , conData   = d+              , conAbstr  = ConcreteDef+              , conComp   = emptyCompKit+              , conProj   = Nothing+              , conForced = []+              , conErased = Nothing+              , conErasure = erasure+              , conInline  = False+              }+      addConstant' q defaultArgInfo t def+      addDataCons d [q]++      bindBuiltinName b $ Con ch ConOSystem []++    Just (BuiltinData mt cs) -> do+      t <- mt+      addConstant' q defaultArgInfo t (def t)+      bindBuiltinName b $ Def q []+      where+        def t = Datatype+              { dataPars       = 0+              , dataIxs        = 0+              , dataClause     = Nothing+              , dataCons       = []     -- Constructors are added later+              , dataSort       = getSort t+              , dataAbstr      = ConcreteDef+              , dataMutual     = Nothing+              , dataPathCons   = []+              , dataTranspIx   = Nothing -- Id has custom transp def.+              , dataTransp     = Nothing+              }++    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 :: BuiltinId -> Maybe KindOfName+builtinKindOfName = distinguish <.> findBuiltinInfo+  where+  distinguish d = case builtinDesc d of+    BuiltinDataCons{}  -> ConName+    BuiltinData{}      -> DataName       -- Andreas, 2020-04-13: Crude.  Could be @RecName@.+    BuiltinPrim{}      -> PrimName+    BuiltinPostulate{} -> AxiomName+    BuiltinSort{}      -> PrimName+    BuiltinUnknown{}   -> OtherDefName
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs view
@@ -1,4 +1,4 @@--- {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- | Handling of the INFINITY, SHARP and FLAT builtins.@@ -6,29 +6,28 @@  module Agda.TypeChecking.Rules.Builtin.Coinduction where -import Control.Applicative+import Prelude hiding (null) -import qualified Data.Map as Map-import qualified Data.Set as Set+import Agda.Interaction.Options.Base  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Position+import Agda.Syntax.Scope.Base  import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Level import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin 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.Permutation+import Agda.Utils.Lens+import Agda.Utils.Null  -- | The type of @∞@. @@ -55,9 +54,10 @@ -- | Binds the INFINITY builtin, but does not change the type's -- definition. -bindBuiltinInf :: A.Expr -> TCM ()-bindBuiltinInf e = bindPostulatedName builtinInf e $ \inf _ ->-  instantiateFull =<< checkExpr (A.Def inf) =<< typeOfInf+bindBuiltinInf :: ResolvedName -> TCM ()+bindBuiltinInf x = bindPostulatedName builtinInf x $ \inf _ -> do+  _ <- checkExpr (A.Def inf) =<< typeOfInf+  return $ Def inf []  -- | Binds the SHARP builtin, and changes the definitions of INFINITY -- and SHARP.@@ -67,14 +67,15 @@ -- codata ∞ {a} (A : Set a) : Set a where --   ♯_ : (x : A) → ∞ A -bindBuiltinSharp :: A.Expr -> TCM ()-bindBuiltinSharp e =-  bindPostulatedName builtinSharp e $ \sharp sharpDefn -> do+bindBuiltinSharp :: ResolvedName -> TCM ()+bindBuiltinSharp x =+  bindPostulatedName builtinSharp x $ \sharp sharpDefn -> do     sharpType <- typeOfSharp     TelV fieldTel _ <- telView sharpType-    sharpE    <- instantiateFull =<< checkExpr (A.Def sharp) sharpType-    Def inf _ <- ignoreSharing <$> primInf+    _ <- 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,27 +83,34 @@                   { recPars           = 2                   , recInduction      = Just CoInductive                   , recClause         = Nothing-                  , recConHead        = ConHead sharp CoInductive []  -- flat is added later+                  , recConHead        = ConHead sharp (IsRecord CopatternMatching) CoInductive []  -- flat is added later                   , recNamedCon       = True                   , recFields         = []  -- flat is added later                   , recTel            = fieldTel-                  , recRecursive      = False-                  , recEtaEquality'   = Inferred False-                  , recMutual         = []+                  , recEtaEquality'   = Inferred $ NoEta CopatternMatching+                  , recPatternMatching= CopatternMatching+                  , recMutual         = Just []+                  , recTerminates     = Just True  -- not recursive                   , recAbstr          = ConcreteDef+                  , recComp           = emptyCompKit                   }               }     addConstant sharp $       sharpDefn { theDef = Constructor                     { conPars   = 2-                    , conSrcCon = ConHead sharp CoInductive [] -- flat is added as field later+                    , conArity  = 1+                    , conSrcCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [] -- flat is added as field later                     , conData   = defName infDefn                     , conAbstr  = ConcreteDef-                    , conInd    = CoInductive-                    , conErased = []+                    , conComp   = emptyCompKit+                    , conProj   = Nothing+                    , conForced = []+                    , conErased = Nothing+                    , conErasure = erasure+                    , conInline  = True  -- This might make the sharp-translation superfluous.                     }                 }-    return sharpE+    return $ Def sharp []  -- | Binds the FLAT builtin, and changes its definition. @@ -111,14 +119,14 @@ --   ♭ : ∀ {a} {A : Set a} → ∞ A → A --   ♭ (♯ x) = x -bindBuiltinFlat :: A.Expr -> TCM ()-bindBuiltinFlat e =-  bindPostulatedName builtinFlat e $ \ flat flatDefn -> do-    flatE       <- instantiateFull =<< checkExpr (A.Def flat) =<< typeOfFlat-    Def sharp _ <- ignoreSharing <$> primSharp+bindBuiltinFlat :: ResolvedName -> TCM ()+bindBuiltinFlat x =+  bindPostulatedName builtinFlat x $ \ flat flatDefn -> do+    _ <- checkExpr (A.Def flat) =<< typeOfFlat+    Def sharp _ <- primSharp     kit         <- requireLevels-    Def inf _   <- ignoreSharing <$> primInf-    let sharpCon = ConHead sharp CoInductive [flat]+    Def inf _   <- primInf+    let sharpCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [defaultArg flat]         level    = El (mkType 0) $ Def (typeName kit) []         tel     :: Telescope         tel      = ExtendTel (domH $ level)                  $ Abs "a" $@@ -126,46 +134,50 @@                    ExtendTel (domN $ El (varSort 1) $ var 0) $ Abs "x" $                    EmptyTel         infA     = El (varSort 2) $ Def inf [ Apply $ defaultArg $ var 1 ]-        cpi      = ConPatternInfo Nothing $ Just $ defaultArg infA+        cpi      = noConPatternInfo { conPType = Just $ defaultArg infA+                                    , conPLazy = True }     let clause   = Clause-          { clauseRange     = noRange+          { clauseLHSRange  = noRange+          , 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+          , clauseCatchall    = empty+          , clauseRecursive   = Just False+          , clauseUnreachable = Just False+          , clauseEllipsis    = NoEllipsis+          , clauseWhereModule = Nothing           }-        cc = Case (defaultArg 0) $ Branches False-                               (Map.singleton sharp-                                 $ WithArity 1 $ Done [defaultArg "x"] $ var 0)-                               Map.empty-                               Nothing+        cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done [defaultArg "x"] $ var 0         projection = Projection-          { projProper   = True+          { projProper   = Just inf           , projOrig     = flat           , projFromType = defaultArg inf           , 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-               , theDef = emptyFunction-                   { funClauses      = [clause]-                   , funCompiled     = Just $ cc-                   , funProjection   = Just projection-                   , funTerminates   = Just True-                   , funCopatternLHS = isCopatternLHS [clause]+               , defCopatternLHS = hasProjectionPatterns cc+               , 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 = [defaultArg flat] }-    return flatE+    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. -- moved to TypeChecking.Monad.Builtin
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs-boot view
@@ -1,17 +1,16 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rules.Builtin.Coinduction where -import Agda.Syntax.Abstract+import Agda.Syntax.Scope.Base+import Agda.Syntax.Internal (Type) import Agda.TypeChecking.Monad -bindBuiltinInf   :: Expr -> TCM ()-bindBuiltinSharp :: Expr -> TCM ()-bindBuiltinFlat  :: Expr -> TCM ()+typeOfInf   :: TCM Type+typeOfSharp :: TCM Type+typeOfFlat  :: TCM Type -{- MOVED to TypeChecking.Monad.Builtin-data CoinductionKit-nameOfInf   :: CoinductionKit -> QName-nameOfSharp :: CoinductionKit -> QName-nameOfFlat  :: CoinductionKit -> QName+bindBuiltinInf   :: ResolvedName -> TCM ()+bindBuiltinSharp :: ResolvedName -> TCM ()+bindBuiltinFlat  :: ResolvedName -> TCM () -coinductionKit :: TCM (Maybe CoinductionKit)--}
src/full/Agda/TypeChecking/Rules/Data.hs view
@@ -1,458 +1,1910 @@-{-# LANGUAGE CPP #-}--module Agda.TypeChecking.Rules.Data where--import Control.Applicative-import Control.Monad--import Data.List (genericTake)-import Data.Maybe (fromMaybe)-import qualified Data.Set as Set--import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Internal-import Agda.Syntax.Common-import Agda.Syntax.Position-import qualified Agda.Syntax.Info as Info--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin (primLevel)-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty-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.Interaction.Options--import Agda.Utils.Except-import Agda.Utils.List-import Agda.Utils.Monad-import Agda.Utils.Permutation-import Agda.Utils.Size-import Agda.Utils.Tuple-import qualified Agda.Utils.VarSet as VarSet--#include "undefined.h"-import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Datatypes-------------------------------------------------------------------------------- | Type check a datatype definition. Assumes that the type has already been---   checked.-checkDataDef :: Info.DefInfo -> QName -> [A.LamBinding] -> [A.Constructor] -> TCM ()-checkDataDef i name ps cs =-    traceCall (CheckDataDef (getRange name) (qnameName name) ps cs) $ do -- TODO!! (qnameName)-        let countPars A.DomainFree{} = 1-            countPars (A.DomainFull (A.TypedBindings _ (Arg _ b))) = case b of-              A.TLet{}       -> 0-              A.TBind _ xs _ -> size xs-            npars = sum $ map countPars ps--        -- Add the datatype module-        addSection (qnameToMName name)--        -- Look up the type of the datatype.-        t <- instantiateFull =<< typeOfConst name--        -- Make sure the shape of the type is visible-        let unTelV (TelV tel a) = telePi tel a-        t <- unTelV <$> telView t--        -- Top level free vars-        freeVars <- getContextArgs--        -- The parameters are in scope when checking the constructors.-        dataDef <- bindParameters ps t $ \tel t0 -> do--            -- Parameters are always hidden in constructors-            let 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 [ text "The sort of" <+> prettyTCM name-                          , text "cannot depend on its indices in the type"-                          , prettyTCM t0-                          ]-                  else throwError err-              return s--            -- the small parameters are taken into consideration for --without-K-            smallPars <- smallParams tel s--            reportSDoc "tc.data.sort" 20 $ vcat-              [ text "checking datatype" <+> prettyTCM name-              , nest 2 $ vcat-                [ text "type (parameters instantiated):   " <+> prettyTCM t0-                , text "type (full):   " <+> prettyTCM t-                , text "sort:   " <+> prettyTCM s-                , text "indices:" <+> text (show nofIxs)-                , text "params:"  <+> text (show ps)-                , text "small params:" <+> text (show smallPars)-                ]-              ]--            -- Change the datatype from an axiom to a datatype with no constructors.-            let dataDef = Datatype-                  { dataPars       = npars-                  , dataSmallPars  = Perm npars smallPars-                  , dataNonLinPars = Drop 0 $ Perm npars []-                  , dataIxs        = nofIxs-                  , dataInduction  = Inductive-                  , dataClause     = Nothing-                  , dataCons       = []     -- Constructors are added later-                  , dataSort       = s-                  , dataAbstr      = Info.defAbstract i-                  , dataMutual     = []-                  }--            escapeContext (size tel) $ do-              addConstant name $-                defaultDefn defaultArgInfo name t dataDef-                -- polarity and argOcc.s determined by the positivity checker--            -- Check the types of the constructors-            -- collect the non-linear parameters of each constructor-            nonLins <- mapM (checkConstructor name tel' nofIxs s) cs-            -- compute the ascending list of non-linear parameters of the data type-            let nonLinPars0 = Set.toAscList $ Set.unions $ map Set.fromList nonLins-                -- The constructors are analyzed in the absolute context,-                -- but the data definition happens in the relative module context,-                -- so we apply to the free module variables.-                -- Unfortunately, we lose precision here, since 'abstract', which-                -- is then performed by addConstant, cannot restore the linearity info.-                nonLinPars  = Drop (size freeVars) $ Perm (npars + size freeVars) nonLinPars0--            -- Return the data definition-            return dataDef{ dataNonLinPars = nonLinPars }--        let s      = dataSort dataDef-            cons   = map A.axiomName cs  -- get constructor names--        -- If proof irrelevance is enabled we have to check that datatypes in-        -- Prop contain at most one element.-        do  proofIrr <- proofIrrelevance-            case (proofIrr, s, cs) of-                (True, Prop, _:_:_) -> setCurrentRange cons $-                                         typeError PropMustBeSingleton-                _                   -> return ()--        -- Add the datatype to the signature with its constructors.-        -- It was previously added without them.-        addConstant name $-          defaultDefn defaultArgInfo name t $-            dataDef{ dataCons = cons }--        -- Andreas 2012-02-13: postpone polarity computation until after positivity check-        -- computePolarity name---- | 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 = case ignoreSharing $ unEl t of-  Sort s -> return s-  _      -> do-    s <- newSortMetaBelowInf-    equalType t (sort s)-    return s----- | A parameter is small if its sort fits into the data sort.---   @smallParams@ overapproximates the small parameters (in doubt: small).-smallParams :: Telescope -> Sort -> TCM [Int]-smallParams tel s = do-  -- get the types of the parameters-  let as = map (snd . unDom) $ telToList tel-  -- get the big parameters-  concat <$> do-    forM (zip [0..] as) $ \ (i, a) -> do-      -- A type is small if it is not Level or its sort is <= the data sort.-      -- In doubt (unsolvable constraints), a type is small.-      -- So, only if we have a solid error, the type is big.-      localTCState $ do-        ([] <$ do equalTerm topSort (unEl a) =<< primLevel)  -- NB: if primLevel fails, the next alternative is picked-        <|> ([i] <$ (getSort a `leqSort` s))-        <|> return []-  where-    (<|>) m1 m2 = m1 `catchError_` (const m2)---- | 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.-  -> Telescope     -- ^ Parameter telescope.-  -> Nat           -- ^ Number of indices of the data type.-  -> Sort          -- ^ Sort of the data type.-  -> A.Constructor -- ^ Constructor declaration (type signature).-  -> TCM [Int]     -- ^ Non-linear parameters.-checkConstructor d tel nofIxs s (A.ScopedDecl scope [con]) = do-  setScope scope-  checkConstructor d tel nofIxs s con-checkConstructor d 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"-          _ -> __IMPOSSIBLE__-        -- check that the type of the constructor is well-formed-        t <- isType_ e-        -- check that the type of the constructor ends in the data type-        n <- getContextSize-        -- OLD: n <- size <$> getContextTelescope-        debugEndsIn t d n-        nonLinPars <- constructs n t d-        debugNonLinPars nonLinPars-        -- check which constructor arguments are determined by the type ('forcing')-        t' <- addForcingAnnotations t-        -- 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-        t' `fitsIn` s-        debugAdd c t'--        -- add parameters to constructor type and put into signature-        let con = ConHead c Inductive [] -- data constructors have no projectable fields and are always inductive-        escapeContext (size tel) $-          addConstant c $-            defaultDefn defaultArgInfo c (telePi tel t') $-              Constructor (size tel) con d (Info.defAbstract i) Inductive []--        -- Add the constructor to the instance table, if needed-        when (Info.defInstance i == InstanceDef) $ do-          addNamedInstance c d--        return nonLinPars-  where-    debugEnter c e =-      reportSDoc "tc.data.con" 5 $ vcat-        [ text "checking constructor" <+> prettyTCM c <+> text ":" <+> prettyTCM e-        ]-    debugEndsIn t d n =-      reportSDoc "tc.data.con" 15 $ vcat-        [ sep [ text "checking that"-              , nest 2 $ prettyTCM t-              , text "ends in" <+> prettyTCM d-              ]-        , nest 2 $ text "nofPars =" <+> text (show n)-        ]-    debugNonLinPars xs =-      reportSDoc "tc.data.con" 15 $ text $ "these constructor parameters are non-linear: " ++ show xs-    debugFitsIn s =-      reportSDoc "tc.data.con" 15 $ sep-        [ text "checking that the type fits in"-        , nest 2 $ prettyTCM s-        ]-    debugAdd c t =-      reportSDoc "tc.data.con" 5 $ vcat-        [ text "adding constructor" <+> prettyTCM c <+> text ":" <+> prettyTCM t-        ]-checkConstructor _ _ _ _ _ = __IMPOSSIBLE__ -- constructors are axioms----- | Bind the parameters of a datatype.-bindParameters :: [A.LamBinding] -> Type -> (Telescope -> Type -> TCM a) -> TCM a-bindParameters [] a ret = ret EmptyTel a-bindParameters (A.DomainFull (A.TypedBindings _ (Arg info (A.TBind _ xs _))) : bs) a ret =-  bindParameters (map (mergeHiding . fmap (A.DomainFree info)) xs ++ bs) a ret-bindParameters (A.DomainFull (A.TypedBindings _ (Arg info (A.TLet _ lbs))) : bs) a ret =-  __IMPOSSIBLE__-bindParameters ps0@(A.DomainFree info x : ps) (El _ (Pi arg@(Dom info' a) b)) ret-  -- Andreas, 2011-04-07 ignore relevance information in binding?!-    | argInfoHiding info /= argInfoHiding info' =-        __IMPOSSIBLE__-    | otherwise = addContext' (x, arg) $ bindParameters ps (absBody b) $ \tel s ->-                    ret (ExtendTel arg $ Abs (nameToArgName x) tel) s-bindParameters bs (El s (Shared p)) ret = bindParameters bs (El s $ derefPtr p) ret-bindParameters (b : bs) t _ = __IMPOSSIBLE__-{- Andreas, 2012-01-17 Concrete.Definitions ensures number and hiding of parameters to be correct--- Andreas, 2012-01-13 due to separation of data declaration/definition, the user--- could give more parameters than declared.-bindParameters (b : bs) t _ = typeError $ DataTooManyParameters--}----- | Check that the arguments to a constructor fits inside the sort of the datatype.---   The first argument is the type of the constructor.-fitsIn :: Type -> Sort -> TCM ()-fitsIn t s = do-  reportSDoc "tc.data.fits" 10 $-    sep [ text "does" <+> prettyTCM t-        , text "of sort" <+> prettyTCM (getSort t)-        , text "fit in" <+> prettyTCM s <+> text "?"-        ]-  -- 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-  t <- reduce t-  case ignoreSharing $ unEl t of-    Pi dom b -> do-      withoutK <- optWithoutK <$> pragmaOptions-      -- Forced constructor arguments are ignored in size-checking.-      when (withoutK || notForced (getRelevance dom)) $ do-        sa <- reduce $ getSort dom-        unless (sa == SizeUniv) $ sa `leqSort` s-      addContext (absName b, dom) $ fitsIn (absBody b) (raise 1 s)-    _ -> return () -- getSort t `leqSort` s  -- Andreas, 2013-04-13 not necessary since constructor type ends in data type-  where-    notForced Forced{} = False-    notForced _        = True---- | Return the parameters that share variables with the indices--- nonLinearParameters :: Int -> Type -> TCM [Int]--- nonLinearParameters nPars t =---- | Check that a type constructs something of the given datatype. The first---   argument is the number of parameters to the datatype.------   As a side effect, return the parameters that occur free in indices.---   E.g. in @data Eq (A : Set)(a : A) : A -> Set where refl : Eq A a a@---   this would include parameter @a@, but not @A@.------   TODO: what if there's a meta here?-constructs :: Int -> Type -> QName -> TCM [Int]-constructs nofPars t q = constrT 0 t-    where-{- OLD-        constrT :: Nat -> Type -> TCM ()-        constrT n (El s v) = constr n s v--        constr :: Nat -> Sort -> Term -> TCM ()-        constr n s v = do-            v <- reduce v-            case ignoreSharing v of-                Pi _ (NoAbs _ b) -> constrT n b-                Pi a b           -> underAbstraction a b $ constrT (n + 1)-                Def d vs-                    | d == q -> checkParams n =<< reduce (take nofPars vs)-                                                    -- we only check the parameters-                _ -> bad $ El s v--        bad t = typeError $ ShouldEndInApplicationOfTheDatatype t--}-        constrT :: Nat -> Type -> TCM [Int]-        constrT n t = do-            t <- reduce t-            case ignoreSharing $ unEl t of-                Pi _ (NoAbs _ b)  -> constrT n b-                Pi a b            -> underAbstraction a b $ constrT (n + 1)-                  -- OR: addCxtString (absName b) a $ constrT (n + 1) (absBody b)-                Def d es | d == q -> do-                  let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                  (pars, ixs) <- normalise $ splitAt nofPars vs-                  -- check that the constructor parameters are the data parameters-                  checkParams n pars-                  -- compute the non-linear parameters-                  m <- getContextSize  -- Note: n /= m if NoAbs encountered-                  let nl = nonLinearParams m pars ixs-                  -- assert that these are correct indices into the parameter vector-                  when (any (< 0) nl) __IMPOSSIBLE__-                  when (any (>= nofPars) nl) __IMPOSSIBLE__-                  return nl-                _ -> typeError $ ShouldEndInApplicationOfTheDatatype t--        checkParams n vs = zipWithM_ sameVar vs ps-            where-                nvs = size vs-                ps = genericTake nvs $ downFrom (n + nvs)--                sameVar arg i-                  -- skip irrelevant parameters-                  | isIrrelevant arg = return ()-                  | otherwise = do-                    t <- typeOfBV i-                    equalTerm t (unArg arg) (var i)--        -- return the parameters (numbered 0,1,...,size pars-1 from left to right)-        -- that occur relevantly in the indices-        nonLinearParams n pars ixs =-          -- compute the free de Bruijn indices in the data indices-          -- ALT: Ignore all sorts?-          let fv = allRelevantVarsIgnoring IgnoreInAnnotations ixs-          -- keep relevant ones, convert to de Bruijn levels-          -- note: xs is descending list-              xs = map ((n-1) -) $ VarSet.toList fv-          -- keep those that correspond to parameters-          -- in ascending list-          in  reverse $ filter (< size pars) xs--{- UNUSED, Andreas 2012-09-13--- | Force a type to be a specific datatype.-forceData :: QName -> Type -> TCM Type-forceData d (El s0 t) = liftTCM $ do-    t' <- reduce t-    d  <- canonicalName d-    case ignoreSharing t' of-        Def d' _-            | d == d'   -> return $ El s0 t'-            | otherwise -> fail $ "wrong datatype " ++ show d ++ " != " ++ show d'-        MetaV m vs          -> do-            Defn {defType = t, theDef = Datatype{dataSort = s}} <- getConstInfo d-            ps <- newArgsMeta t-            noConstraints $ leqType (El s0 t') (El s (Def d ps)) -- TODO: need equalType?-            reduce $ El s0 t'-        _ -> typeError $ ShouldBeApplicationOf (El s0 t) d--}---- | Is the type coinductive? Returns 'Nothing' if the answer cannot--- be determined.--isCoinductive :: Type -> TCM (Maybe Bool)-isCoinductive t = do-  El s t <- reduce t-  case ignoreSharing t of-    Def q _ -> do-      def <- getConstInfo q-      case theDef def of-        Axiom       {} -> return (Just False)-        Function    {} -> return Nothing-        Datatype    { dataInduction = CoInductive } -> return (Just True)-        Datatype    { dataInduction = Inductive   } -> return (Just False)-        Record      {  recInduction = Just CoInductive } -> return (Just True)-        Record      {  recInduction = _                } -> return (Just False)-        Constructor {} -> __IMPOSSIBLE__-        Primitive   {} -> __IMPOSSIBLE__-        AbstractDefn{} -> __IMPOSSIBLE__-    Var   {} -> return Nothing-    Lam   {} -> __IMPOSSIBLE__-    Lit   {} -> __IMPOSSIBLE__-    Level {} -> __IMPOSSIBLE__-    Con   {} -> __IMPOSSIBLE__-    Pi    {} -> return (Just False)-    Sort  {} -> return (Just False)-    MetaV {} -> return Nothing-    Shared{} -> __IMPOSSIBLE__-    DontCare{} -> __IMPOSSIBLE__+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Data where++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.+checkIndexSorts :: Sort -> Telescope -> TCM ()+checkIndexSorts s = \case+  EmptyTel -> return ()+  ExtendTel a tel' -> do+    let sa = getSort a+    -- Andreas, 2020-10-19, allow Size indices+    unless (sa == SizeUniv) $ sa `leqSort` s+    underAbstraction a tel' $ checkIndexSorts (raise 1 s)++-- | Return the parameters that share variables with the indices+-- nonLinearParameters :: Int -> Type -> TCM [Int]+-- nonLinearParameters nPars t =++data IsPathCons = PathCons | PointCons+  deriving (Eq,Show)++-- | Check that a type constructs something of the given datatype. The first+--   argument is the number of parameters to the datatype and the second the+--   number of additional non-parameters in the context (1 when generalizing, 0+--   otherwise).+--+constructs :: Int -> Int -> Type -> QName -> TCM IsPathCons+constructs nofPars nofExtraVars t q = constrT nofExtraVars t+    where+        -- The number n counts the proper (non-parameter) constructor arguments.+        constrT :: Nat -> Type -> TCM IsPathCons+        constrT n t = do+            t <- reduce t+            pathV <- pathViewAsPi'whnf+            case unEl t of+                Pi _ (NoAbs _ b)  -> constrT n b+                Pi a b            -> underAbstraction a b $ constrT (n + 1)+                  -- OR: addCxtString (absName b) a $ constrT (n + 1) (absBody b)+                _ | Left ((a,b),_) <- pathV t -> do+                      _ <- case b of+                             NoAbs _ b -> constrT n b+                             b         -> underAbstraction a b $ constrT (n + 1)+                      return PathCons+                Def d es | d == q -> do+                  let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+                  let (pars, ixs) = splitAt nofPars vs+                  -- check that the constructor parameters are the data parameters+                  checkParams n pars+                  return PointCons+                MetaV{} -> do+                  def <- getConstInfo q+                  -- Analyse the type of q (name of the data type)+                  let td = defType def+                  TelV tel core <- telView td+                  -- Construct the parameter arguments+                  -- The parameters are @n + nofPars - 1 .. n@+                  let us = zipWith (\ arg x -> var x <$ arg ) (telToArgs tel) $+                             take nofPars $ downFrom (nofPars + n)+                  -- The indices are fresh metas+                  xs <- newArgsMeta =<< piApplyM td us+                  let t' = El (raise n $ dataSort $ theDef def) $ Def q $ map Apply $ us ++ xs+                  -- Andreas, 2017-11-07, issue #2840+                  -- We should not postpone here, otherwise we might upset the positivity checker.+                  ifM (tryConversion $ equalType t t')+                      (constrT n t')+                      (typeError $ ShouldEndInApplicationOfTheDatatype t)+                _ -> typeError $ ShouldEndInApplicationOfTheDatatype t++        checkParams n vs = zipWithM_ sameVar vs ps+            where+                nvs = length vs+                ps  = reverse $ take nvs [n..]++                sameVar arg i+                  -- skip irrelevant parameters+                  | isIrrelevant arg = return ()+                  | otherwise = do+                    t <- typeOfBV i+                    equalTerm t (unArg arg) (var i)+++-- | Is the type coinductive? Returns 'Nothing' if the answer cannot+-- be determined.++isCoinductive :: Type -> TCM (Maybe Bool)+isCoinductive t = do+  El s t <- reduce t+  case t of+    Def q _ -> do+      def <- getConstInfo q+      case theDef def of+        Axiom       {} -> return (Just False)+        DataOrRecSig{} -> return Nothing+        Function    {} -> return Nothing+        Datatype    {} -> return (Just False)+        Record      {  recInduction = Just CoInductive } -> return (Just True)+        Record      {  recInduction = _                } -> return (Just False)+        GeneralizableVar{} -> __IMPOSSIBLE__+        Constructor {} -> __IMPOSSIBLE__+        Primitive   {} -> __IMPOSSIBLE__+        PrimitiveSort{} -> __IMPOSSIBLE__+        AbstractDefn{} -> __IMPOSSIBLE__+    Var   {} -> return Nothing+    Lam   {} -> __IMPOSSIBLE__+    Lit   {} -> __IMPOSSIBLE__+    Level {} -> __IMPOSSIBLE__+    Con   {} -> __IMPOSSIBLE__+    Pi    {} -> return (Just False)+    Sort  {} -> return (Just False)+    MetaV {} -> return Nothing+    DontCare{} -> __IMPOSSIBLE__+    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s
+ 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,1009 +1,1183 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.Rules.Decl where--import Prelude hiding (null)--import Control.Monad-import Control.Monad.Reader-import Control.Monad.State (modify, gets, get)-import Control.Monad.Writer (tell)--import Data.Either (partitionEithers)-import qualified Data.Foldable as Fold-import Data.List (genericLength)-import Data.Maybe-import Data.Map (Map)-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import Data.Set (Set)--import Agda.Compiler.HaskellTypes-import Agda.Compiler.UHC.Pragmas.Parse-import Agda.Interaction.Options-import Agda.Interaction.Highlighting.Generate--import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views (deepUnscopeDecl, deepUnscopeDecls)-import Agda.Syntax.Internal-import qualified Agda.Syntax.Reflected as R-import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Position-import Agda.Syntax.Common-import Agda.Syntax.Literal-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Translation.ReflectedToAbstract--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import qualified Agda.TypeChecking.Monad.Benchmark as Bench--import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Errors-import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Positivity-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Polarity-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.ProjectionLike-import Agda.TypeChecking.Quote-import Agda.TypeChecking.Unquote-import Agda.TypeChecking.Records-import Agda.TypeChecking.RecordPatterns-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Rewriting-import Agda.TypeChecking.SizedTypes.Solve-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Unquote--import Agda.TypeChecking.Rules.Term-import Agda.TypeChecking.Rules.Data    ( checkDataDef )-import Agda.TypeChecking.Rules.Record  ( checkRecDef )-import Agda.TypeChecking.Rules.Def     ( checkFunDef, newSection, useTerPragma )-import Agda.TypeChecking.Rules.Builtin-import Agda.TypeChecking.Rules.Display ( checkDisplayPragma )--import Agda.Termination.TermCheck--import Agda.Utils.Except-import Agda.Utils.Functor-import Agda.Utils.Function-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible---- | Cached checkDecl-checkDeclCached :: A.Declaration -> TCM ()-checkDeclCached d@A.ScopedDecl{} = checkDecl d-checkDeclCached d@(A.Section minfo mname tbinds _) = do-  e <- readFromCachedLog-  reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)-  case e of-    Just (EnterSection minfo' mname' tbinds', _)-      | killRange minfo == killRange minfo' && mname == mname' && tbinds == tbinds' -> do-        return ()-    _ -> do-      cleanCachedLog-  writeToCurrentLog $ EnterSection minfo mname tbinds-  checkDecl d-  e' <- readFromCachedLog-  case e' of-    Just (LeaveSection mname', _) | mname == mname' -> do-      return ()-    _ -> do-      cleanCachedLog-  writeToCurrentLog $ LeaveSection mname--checkDeclCached d = do-    e <- readFromCachedLog--    reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)--    case e of-      (Just (Decl d',s)) | compareDecl d d' -> do-        restorePostScopeState s-        reportSLn "cache.decl" 50 $ "range: " ++ show (getRange d)-        printSyntaxInfo (getRange d)-      _ -> do-        cleanCachedLog-        checkDeclWrap d-    writeToCurrentLog $ Decl d- where-   compareDecl A.Section{} A.Section{} = __IMPOSSIBLE__-   compareDecl A.ScopedDecl{} A.ScopedDecl{} = __IMPOSSIBLE__-   compareDecl x y = x == y-   -- changes to CS inside a RecDef or Mutual ought not happen,-   -- but they do happen, so we discard them.-   ignoreChanges m = do-     cs <- gets $ stLoadedFileCache . stPersistentState-     cleanCachedLog-     _ <- m-     modifyPersistentState $ \st -> st{stLoadedFileCache = cs}-   checkDeclWrap d@A.RecDef{} = ignoreChanges $ checkDecl d-   checkDeclWrap d@A.Mutual{} = ignoreChanges $ checkDecl d-   checkDeclWrap d            = checkDecl d---- | Type check a sequence of declarations.-checkDecls :: [A.Declaration] -> TCM ()-checkDecls ds = do-  reportSLn "tc.decl" 45 $ "Checking " ++ show (length ds) ++ " declarations..."-  mapM_ checkDecl ds-  -- Andreas, 2011-05-30, unfreezing moved to Interaction/Imports-  -- whenM onTopLevel unfreezeMetas---- | Type check a single declaration.--checkDecl :: A.Declaration -> TCM ()-checkDecl d = setCurrentRange d $ do-    reportSDoc "tc.decl" 10 $ text "checking declaration"-    debugPrintDecl d-    reportSDoc "tc.decl" 90 $ (text . show) (deepUnscopeDecl d)-    reportSDoc "tc.decl" 10 $ prettyA d  -- Might loop, see e.g. Issue 1597--    -- Issue 418 fix: freeze metas before checking an abstract thing-    -- when_ isAbstract freezeMetas -- WAS IN PLACE 2012-2016, but too crude-    -- applyWhen isAbstract withFreezeMetas $ do -- WRONG--    let -- What kind of final checks/computations should be performed-        -- if we're not inside a mutual block?-        none        m = m $>  Nothing           -- skip all checks-        meta        m = m $>  Just (return ())  -- do the usual checks-        mutual i ds m = m <&> Just . uncurry (mutualChecks i d ds)-        impossible  m = m $>  __IMPOSSIBLE__-                        -- We're definitely inside a mutual block.--    finalChecks <- case d of-      A.Axiom{}                -> meta $ checkTypeSignature d-      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 i x tel ds     -> meta $ checkSection i 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.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.DataDef i x ps cs      -> impossible $ check x i $ checkDataDef i x ps cs-      A.RecDef i x ind eta c ps tel cs -> mutual empty [d] $ check x i $ do-                                    checkRecDef i x ind eta c ps tel cs-                                    blockId <- mutualBlockOf x--                                    -- Andreas, 2016-10-01 testing whether-                                    -- envMutualBlock is set correctly.-                                    -- Apparently not.-                                    verboseS "tc.decl.mutual" 70 $ do-                                      current <- asks envMutualBlock-                                      unless (Just blockId == current) $ do-                                        reportSLn "" 0 $ unlines-                                          [ "mutual block id discrepancy for " ++ show x-                                          , "  current    mut. bl. = " ++ show current-                                          , "  calculated mut. bl. = " ++ show blockId-                                          ]--                                    return (blockId, Set.singleton x)-      A.DataSig i x ps t       -> impossible $ checkSig i x ps t-      A.RecSig i x ps t        -> none $ checkSig i x ps t-                                  -- A record signature is always followed by a-                                  -- record definition. Metas should not be-                                  -- frozen until after the definition has been-                                  -- checked. NOTE: Metas are not frozen-                                  -- immediately after the last field. Perhaps-                                  -- they should be (unless we're in a mutual-                                  -- block).-      A.Open{}                 -> none $ return ()-      A.PatternSynDef{}        -> none $ return ()-                                  -- Open and PatternSynDef are just artifacts-                                  -- from the concrete syntax, retained for-                                  -- highlighting purposes.-      A.UnquoteDecl mi i x e   -> checkUnquoteDecl mi i x e-      A.UnquoteDef i x e       -> impossible $ checkUnquoteDef i x e--    whenNothingM (asks envMutualBlock) $ do--      -- Syntax highlighting.-      highlight_ d--      -- Post-typing checks.-      whenJust finalChecks $ \ theMutualChecks -> do-        checkingWhere <- asks envCheckingWhere-        solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty-        wakeupConstraints_   -- solve emptiness constraints-        _ <- freezeMetas-        theMutualChecks--    where--    -- check record or data type signature-    checkSig i x ps t = checkTypeSignature $-      A.Axiom A.NoFunSig i defaultArgInfo Nothing x-              (A.Pi (Info.ExprRange (fuseRange ps t)) ps t)--    check x i m = do-      reportSDoc "tc.decl" 5 $ text "Checking" <+> prettyTCM x <> text "."-      reportSLn "tc.decl.abstract" 25 $ show (Info.defAbstract i)-      r <- abstract (Info.defAbstract i) m-      reportSDoc "tc.decl" 5 $ text "Checked" <+> prettyTCM x <> text "."-      return r--    isAbstract = fmap Info.defAbstract (A.getDefInfo d) == Just AbstractDef--    -- Concrete definitions cannot use information about abstract things.-    abstract ConcreteDef = inConcreteMode-    abstract AbstractDef = inAbstractMode---- Some checks that should be run at the end of a mutual--- block (or non-mutual record declaration). The set names--- contains the names defined in the mutual block.-mutualChecks :: Info.MutualInfo -> A.Declaration -> [A.Declaration] -> MutualId -> Set QName -> TCM ()-mutualChecks mi d ds mid names = do-  -- Andreas, 2014-04-11: instantiate metas in definition types-  let nameList = Set.toList names-  mapM_ instantiateDefinitionType nameList-  -- Andreas, 2013-02-27: check termination before injectivity,-  -- to avoid making the injectivity checker loop.-  local (\ e -> e { envMutualBlock = Just mid }) $ checkTermination_ d-  checkPositivity_         mi names-  revisitRecordPatternTranslation nameList -- Andreas, 2016-11-19 issue #2308-  -- Andreas, 2015-03-26 Issue 1470:-  -- Restricting coinduction to recursive does not solve the-  -- actual problem, and prevents interesting sound applications-  -- of sized types.-  -- checkCoinductiveRecords  ds-  -- Andreas, 2012-09-11:  Injectivity check stores clauses-  -- whose 'Relevance' is affected by polarity computation,-  -- so do it here (again).-  -- Andreas, 2015-07-01:  In particular, 'UnusedArg's of local functions-  -- are only recognized after the polarity computation.-  -- See Issue 1366 for an example where injectivity of a local function-  -- is used to solve metas.  It fails if we do injectivity analysis-  -- before polarity only.-  checkInjectivity_        names-  checkProjectionLikeness_ names---- | Check if there is a inferred eta record type in the mutual block.---   If yes, repeat the record pattern translation for all function definitions---   in the block.---   This is necessary since the original record pattern translation will---   have skipped record patterns of the new record types (as eta was off for them).---   See issue #2308 (and #2197).-revisitRecordPatternTranslation :: [QName] -> TCM ()-revisitRecordPatternTranslation qs = do-  -- rs: inferred eta record types of this mutual block-  -- qccs: compiled clauses of definitions-  (rs, qccs) <- partitionEithers . catMaybes <$> mapM classify qs-  unless (null rs) $ forM_ qccs $ \(q,cc) -> do-    cc <- translateCompiledClauses cc-    modifySignature $ updateDefinition q $ updateTheDef $-      updateCompiledClauses $ const $ Just cc-  where-  -- Walk through the definitions and return the set of inferred eta record types-  -- and the set of function definitions in the mutual block-  classify q = inConcreteOrAbstractMode q $ \ def -> do-    case theDef def of-      Record{ recEtaEquality' = Inferred True } -> return $ Just $ Left q-      Function{ funCompiled = Just cc } -> return $ Just $ Right (q, cc)-      _ -> return Nothing--type FinalChecks = Maybe (TCM ())--checkUnquoteDecl :: Info.MutualInfo -> [Info.DefInfo] -> [QName] -> A.Expr -> TCM FinalChecks-checkUnquoteDecl mi is xs e = do-  reportSDoc "tc.unquote.decl" 20 $ text "Checking unquoteDecl" <+> sep (map prettyTCM xs)-  Nothing <$ unquoteTop xs e--checkUnquoteDef :: [Info.DefInfo] -> [QName] -> A.Expr -> TCM ()-checkUnquoteDef _ xs e = do-  reportSDoc "tc.unquote.decl" 20 $ text "Checking unquoteDef" <+> sep (map prettyTCM xs)-  () <$ unquoteTop xs e---- | Run a reflected TCM computatation expected to define a given list of---   names.-unquoteTop :: [QName] -> A.Expr -> TCM [QName]-unquoteTop xs e = do-  tcm   <- primAgdaTCM-  unit  <- primUnit-  lzero <- primLevelZero-  let vArg = defaultArg-      hArg = setHiding Hidden . vArg-  m    <- checkExpr e $ El (mkType 0) $ apply tcm [hArg lzero, vArg unit]-  res  <- runUnquoteM $ tell xs >> evalTCM m-  case res of-    Left err      -> typeError $ UnquoteFailed err-    Right (_, xs) -> return xs---- | Instantiate all metas in 'Definition' associated to 'QName'.---   Makes sense after freezing metas. Some checks, like free variable---   analysis, are not in 'TCM', so they will be more precise (see issue 1099)---   after meta instantiation.---   Precondition: name has been added to signature already.-instantiateDefinitionType :: QName -> TCM ()-instantiateDefinitionType q = do-  reportSLn "tc.decl.inst" 20 $ "instantiating type of " ++ show q-  sig <- getSignature-  let t = defType $ fromMaybe __IMPOSSIBLE__ $ lookupDefinition q sig-  t <- instantiateFull t-  modifySignature $ updateDefinition q $ \ def -> def { defType = t }---- Andreas, 2014-04-11--- UNUSED, costs a couple of sec on the std-lib--- -- | Instantiate all metas in 'Definition' associated to 'QName'.--- --   Makes sense after freezing metas.--- --   Some checks, like free variable analysis, are not in 'TCM',--- --   so they will be more precise (see issue 1099) after meta instantiation.--- ----- --   Precondition: name has been added to signature already.--- instantiateDefinition :: QName -> TCM ()--- instantiateDefinition q = do---   reportSLn "tc.decl.inst" 20 $ "instantiating " ++ show q---   sig <- getSignature---   let def = fromMaybe __IMPOSSIBLE__ $ lookupDefinition q sig---   def <- instantiateFull def---   modifySignature $ updateDefinition q $ const def---- | Highlight a declaration.-highlight_ :: A.Declaration -> TCM ()-highlight_ d = do-  let highlight d = generateAndPrintSyntaxInfo d Full-  Bench.billTo [Bench.Highlighting] $ case d of-    A.Axiom{}                -> highlight d-    A.Field{}                -> __IMPOSSIBLE__-    A.Primitive{}            -> highlight d-    A.Mutual i ds            -> mapM_ highlight_ $ deepUnscopeDecls ds-    A.Apply{}                -> highlight d-    A.Import{}               -> highlight d-    A.Pragma{}               -> highlight d-    A.ScopedDecl{}           -> return ()-    A.FunDef{}               -> highlight d-    A.DataDef{}              -> highlight d-    A.DataSig{}              -> highlight d-    A.Open{}                 -> highlight d-    A.PatternSynDef{}        -> highlight d-    A.UnquoteDecl{}          -> highlight d-    A.UnquoteDef{}           -> highlight d-    A.Section i x tel _      -> highlight (A.Section i x tel [])-      -- Each block in the section has already been highlighted,-      -- all that remains is the module declaration.-    A.RecSig{}               -> highlight d-    A.RecDef i x ind eta c ps tel cs ->-      highlight (A.RecDef i x ind eta c [] dummy (fields cs))-      -- The telescope and all record module declarations except-      -- for the fields have already been highlighted.-      where-      fields (A.ScopedDecl _ ds1 : ds2) = fields ds1 ++ fields ds2-      fields (d@A.Field{}        : ds)  = d : fields ds-      fields (_                  : ds)  = fields ds-      fields []                         = []-      -- Andreas, 2016-01-22, issue 1791-      -- The expression denoting the record constructor type-      -- is replace by a dummy expression in order to /not/-      -- generate highlighting from it.-      -- Simply because all the highlighting info is wrong-      -- in the record constructor type:-      -- * fields become bound variables,-      -- * declarations become let-bound variables.-      -- We do not need that crap.-      dummy = A.Lit $ LitString noRange $-        "do not highlight construct(ed/or) type"---- | Termination check a declaration.-checkTermination_ :: A.Declaration -> TCM ()-checkTermination_ d = Bench.billTo [Bench.Termination] $ do-  reportSLn "tc.decl" 20 $ "checkDecl: checking termination..."-  case d of-      -- Record module definitions should not be termination-checked twice.-      A.RecDef {} -> return ()-      _ -> disableDestructiveUpdate $ do-        termErrs <- termDecl d-        -- If there are some termination errors, we collect them in-        -- the state.-        -- The termination checker already marked non-terminating functions as such.-        unless (null termErrs) $ do-          warning $ TerminationIssue termErrs---- | Check a set of mutual names for positivity.-checkPositivity_ :: Info.MutualInfo -> Set QName -> TCM ()-checkPositivity_ mi names = Bench.billTo [Bench.Positivity] $ do-  -- Positivity checking.-  reportSLn "tc.decl" 20 $ "checkDecl: checking positivity..."-  checkStrictlyPositive mi names--  -- Andreas, 2012-02-13: Polarity computation uses info from-  -- positivity check, so it needs happen after positivity-  -- check.-  mapM_ 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 (Just (Ranged r CoInductive)) _ _ _ _ _ -> 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-  reportSLn "tc.decl" 20 $ "checkDecl: checking injectivity..."-  -- Andreas, 2015-07-01, see Issue1366b:-  -- Injectivity check needs also to be run for abstract definitions.-  -- Fold.forM_ names $ \ q -> ignoreAbstractMode $ do -- NOT NECESSARY after all-  Fold.forM_ names $ \ q -> inConcreteOrAbstractMode q $ \ def -> do-    -- For abstract q, we should be inAbstractMode,-    -- otherwise getConstInfo returns Axiom.-    ---    -- Andreas, 2015-07-01:-    -- Quite surprisingly, inAbstractMode does not allow us to look-    -- at a local definition (@where@ block) of an abstract definition.-    -- This is because the local definition is defined in a strict submodule.-    -- We can only see through abstract definitions in the current module-    -- or super modules inAbstractMode.-    -- I changed that in Monad.Signature.treatAbstractly', so we can see-    -- our own local definitions.-    case theDef def of-      d@Function{ funClauses = cs, funTerminates = term } -> do-        case term of-          Just True -> do-            inv <- checkInjectivity q cs-            modifySignature $ updateDefinition q $ const $-              def { theDef = d { funInv = inv }}-          _ -> reportSLn "tc.inj.check" 20 $-             show q ++ " is not verified as terminating, thus, not considered for injectivity"-      _ -> do-        abstr <- asks envAbstractMode-        reportSLn "tc.inj.check" 20 $-          "we are in " ++ show abstr ++ " and " ++-             show q ++ " is abstract or not a function, thus, not considered for injectivity"---- | Check a set of mutual names for projection likeness.------   Only a single, non-abstract function can be projection-like.---   Making an abstract function projection-like would break the---   invariant that the type of the principle argument of a projection-like---   function is always inferable.--checkProjectionLikeness_ :: Set QName -> TCM ()-checkProjectionLikeness_ names = Bench.billTo [Bench.ProjectionLikeness] $ do-      -- Non-mutual definitions can be considered for-      -- projection likeness-      let ds = Set.toList names-      reportSLn "tc.proj.like" 20 $ "checkDecl: checking projection-likeness of " ++ show ds-      case ds of-        [d] -> do-          def <- getConstInfo d-          -- For abstract identifiers, getConstInfo returns Axiom.-          -- Thus, abstract definitions are not considered for projection-likeness.-          case theDef def of-            Function{} -> makeProjection (defName def)-            _          -> reportSLn "tc.proj.like" 25 $-              show d ++ " is abstract or not a function, thus, not considered for projection-likeness"-        _ -> reportSLn "tc.proj.like" 25 $-               "mutual definitions are not considered for projection-likeness"---- | Freeze metas created by given computation if in abstract mode.-whenAbstractFreezeMetasAfter :: Info.DefInfo -> TCM a -> TCM a-whenAbstractFreezeMetasAfter Info.DefInfo{ defAccess, defAbstract} m = do-  let pubAbs = defAccess == PublicAccess && defAbstract == AbstractDef-  if not pubAbs then m else do-    (a, ms) <- metasCreatedBy m-    xs <- freezeMetas' $ (`Set.member` ms)-    reportSDoc "tc.decl.ax" 20 $ vcat-      [ text "Abstract type signature produced new metas: " <+> sep (map prettyTCM $ Set.toList ms)-      , text "We froze the following ones of these:       " <+> sep (map prettyTCM xs)-      ]-    return a---- | Type check an axiom.-checkAxiom :: A.Axiom -> Info.DefInfo -> ArgInfo ->-              Maybe [Occurrence] -> QName -> A.Expr -> TCM ()-checkAxiom funSig i info0 mp x e = whenAbstractFreezeMetasAfter i $ do-  -- Andreas, 2016-07-19 issues #418 #2102:-  -- We freeze metas in type signatures of abstract definitions, to prevent-  -- leakage of implementation details.--  -- Andreas, 2012-04-18  if we are in irrelevant context, axioms is irrelevant-  -- even if not declared as such (Issue 610).-  rel <- max (getRelevance info0) <$> asks envRelevance-  let info = setRelevance rel info0-  -- rel <- ifM ((Irrelevant ==) <$> asks envRelevance) (return Irrelevant) (return rel0)-  t <- workOnTypes $ isType_ e-  reportSDoc "tc.decl.ax" 10 $ sep-    [ text $ "checked type signature"-    , nest 2 $ prettyTCM rel <> prettyTCM x <+> text ":" <+> prettyTCM t-    , nest 2 $ text "of sort " <+> prettyTCM (getSort t)-    ]--  -- Andreas, 2015-03-17 Issue 1428: Do not postulate sizes in parametrized-  -- modules!-  when (funSig == A.NoFunSig) $ do-    whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do-      whenM ((> 0) <$> getContextSize) $ do-        typeError $ GenericError $ "We don't like postulated sizes in parametrized modules."--  -- 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 = genericLength (telToList tel)-      when (n < genericLength occs) $-        typeError $ TooManyPolarities x n-      let pols = map polFromOcc occs-      reportSLn "tc.polarity.pragma" 10 $-        "Setting occurrences and polarity for " ++ show x ++ ":\n  " ++-        show occs ++ "\n  " ++ show pols-      return (occs, pols)--  -- Not safe. See Issue 330-  -- t <- addForcingAnnotations t-  addConstant x =<< do-    useTerPragma $-      (defaultDefn info x t $-         case funSig of-           A.FunSig   -> set funMacro (Info.defMacro i == MacroDef) emptyFunction-           A.NoFunSig -> Axiom)   -- NB: used also for data and record type sigs-        { defArgOccurrences = occs-        , defPolarity       = pols-        }--  -- Add the definition to the instance table, if needed-  when (Info.defInstance i == InstanceDef) $ do-    addTypedInstance x t--  traceCall (IsType_ e) $ do -- need Range for error message-    -- Andreas, 2016-06-21, issue #2054-    -- Do not default size metas to ∞ in local type signatures-    checkingWhere <- asks envCheckingWhere-    solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty--  -- Andreas, 2011-05-31, that freezing below is probably wrong:-  -- when_ (Info.defAbstract i == AbstractDef) $ freezeMetas---- | Type check a primitive function declaration.-checkPrimitive :: Info.DefInfo -> QName -> A.Expr -> TCM ()-checkPrimitive i x e =-    traceCall (CheckPrimitive (getRange i) (qnameName x) e) $ do  -- TODO!! (qnameName)-    (name, PrimImpl t' pf) <- lookupPrimitiveFunctionQ x-    -- Primitive functions on nats are BUILTIN not 'primitive'-    let builtinPrimitives =-          [ "primNatPlus", "primNatMinus" , "primNatTimes"-          , "primNatDivSucAux", "primNatModSucAux"-          , "primNatEquality", "primNatLess" ]-    when (elem name builtinPrimitives) $ typeError $ NoSuchPrimitiveFunction name-    t <- isType_ e-    noConstraints $ equalType t t'-    let s  = prettyShow $ qnameName x-    bindPrimitive s pf-    addConstant x $-      defaultDefn defaultArgInfo x t $-        Primitive (Info.defAbstract i) s [] Nothing--assertCurrentModule :: QName -> String -> TCM ()-assertCurrentModule x err =-  do def <- getConstInfo x-     m <- currentModule-     let m' = qnameModule $ defName def-     unless (m == m') $ typeError $ GenericError err---- | Check a pragma.-checkPragma :: Range -> A.Pragma -> TCM ()-checkPragma r p =-    traceCall (CheckPragma r p) $ case p of-        A.BuiltinPragma x e -> bindBuiltin x e-        A.BuiltinNoDefPragma b x -> bindBuiltinNoDef b x-        A.RewritePragma q   -> addRewriteRule q-        A.CompiledDeclareDataPragma x hs -> do-          def <- getConstInfo x-          assertCurrentModule x $-              "COMPILED_DECLARE_DATA directives must appear in the same module " ++-              "as their corresponding datatype definition,"-          case theDef def of-            Datatype{} -> addHaskellType x hs-            Axiom{}    -> -- possible when the data type has only been declared yet-              addHaskellType x hs-            _          -> typeError $ GenericError-                          "COMPILED_DECLARE_DATA directive only works on data types"-        A.CompiledTypePragma x hs -> do-          def <- getConstInfo x-          case theDef def of-            Axiom{} -> addHaskellType x hs-            _       -> typeError $ GenericError-                        "COMPILED_TYPE directive only works on postulates"-        A.CompiledDataPragma x hs hcs -> do-          def <- getConstInfo x-          -- Check that the pragma appears in the same module-          -- as the datatype.-          assertCurrentModule x $-              "COMPILED_DATA directives must appear in the same module " ++-              "as their corresponding datatype definition,"-          let addCompiledData cs = do-                addHaskellType x hs-                let computeHaskellType c = do-                      def <- getConstInfo c-                      let Constructor{ conPars = np } = theDef def-                          underPars 0 a = haskellType a-                          underPars n a = do-                            a <- reduce a-                            case unEl a of-                              Pi a (NoAbs _ b) -> underPars (n - 1) b-                              Pi a b  -> underAbstraction a b $ \b -> hsForall <$> getHsVar 0 <*> underPars (n - 1) b-                              _       -> __IMPOSSIBLE__-                      ty <- underPars np $ defType def-                      reportSLn "tc.pragma.compile" 10 $ "Haskell type for " ++ show c ++ ": " ++ ty-                      return ty-                hts <- mapM computeHaskellType cs-                sequence_ $ zipWith3 addHaskellCode cs hts hcs-          case theDef def of-            Datatype{dataCons = cs}-              | length cs /= length hcs -> do-                  let n_forms_are = case length hcs of-                        1 -> "1 compiled form is"-                        n -> show n ++ " compiled forms are"-                      only | null hcs               = ""-                           | length hcs < length cs = "only "-                           | otherwise              = ""--                  err <- fsep $ [prettyTCM x] ++ pwords ("has " ++ show (length cs) ++-                                " constructors, but " ++ only ++ n_forms_are ++ " given [" ++ unwords hcs ++ "]")-                  typeError $ GenericError $ show err-              | otherwise -> addCompiledData cs-            Record{recConHead = ch}-              | length hcs == 1 -> addCompiledData [conName ch]-              | otherwise -> do-                  err <- fsep $ [prettyTCM x] ++ pwords ("has 1 constructor, but " ++-                                show (length hcs) ++ " Haskell constructors are given [" ++ unwords hcs ++ "]")-                  typeError $ GenericError $ show err-            _ -> typeError $ GenericError "COMPILED_DATA on non datatype"-        A.CompiledPragma x hs -> do-          def <- getConstInfo x-          case theDef def of-            Axiom{} -> do-              ty <- haskellType $ defType def-              reportSLn "tc.pragma.compile" 10 $ "Haskell type for " ++ show x ++ ": " ++ ty-              addHaskellCode x ty hs-            _   -> typeError $ GenericError "COMPILED directive only works on postulates"-        A.CompiledExportPragma x hs -> do-          def <- getConstInfo x-          let correct = case theDef def of-                            -- Axiom{} -> do-                            --   ty <- haskellType $ defType def-                            --   reportSLn "tc.pragma.compile" 10 $ "Haskell type for " ++ show x ++ ": " ++ ty-                            --   addHaskellCode x ty hs-                            Function{} -> True-                            Constructor{} -> False-                            _   -> False-          if not correct-            then typeError $ GenericError "COMPILED_EXPORT directive only works on functions"-            else do-              ty <- haskellType $ defType def-              addHaskellExport x ty hs-        A.CompiledEpicPragma x ep -> do-          def <- getConstInfo x-          case theDef def of-            Axiom{} -> do-              --ty <- haskellType $ defType def-              --reportSLn "tc.pragma.compile" 10 $ "Haskell type for " ++ show x ++ ": " ++ ty-              addEpicCode x ep-            _   -> typeError $ GenericError "COMPILED_EPIC directive only works on postulates"-        A.CompiledJSPragma x ep ->-          addJSCode x ep-        A.CompiledUHCPragma x cr -> do-          def <- getConstInfo x-          case theDef def of-            Axiom{} -> case parseCoreExpr cr of-                    Left msg -> typeError $ GenericError $ "Could not parse COMPILED_UHC pragma: " ++ msg-                    Right cr -> addCoreCode x cr-            _ -> typeError $ GenericError "COMPILED_UHC directive only works on postulates" -- only allow postulates for the time being-        A.CompiledDataUHCPragma x crd crcs -> do-          -- TODO mostly copy-paste from the CompiledDataPragma, should be refactored into a seperate function-          def <- getConstInfo x-          -- Check that the pragma appears in the same module-          -- as the datatype.-          m <- currentModule-          let m' = qnameModule $ defName def-          unless (m == m') $ typeError $ GenericError $-              "COMPILED_DATA_UHC directives must appear in the same module " ++-              "as their corresponding datatype definition,"-          case theDef def of-            Datatype{dataCons = cs}-              | length cs /= length crcs -> do-                  let n_forms_are = case length crcs of-                        1 -> "1 compiled form is"-                        n -> show n ++ " compiled forms are"-                      only | null crcs               = ""-                           | length crcs < length cs = "only "-                           | otherwise               = ""--                  err <- fsep $ [prettyTCM x] ++ pwords ("has " ++ show (length cs) ++-                                " constructors, but " ++ only ++ n_forms_are ++ " given [" ++ unwords crcs ++ "]")-                  typeError $ GenericError $ show err-              | otherwise -> do-                -- Remark: core pragmas are not type-checked-                dt' <- parseCoreData crd-                cons' <- parseCoreConstrs dt' crcs-                addCoreType x dt'-                sequence_ $ zipWith addCoreConstr cs cons'-            _ -> typeError $ GenericError "COMPILED_DATA_UHC on non datatype"-        A.StaticPragma x -> do-          def <- getConstInfo x-          case theDef def of-            Function{} -> markStatic x-            _          -> typeError $ GenericError "STATIC directive only works on functions"-        A.InlinePragma x -> do-          def <- getConstInfo x-          case theDef def of-            Function{} -> markInline x-            _          -> typeError $ GenericError "INLINE directive only works on functions"-        A.OptionsPragma{} -> typeError $ GenericError $ "OPTIONS pragma only allowed at beginning of file, before top module declaration"-        A.DisplayPragma f ps e -> checkDisplayPragma f ps e---- | Type check a bunch of mutual inductive recursive definitions.------ All definitions which have so far been assigned to the given mutual--- block are returned.-checkMutual :: Info.MutualInfo -> [A.Declaration] -> TCM (MutualId, Set QName)-checkMutual i ds = inMutualBlock $ \ blockId -> do--  verboseS "tc.decl.mutual" 20 $ do-    reportSDoc "tc.decl.mutual" 20 $ vcat $-      (text "Checking mutual block" <+> text (show blockId) <> text ":") :-      map (nest 2 . prettyA) ds--  insertMutualBlockInfo blockId i-  local (\e -> e { envTerminationCheck = () <$ Info.mutualTermCheck i }) $-    mapM_ checkDecl ds--  (blockId, ) . mutualNames <$> lookupMutualBlock blockId---- | Type check the type signature of an inductive or recursive definition.-checkTypeSignature :: A.TypeSignature -> TCM ()-checkTypeSignature (A.ScopedDecl scope ds) = do-  setScope scope-  mapM_ checkTypeSignature ds-checkTypeSignature (A.Axiom funSig i info mp x e) =-  Bench.billTo [Bench.Typing, Bench.TypeSig] $-    let abstr = case Info.defAccess i of-          PrivateAccess{}-            | Info.defAbstract i == AbstractDef -> inAbstractMode-              -- Issue #2321, only go to AbstractMode for abstract definitions-            | otherwise -> inConcreteMode-          PublicAccess  -> inConcreteMode-          OnlyQualified -> __IMPOSSIBLE__-    in abstr $ checkAxiom funSig i info mp x e-checkTypeSignature _ = __IMPOSSIBLE__   -- type signatures are always axioms----- | Type check a module.--checkSection :: Info.ModuleInfo -> ModuleName -> A.Telescope -> [A.Declaration] -> TCM ()-checkSection _ x tel ds = newSection x tel $ mapM_ checkDeclCached ds----- | Helper for 'checkSectionApplication'.------   Matches the arguments of the module application with the---   module parameters.------   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.-  -> Telescope            -- ^ The module parameters.-  -> [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--    check tel []             = return tel-    check EmptyTel (_:_)     = bad-    check (ExtendTel (Dom info _) btel) args0@(Arg info' (Named rname _) : args) =-      let name = fmap rangedThing rname-          y    = absName btel-          tel  = absBody btel in-      case (argInfoHiding info, argInfoHiding info', name) of-        (Instance, NotHidden, _) -> check tel args0-        (Instance, Hidden, _)    -> check tel args0-        (Instance, Instance, Nothing) -> check tel args-        (Instance, Instance, Just x)-          | x == y                -> check tel args-          | otherwise             -> check tel args0-        (Hidden, NotHidden, _)    -> check tel args0-        (Hidden, Instance, _)     -> check tel args0-        (Hidden, Hidden, Nothing) -> check tel args-        (Hidden, Hidden, Just x)-          | x == y                -> check tel args-          | otherwise             -> check tel args0-        (NotHidden, NotHidden, _) -> check tel args-        (NotHidden, Hidden, _)    -> bad-        (NotHidden, Instance, _)    -> bad---- | Check an application of a section (top-level function, includes @'traceCall'@).-checkSectionApplication-  :: Info.ModuleInfo-  -> 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 modapp copyInfo =-  traceCall (CheckSectionApplication (getRange i) m1 modapp) $-  checkSectionApplication' i m1 modapp copyInfo---- | Check an application of a section.-checkSectionApplication'-  :: Info.ModuleInfo-  -> 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-  -- Module applications can appear in lets, in which case we treat-  -- lambda-bound variables as additional parameters to the module.-  extraParams <- do-    mfv <- getCurrentModuleFreeVars-    fv  <- size <$> getContextTelescope-    return (fv - mfv)-  when (extraParams > 0) $ reportSLn "tc.mod.apply" 30 $ "Extra parameters to " ++ show m1 ++ ": " ++ show extraParams-  -- Type-check the LHS (ptel) of the module macro.-  checkTelescope ptel $ \ ptel -> do-    -- We are now in the context @ptel@.-    -- Get the correct parameter telescope of @m2@.-    tel <- lookupSection m2-    vs  <- freeVarsToApply $ mnameToQName m2-    let tel'  = apply tel vs-    -- Compute the remaining parameter telescope after stripping of-    -- the initial parameters that are determined by the @args@.-    -- Warning: @etaTel@ is not well-formed in @ptel@, since-    -- the actual application has not happened.-    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-      [ text "applying section" <+> prettyTCM m2-      , nest 2 $ text "args =" <+> sep (map prettyA args)-      , nest 2 $ text "ptel =" <+> escapeContext (size ptel) (prettyTCM ptel)-      , nest 2 $ text "tel  =" <+> prettyTCM tel-      , nest 2 $ text "tel' =" <+> prettyTCM tel'-      , nest 2 $ text "tel''=" <+> prettyTCM tel''-      , nest 2 $ text "eta  =" <+> escapeContext (size ptel) (addContext tel'' $ prettyTCM etaTel)-      ]-    -- Now, type check arguments.-    ts <- (noConstraints $ checkArguments_ DontExpandLast (getRange i) args tel') >>= \case-      (ts, etaTel') | (size etaTel == size etaTel') -> return ts-      _ -> __IMPOSSIBLE__-    -- Perform the application of the module parameters.-    let aTel = tel' `apply` ts-    reportSDoc "tc.mod.apply" 15 $ vcat-      [ nest 2 $ text "aTel =" <+> prettyTCM aTel-      ]-    -- Andreas, 2014-04-06, Issue 1094:-    -- Add the section with well-formed telescope.-    addContext aTel $ do-      reportSDoc "tc.mod.apply" 80 $-        text "addSection" <+> prettyTCM m1 <+> (getContextTelescope >>= \ tel -> inTopContext (prettyTCM tel))-      addSection m1--    reportSDoc "tc.mod.apply" 20 $ vcat-      [ sep [ text "applySection", prettyTCM m1, text "=", prettyTCM m2, fsep $ map prettyTCM (vs ++ ts) ]-      , nest 2 $ pretty copyInfo-      ]-    args <- instantiateFull $ vs ++ ts-    let n = size aTel-    etaArgs <- inTopContext $ addContext aTel getContextArgs-    addContext' aTel $-      applySection m1 (ptel `abstract` aTel) m2 (raise n args ++ etaArgs) copyInfo--checkSectionApplication' i m1 (A.RecordModuleIFS x) copyInfo = do-  let name = mnameToQName x-  tel' <- lookupSection x-  vs   <- freeVarsToApply name-  let tel = tel' `apply` vs-      args = teleArgs tel--      telInst :: Telescope-      telInst = instFinal tel--      -- Locate last (rightmost) parameter and make it @Instance@.-      instFinal :: Telescope -> Telescope-      -- Telescopes do not have @NoAbs@.-      instFinal (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__-      -- Found last parameter: switch it to @Instance@.-      instFinal (ExtendTel (Dom info t) (Abs n EmptyTel)) =-                 ExtendTel (Dom ifo' t) (Abs n EmptyTel)-        where ifo' = setHiding Instance info-      -- Otherwise, keep searching for last parameter:-      instFinal (ExtendTel arg (Abs n tel)) =-                 ExtendTel arg (Abs n (instFinal tel))-      -- Before instFinal is invoked, we have checked that the @tel@ is not empty.-      instFinal EmptyTel = __IMPOSSIBLE__--  reportSDoc "tc.mod.apply" 20 $ vcat-    [ sep [ text "applySection", prettyTCM name, text "{{...}}" ]-    , nest 2 $ text "x       =" <+> prettyTCM x-    , nest 2 $ text "name    =" <+> prettyTCM name-    , nest 2 $ text "tel     =" <+> prettyTCM tel-    , nest 2 $ text "telInst =" <+> prettyTCM telInst-    , nest 2 $ text "vs      =" <+> sep (map prettyTCM vs)-    -- , nest 2 $ text "args    =" <+> sep (map prettyTCM args)-    ]-  reportSDoc "tc.mod.apply" 60 $ vcat-    [ nest 2 $ text "vs      =" <+> text (show vs)-    -- , nest 2 $ text "args    =" <+> text (show args)-    ]-  when (tel == EmptyTel) $-    typeError $ GenericError $ show (qnameToConcrete name) ++ " is not a parameterised section"--  addContext' telInst $ do-    vs <- freeVarsToApply name-    reportSDoc "tc.mod.apply" 20 $ vcat-      [ nest 2 $ text "vs      =" <+> sep (map prettyTCM vs)-      , nest 2 $ text "args    =" <+> sep (map (parens . prettyTCM) args)-      ]-    reportSDoc "tc.mod.apply" 60 $ vcat-      [ nest 2 $ text "vs      =" <+> text (show vs)-      , nest 2 $ text "args    =" <+> text (show args)-      ]-    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 ()----------------------------------------------------------------------------- * Debugging---------------------------------------------------------------------------class ShowHead a where-  showHead :: a -> String--instance ShowHead A.Declaration where-  showHead d =-    case d of-      A.Axiom        {} -> "Axiom"-      A.Field        {} -> "Field"-      A.Primitive    {} -> "Primitive"-      A.Mutual       {} -> "Mutual"-      A.Section      {} -> "Section"-      A.Apply        {} -> "Apply"-      A.Import       {} -> "Import"-      A.Pragma       {} -> "Pragma"-      A.Open         {} -> "Open"-      A.FunDef       {} -> "FunDef"-      A.DataSig      {} -> "DataSig"-      A.DataDef      {} -> "DataDef"-      A.RecSig       {} -> "RecSig"-      A.RecDef       {} -> "RecDef"-      A.PatternSynDef{} -> "PatternSynDef"-      A.UnquoteDecl  {} -> "UnquoteDecl"-      A.ScopedDecl   {} -> "ScopedDecl"-      A.UnquoteDef   {} -> "UnquoteDef"--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-          reportSLn "tc.decl" 45 $-            "section " ++ show mname ++ " has "-              ++ show (length tel) ++ " parameters and "-              ++ show (length ds) ++ " declarations"-          reportSDoc "tc.decl" 45 $ prettyA $ A.Section info mname tel []+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Decl where++import Prelude hiding ( null )++import Control.Monad.Writer (tell)++import Data.Either (partitionEithers)+import qualified Data.Foldable as Fold+import qualified Data.Map.Strict as MapS+import Data.Maybe+import qualified Data.Set as Set+import Data.Set (Set)++import Agda.Interaction.Highlighting.Generate+import Agda.Interaction.Options++import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Views (deepUnscopeDecl, deepUnscopeDecls)+import Agda.Syntax.Internal+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(..) )++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad.Benchmark (MonadBench, Phase)+import qualified Agda.TypeChecking.Monad.Benchmark as Bench++import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.IApplyConfluence+import Agda.TypeChecking.Generalize+import Agda.TypeChecking.Injectivity+import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.Level.Solve+import Agda.TypeChecking.Positivity+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Polarity+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.ProjectionLike+import Agda.TypeChecking.Unquote+import Agda.TypeChecking.Records+import Agda.TypeChecking.RecordPatterns+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rewriting+import Agda.TypeChecking.SizedTypes.Solve+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings++import Agda.TypeChecking.Rules.Application+import Agda.TypeChecking.Rules.Term+import Agda.TypeChecking.Rules.Data    ( checkDataDef )+import Agda.TypeChecking.Rules.Record  ( checkRecDef )+import Agda.TypeChecking.Rules.Def     ( checkFunDef, newSection, useTerPragma )+import Agda.TypeChecking.Rules.Builtin+import Agda.TypeChecking.Rules.Display ( checkDisplayPragma )++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.Size+import Agda.Utils.Update+import qualified Agda.Syntax.Common.Pretty as P+import qualified Agda.Utils.SmallSet as SmallSet++import Agda.Utils.Impossible++-- | Cached checkDecl+checkDeclCached :: A.Declaration -> TCM ()+checkDeclCached d@A.ScopedDecl{} = checkDecl d+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 erased' mname' tbinds', _)+      | erased == erased' && mname == mname' && tbinds == tbinds' ->+        return ()+    _ -> cleanCachedLog+  writeToCurrentLog $ EnterSection erased mname tbinds+  checkDecl d+  readFromCachedLog >>= \case+    Just (LeaveSection mname', _) | mname == mname' -> return ()+    _ -> cleanCachedLog+  writeToCurrentLog $ LeaveSection mname++checkDeclCached d = do+    e <- readFromCachedLog++    reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)++    case e of+      (Just (Decl d',s)) | compareDecl d d' -> do+        restorePostScopeState s+        reportSLn "cache.decl" 50 $ "range: " ++ prettyShow (getRange d)+        printSyntaxInfo (getRange d)+      _ -> do+        cleanCachedLog+        checkDeclWrap d+    writeToCurrentLog $ Decl d+ where+   compareDecl A.Section{} A.Section{} = __IMPOSSIBLE__+   compareDecl A.ScopedDecl{} A.ScopedDecl{} = __IMPOSSIBLE__+   compareDecl x y = x == y+   -- changes to CS inside a RecDef or Mutual ought not happen,+   -- but they do happen, so we discard them.+   ignoreChanges m = localCache $ do+     cleanCachedLog+     m+   checkDeclWrap d@A.RecDef{} = ignoreChanges $ checkDecl d+   checkDeclWrap d@A.Mutual{} = ignoreChanges $ checkDecl d+   checkDeclWrap d            = checkDecl d++-- | Type check a sequence of declarations.+checkDecls :: [A.Declaration] -> TCM ()+checkDecls ds = do+  reportSLn "tc.decl" 45 $ "Checking " ++ show (length ds) ++ " declarations..."+  mapM_ checkDecl ds++-- | Type check a single declaration.++checkDecl :: A.Declaration -> TCM ()+checkDecl d = setCurrentRange d $ do+    reportSDoc "tc.decl" 10 $ "checking declaration"+    debugPrintDecl d+    reportSDoc "tc.decl" 90 $ (text . show) (deepUnscopeDecl d)+    reportSDoc "tc.decl" 10 $ prettyA d  -- Might loop, see e.g. Issue 1597++    let -- What kind of final checks/computations should be performed+        -- if we're not inside a mutual block?+        none        m = m $>  Nothing           -- skip all checks+        meta        m = m $>  Just (return ())  -- do the usual checks+        mutual i ds m = m <&> Just . uncurry (mutualChecks i d ds)+        impossible  m = m $>  __IMPOSSIBLE__+                        -- We're definitely inside a mutual block.++    (finalChecks, metas) <- metasCreatedBy $ case d of+      A.Axiom{}                -> meta $ checkTypeSignature d+      A.Generalize s i info x e -> meta $ inConcreteMode $ checkGeneralize s i info x e+      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 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 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 <- defMutual <$> getConstInfo x++                                    -- Andreas, 2016-10-01 testing whether+                                    -- envMutualBlock is set correctly.+                                    -- Apparently not.+                                    verboseS "tc.decl.mutual" 70 $ do+                                      current <- asksTC envMutualBlock+                                      unless (Just blockId == current) $ do+                                        reportS "" 0+                                          [ "mutual block id discrepancy for " ++ prettyShow x+                                          , "  current    mut. bl. = " ++ show current+                                          , "  calculated mut. bl. = " ++ show blockId+                                          ]++                                    return (blockId, Set.singleton x)+      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+                                  -- checked. NOTE: Metas are not frozen+                                  -- immediately after the last field. Perhaps+                                  -- they should be (unless we're in a mutual+                                  -- block).+      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+                                  -- highlighting purposes.+      -- Andreas, 2019-08-19, issue #4010, observe @abstract@ also for unquoting.+      -- TODO: is it possible that some of the unquoted declarations/definitions+      -- are abstract and some are not?  Then allowing all to look into abstract things,+      -- as we do here, will leak information about the implementation of abstract things.+      -- 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++      -- Syntax highlighting.+      highlight_ DontHightlightModuleContents d++      -- Defaulting of levels (only when --cumulativity)+      whenM (optCumulativity <$> pragmaOptions) $+        defaultLevelsToZero (openMetas metas)++      -- Post-typing checks.+      whenJust finalChecks \theMutualChecks -> do+        reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing."+        locallyTCState stInstanceHack (const True) $+          wakeupConstraints_   -- solve emptiness and instance constraints++        checkingWhere <- asksTC envCheckingWhere+        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 open metas."+            void $ freezeMetas (openMetas metas)++        theMutualChecks++    where++    -- 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+            , 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) <> "."+      reportSLn "tc.decl.abstract" 25 $ show $ anyIsAbstract i+      r <- checkMaybeAbstractly i m+      reportSDoc "tc.decl" 5 $ ("Checked" <+> prettyTCM x) <> "."+      return r++    -- Switch to AbstractMode if any of the i is AbstractDef.+    checkMaybeAbstractly :: forall m i a . ( MonadTCEnv m, AnyIsAbstract i, AllAreOpaque i )+                         => i -> m a -> m a+    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.+mutualChecks :: Info.MutualInfo -> A.Declaration -> [A.Declaration] -> MutualId -> Set QName -> TCM ()+mutualChecks mi d ds mid names = do+  -- Andreas, 2014-04-11: instantiate metas in definition types+  let nameList = Set.toList names+  mapM_ instantiateDefinitionType nameList+  -- Andreas, 2017-03-23: check positivity before termination.+  -- This allows us to reuse the information about SCCs+  -- to skip termination of non-recursive functions.+  modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $+    checkPositivity_ mi names+  -- Andreas, 2013-02-27: check termination before injectivity,+  -- to avoid making the injectivity checker loop.+  localTC (\ e -> e { envMutualBlock = Just mid }) $+    checkTermination_ d+  revisitRecordPatternTranslation nameList -- Andreas, 2016-11-19 issue #2308++  mapM_ checkIApplyConfluence_ nameList++  -- Andreas, 2015-03-26 Issue 1470:+  -- Restricting coinduction to recursive does not solve the+  -- actual problem, and prevents interesting sound applications+  -- of sized types.+  -- checkCoinductiveRecords  ds++  -- Andreas, 2019-07-11: The following remarks about injectivity+  -- and polarity seem outdated, since the UnusedArg Relevance has+  -- been removed.+  -- -- Andreas, 2012-09-11:  Injectivity check stores clauses+  -- -- whose 'Relevance' is affected by polarity computation,+  -- -- so do it here (again).+  -- -- Andreas, 2015-07-01:  In particular, 'UnusedArg's of local functions+  -- -- are only recognized after the polarity computation.+  -- -- See Issue 1366 for an example where injectivity of a local function+  -- -- is used to solve metas.  It fails if we do injectivity analysis+  -- -- before polarity only.+  -- However, we need to repeat injectivity checking after termination checking,+  -- since more reductions are available after termination checking, thus,+  -- more instances of injectivity can be recognized.+  checkInjectivity_        names+  checkProjectionLikeness_ names++-- | Check if there is a inferred eta record type in the mutual block.+--   If yes, repeat the record pattern translation for all function definitions+--   in the block.+--   This is necessary since the original record pattern translation will+--   have skipped record patterns of the new record types (as eta was off for them).+--   See issue #2308 (and #2197).+revisitRecordPatternTranslation :: [QName] -> TCM ()+revisitRecordPatternTranslation qs = do+  -- rs: inferred eta record types of this mutual block+  -- qccs: compiled clauses of definitions+  (rs, qccs) <- partitionEithers . catMaybes <$> mapM classify qs+  unless (null rs) $ forM_ qccs $ \(q,cc) -> do+    (cc, recordExpressionBecameCopatternLHS) <- runChangeT $ translateCompiledClauses q cc+    modifySignature $ updateDefinition q+      $ updateTheDef (updateCompiledClauses $ const $ Just cc)+      . updateDefCopatternLHS (|| recordExpressionBecameCopatternLHS)+  where+  -- Walk through the definitions and return the set of inferred eta record types+  -- and the set of function definitions in the mutual block+  classify q = inConcreteOrAbstractMode q $ \ def -> do+    case theDef def of+      Record{ recEtaEquality' = Inferred YesEta } -> return $ Just $ Left q+      Function+        { funProjection = Left MaybeProjection+            -- Andreas, 2017-08-10, issue #2664:+            -- Do not record pattern translate record projection definitions!+        , funCompiled   = Just cc+        } -> return $ Just $ Right (q, cc)+      _ -> return Nothing++type FinalChecks = Maybe (TCM ())++checkUnquoteDecl :: Info.MutualInfo -> [A.DefInfo] -> [QName] -> A.Expr -> TCM FinalChecks+checkUnquoteDecl mi is xs e = do+  reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDecl" <+> sep (map prettyTCM xs)+  Nothing <$ unquoteTop xs e++checkUnquoteDef :: [A.DefInfo] -> [QName] -> A.Expr -> TCM ()+checkUnquoteDef _ xs e = do+  reportSDoc "tc.unquote.decl" 20 $ "Checking unquoteDef" <+> sep (map prettyTCM xs)+  () <$ unquoteTop xs e++-- | Run a reflected TCM computatation expected to define a given list of+--   names.+unquoteTop :: [QName] -> A.Expr -> TCM [QName]+unquoteTop xs e = do+  tcm   <- primAgdaTCM+  unit  <- primUnit+  lzero <- primLevelZero+  let vArg = defaultArg+      hArg = setHiding Hidden . vArg+  m    <- applyQuantityToJudgement zeroQuantity $+            checkExpr e $ El (mkType 0) $ apply tcm [hArg lzero, vArg unit]+  res  <- runUnquoteM $ tell xs >> evalTCM m+  case res of+    Left err      -> typeError $ UnquoteFailed err+    Right (_, xs) -> return xs++-- | Instantiate all metas in 'Definition' associated to 'QName'.+--   Makes sense after freezing metas. Some checks, like free variable+--   analysis, are not in 'TCM', so they will be more precise (see issue 1099)+--   after meta instantiation.+--   Precondition: name has been added to signature already.+instantiateDefinitionType :: QName -> TCM ()+instantiateDefinitionType q = do+  reportSLn "tc.decl.inst" 20 $ "instantiating type of " ++ prettyShow q+  t  <- defType . fromMaybe __IMPOSSIBLE__ . lookupDefinition q <$> getSignature+  t' <- instantiateFull t+  modifySignature $ updateDefinition q $ updateDefType $ const t'+  reportSDoc "tc.decl.inst" 30 $ vcat+    [ "  t  = " <+> prettyTCM t+    , "  t' = " <+> prettyTCM t'+    ]++-- Andreas, 2014-04-11+-- UNUSED, costs a couple of sec on the std-lib+-- -- | Instantiate all metas in 'Definition' associated to 'QName'.+-- --   Makes sense after freezing metas.+-- --   Some checks, like free variable analysis, are not in 'TCM',+-- --   so they will be more precise (see issue 1099) after meta instantiation.+-- --+-- --   Precondition: name has been added to signature already.+-- instantiateDefinition :: QName -> TCM ()+-- instantiateDefinition q = do+--   reportSLn "tc.decl.inst" 20 $ "instantiating " ++ prettyShow q+--   sig <- getSignature+--   let def = fromMaybe __IMPOSSIBLE__ $ lookupDefinition q sig+--   def <- instantiateFull def+--   modifySignature $ updateDefinition q $ const def++data HighlightModuleContents = DontHightlightModuleContents | DoHighlightModuleContents+  deriving (Eq)++-- | Highlight a declaration. Called after checking a mutual block (to ensure+--   we have the right definitions for all names). For modules inside mutual+--   blocks we haven't highlighted their contents, but for modules not in a+--   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+    A.Field{}                -> __IMPOSSIBLE__+    A.Primitive{}            -> highlight d+    A.Mutual i ds            -> mapM_ (highlight_ DoHighlightModuleContents) $ deepUnscopeDecls ds+    A.Apply{}                -> highlight d+    A.Import{}               -> highlight d+    A.Pragma{}               -> highlight d+    A.ScopedDecl{}           -> return ()+    A.FunDef{}               -> highlight d+    A.DataDef{}              -> highlight d+    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.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 ps dummy cs)+      -- The telescope has already been highlighted.+      where+      -- Andreas, 2016-01-22, issue 1790+      -- The expression denoting the record constructor type+      -- is replace by a dummy expression in order to /not/+      -- generate highlighting from it.+      -- Simply because all the highlighting info is wrong+      -- in the record constructor type:+      -- i) fields become bound variables,+      -- ii) declarations become let-bound variables.+      -- We do not need that crap.+      dummy = A.Lit empty $ LitString $+        "do not highlight construct(ed/or) type"++-- | Termination check a declaration.+checkTermination_ :: A.Declaration -> TCM ()+checkTermination_ d = Bench.billTo [Bench.Termination] $ do+  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.+  List1.unlessNullM (termDecl d) \ termErrs -> do+    warning $ TerminationIssue termErrs++-- | Check a set of mutual names for positivity.+checkPositivity_ :: Info.MutualInfo -> Set QName -> TCM ()+checkPositivity_ mi names = Bench.billTo [Bench.Positivity] $ do+  -- Positivity checking.+  reportSLn "tc.decl" 20 $ "checkDecl: checking positivity..."+  checkStrictlyPositive mi names++  -- Andreas, 2012-02-13: Polarity computation uses information from the+  -- positivity check, so it needs happen after the positivity check.+  computePolarity $ Set.toList names++-- | Check a set of mutual names for constructor-headedness.+checkInjectivity_ :: Set QName -> TCM ()+checkInjectivity_ names = Bench.billTo [Bench.Injectivity] $ do+  reportSLn "tc.decl" 20 $ "checkDecl: checking injectivity..."+  -- Andreas, 2015-07-01, see Issue1366b:+  -- Injectivity check needs also to be run for abstract definitions.+  -- Fold.forM_ names $ \ q -> ignoreAbstractMode $ do -- NOT NECESSARY after all+  Fold.forM_ names $ \ q -> inConcreteOrAbstractMode q $ \ def -> do+    -- For abstract q, we should be inAbstractMode,+    -- otherwise getConstInfo returns Axiom.+    --+    -- Andreas, 2015-07-01:+    -- Quite surprisingly, inAbstractMode does not allow us to look+    -- at a local definition (@where@ block) of an abstract definition.+    -- This is because the local definition is defined in a strict submodule.+    -- We can only see through abstract definitions in the current module+    -- or super modules inAbstractMode.+    -- I changed that in Monad.Signature.treatAbstractly', so we can see+    -- our own local definitions.+    case theDef def of+      d@Function{ funClauses = cs, funTerminates = term, funProjection = mproj }+        | term /= Just True -> do+            -- Not terminating, thus, running the injectivity check could get us into a loop.+            reportSLn "tc.inj.check" 35 $+              prettyShow q ++ " is not verified as terminating, thus, not considered for injectivity"+        | isProperProjection d -> do+            reportSLn "tc.inj.check" 40 $+              prettyShow q ++ " is a projection, thus, not considered for injectivity"+        | otherwise -> do++            inv <- checkInjectivity q cs+            modifySignature $ updateDefinition q $ updateTheDef $ const $+              d { funInv = inv }++      _ -> do+        abstr <- asksTC envAbstractMode+        reportSLn "tc.inj.check" 40 $+          "we are in " ++ show abstr ++ " and " +++             prettyShow q ++ " is abstract or not a function, thus, not considered for injectivity"++-- | Check a set of mutual names for projection likeness.+--+--   Only a single, non-abstract function can be projection-like.+--   Making an abstract function projection-like would break the+--   invariant that the type of the principle argument of a projection-like+--   function is always inferable.++checkProjectionLikeness_ :: Set QName -> TCM ()+checkProjectionLikeness_ names = Bench.billTo [Bench.ProjectionLikeness] $ do+      -- Non-mutual definitions can be considered for+      -- projection likeness+      let ds = Set.toList names+      reportSLn "tc.proj.like" 20 $ "checkDecl: checking projection-likeness of " ++ prettyShow ds+      case ds of+        [d] -> do+          def <- getConstInfo d+          -- For abstract identifiers, getConstInfo returns Axiom.+          -- Thus, abstract definitions are not considered for projection-likeness.+          case theDef def of+            Function{} -> makeProjection (defName def)+            _          -> reportSLn "tc.proj.like" 25 $+              prettyShow d ++ " is abstract or not a function, thus, not considered for projection-likeness"+        _ -> reportSLn "tc.proj.like" 25 $+               "mutual definitions are not considered for projection-likeness"++-- | Freeze metas created by given computation if in abstract mode.+whenAbstractFreezeMetasAfter :: A.DefInfo -> TCM a -> TCM a+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."+    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 open metas: " <+>+        sep (map prettyTCM $ MapS.keys (openMetas ms))+      , "We froze the following ones of these:            " <+>+        sep (map prettyTCM $ Set.toList xs)+      ]+    return a++checkGeneralize :: Set QName -> A.DefInfo -> ArgInfo -> QName -> A.Expr -> TCM ()+checkGeneralize s i info x e = do++    reportSDoc "tc.decl.gen" 20 $ sep+      [ "checking type signature of generalizable variable" <+> prettyTCM x <+> ":"+      , nest 2 $ prettyTCM e+      ]++    -- Check the signature and collect the created metas.+    (telNames, tGen) <-+      generalizeType s $ locallyTC eGeneralizeMetas (const YesGeneralizeMeta) $+        workOnTypes $ isType_ e+    let n = length telNames++    reportSDoc "tc.decl.gen" 10 $ sep+      [ "checked type signature of generalizable variable" <+> prettyTCM x <+> ":"+      , nest 2 $ prettyTCM tGen+      ]++    lang <- getLanguage+    addConstant x $ defaultDefn info x tGen lang $+      GeneralizableVar $ SomeGeneralizableArgs n++-- | Type check an axiom.+checkAxiom :: KindOfName -> A.DefInfo -> ArgInfo ->+              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 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).+  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 p = getModalPolarity info0+  let mod  = Modality rel (getQuantity info0) c p+  let info = setModality mod info0++  -- 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+    , nest 2 $ caseMaybe gentel "(no gentel)" $ \ _ -> "(has gentel)"+    ]++  (genParams, npars, t) <- workOnTypes $ case gentel of+        Nothing     -> ([], 0,) <$> isType_ e+        Just gentel ->+          checkGeneralizeTelescope Nothing gentel $ \ genParams ptel -> do+            t <- workOnTypes $ isType_ e+            return (genParams, size ptel, abstract ptel t)++  reportSDoc "tc.decl.ax" 10 $ sep+    [ text $ "checked type signature"+    , nest 2 $ (prettyTCM mod <> prettyTCM x) <+> ":" <+> prettyTCM t+    , nest 2 $ "of sort " <+> prettyTCM (getSort t)+    ]++  unless (null genParams) $+    reportSLn "tc.decl.ax" 40 $ "  generalized params: " ++ show genParams++  -- Jesper, 2018-06-05: should be done AFTER generalizing+  --whenM (optDoubleCheck <$> pragmaOptions) $ workOnTypes $ do+  --  checkInternal (unEl t) (sort $ getSort t)++  -- Andreas, 2015-03-17 Issue 1428: Do not postulate sizes in parametrized+  -- modules!+  when (kind == AxiomName) $ do+    whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do+      whenM ((> 0) <$> getContextSize) $ typeError PostulatedSizeInModule++  -- 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 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   -> 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+        , defPolarity          = pols+        , defGeneralizedParams = genParams+        , 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+      -- Put highlighting on name only; including the instance keyword,+      -- like @(getRange (r,x))@, does not produce good results.+    NotInstanceDef -> pure ()++  traceCall (IsType_ e) $ do -- need Range for error message+    -- Andreas, 2016-06-21, issue #2054+    -- Do not default size metas to ∞ in local type signatures+    checkingWhere <- asksTC envCheckingWhere+    solveSizeConstraints $ if checkingWhere /= NoWhere_ then DontDefaultToInfty else DefaultToInfty++-- | Type check a primitive function declaration.+checkPrimitive :: A.DefInfo -> QName -> Arg A.Expr -> TCM ()+checkPrimitive i x (Arg info e) =+    traceCall (CheckPrimitive (getRange i) x e) $ do+    (name, PrimImpl t' pf) <- lookupPrimitiveFunctionQ x+    -- Certain "primitive" functions are BUILTIN rather than+    -- primitive.+    let builtinPrimitives =+          [ PrimNatPlus+          , PrimNatMinus+          , PrimNatTimes+          , PrimNatDivSucAux+          , PrimNatModSucAux+          , PrimNatEquality+          , PrimNatLess+          , PrimLevelZero+          , PrimLevelSuc+          , PrimLevelMax+          ]+    when (name `elem` builtinPrimitives) $ do+      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 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 =+          -- 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 = do+    let uselessPragma = warning . UselessPragma r+    traceCall (CheckPragma r p) $ case p of+        A.BuiltinPragma rb 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.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.+          ifM ((x' `isInModule`) <$> currentModule)+            {- then -} (addPragma (rangedThing b) x s)+            {- else -} $ uselessPragma+              "COMPILE pragmas must appear in the same module as their corresponding definitions,"++        A.StaticPragma x -> do+          def <- ignoreAbstractMode $ getConstInfo x+          case theDef def of+            Function{} -> markStatic x+            _          -> 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 <- ignoreAbstractMode $ getConstInfo x+          case theDef def of+            Function{} -> markInline b x+            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.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+-- block are returned.+checkMutual :: Info.MutualInfo -> [A.Declaration] -> TCM (MutualId, Set QName)+checkMutual i ds = inMutualBlock $ \ blockId -> defaultOpenLevelsToZero $ do++  reportSDoc "tc.decl.mutual" 20 $ vcat $+      (("Checking mutual block" <+> text (show blockId)) <> ":") :+      map (nest 2 . prettyA) ds++  insertMutualBlockInfo blockId i+  localTC ( set eTerminationCheck (() <$ Info.mutualTerminationCheck i)+          . set eCoverageCheck (Info.mutualCoverageCheck i)) $+    mapM_ checkDecl ds++  (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++checkTypeSignature' :: Maybe A.GeneralizeTelescope -> A.TypeSignature -> TCM ()+checkTypeSignature' gtel (A.ScopedDecl scope ds) = do+  setScope scope+  mapM_ (checkTypeSignature' gtel) ds+checkTypeSignature' gtel (A.Axiom funSig i info mp x e) =+  Bench.billTo [Bench.Definition x] $+  Bench.billTo [Bench.Typing, Bench.TypeSig] $+    let abstr = case Info.defAccess i of+          PrivateAccess{}+            | Info.defAbstract i == AbstractDef -> inConcreteMode+              -- Issue #2321, only go to AbstractMode for abstract definitions+              -- Issue #418, #3744, in fact don't go to AbstractMode at all+            | otherwise -> inConcreteMode+          PublicAccess  -> inConcreteMode+    in abstr $ checkAxiom' gtel funSig i info mp x e+checkTypeSignature' _ _ =+  __IMPOSSIBLE__   -- type signatures are always axioms+++-- | Type check a module.++checkSection ::+  Erased -> ModuleName -> A.GeneralizeTelescope -> [A.Declaration] ->+  TCM ()+checkSection e x tel ds =+  newSection e x tel $ mapM_ checkDeclCached ds+++-- | Helper for 'checkSectionApplication'.+--+--   Matches the arguments of the module application with the+--   module parameters.+--+--   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.+  -> Telescope            -- ^ The module parameters.+  -> [NamedArg A.Expr]    -- ^ The arguments this module is applied to.+  -> TCM Telescope        -- ^ The remaining module parameters (has free de Bruijn indices!).+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 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+      case (argInfoHiding info, argInfoHiding info', name) of+        (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                     -> 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                     -> 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 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 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+    mfv <- getCurrentModuleFreeVars+    fv  <- getContextSize+    return (fv - mfv)+  when (extraParams > 0) $ reportSLn "tc.mod.apply" 30 $ "Extra parameters to " ++ prettyShow m1 ++ ": " ++ show extraParams+  -- Type-check the LHS (ptel) of the module macro.+  checkTelescope ptel $ \ ptel -> do+    -- We are now in the context @ptel@.+    -- Get the correct parameter telescope of @m2@. This is the fully lifted+    -- telescope obtained by `lookupSection` instantiated with the module+    -- parameters of `m2` currently in scope. For instance+    -- ```+    --  module _ (A : Set) where+    --    module M (B : Set) where ...+    --    module M' = M B+    -- ```+    -- In the application `M' = M B`, `tel = (A B : Set)` and+    -- `moduleParamsToApply M = [A]`, so the resulting parameter telescope is+    -- `tel' = (B : Set)`.+    tel <- lookupSection m2+    vs  <- moduleParamsToApply m2+    let tel'  = apply tel vs+    -- Compute the remaining parameter telescope after stripping of+    -- the initial parameters that are determined by the @args@.+    -- Warning: @etaTel@ is not well-formed in @ptel@, since+    -- the actual application has not happened.+    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 $+        "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.+    -- 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__+    -- Perform the application of the module parameters.+    let aTel = tel' `apply` ts+    reportSDoc "tc.mod.apply" 15 $ vcat+      [ nest 2 $ "aTel =" <+> prettyTCM aTel+      ]+    -- Andreas, 2014-04-06, Issue 1094:+    -- Add the section with well-formed telescope.+    addContext (KeepNames aTel) $ do+      reportSDoc "tc.mod.apply" 80 $+        "addSection" <+> prettyTCM m1 <+> (getContextTelescope >>= \ tel -> inTopContext (prettyTCM tel))+      addSection m1++    reportSDoc "tc.mod.apply" 20 $ vcat+      [ sep [ "applySection", prettyTCM m1, "=", prettyTCM m2, fsep $ map prettyTCM (vs ++ ts) ]+      , nest 2 $ pretty copyInfo+      ]+    args <- instantiateFull $ vs ++ ts+    let n = size aTel+    etaArgs <- inTopContext $ addContext aTel getContextArgs+    addContext (KeepNames aTel) $+      applySection m1 (ptel `abstract` aTel) m2 (raise n args ++ etaArgs) copyInfo++checkSectionApplication' _ Erased{} _ A.RecordModuleInstance{} _ =+  __IMPOSSIBLE__+checkSectionApplication'+  i NotErased{} m1 (A.RecordModuleInstance x) copyInfo = do+  let name = mnameToQName x+  tel' <- lookupSection x+  vs   <- moduleParamsToApply x+  let tel = tel' `apply` vs+      args = teleArgs tel++      telInst :: Telescope+      telInst = instFinal tel++      -- Locate last (rightmost) parameter and make it @Instance@.+      -- Issue #3463: also name it so it can be given by name.+      instFinal :: Telescope -> Telescope+      -- Telescopes do not have @NoAbs@.+      instFinal (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__+      -- Found last parameter: switch it to @Instance@.+      instFinal (ExtendTel dom (Abs n EmptyTel)) =+                 ExtendTel do' (Abs n EmptyTel)+        where do' = makeInstance dom { domName = Just $ WithOrigin Inserted $ unranged "r" }+      -- Otherwise, keep searchinf for last parameter:+      instFinal (ExtendTel arg (Abs n tel)) =+                 ExtendTel arg (Abs n (instFinal tel))+      -- Before instFinal is invoked, we have checked that the @tel@ is not empty.+      instFinal EmptyTel = __IMPOSSIBLE__++  reportSDoc "tc.mod.apply" 20 $ vcat+    [ sep [ "applySection", prettyTCM name, "{{...}}" ]+    , nest 2 $ "x       =" <+> prettyTCM x+    , nest 2 $ "name    =" <+> prettyTCM name+    , nest 2 $ "tel     =" <+> prettyTCM tel+    , nest 2 $ "telInst =" <+> prettyTCM telInst+    , nest 2 $ "vs      =" <+> sep (map prettyTCM vs)+    -- , nest 2 $ "args    =" <+> sep (map prettyTCM args)+    ]+  reportSDoc "tc.mod.apply" 60 $ vcat+    [ nest 2 $ "vs      =" <+> text (show vs)+    -- , nest 2 $ "args    =" <+> text (show args)+    ]+  when (tel == EmptyTel) $ typeError $ ModuleArityMismatch x EmptyTel (Right vs)++  addContext telInst $ do+    vs <- moduleParamsToApply x+    reportSDoc "tc.mod.apply" 20 $ vcat+      [ nest 2 $ "vs      =" <+> sep (map prettyTCM vs)+      , nest 2 $ "args    =" <+> sep (map (parens . prettyTCM) args)+      ]+    reportSDoc "tc.mod.apply" 60 $ vcat+      [ nest 2 $ "vs      =" <+> text (show vs)+      , nest 2 $ "args    =" <+> text (show args)+      ]+    addSection m1+    applySection m1 telInst x (vs ++ args) copyInfo++-- | 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+------------------------------------------------------------------------++class ShowHead a where+  showHead :: a -> String++instance ShowHead A.Declaration where+  showHead d =+    case d of+      A.Axiom        {} -> "Axiom"+      A.Field        {} -> "Field"+      A.Primitive    {} -> "Primitive"+      A.Mutual       {} -> "Mutual"+      A.Section      {} -> "Section"+      A.Apply        {} -> "Apply"+      A.Import       {} -> "Import"+      A.Pragma       {} -> "Pragma"+      A.Open         {} -> "Open"+      A.FunDef       {} -> "FunDef"+      A.DataSig      {} -> "DataSig"+      A.DataDef      {} -> "DataDef"+      A.RecSig       {} -> "RecSig"+      A.RecDef       {} -> "RecDef"+      A.PatternSynDef{} -> "PatternSynDef"+      A.Generalize   {} -> "Generalize"+      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 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 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    (QName, Declaration, ModuleName, ModuleApplication, ScopeCopyInfo)-import Agda.TypeChecking.Monad (TCM)+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
@@ -1,799 +1,1342 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.Rules.Def where--import Prelude hiding (mapM)-import Control.Arrow ((***))-import Control.Applicative-import Control.Monad.State hiding (forM, mapM)-import Control.Monad.Reader hiding (forM, mapM)--import Data.Function-import Data.List hiding (sort)-import Data.Maybe-import Data.Traversable-import qualified Data.Set as Set--import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete (exprFieldA)-import Agda.Syntax.Position-import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Abstract.Views as A-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern as I-import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Fixity-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Info--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import qualified Agda.TypeChecking.Monad.Benchmark as Bench--import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Free-import Agda.TypeChecking.CheckInternal (checkType)-import Agda.TypeChecking.With-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.SizedTypes.Solve-import Agda.TypeChecking.RecordPatterns-import Agda.TypeChecking.CompiledClause (CompiledClauses(..))-import Agda.TypeChecking.CompiledClause.Compile-import Agda.TypeChecking.Primitive hiding (Nat)--import Agda.TypeChecking.Rules.Term                ( checkExpr, inferExpr, inferExprForWith, checkDontExpandLast, checkTelescope )-import Agda.TypeChecking.Rules.LHS                 ( checkLeftHandSide, LHSResult(..), bindAsPatterns )-import Agda.TypeChecking.Rules.LHS.Problem         ( AsBinding(..) )-import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls )--import Agda.Utils.Except ( MonadError(catchError, throwError) )-import Agda.Utils.Lens-import Agda.Utils.Maybe ( whenNothing )-import Agda.Utils.Monad-import Agda.Utils.Permutation-import Agda.Utils.Size-import Agda.Utils.Functor--#include "undefined.h"-import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Definitions by pattern matching------------------------------------------------------------------------------checkFunDef :: Delayed -> Info.DefInfo -> QName -> [A.Clause] -> TCM ()-checkFunDef delayed i name cs = do-        -- Get the type and relevance of the function-        t    <- typeOfConst name-        info  <- flip setRelevance defaultArgInfo <$> relOfConst name-        case isAlias cs t of-          Just (e, mc, x) ->-            traceCall (CheckFunDef (getRange i) (qnameName name) cs) $ 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.-              whenM (isFrozen x) $ unfreezeMeta x-              checkAlias t info delayed i name e mc-          _ -> checkFunDef' t info delayed Nothing Nothing i name cs--        -- If it's a macro check that it ends in Term → TC ⊤-        ismacro <- isMacro . theDef <$> getConstInfo name-        when (ismacro || Info.defMacro i == MacroDef) $ checkMacroType t--checkMacroType :: Type -> TCM ()-checkMacroType t = do-  t' <- normalise t-  TelV tel tr <- telView t'--  let telList = telToList tel-      resType = abstract (telFromList (drop (length telList - 1) telList)) tr-  expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)-  equalType resType expectedType-    `catchError` \ _ -> typeError . GenericDocError =<< sep [ text "Result type of a macro must be"-                                                            , nest 2 $ prettyTCM expectedType ]---- | A single clause without arguments and without type signature is an alias.-isAlias :: [A.Clause] -> Type -> Maybe (A.Expr, Maybe C.Expr, MetaId)-isAlias cs t =-        case trivialClause cs of-          -- if we have just one clause without pattern matching and-          -- without a type signature, then infer, to allow-          -- "aliases" for things starting with hidden abstractions-          Just (e, mc) | Just x <- isMeta (ignoreSharing $ unEl t) -> Just (e, mc, x)-          _ -> Nothing-  where-    isMeta (MetaV x _) = Just x-    isMeta _           = Nothing-    trivialClause [A.Clause (A.LHS i (A.LHSHead f []) []) _ (A.RHS e mc) [] _] = Just (e, mc)-    trivialClause _ = Nothing---- | Check a trivial definition of the form @f = e@-checkAlias :: Type -> ArgInfo -> Delayed -> Info.DefInfo -> QName -> A.Expr -> Maybe C.Expr -> TCM ()-checkAlias t' ai delayed i name e mc = atClause name 0 (A.RHS e mc) $ do-  reportSDoc "tc.def.alias" 10 $ text "checkAlias" <+> vcat-    [ text (show name) <+> colon  <+> prettyTCM t'-    , text (show name) <+> equals <+> prettyTCM e-    ]--{--  -- Infer the type of the rhs-  (v, t) <- applyRelevanceToContext (argInfoRelevance ai) $-                                    inferOrCheck e (Just t')-  -- v <- coerce v t t'--}--  -- Infer the type of the rhs-  v <- applyRelevanceToContext (getRelevance ai) $ checkDontExpandLast e t'-  let t = t'--  reportSDoc "tc.def.alias" 20 $ text "checkAlias: finished checking"--  solveSizeConstraints DontDefaultToInfty--  v <- instantiateFull v  -- if we omit this, we loop (stdlib: Relation.Binary.Sum)-    -- or the termination checker might stumble over levels in sorts-    -- that cannot be converted to expressions without the level built-ins-    -- (test/succeed/Issue655.agda)--  -- compute body modification for irrelevant definitions, see issue 610-  let bodyMod = case getRelevance ai of-        Irrelevant -> dontCare-        _          -> id--  -- Add the definition-  addConstant name $ defaultDefn ai name t-                   $ set funMacro (Info.defMacro i == MacroDef) $-                     emptyFunction-                      { funClauses = [ Clause  -- trivial clause @name = v@-                          { clauseRange     = getRange i-                          , clauseTel       = EmptyTel-                          , namedClausePats = []-                          , clauseBody      = Just $ bodyMod v-                          , clauseType      = Just $ Arg ai t-                          , clauseCatchall  = False-                          } ]-                      , funCompiled = Just $ Done [] $ bodyMod v-                      , funDelayed  = delayed-                      , funAbstr    = Info.defAbstract i-                      }-  reportSDoc "tc.def.alias" 20 $ text "checkAlias: leaving"----- | 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)-             -> Info.DefInfo     -- ^ range info-             -> 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---- | 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)-             -> Info.DefInfo     -- ^ range info-             -> QName            -- ^ the name of the function-             -> Maybe Substitution -- ^ substitution (from with abstraction) that needs to be applied to module parameters-             -> [A.Clause]       -- ^ the clauses to check-             -> TCM ()-checkFunDefS t ai delayed extlam with i name withSub cs =--    traceCall (CheckFunDef (getRange i) (qnameName name) cs) $ do   -- TODO!! (qnameName)-        reportSDoc "tc.def.fun" 10 $-          sep [ text "checking body of" <+> prettyTCM name-              , nest 2 $ text ":" <+> prettyTCM t-              , nest 2 $ text "full type:" <+> (prettyTCM . defType =<< getConstInfo name)-              ]--        reportSDoc "tc.def.fun" 70 $-          sep $ [ text "clauses:" ] ++ map (nest 2 . text . show . A.deepUnscope) cs--        cs <- return $ map A.lhsToSpine cs--        reportSDoc "tc.def.fun" 70 $-          sep $ [ text "spine clauses:" ] ++ map (nest 2 . text . show . A.deepUnscope) cs--        -- Ensure that all clauses have the same number of trailing hidden patterns-        -- This is necessary since trailing implicits are no longer eagerly inserted.-        -- Andreas, 2013-10-13-        -- Since we have flexible function arity, it is no longer necessary-        -- to patch clauses to same arity-        -- cs <- trailingImplicits t cs--        -- Check the clauses-        cs <- traceCall NoHighlighting $ do -- To avoid flicker.-          forM (zip cs [0..]) $ \ (c, clauseNo) -> do-            atClause name clauseNo (A.clauseRHS c) $ do-              c <- applyRelevanceToContext (argInfoRelevance ai) $ do-                checkClause t withSub 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-              -- checked individually, since otherwise we get constraints-              -- in typing contexts which are not prefixes of each other.-              whenNothing extlam $ solveSizeConstraints DontDefaultToInfty-              -- Andreas, 2013-10-27 add clause as soon it is type-checked-              -- TODO: instantiateFull?-              inTopContext $ addClauses name [c]-              return c--        reportSDoc "tc.def.fun" 70 $-          sep $ [ text "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 $ do-          sep [ text "clauses before injectivity test"-              , nest 2 $ prettyTCM $ map (QNamed name) cs  -- broken, reify (QNamed n cl) expect cl to live at top level-              ]-        reportSDoc "tc.cc" 60 $ do-          sep [ text "raw clauses: "-              , nest 2 $ sep $ map (text . show . QNamed name) cs-              ]--        -- 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!?--        -- 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-        -- We do it again for the mutual block after polarity analysis, see Rules.Decl.-        reportSLn "tc.inj.def" 20 $ "checkFunDef': checking injectivity..."-        inv <- Bench.billTo [Bench.Injectivity] $-          checkInjectivity name cs--        reportSDoc "tc.cc" 15 $ do-          sep [ text "clauses before compilation"-              , nest 2 $ sep $ map (prettyTCM . QNamed name) cs-              ]--        -- add clauses for the coverage checker (needs to reduce)-        inTopContext $ addClauses name cs--        fullType <- flip telePi t <$> getContextTelescope--        -- Coverage check and compile the clauses-        cc <- Bench.billTo [Bench.Coverage] $-          inTopContext $ compileClauses (Just (name, fullType)) cs--        reportSDoc "tc.cc" 10 $ do-          sep [ text "compiled clauses of" <+> prettyTCM name-              , nest 2 $ text (show cc)-              ]--        -- The macro tag might be on the type signature-        ismacro <- isMacro . theDef <$> getConstInfo name--        -- Add the definition-        inTopContext $ addConstant name =<< do-          -- If there was a pragma for this definition, we can set the-          -- funTerminates field directly.-          useTerPragma $ defaultDefn ai name fullType $-             set funMacro (ismacro || Info.defMacro i == MacroDef) $-             emptyFunction-             { funClauses        = cs-             , funCompiled       = Just cc-             , funDelayed        = delayed-             , funInv            = inv-             , funAbstr          = Info.defAbstract i-             , funExtLam         = extlam-             , funWith           = with-             , funCopatternLHS   = isCopatternLHS cs-             }--        -- Andreas 2012-02-13: postpone polarity computation until after positivity check-        -- computePolarity name--        reportSDoc "tc.def.fun" 10 $ do-          sep [ text "added " <+> prettyTCM name <+> text ":"-              , nest 2 $ prettyTCM . defType =<< getConstInfo name-              ]---- | Set 'funTerminates' according to termination info in 'TCEnv',---   which comes from a possible termination pragma.-useTerPragma :: Definition -> TCM Definition-useTerPragma def@Defn{ defName = name, theDef = fun@Function{}} = do-  tc <- asks envTerminationCheck-  let terminates = case tc of-        NonTerminating -> Just False-        Terminating    -> Just True-        _              -> Nothing-  reportSLn "tc.fundef" 30 $ unlines $-    [ "funTerminates of " ++ show name ++ " set to " ++ show terminates-    , "  tc = " ++ show tc-    ]-  return $ def { theDef = fun { funTerminates = terminates }}-useTerPragma def = return def----- | Insert some patterns in the in with-clauses LHS of the given RHS-insertPatterns :: [A.Pattern] -> A.RHS -> A.RHS-insertPatterns pats (A.WithRHS aux es cs) = A.WithRHS aux es (map insertToClause cs)-    where insertToClause (A.Clause (A.LHS i lhscore ps) dots rhs ds catchall)-              = A.Clause (A.LHS i lhscore (pats ++ ps)) dots (insertPatterns pats rhs) ds catchall-insertPatterns pats (A.RewriteRHS qes rhs wh) = A.RewriteRHS qes (insertPatterns pats rhs) wh-insertPatterns pats rhs = rhs---- | 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.-    , 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      :: [Term]               -- ^ With and rewrite expressions.-    , wfExprTypes  :: [EqualityView]       -- ^ Types of the with and rewrite expressions.-    , 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-    }---- | Type check a function clause.--checkClause-  :: Type          -- ^ Type of function defined by this clause.-  -> Maybe Substitution  -- ^ Module parameter substitution arising from with-abstraction.-  -> A.SpineClause -- ^ Clause.-  -> TCM Clause    -- ^ Type-checked clause.--checkClause t withSub c@(A.Clause (A.SpineLHS i x aps withPats) namedDots rhs0 wh catchall) = do-    reportSDoc "tc.lhs.top" 30 $ text "Checking clause" $$ prettyA c-    unless (null withPats) $-      typeError $ UnexpectedWithPatterns withPats-    traceCall (CheckClause t c) $ do-      aps <- expandPatternSynonyms aps-      cxtNames <- reverse . map (fst . unDom) <$> getContext-      when (not $ null namedDots) $ reportSDoc "tc.lhs.top" 50 $-        text "namedDots:" <+> vcat [ prettyTCM x <+> text "=" <+> prettyTCM v <+> text ":" <+> prettyTCM a | A.NamedDot x v a <- namedDots ]-      -- Not really an as-pattern, but this does the right thing.-      bindAsPatterns [ AsB x v a | A.NamedDot x v a <- namedDots ] $-        checkLeftHandSide (CheckPatternShadowing c) (Just x) aps t withSub $ \ lhsResult@(LHSResult npars delta ps trhs patSubst asb) -> do-        -- Note that we might now be in irrelevant context,-        -- in case checkLeftHandSide walked over an irrelevant projection pattern.--        -- Subtle: checkRHS expects the function type to be the lambda lifted-        -- type. If we're checking a with-function that's already the case,-        -- otherwise we need to abstract over the module telescope.-        t' <- case withSub of-                Just{}  -> return t-                Nothing -> do-                  theta <- lookupSection (qnameModule x)-                  return $ abstract theta t--        -- At this point we should update the named dots potential with-clauses-        -- in the right-hand side. When checking a clause we expect the named-        -- dots to live in the context of the closest parent lhs, but the named-        -- dots added by buildWithFunction live in the context of the-        -- with-function arguments before pattern matching. That's what we need-        -- patSubst for.-        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.RewriteRHS qes rhs wh) = A.RewriteRHS qes (updateRHS rhs) wh--            updateClause (A.Clause f dots rhs wh ca) = A.Clause f (applySubst patSubst dots) (updateRHS rhs) wh ca--        (body, with) <- bindAsPatterns asb $ checkWhere wh $ checkRHS i x aps t' lhsResult rhs--        -- Note that the with function doesn't necessarily share any part of-        -- the context with the parent (but withSub will take you from parent-        -- to child).-        inTopContext $ Bench.billTo [Bench.Typing, Bench.With] $ checkWithFunction cxtNames with--        reportSDoc "tc.lhs.top" 10 $ escapeContext (size delta) $ vcat-          [ text "Clause before translation:"-          , nest 2 $ vcat-            [ text "delta =" <+> prettyTCM delta-            , text "ps    =" <+> text (show ps)-            , text "body  =" <+> text (show body)-            , text "body  =" <+> maybe (text "_|_") prettyTCM body-            ]-          ]--        -- compute body modification for irrelevant definitions, see issue 610-        rel <- asks envRelevance-        let bodyMod body = case rel of-              Irrelevant -> dontCare <$> body-              _          -> body--        return $-          Clause { clauseRange     = getRange i-                 , clauseTel       = killRange delta-                 , namedClausePats = ps-                 , clauseBody      = bodyMod body-                 , clauseType      = Just trhs-                 , clauseCatchall  = catchall-                 }---- | Type check the @with@ and @rewrite@ lhss and/or the rhs.--checkRHS-  :: LHSInfo                 -- ^ Range of lhs.-  -> QName                   -- ^ Name of function.-  -> [NamedArg A.Pattern]    -- ^ Patterns in lhs.-  -> Type                    -- ^ Top-level type of function.-  -> LHSResult               -- ^ Result of type-checking patterns-  -> 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 trhs _ _asb) rhs0 = handleRHS rhs0-  where-  absurdPat = any (containsAbsurdPattern . namedArg) aps-  handleRHS rhs =-    case rhs of--      -- Case: ordinary RHS-      A.RHS e _ -> Bench.billTo [Bench.Typing, Bench.CheckRHS] $ do-        when absurdPat $ typeError $ AbsurdPatternRequiresNoRHS aps-        v <- checkExpr e $ unArg trhs-        return (Just v, NoWithFunction)--      -- Case: no RHS-      A.AbsurdRHS -> do-        unless absurdPat $ typeError $ NoRHSRequiresAbsurdPattern aps-        return (Nothing, NoWithFunction)--      -- Case: @rewrite@-      -- Andreas, 2014-01-17, Issue 1402:-      -- If the rewrites are discarded since lhs=rhs, then-      -- we can actually have where clauses.-      A.RewriteRHS [] rhs wh -> checkWhere wh $ handleRHS rhs-      A.RewriteRHS ((qname,eq):qes) rhs wh -> do--        -- Action for skipping this rewrite.-        -- We do not want to create unsolved metas in case of-        -- a futile rewrite with a reflexive equation.-        -- Thus, we restore the state in this case,-        -- unless the rewrite expression contains questionmarks.-        st <- get-        let recurse = do-             st' <- get-             -- Comparing the whole stInteractionPoints maps is a bit-             -- wasteful, but we assume-             -- 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)-             when (sameIP st st') $ put st-             handleRHS $ A.RewriteRHS qes rhs wh--        -- Get value and type of rewrite-expression.--        (proof, eqt) <- inferExpr eq--        -- 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.-        solveSizeConstraints DefaultToInfty--        -- Check that the type is actually an equality (lhs ≡ rhs)-        -- and extract lhs, rhs, and their type.--        t' <- reduce =<< instantiateFull eqt-        (eqt,rewriteType,rewriteFrom,rewriteTo) <- equalityView t' >>= \case-          eqt@(EqualityType s _eq _level dom a b) -> return (eqt, El s (unArg dom), unArg a, unArg b)-          OtherType{} -> typeError . GenericDocError =<< do-            text "Cannot rewrite by equation of type" <+> prettyTCM t'--        -- Get the name of builtin REFL.--        Con reflCon _ [] <- ignoreSharing <$> primRefl--        -- Andreas, 2014-05-17  Issue 1110:-        -- Rewriting with @refl@ has no effect, but gives an-        -- incomprehensible error message about the generated-        -- with clause. Thus, we rather do simply nothing if-        -- rewriting with @refl@ is attempted.--        let isReflProof = do-             v <- reduce proof-             case ignoreSharing v of-               Con c _ [] | c == reflCon -> return True-               _ -> return False--        ifM isReflProof recurse $ {- else -} do--        -- Process 'rewrite' clause like a suitable 'with' clause.--        let reflPat  = A.ConP (ConPatInfo ConOCon patNoRange) (AmbQ [conName reflCon]) []--        -- Andreas, 2015-12-25  Issue #1740:-        -- After the fix of #520, rewriting with a reflexive equation-        -- has to be desugared as matching against refl.-        let isReflexive = tryConversion $ dontAssignMetas $-             equalTerm rewriteType rewriteFrom rewriteTo--        (pats, withExpr, withType) <- do-          ifM isReflexive-            {-then-} (return ([ reflPat ], proof, OtherType t'))-            {-else-} (return ([ A.WildP patNoRange, reflPat ], proof, eqt))--        let rhs'     = insertPatterns pats rhs-            (rhs'', outerWhere) -- the where clauses should go on the inner-most with-              | null qes  = (rhs', wh)-              | otherwise = (A.RewriteRHS qes rhs' wh, [])-            -- Andreas, 2014-03-05 kill range of copied patterns-            -- since they really do not have a source location.-            cs       = [A.Clause (A.LHS i (A.LHSHead x (killRange aps)) pats) [] rhs'' outerWhere False]--        checkWithRHS x qname t lhsResult [withExpr] [withType] cs--      -- Case: @with@-      A.WithRHS aux es cs -> do-        reportSDoc "tc.with.top" 15 $ vcat-          [ text "TC.Rules.Def.checkclause reached A.WithRHS"-          , sep $ prettyA aux : map (parens . prettyA) es-          ]-        reportSDoc "tc.with.top" 20 $ do-          nfv <- getCurrentModuleFreeVars-          m   <- currentModule-          sep [ text "with function module:" <+>-                prettyList (map prettyTCM $ mnameToList m)-              ,  text $ "free variables: " ++ show nfv-              ]--        -- Infer the types of the with expressions-        (vs0, as) <- unzip <$> mapM inferExprForWith es--        -- Andreas, 2016-01-23, Issue #1796-        -- Run the size constraint solver to improve with-abstraction-        -- in case the with-expression contains size metas.-        solveSizeConstraints DefaultToInfty--        checkWithRHS x aux t lhsResult vs0 (map OtherType as) cs--checkWithRHS-  :: QName                   -- ^ Name of function.-  -> QName                   -- ^ Name of the with-function.-  -> Type                    -- ^ Type of function.-  -> LHSResult               -- ^ Result of type-checking patterns-  -> [Term]                  -- ^ With-expressions.-  -> [EqualityView]          -- ^ Types of with-expressions.-  -> [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 trhs _ _asb) vs0 as cs = Bench.billTo [Bench.Typing, Bench.With] $ do-        let withArgs = withArguments vs0 as-            perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps-        (vs, as)  <- normalise (vs0, as)--        -- Andreas, 2012-09-17: for printing delta,-        -- we should remove it from the context first-        reportSDoc "tc.with.top" 25 $ escapeContext (size delta) $ vcat-          [ text "delta  =" <+> prettyTCM delta-          ]-        reportSDoc "tc.with.top" 25 $ vcat-          [ text "vs     =" <+> prettyTCM vs-          , text "as     =" <+> prettyTCM as-          , text "perm   =" <+> text (show perm)-          ]--        -- Split the telescope into the part needed to type the with arguments-        -- and all the other stuff-        (delta1, delta2, perm', t', as, vs) <- return $-          splitTelForWith delta (unArg trhs) as vs-        let finalPerm = composeP perm' perm--        reportSLn "tc.with.top" 75 $ "delta  = " ++ show delta--        -- Andreas, 2012-09-17: for printing delta,-        -- we should remove it from the context first-        reportSDoc "tc.with.top" 25 $ escapeContext (size delta) $ vcat-          [ text "delta1 =" <+> prettyTCM delta1-          , text "delta2 =" <+> addContext delta1 (prettyTCM delta2)-          ]-        reportSDoc "tc.with.top" 25 $ vcat-          [ text "perm'  =" <+> text (show perm')-          , text "fPerm  =" <+> text (show finalPerm)-          ]--        -- Create the body of the original function--        -- All the context variables-        us <- getContextArgs-        let n = size us-            m = size delta-            -- First the variables bound outside this definition-            (us0, us1') = genericSplitAt (n - m) us-            -- Then permute the rest and grab those needed to for the with arguments-            (us1, us2)  = genericSplitAt (size delta1) $ permute perm' us1'-            -- Now stuff the with arguments in between and finish with the remaining variables-            v    = Def aux $ map Apply $ us0 ++ us1 ++ map defaultArg withArgs ++ us2-        -- Andreas, 2013-02-26 add with-name to signature for printing purposes-        addConstant aux =<< do-          useTerPragma $ defaultDefn defaultArgInfo aux typeDontCare emptyFunction--        -- Andreas, 2013-02-26 separate msgs to see which goes wrong-        reportSDoc "tc.with.top" 20 $-          text "    with arguments" <+> do escapeContext (size delta) $ addContext delta1 $ prettyList (map prettyTCM vs)-        reportSDoc "tc.with.top" 20 $-          text "             types" <+> do escapeContext (size delta) $ addContext delta1 $ prettyList (map prettyTCM as)-        reportSDoc "tc.with.top" 20 $-          text "with function call" <+> prettyTCM v-        reportSDoc "tc.with.top" 20 $-          text "           context" <+> (prettyTCM =<< getContextTelescope)-        reportSDoc "tc.with.top" 20 $-          text "             delta" <+> do escapeContext (size delta) $ prettyTCM delta-        reportSDoc "tc.with.top" 20 $-          text "            delta1" <+> do escapeContext (size delta) $ prettyTCM delta1-        reportSDoc "tc.with.top" 20 $-          text "            delta2" <+> do escapeContext (size delta) $ addContext delta1 $ prettyTCM delta2-        reportSDoc "tc.with.top" 20 $-          text "              body" <+> prettyTCM v--        return (Just v, WithFunction x aux t delta1 delta2 vs as t' ps npars perm' perm finalPerm cs)--checkWithFunction :: [Name] -> WithFunctionProblem -> TCM ()-checkWithFunction _ NoWithFunction = return ()-checkWithFunction cxtNames (WithFunction f aux t delta1 delta2 vs as b qs npars perm' perm finalPerm cs) = do--  let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′    (where Δ′ is the context of the parent lhs)-      withSub :: Substitution-      withSub = liftS (size delta2) (wkS (countWithArgs as) idS) `composeS` renaming __IMPOSSIBLE__ (reverseP perm')--  reportSDoc "tc.with.top" 10 $ vcat-    [ text "checkWithFunction"-    , nest 2 $ vcat-      [ text "delta1 =" <+> prettyTCM delta1-      , text "delta2 =" <+> addContext delta1 (prettyTCM delta2)-      , text "t      =" <+> prettyTCM t-      , text "as     =" <+> addContext delta1 (prettyTCM as)-      , text "vs     =" <+> do addContext delta1 $ prettyTCM vs-      , text "b      =" <+> do addContext delta1 $ addContext delta2 $ prettyTCM b-      , text "qs     =" <+> prettyList (map pretty qs)-      , text "perm'  =" <+> text (show perm')-      , text "perm   =" <+> text (show perm)-      , text "fperm  =" <+> text (show finalPerm)-      , text "withSub=" <+> text (show withSub)-      ]-    ]--  -- Add the type of the auxiliary function to the signature--  -- Generate the type of the with function-  delta1 <- normalise delta1 -- Issue 1332: checkInternal is picky about argInfo-                             -- but module application is sloppy.-                             -- We normalise to get rid of Def's coming-                             -- from module applications.-  (withFunType, n) <- withFunctionType delta1 vs as delta2 b-  reportSDoc "tc.with.type" 10 $ sep [ text "with-function type:", nest 2 $ prettyTCM withFunType ]-  reportSDoc "tc.with.type" 50 $ sep [ text "with-function type:", nest 2 $ pretty withFunType ]--  -- Andreas, 2013-10-21-  -- Check generated type directly in internal syntax.-  setCurrentRange cs-    (traceCall NoHighlighting $   -- To avoid flicker.-      checkType withFunType)-    `catchError` \err -> case err of-      TypeError s e -> do-        put s-        wt <- reify withFunType-        enterClosure e $ do-          traceCall (CheckWithFunctionType wt) . typeError-      err           -> throwError err--  -- With display forms are closed--  df <- makeGlobal =<< withDisplayForm f aux delta1 delta2 n qs perm' perm--  reportSLn "tc.with.top" 20 "created with display form"--  case dget df of-    Display n ts dt ->-      reportSDoc "tc.with.top" 20 $ text "Display" <+> fsep-        [ text (show n)-        , prettyList $ map prettyTCM ts-        , prettyTCM dt-        ]-  addConstant aux =<< do-    useTerPragma $ (defaultDefn defaultArgInfo aux withFunType emptyFunction)-                   { defDisplay = [df] }-  -- solveSizeConstraints -- Andreas, 2012-10-16 does not seem necessary--  reportSDoc "tc.with.top" 10 $ sep-    [ text "added with function" <+> (prettyTCM aux) <+> text "of type"-    , nest 2 $ prettyTCM withFunType-    , nest 2 $ text "-|" <+> (prettyTCM =<< getContextTelescope)-    ]-  reportSDoc "tc.with.top" 70 $ vcat-    [ nest 2 $ text $ "raw with func. type = " ++ show withFunType-    ]---  -- Construct the body for the with function-  cs <- return $ map (A.lhsToSpine) cs-  cs <- buildWithFunction cxtNames f aux t qs npars withSub finalPerm (size delta1) n cs-  cs <- return $ map (A.spineToLhs) cs--  -- Check the with function-  checkFunDefS withFunType defaultArgInfo NotDelayed Nothing (Just f) info aux (Just withSub) cs--  where-    info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess ConcreteDef (getRange cs)---- | Type check a where clause.-checkWhere-  :: [A.Declaration] -- ^ Where-declarations to check.-  -> TCM a           -- ^ Continuation.-  -> TCM a-checkWhere ds ret = loop ds-  where-    loop ds = case ds of-      [] -> ret-      [A.ScopedDecl scope ds] -> withScope_ scope $ loop ds-      [A.Section _ m tel ds]  -> newSection m tel $ do-          local (\ e -> e { envCheckingWhere = True }) $ do-            checkDecls ds-            ret-      _ -> __IMPOSSIBLE__---- | Enter a new section during type-checking.--newSection :: ModuleName -> A.Telescope -> TCM a -> TCM a-newSection m tel cont = do-  reportSDoc "tc.section" 10 $-    text "checking section" <+> prettyTCM m <+> fsep (map prettyAs tel)--  checkTelescope tel $ \ tel' -> do-    reportSDoc "tc.section" 10 $-      text "adding section:" <+> prettyTCM m <+> text (show (size tel'))--    addSection m--    reportSDoc "tc.section" 10 $ inTopContext $-      nest 4 $ text "actual tele:" <+> do prettyTCM =<< lookupSection m--    withCurrentModule m cont----- | Check if a pattern contains an absurd pattern. For instance, @suc ()@-containsAbsurdPattern :: A.Pattern -> Bool-containsAbsurdPattern p = case p of-    A.AbsurdP _   -> True-    A.VarP _      -> False-    A.WildP _     -> False-    A.DotP _ _ _  -> False-    A.LitP _      -> False-    A.AsP _ _ p   -> containsAbsurdPattern p-    A.ConP _ _ ps -> any (containsAbsurdPattern . namedArg) ps-    A.RecP _ fs   -> any (containsAbsurdPattern . (^. exprFieldA)) fs-    A.ProjP{}     -> False-    A.DefP _ _ ps -> any (containsAbsurdPattern . namedArg) ps-    A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- False---- | Set the current clause number.-atClause :: QName -> Int -> A.RHS -> TCM a -> TCM a-atClause name i rhs = local $ \ e -> e { envClause = IPClause name i rhs }+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Def where++import Prelude hiding ( null )++import Control.Monad        ( forM, forM_ )+import Control.Monad.Except ( MonadError(..) )++import Data.Bifunctor+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.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+import qualified Agda.Syntax.Abstract.Views as A+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.Pattern as I+import Agda.Syntax.Internal.MetaVars (allMetasList)+import qualified Agda.Syntax.Info as Info+import Agda.Syntax.Info hiding (defAbstract)++import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Warnings ( warning )++import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Inlining+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.With+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.Injectivity+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+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.Permutation+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++---------------------------------------------------------------------------+-- * Definitions by pattern matching+---------------------------------------------------------------------------++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 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 == 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 <$> lookupLocalMeta x+                  mapM_ unfreezeMeta (x : xs)+                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 <$> 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+        when (ismacro || Info.defMacro i == MacroDef) $ checkMacroType t+    `catchIlltypedPatternBlockedOnMeta` \ (err, blocker) -> do+        reportSDoc "tc.def" 20 $ vcat $+          [ "checking function definition got stuck on: " <+> pretty blocker ]+        modifySignature $ updateDefinition name $ updateDefBlocked $ const $ Blocked blocker ()+        addConstraint blocker $ CheckFunDef i name cs err++checkMacroType :: Type -> TCM ()+checkMacroType t = do+  TelV tel tr <- telView t++  let telList = telToList tel+      resType = abstract (telFromList (drop (length telList - 1) telList)) tr+  expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)+  equalType resType 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)+isAlias cs t =+        case trivialClause cs of+          -- if we have just one clause without pattern matching and+          -- without a type signature, then infer, to allow+          -- "aliases" for things starting with hidden abstractions+          Just (e, mc) | Just x <- isMeta (unEl t) -> Just (e, mc, x)+          _ -> Nothing+  where+    isMeta (MetaV x _) = Just x+    isMeta _           = Nothing+    trivialClause [A.Clause (A.LHS i (A.LHSHead f [])) _ (A.RHS e mc) wh _]+      | null wh     = Just (e, mc)+    trivialClause _ = Nothing++-- | Check a trivial definition of the form @f = e@+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     = empty } in+  atClause name 0 t Nothing clause $ do+  reportSDoc "tc.def.alias" 10 $ "checkAlias" <+> vcat+    [ text (prettyShow name) <+> colon  <+> prettyTCM t+    , text (prettyShow name) <+> equals <+> prettyTCM e+    ]++  -- Infer the type of the rhs.+  -- Andreas, 2018-06-09, issue #2170.+  -- The context will only be resurrected if we have --irrelevant-projections.+  v <- applyModalityToContextFunBody ai $ checkDontExpandLast CmpLeq e t++  reportSDoc "tc.def.alias" 20 $ "checkAlias: finished checking"++  solveSizeConstraints DontDefaultToInfty++  v <- instantiateFull v  -- if we omit this, we loop (stdlib: Relation.Binary.Sum)+    -- or the termination checker might stumble over levels in sorts+    -- that cannot be converted to expressions without the level built-ins+    -- (test/succeed/Issue655.agda)++  -- compute body modification for irrelevant definitions, see issue 610+  let bodyMod = applyWhen (isIrrelevant ai) dontCare++  -- Add the definition+  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 $ readdTypedInstance name t+      -- Put highlighting on the name only;+      -- @(getRange (r, name))@ does not give good results.+    NotInstanceDef -> pure ()++  reportSDoc "tc.def.alias" 20 $ "checkAlias: leaving"+++-- | Type check a definition by pattern matching.+checkFunDef' :: Type             -- ^ the type we expect the function to have+             -> ArgInfo          -- ^ is it irrelevant (for instance)+             -> 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+             -> [A.Clause]       -- ^ the clauses to check+             -> TCM ()+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)+             -> 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, 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 extlam with i name withSubAndLets cs = do++    traceCall (CheckFunDefCall (getRange i) name cs True) $ do+        reportSDoc "tc.def.fun" 10 $+          sep [ "checking body of" <+> prettyTCM name+              , nest 2 $ ":" <+> prettyTCM t+              , nest 2 $ "full type:" <+> (prettyTCM . defType =<< getConstInfo name)+              ]++        reportSDoc "tc.def.fun" 70 $+          sep $ "clauses:" : map (nest 2 . text . show . A.deepUnscope) cs++        cs <- return $ map A.lhsToSpine cs++        reportSDoc "tc.def.fun" 70 $+          sep $ "spine clauses:" : map (nest 2 . text . show . A.deepUnscope) cs++        -- Ensure that all clauses have the same number of trailing hidden patterns+        -- This is necessary since trailing implicits are no longer eagerly inserted.+        -- Andreas, 2013-10-13+        -- Since we have flexible function arity, it is no longer necessary+        -- to patch clauses to same arity+        -- cs <- trailingImplicits t cs++        -- Check the clauses+        cs <- traceCall NoHighlighting $ do -- To avoid flicker.+          forM (zip cs [0..]) $ \ (c, clauseNo) -> do+            atClause name clauseNo t (fst <$> withSubAndLets) c $ do+              (c,b) <- applyModalityToContextFunBody ai $ do+                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+              -- checked individually, since otherwise we get constraints+              -- in typing contexts which are not prefixes of each other.+              whenNothing extlam $ solveSizeConstraints DontDefaultToInfty+              -- Andreas, 2013-10-27 add clause as soon it is type-checked+              -- TODO: instantiateFull?+              inTopContext $ addClauses name [c]+              return (c,b)++        (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+        when isSystem do+          -- allow VarP and ConP i0/i1 fallThrough = yes, DotP+          let pss = map namedClausePats cs+              allowed = \case+                VarP{} -> True+                -- pattern inserted by splitPartial+                ConP _ cpi [] | conPFallThrough cpi -> True+                DotP{} -> True+                _      -> False+          unless (all (all $ allowed . namedArg) pss) $+            typeError PatternInSystem++        reportSDoc "tc.def.fun" 70 $ inTopContext $ do+          sep $ "checked clauses:" : map (nest 2 . text . show) cs++        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+              ]+        reportSDoc "tc.cc" 60 $ inTopContext $ do+          sep [ "raw clauses: "+              , nest 2 $ sep $ map (text . show . QNamed name) cs+              ]++        -- Needed to calculate the proper fullType below.+        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.+        (cs,sys) <- if not isSystem then return (cs, empty) else do+                 fullType <- flip abstract t <$> getContextTelescope+                 sys <- inTopContext $ checkSystemCoverage name (IntSet.toList isOneIxs) fullType cs+                 tel <- getContextTelescope+                 let c = Clause+                       { clauseFullRange = noRange+                       , clauseLHSRange  = noRange+                       , clauseTel       = tel+                       , namedClausePats = teleNamedArgs tel+                       , clauseBody      = Nothing+                       , clauseType      = Just (defaultArg t)+                       , clauseCatchall    = empty+                       , clauseRecursive   = Just False+                       , clauseUnreachable = Just False+                       , 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+        -- We do it again for the mutual block after termination checking, see Rules.Decl.+        reportSLn "tc.inj.def" 20 $ "checkFunDef': checking injectivity..."+        inv <- Bench.billTo [Bench.Injectivity] $+          checkInjectivity name cs++        reportSDoc "tc.cc" 15 $ inTopContext $ do+          sep [ "clauses before compilation"+              , nest 2 $ sep $ map (prettyTCM . QNamed name) cs+              ]++        reportSDoc "tc.cc.raw" 65 $ do+          sep [ "clauses before compilation"+              , nest 2 $ sep $ map (text . show) cs+              ]++        -- add clauses for the coverage (& confluence) checker (needs to reduce)+        inTopContext $ addClauses name cs++        reportSDoc "tc.cc.type" 60 $ "  type   : " <+> (text . prettyShow) t+        reportSDoc "tc.cc.type" 60 $ "  context: " <+> (text . prettyShow =<< getContextTelescope)++        fullType <- flip telePi t <$> getContextTelescope++        reportSLn  "tc.cc.type" 80 $ show fullType++        -- Coverage check and compile the clauses+        (mst, _recordExpressionBecameCopatternLHS, cc) <- Bench.billTo [Bench.Coverage] $+          unsafeInTopContext $ compileClauses (if isSystem then Nothing else (Just (name, fullType)))+                                        cs+        -- Andreas, 2019-10-21 (see also issue #4142):+        -- We ignore whether the clause compilation turned some+        -- record expressions into copatterns+        -- (_recordExpressionsBecameCopatternLHS),+        -- since the defCopatternLHS flag is anyway set by traversing+        -- the compiled clauses looking for a copattern match+        -- (hasProjectionPatterns).++        -- Clause compilation runs the coverage checker, which might add+        -- some extra clauses.+        cs <- defClauses <$> getConstInfo name++        reportSDoc "tc.cc" 60 $ inTopContext $ do+          sep [ "compiled clauses of" <+> prettyTCM name+              , nest 2 $ pretty cc+              ]++        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.+          --+          -- 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)++        reportSDoc "tc.def.fun" 10 $ do+          sep [ "added " <+> prettyTCM name <+> ":"+              , nest 2 $ prettyTCM . defType =<< getConstInfo name+              ]++        -- Jesper, 2019-05-30: if the constructors used in the+        -- lhs of a clause have rewrite rules, we need to check+        -- confluence here+        whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> inTopContext $+          checkConfluenceOfClauses confChk name++-- | Set 'funTerminates' according to termination info in 'TCEnv',+--   which comes from a possible termination pragma.+useTerPragma :: Definition -> TCM Definition+useTerPragma def@Defn{ defName = name, theDef = fun@Function{}} = do+  tc <- viewTC eTerminationCheck+  let terminates = case tc of+        NonTerminating -> Just False+        Terminating    -> Just True+        _              -> Nothing+  reportS "tc.fundef" 30 $+    [ "funTerminates of " ++ prettyShow name ++ " set to " ++ show terminates+    , "  tc = " ++ show tc+    ]+  return $ def { theDef = fun { funTerminates = terminates }}+useTerPragma def = return def++-- | Modify all the LHSCore of the given RHS.+-- (Used to insert patterns for @rewrite@ or the inspect idiom)+mapLHSCores :: (A.LHSCore -> A.LHSCore) -> (A.RHS -> A.RHS)+mapLHSCores f = \case+  A.WithRHS aux es cs -> A.WithRHS aux es $ for cs $+    \ (A.Clause (A.LHS info core)     spats rhs                 ds catchall) ->+       A.Clause (A.LHS info (f core)) spats (mapLHSCores f rhs) ds catchall+  A.RewriteRHS qes spats rhs wh -> A.RewriteRHS qes spats (mapLHSCores f rhs) wh+  rhs@A.AbsurdRHS -> rhs+  rhs@A.RHS{}     -> rhs++-- | Insert some names into the with-clauses LHS of the given RHS.+-- (Used for the inspect idiom)+insertNames :: List1 (Arg (Maybe A.BindName)) -> A.RHS -> A.RHS+insertNames = mapLHSCores . insertInspects++insertInspects :: List1 (Arg (Maybe A.BindName)) -> A.LHSCore -> A.LHSCore+insertInspects ps = \case+  A.LHSWith core wps [] ->+    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++    patOfName :: A.BindName -> Arg A.Pattern+    patOfName = defaultArg . A.VarP++    insertIn :: [Arg (Maybe (Arg a))]+             -> [Arg a] -> [Arg a]+    insertIn []                 wps  = wps+    insertIn (Arg info nm : ps) (w : wps) | visible info =+      w : maybeToList nm ++ insertIn ps wps+    insertIn (Arg info nm : ps) wps       | notVisible info =+          maybeToList nm ++ insertIn ps wps+    insertIn _ _ = __IMPOSSIBLE__+++-- | Insert some with-patterns into the with-clauses LHS of the given RHS.+-- (Used for @rewrite@)+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 :: List1 (Arg A.Pattern) -> A.LHSCore -> A.LHSCore+insertPatternsLHSCore pats = \case+  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        :: 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+  :: QName+  -> [Int]+  -> Type+  -> [Clause]+  -> TCM System+checkSystemCoverage f [n] t cs = do+  reportSDoc "tc.sys.cover" 10 $ text (show (n , length cs)) <+> prettyTCM t+  TelV gamma t <- telViewUpTo n t+  addContext gamma $ do+  TelV (ExtendTel a _) _ <- telViewUpTo 1 t+  a <- reduce $ unEl $ unDom a++  case a of+    Def q [Apply phi] -> do+      [iz,io] <- mapM getBuiltinName' [builtinIZero, builtinIOne]+      ineg <- primINeg+      imin <- primIMin+      imax <- primIMax+      i0 <- primIZero+      i1 <- primIOne+      let+        isDir (ConP q _ []) | Just (conName q) == iz = Just False+        isDir (ConP q _ []) | Just (conName q) == io = Just True+        isDir _ = Nothing++        collectDirs :: [Int] -> [DeBruijnPattern] -> [(Int,Bool)]+        collectDirs [] [] = []+        collectDirs (i : is) (p : ps) | Just d <- isDir p = (i,d) : collectDirs is ps+                                      | otherwise         = collectDirs is ps+        collectDirs _ _ = __IMPOSSIBLE__++        dir :: (Int,Bool) -> Term+        dir (i,False) = ineg `apply` [argN $ var i]+        dir (i,True) = var i++        -- andI and orI have cases for singletons to improve error messages.+        andI, orI :: [Term] -> Term+        andI [] = i1+        andI [t] = t+        andI (t:ts) = (\ x -> imin `apply` [argN t, argN x]) $ andI ts++        orI [] = i0+        orI [t] = t+        orI (t:ts) = imax `apply` [argN t, argN (orI ts)]++      let+        pats = map (take n . map (namedThing . unArg) . namedClausePats) cs+        alphas :: [[(Int,Bool)]] -- the face maps corresponding to each clause+        alphas = map (collectDirs (downFrom n)) pats+        phis :: [Term] -- the φ terms for each clause (i.e. the alphas as terms)+        phis = map (andI . (map dir)) alphas+        psi = orI $ phis+        pcs = zip phis cs++      reportSDoc "tc.sys.cover" 20 $ fsep $ map prettyTCM pats+      interval <- primIntervalType+      reportSDoc "tc.sys.cover" 10 $ "equalTerm " <+> prettyTCM (unArg phi) <+> prettyTCM psi+      equalTerm interval (unArg phi) psi++      forM_ (initWithDefault __IMPOSSIBLE__ $+             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+            let args = sigma `applySubst` teleArgs gamma+                t' = sigma `applySubst` t+                fromReduced (YesReduction _ x) = x+                fromReduced (NoReduction x) = ignoreBlocking x+                body cl = do+                  let extra = length (drop n $ namedClausePats cl)+                  TelV delta _ <- telViewUpTo extra t'+                  fmap (abstract delta) $ addContext delta $ do+                    fmap fromReduced $ runReduceM $+                      appDef' f (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta)+            v1 <- body cl1+            v2 <- body cl2+            equalTerm t' v1 v2++      sys <- forM (zip alphas cs) $ \ (alpha,cl) -> do++            let+                -- Δ = Γ_α , Δ'α+                delta = clauseTel cl+                -- Δ ⊢ b+                Just b = clauseBody cl+                -- Δ ⊢ ps : Γ , o : [φ] , Δ'+                -- we assume that there's no pattern matching other+                -- than from the system+                ps = namedClausePats cl+                extra = length (drop (size gamma + 1) ps)+                -- size Δ'α = size Δ' = extra+                -- Γ , α ⊢ u+                takeLast n xs = drop (length xs - n) xs+                weak [] = idS+                weak (i:is) = weak is `composeS` liftS i (raiseS 1)+                tel = telFromList (takeLast extra (telToList delta))+                u = abstract tel (liftS extra (weak $ List.sort $ map fst alpha) `applySubst` b)+            return (map (first var) alpha,u)++      reportSDoc "tc.sys.cover.sys" 20 $ fsep $ prettyTCM gamma : map prettyTCM sys+      reportSDoc "tc.sys.cover.sys" 40 $ fsep $ (text . show) gamma : map (text . show) sys+      return (System gamma sys) -- gamma uses names from the type, not the patterns, could we do better?+    _ -> __IMPOSSIBLE__+checkSystemCoverage _ _ t cs = __IMPOSSIBLE__+++-- * Info that is needed after all clauses have been processed.++data ClausesPostChecks = CPC+    { cpcPartialSplits :: IntSet+      -- ^ Which argument indexes have a partial split.+    }++instance Semigroup ClausesPostChecks where+  CPC xs <> CPC xs' = CPC (IntSet.union xs xs')++instance Monoid ClausesPostChecks where+  mempty  = CPC empty+  mappend = (<>)++-- | The LHS part of checkClause.+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+    () <- 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) (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, Map Name LetBinding)  -- ^ Module parameter substitution arising from with-abstraction, and inherited let-bindings.+  -> A.SpineClause -- ^ Clause.+  -> TCM (Clause, ClausesPostChecks)  -- ^ Type-checked clause++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.++        -- Subtle: checkRHS expects the function type to be the lambda lifted+        -- type. If we're checking a with-function that's already the case,+        -- otherwise we need to abstract over the module telescope.+        t' <- case withSub of+                Just{}  -> return t+                Nothing -> do+                  theta <- lookupSection (qnameModule x)+                  return $ abstract theta t++        -- At this point we should update the named dots potential with-clauses+        -- in the right-hand side. When checking a clause we expect the named+        -- dots to live in the context of the closest parent lhs, but the named+        -- dots added by buildWithFunction live in the context of the+        -- with-function arguments before pattern matching. That's what we need+        -- patSubst for.+        let rhs = updateRHS rhs0+            updateRHS rhs@A.RHS{}               = rhs+            updateRHS rhs@A.AbsurdRHS{}         = rhs+            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++            updateClause (A.Clause f spats rhs wh ca) =+              A.Clause f (applySubst patSubst spats) (updateRHS rhs) wh ca++        (body, with) <- bindAsPatterns asb $ checkWhere wh $ checkRHS i x aps t' lhsResult rhs++        -- Note that the with function doesn't necessarily share any part of+        -- the context with the parent (but withSub will take you from parent+        -- to child).++        wbody <- unsafeInTopContext $ Bench.billTo [Bench.Typing, Bench.With] $ checkWithFunction cxtNames with++        body <- return $ body `mplus` wbody++        whenM (optDoubleCheck <$> pragmaOptions) $ case body of+          Just v  -> do+            reportSDoc "tc.lhs.top" 30 $ vcat+              [ "double checking rhs"+              , nest 2 (prettyTCM v <+> " : " <+> prettyTCM (unArg trhs))+              ]+            noConstraints $ withFrozenMetas $ checkInternal v CmpLeq $ unArg trhs+          Nothing -> return ()++        reportSDoc "tc.lhs.top" 10 $ vcat+          [ "Clause before translation:"+          , nest 2 $ vcat+            [ "delta =" <+> do escapeContext impossible (size delta) $ prettyTCM delta+            , "ps    =" <+> do P.fsep <$> prettyTCMPatterns ps+            , "body  =" <+> maybe "_|_" prettyTCM body+            , "type  =" <+> prettyTCM t+            ]+          ]++        reportSDoc "tc.lhs.top" 60 $ escapeContext impossible (size delta) $ vcat+          [ "Clause before translation (raw):"+          , nest 2 $ vcat+            [ "ps    =" <+> text (show ps)+            , "body  =" <+> text (show body)+            , "type  =" <+> text (show t)+            ]+          ]++        -- compute body modification for irrelevant definitions, see issue 610+        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' = if isNothing body then YesCatchall empty else catchall++        return $ (, CPC psplit)+          Clause { clauseLHSRange  = getRange i+                 , clauseFullRange = getRange c+                 , clauseTel       = killRange delta+                 , namedClausePats = ps+                 , clauseBody      = bodyMod body+                 , clauseType      = Just trhs+                 , clauseCatchall  = catchall'+                 , clauseRecursive   = Nothing -- we don't know yet+                 , clauseUnreachable = Nothing -- we don't know yet+                 , clauseEllipsis    = lhsEllipsis i+                 , clauseWhereModule = A.whereModule wh+                 }++++-- | Generate the abstract pattern corresponding to Refl+getReflPattern :: TCM A.Pattern+getReflPattern = do+  -- Get the name of builtin REFL.+  Con reflCon _ [] <- primRefl++  reflInfo <- fmap (setOrigin Inserted) <$> getReflArgInfo reflCon+  let patInfo = ConPatInfo ConOCon patNoRange ConPatEager+  -- The REFL constructor might have an argument+  let reflArg = maybeToList $ fmap (\ ai -> Arg ai $ unnamed $ A.WildP patNoRange) reflInfo++  pure $ A.ConP patInfo (unambiguous $ conName reflCon) reflArg++-- | Type check the @with@ and @rewrite@ lhss and/or the rhs.+checkRHS+  :: LHSInfo                 -- ^ Range of lhs.+  -> QName                   -- ^ Name of function.+  -> [NamedArg A.Pattern]    -- ^ Patterns in lhs.+  -> Type                    -- ^ Top-level type of function.+  -> LHSResult               -- ^ Result of type-checking patterns+  -> 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 =+  handleRHS rhs0 where++  handleRHS :: A.RHS -> TCM (Maybe Term, WithFunctionProblem)+  handleRHS rhs = case rhs of+    A.RHS e _                  -> ordinaryRHS e+    A.AbsurdRHS                -> noRHS+    A.RewriteRHS eqs ps rhs wh -> rewriteEqnsRHS eqs ps rhs wh+    A.WithRHS aux es cs        -> withRHS aux es cs++  -- Ordinary case: f xs = e+  ordinaryRHS :: A.Expr -> TCM (Maybe Term, WithFunctionProblem)+  ordinaryRHS e = Bench.billTo [Bench.Typing, Bench.CheckRHS] $ do+    -- If there is an absurd pattern, we do not need a RHS. If we have+    -- one we complain, ignore it and return the same @(Nothing, NoWithFunction)@+    -- as the case dealing with @A.AbsurdRHS@.+    mv <- if absurdPat+          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 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+    -> 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 <| fmap (parens . prettyA . namedThing) es+      ]+    reportSDoc "tc.with.top" 20 $ do+      nfv <- getCurrentModuleFreeVars+      m   <- currentModule+      sep [ "with function module:" <+>+             prettyList (map prettyTCM $ mnameToList m)+          ,  text $ "free variables: " ++ show nfv+          ]++    -- Infer the types of the with expressions++    vtys <- forM es $ \ (Named nm we) -> do+              (e, ty) <- inferExprForWith we+              pure $ (<$ we) . (e,) $ case nm of+                Nothing -> OtherType ty+                Just{}  -> IdiomType ty++    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+      pure $ A.Clause (A.LHS i core') eqs rhs' wh b++    -- Andreas, 2016-01-23, Issue #1796+    -- Run the size constraint solver to improve with-abstraction+    -- in case the with-expression contains size metas.+    solveSizeConstraints DefaultToInfty++    checkWithRHS x aux t lhsResult vtys cs++  -- Rewrite case: f xs (rewrite / invert) a | b | c | ...+  rewriteEqnsRHS+    :: [A.RewriteEqn]+    -> [A.ProblemEq]+    -> A.RHS+    -> A.WhereDeclarations+    -> TCM (Maybe Term, WithFunctionProblem)++  rewriteEqnsRHS [] strippedPats rhs wh = checkWhere wh $ handleRHS rhs+      -- Case: @rewrite@+      -- Andreas, 2014-01-17, Issue 1402:+      -- If the rewrites are discarded since lhs=rhs, then+      -- we can actually have where clauses.+  rewriteEqnsRHS (r:rs) strippedPats rhs wh = case r of+    Rewrite ((qname, eq) :| qes) ->+      rewriteEqnRHS qname eq $+        List1.ifNull qes {-then-} rs {-else-} $ \ qes -> Rewrite qes : 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 -> List1 (Named A.BindName (A.Pattern,A.Expr)) -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)+    invertEqnRHS qname pes rs = do++      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)+        pure $ defaultArg . (e,) $ case nm of+          Nothing -> OtherType ty+          Just{}  -> IdiomType ty++      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+      -- in case the with-expression contains size metas.+      solveSizeConstraints DefaultToInfty++      let rhs' = insertPatterns pats rhs+          (rhs'', outerWhere) -- the where clauses should go on the inner-most with+            | null rs  = (rhs', wh)+            | otherwise = (A.RewriteRHS rs strippedPats rhs' wh, A.noWhereDecls)+          -- 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 empty++      reportSDoc "tc.invert" 60 $ vcat+        [ text "invert"+        , "  rhs' = " <> (text . show) rhs'+        ]+      checkWithRHS x qname t lhsResult vtys $ singleton cl++    -- @rewrite@ clauses+    rewriteEqnRHS+      :: QName+      -> A.Expr+      -> [A.RewriteEqn]+      -> TCM (Maybe Term, WithFunctionProblem)+    rewriteEqnRHS qname eq rs = do++      -- Action for skipping this rewrite.+      -- We do not want to create unsolved metas in case of+      -- a futile rewrite with a reflexive equation.+      -- Thus, we restore the state in this case,+      -- unless the rewrite expression contains questionmarks.+      st <- getTC+      -- TODO:: recurse defined but not used+      let recurse = do+           st' <- getTC+           -- Comparing the whole stInteractionPoints maps is a bit+           -- wasteful, but we assume+           -- 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)+           when (sameIP st st') $ putTC st+           handleRHS $ A.RewriteRHS rs strippedPats rhs wh++      -- Get value and type of rewrite-expression.++      (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.+      solveSizeConstraints DefaultToInfty++      -- Check that the type is actually an equality (lhs ≡ rhs)+      -- and extract lhs, rhs, and their type.++      t' <- reduce =<< instantiateFull eqt+      (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 $ CannotRewriteByNonEquation t'+        IdiomType{} -> typeError $ CannotRewriteByNonEquation t'++      reflPat <- getReflPattern++      -- Andreas, 2015-12-25  Issue #1740:+      -- After the fix of #520, rewriting with a reflexive equation+      -- has to be desugared as matching against refl.+      let isReflexive = tryConversion $ dontAssignMetas $+           equalTerm rewriteType rewriteFrom rewriteTo++      (pats', withExpr, withType) <- do+        ifM isReflexive+          {-then-} (return (                      reflPat :| [], proof, OtherType t'))+          {-else-} (return (A.WildP patNoRange <| reflPat :| [], proof, eqt))+      let pats = defaultArg <$> pats'++      let rhs' = insertPatterns pats rhs+          (rhs'', outerWhere) -- the where clauses should go on the inner-most with+            | null rs  = (rhs', wh)+            | otherwise = (A.RewriteRHS rs strippedPats rhs' wh, A.noWhereDecls)+          -- 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 empty++      reportSDoc "tc.rewrite" 60 $ vcat+        [ text "rewrite"+        , "  rhs' = " <> (text . show) rhs'+        ]+      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+  -> 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 =+  verboseBracket "tc.with.top" 25 "checkWithRHS" $ do+    Bench.billTo [Bench.Typing, Bench.With] $ do+        withArgs <- withArguments vtys0+        let perm = fromMaybe __IMPOSSIBLE__ $ dbPatPerm ps++        reportSDoc "tc.with.top" 30 $ vcat $+          -- declared locally because we do not want to use the unzip'd thing!+          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) = List1.unzipWith unArg vtys0 in+          [ "vs (before norm., raw) =" <+> pretty vs+          ]+        vtys0 <- normalise vtys0++        -- Andreas, 2012-09-17: for printing delta,+        -- we should remove it from the context first+        reportSDoc "tc.with.top" 25 $ escapeContext impossible (size delta) $ vcat+          [ "delta  =" <+> prettyTCM delta+          ]+        reportSDoc "tc.with.top" 25 $ vcat $+          -- declared locally because we do not want to use the unzip'd thing!+          let (vs, as) = List1.unzipWith unArg vtys0 in+          [ "vs     =" <+> prettyTCM vs+          , "as     =" <+> prettyTCM as+          , "perm   =" <+> text (show perm)+          ]++        -- Split the telescope into the part needed to type the with arguments+        -- and all the other stuff+        let (delta1, delta2, perm', t', vtys) = splitTelForWith delta (unArg trhs) vtys0+        let finalPerm = composeP perm' perm++        reportSLn "tc.with.top" 75 $ "delta  = " ++ show delta++        -- Andreas, 2012-09-17: for printing delta,+        -- we should remove it from the context first+        reportSDoc "tc.with.top" 25 $ escapeContext impossible (size delta) $ vcat+          [ "delta1 =" <+> prettyTCM delta1+          , "delta2 =" <+> addContext delta1 (prettyTCM delta2)+          ]+        reportSDoc "tc.with.top" 25 $ vcat+          [ "perm'  =" <+> text (show perm')+          , "fPerm  =" <+> text (show finalPerm)+          ]++        -- Create the body of the original function++        -- All the context variables+        us <- getContextTerms+        let n = size us+            m = size delta+            -- First the variables bound outside this definition+            (us0, us1') = splitAt (n - m) us+            -- 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 (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 <$>+              emptyFunction++        reportSDoc "tc.with.top" 20 $ vcat $+          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+          ]++        -- 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 lets) = do+  let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′    (where Δ′ is the context of the parent lhs)+      withSub :: Substitution+      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) = List1.unzipWith unArg vtys in+      [ "delta1 =" <+> prettyTCM delta1+      , "delta2 =" <+> addContext delta1 (prettyTCM delta2)+      , "t      =" <+> prettyTCM t+      , "as     =" <+> addContext delta1 (prettyTCM as)+      , "vs     =" <+> do addContext delta1 $ prettyTCM vs+      , "b      =" <+> do addContext delta1 $ addContext delta2 $ prettyTCM b+      , "qs     =" <+> do addContext delta $ prettyTCMPatternList qs+      , "perm'  =" <+> text (show perm')+      , "perm   =" <+> text (show perm)+      , "fperm  =" <+> text (show finalPerm)+      , "withSub=" <+> text (show withSub)+      ]+    ]++  -- Add the type of the auxiliary function to the signature++  -- Jesper, 2020-04-05: Currently variable generalization inserts+  -- dummy terms, we have to reduce projections to get rid of them.+  -- (see also #1332).+  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, (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 empty else do+      iz <- primIZero+      io <- primIOne+      let tm = Def f (patternsToElims ps)+      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+  reportSDoc "tc.with.type" 10 $ sep [ "with-function type:", nest 2 $ prettyTCM withFunType ]+  reportSDoc "tc.with.type" 50 $ sep [ "with-function type:", nest 2 $ pretty withFunType ]++  call_in_parent <- do+    (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++  -- Andreas, 2013-10-21+  -- Check generated type directly in internal syntax.+  setCurrentRange cs $+    traceCall NoHighlighting $   -- To avoid flicker.+    traceCall (CheckWithFunctionType 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 nwithargs qs perm' perm++  reportSLn "tc.with.top" 20 "created with display form"++  case dget df of+    Display n ts dt ->+      reportSDoc "tc.with.top" 20 $ "Display" <+> fsep+        [ text (show n)+        , prettyList $ map prettyTCM ts+        , prettyTCM dt+        ]+  addConstant aux =<< do+    lang <- getLanguage+    fun  <- emptyFunction+    useTerPragma $+      (defaultDefn defaultArgInfo aux withFunType lang fun)+        { defDisplay = [df] }+  -- solveSizeConstraints -- Andreas, 2012-10-16 does not seem necessary++  reportSDoc "tc.with.top" 10 $ sep+    [ "added with function" <+> (prettyTCM aux) <+> "of type"+    , nest 2 $ prettyTCM withFunType+    , nest 2 $ "-|" <+> (prettyTCM =<< getContextTelescope)+    ]+  reportSDoc "tc.with.top" 70 $ vcat+    [ nest 2 $ text $ "raw with func. type = " ++ show withFunType+    ]+++  -- Construct the body for the with function+  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)+  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.+checkWhere+  :: A.WhereDeclarations -- ^ Where-declarations to check.+  -> TCM a               -- ^ Continuation.+  -> TCM a+checkWhere wh@(A.WhereDecls whmod whNamed mds) ret = do+  when (not whNamed) $ ensureNoNamedWhereInRefinedContext whmod+  case mds of+      Nothing -> ret+      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) $ 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+          where+            isWk i []                = True+            isWk i (Var j [] : args) = i == j && isWk (i - 1) args+            isWk _ _ = False+        isWeakening _ = False+++-- | Enter a new section during type-checking.++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" <+> (prettyErased e <$> prettyTCM m) <+>+    fsep (map prettyA tel)++  checkGeneralizeTelescope (Just m) gtel $ \ _ tel' -> do+    reportSDoc "tc.section" 10 $+      "adding section:" <+> prettyTCM m <+> text (show (size tel'))++    addSection m++    reportSDoc "tc.section" 10 $ inTopContext $+      nest 4 $ "actual tele:" <+> do prettyTCM =<< lookupSection m++    withCurrentModule m cont++-- | Set the current clause number.++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
src/full/Agda/TypeChecking/Rules/Def.hs-boot view
@@ -1,15 +1,17 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rules.Def where  import Agda.Syntax.Abstract as A import Agda.Syntax.Common-import Agda.Syntax.Info 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.Telescope -> 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,9 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.Display (checkDisplayPragma) where -import Control.Applicative+import Control.Monad.Except+import Control.Monad.State import Data.Maybe-import Data.List  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views@@ -14,97 +15,163 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Warnings (warning) +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 = inTopContext $ do-  pappToTerm f id ps $ \n args -> do-    let lhs = map I.Apply args-    v <- exprToTerm e-    let df = Display n lhs (DTerm v)-    reportSLn "tc.display.pragma" 20 $ "Adding display form for " ++ show f ++ "\n  " ++ show df-    escapeContext n $ addDisplayForm f df+checkDisplayPragma f ps e = do+  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 --- 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 -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 = do-  let isMatch = getHiding p == getHiding a &&-                (notHidden p || isNothing (nameOf (unArg p)) ||-                 Just (absName tel) == (rangedThing <$> nameOf (unArg p)))-  case isMatch of-    True ->-      patternToTerm (namedArg p) $ \n v ->-      patternsToTerms (unAbs tel) ps  $ \m vs -> ret (n + m) (inheritHiding p v : vs)-    False ->-      bindWild $ patternsToTerms (unAbs tel) (p : ps) $ \n vs -> ret (1 + n) (inheritHiding a (Var 0 []) : vs)+-- | 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 -inheritHiding :: LensHiding a => a -> b -> Arg b-inheritHiding a b = setHiding (getHiding a) (defaultArg b)+var0 :: ProjOrApp+var0 = IsApp (var 0) -pappToTerm :: QName -> (Args -> b) -> [NamedArg A.Pattern] -> (Int -> b -> TCM a) -> TCM a+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)++{-# 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 x               -> bindVar x $ ret 1 (Var 0 [])-    A.ConP _ (AmbQ [c]) ps -> pappToTerm c (Con (ConHead c Inductive []) ConOCon) ps ret-    A.ConP _ (AmbQ cs) _   -> genericError $ "Ambiguous constructor: " ++ intercalate ", " (map show cs)-    A.ProjP _ _ (AmbQ [d]) -> ret 0 (Def d [])-    A.ProjP _ _ (AmbQ ds)    -> genericError $ "Ambiguous projection: " ++ intercalate ", " (map show ds)-    A.DefP _ (AmbQ [f]) ps -> pappToTerm f (Def f . map Apply) ps ret-    A.DefP _ (AmbQ ds) _   -> genericError $ "Ambiguous DefP: " ++ intercalate ", " (map show ds)-    A.LitP l               -> ret 0 (Lit l)-    A.WildP _              -> bindWild $ ret 1 (Var 0 [])-    _ -> do-      doc <- prettyA p-      typeError $ GenericError $ "Pattern not allowed in DISPLAY pragma:\n" ++ show doc+    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) ps \ n t -> ret n (IsApp t)+      | otherwise                   -> ambigErr "constructor" cs+    A.ProjP _ _ ds+      | Just d <- getUnambiguous ds -> ret 0 $ IsProj d+      | otherwise                   -> ambigErr "projection" ds+    A.DefP _ fs ps+      | Just f <- getUnambiguous fs -> pappToTerm f (Def f) ps \ n t -> ret n (IsApp t)+      | otherwise                   -> ambigErr "DefP" fs+    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) =+      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 (AmbQ (c:_)) -> pure $ Con (ConHead c 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 _ (AmbQ (f:_)) -> pure $ Def f []   -- only for printing so we don't have to worry too much here-    A.PatternSyn f -> pure $ Def 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+  where+    next :: State Nat Nat+    next = do i <- get; i <$ put (i - 1)++    renumbers :: Elims -> State Nat Elims+    renumbers = (traverse . traverse) renumber++    renumber :: Term -> State Nat Term+    renumber (Var 0 [])   = var <$> next+    renumber (Def f es)   = Def f <$> renumbers es+    renumber (Con c h es) = Con c h <$> renumbers es+    renumber (Lit l)      = pure $ Lit l+    renumber _            = __IMPOSSIBLE__ -- We need only handle the result of patternToTerm here
src/full/Agda/TypeChecking/Rules/LHS.hs view
@@ -1,1016 +1,2097 @@-{-# LANGUAGE CPP                  #-}--module Agda.TypeChecking.Rules.LHS where--import Prelude hiding (mapM, sequence)--import Data.Maybe--import Control.Applicative-import Control.Arrow (first, second, (***))-import Control.Monad hiding (mapM, forM, sequence)-import Control.Monad.State hiding (mapM, forM, sequence)-import Control.Monad.Reader hiding (mapM, forM, sequence)-import Control.Monad.Trans.Maybe--import Data.Function (on)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.List (delete, sortBy, stripPrefix)-import Data.Monoid-import Data.Traversable-import Data.Map (Map)-import qualified Data.Map as Map--import Agda.Interaction.Options-import Agda.Interaction.Options.Lenses--import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Abstract (IsProjP(..))-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views (asView)-import Agda.Syntax.Common as Common-import Agda.Syntax.Info as A-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base (ScopeInfo, emptyScopeInfo)---import Agda.TypeChecking.Monad--import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Irrelevance-import {-# SOURCE #-} Agda.TypeChecking.Empty-import Agda.TypeChecking.Patterns.Abstract-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Rewriting-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope--import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr)-import Agda.TypeChecking.Rules.LHS.AsPatterns-import Agda.TypeChecking.Rules.LHS.Problem hiding (Substitution)-import Agda.TypeChecking.Rules.LHS.ProblemRest-import Agda.TypeChecking.Rules.LHS.Unify-import Agda.TypeChecking.Rules.LHS.Split-import Agda.TypeChecking.Rules.LHS.Implicit-import Agda.TypeChecking.Rules.LHS.Instantiate-import Agda.TypeChecking.Rules.Data--import Agda.Utils.Except (MonadError(..))-import Agda.Utils.Functor-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Permutation-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible---- | 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) f (Just i) i) <$> maybeFlexiblePattern p---- | A pattern is flexible if it is dotted or implicit, or a record pattern---   with only flexible subpatterns.-class IsFlexiblePattern a where-  maybeFlexiblePattern :: a -> MaybeT TCM FlexibleVarKind--  isFlexiblePattern :: a -> TCM Bool-  isFlexiblePattern p = isJust <$> runMaybeT (maybeFlexiblePattern p)--instance IsFlexiblePattern A.Pattern where-  maybeFlexiblePattern p =-    case p of-      A.DotP{}  -> return DotFlex-      A.VarP{}  -> return ImplicitFlex-      A.WildP{} -> return ImplicitFlex-      A.AsP _ _ p -> maybeFlexiblePattern p-      A.ConP _ (A.AmbQ [c]) qs-        -> ifM (isNothing <$> isRecordConstructor c) mzero {-else-}-             (maybeFlexiblePattern qs)-      _ -> mzero--instance IsFlexiblePattern (I.Pattern' a) where-  maybeFlexiblePattern p =-    case p of-      I.DotP{}  -> return DotFlex-      I.ConP _ i ps-        | Just ConOSystem <- conPRecord i -> return ImplicitFlex  -- expanded from ImplicitP-        | Just _            <- conPRecord i -> maybeFlexiblePattern ps-        | otherwise -> mzero-      I.VarP{}  -> mzero-      I.LitP{}  -> mzero-      I.ProjP{} -> mzero---- | Lists of flexible patterns are 'RecordFlex'.-instance IsFlexiblePattern a => IsFlexiblePattern [a] where-  maybeFlexiblePattern ps = RecordFlex <$> mapM maybeFlexiblePattern ps--instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where-  maybeFlexiblePattern = maybeFlexiblePattern . unArg--instance IsFlexiblePattern a => IsFlexiblePattern (Common.Named name a) where-  maybeFlexiblePattern = maybeFlexiblePattern . namedThing---- | Update the in patterns according to the given substitution, collecting---   new dot pattern instantiations in the process.-updateInPatterns- :: [Dom Type]              -- ^ the types of the old pattern variables,-                              --   relative to the new telescope- -> [NamedArg A.Pattern]    -- ^ old in patterns- -> [Arg DeBruijnPattern] -- ^ patterns to be substituted, living in the-                              --   new telescope- -> TCM ([NamedArg A.Pattern]   -- new in patterns-        ,[DotPatternInst])        -- new dot pattern instantiations-updateInPatterns as ps qs = do-  reportSDoc "tc.lhs.top" 20 $ text "updateInPatterns" <+> nest 2 (vcat-    [ text "as      =" <+> prettyList (map prettyTCM as)-    , text "ps      =" <+> prettyList (map prettyA ps)-    , text "qs      =" <+> prettyList (map (text . show) qs)-    ])-  first (map snd . IntMap.toDescList) <$> updates as ps qs-  where-    updates :: [Dom Type] -> [NamedArg A.Pattern] -> [Arg DeBruijnPattern]-           -> TCM (IntMap (NamedArg A.Pattern), [DotPatternInst])-    updates as ps qs = mconcat <$> sequence (zipWith3 update as ps qs)--    update :: Dom Type -> NamedArg A.Pattern -> Arg DeBruijnPattern-           -> TCM (IntMap (NamedArg A.Pattern), [DotPatternInst])-    update a p q = case unArg q of-      -- Case: the unifier did not instantiate the variable-      VarP x     -> return (IntMap.singleton (dbPatVarIndex x) p, [])-      -- Case: the unifier did instantiate the variable-      DotP u     -> case snd $ asView $ namedThing (unArg p) of-        A.DotP _ _ e -> return (IntMap.empty, [DPI Nothing  (Just e) u a])-        A.WildP _  -> return (IntMap.empty, [DPI Nothing  Nothing  u a])-        A.VarP x   -> return (IntMap.empty, [DPI (Just x) Nothing  u a])-        A.ConP _ (A.AmbQ [c]) qs -> do-          Def r es  <- ignoreSharing <$> reduce (unEl $ unDom a)-          let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          (ftel, us) <- etaExpandRecord r vs u-          qs <- insertImplicitPatterns ExpandLast qs ftel-          let instTel EmptyTel _                   = []-              instTel (ExtendTel arg tel) (u : us) = arg : instTel (absApp tel u) us-              instTel ExtendTel{} []               = __IMPOSSIBLE__-              bs0 = instTel ftel (map unArg us)-              -- Andreas, 2012-09-19 propagate relevance info to dot patterns-              bs  = map (mapRelevance (composeRelevance (getRelevance a))) bs0-          updates bs qs (map (DotP . unArg) us `withArgsFrom` teleArgNames ftel)-        A.AsP         _ _ _ -> __IMPOSSIBLE__-        A.ConP        _ _ _ -> __IMPOSSIBLE__-        A.RecP        _ _   -> __IMPOSSIBLE__-        A.ProjP       _ _ _ -> __IMPOSSIBLE__-        A.DefP        _ _ _ -> __IMPOSSIBLE__-        A.AbsurdP     _     -> __IMPOSSIBLE__-        A.LitP        _     -> __IMPOSSIBLE__-        A.PatternSynP _ _ _ -> __IMPOSSIBLE__-      -- Case: the unifier eta-expanded the variable-      ConP c cpi qs -> do-        Def r es <- ignoreSharing <$> reduce (unEl $ unDom a)-        def      <- theDef <$> getConstInfo r-        let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-            fs  = killRange $ recFields def-            tel = recTel def `apply` pars-            as  = applyPatSubst (parallelS $ map (namedThing . unArg) qs) $ flattenTel tel-            -- If the user wrote a dot pattern or variable but the unifier-            -- eta-expanded it, add the corresponding instantiation.-            dpi :: [DotPatternInst]-            dpi = mkDPI $ patternToTerm $ unArg q-              where-                mkDPI v = case namedThing $ unArg p of-                  A.DotP _ _ e -> [DPI Nothing (Just e) v a]-                  A.VarP x     -> [DPI (Just x) Nothing v a]-                  _            -> []-        second (dpi++) <$>-          updates as (projectInPat p fs) (map (fmap namedThing) qs)-      LitP _     -> __IMPOSSIBLE__-      ProjP{}    -> __IMPOSSIBLE__--    projectInPat :: NamedArg A.Pattern -> [Arg QName] -> [NamedArg A.Pattern]-    projectInPat p fs = case namedThing (unArg p) of-      A.VarP x            -> map (makeDotField (PatRange $ getRange x)) fs-      A.ConP cpi _ nps    -> nps-      A.WildP pi          -> map (makeWildField pi) fs-      A.DotP pi _ e       -> map (makeDotField pi) fs-      A.ProjP _ _ _       -> __IMPOSSIBLE__-      A.DefP _ _ _        -> __IMPOSSIBLE__-      A.AsP _ _ _         -> __IMPOSSIBLE__-      A.AbsurdP _         -> __IMPOSSIBLE__-      A.LitP _            -> __IMPOSSIBLE__-      A.PatternSynP _ _ _ -> __IMPOSSIBLE__-      A.RecP _ _          -> __IMPOSSIBLE__-      where-        makeWildField pi (Arg fi f) = Arg fi $ unnamed $ A.WildP pi-        makeDotField pi (Arg fi f) = Arg fi $ unnamed $-          A.DotP pi Inserted $ A.Underscore underscoreInfo-          where-            underscoreInfo = A.MetaInfo-              { A.metaRange          = getRange pi-              , A.metaScope          = emptyScopeInfo-              , A.metaNumber         = Nothing-              , A.metaNameSuggestion = show $ A.nameConcrete $ qnameName f-              }----- | Check if a problem is solved. That is, if the patterns are all variables.-isSolvedProblem :: Problem -> Bool-isSolvedProblem problem = null (restPats $ problemRest problem) &&-    all (isSolved . snd . asView . namedArg) (problemInPat problem)-  where-    -- need further splitting:-    isSolved A.ConP{}        = False-    isSolved A.LitP{}        = False-    isSolved A.ProjP{}       = False-    isSolved A.RecP{}        = False  -- record pattern-    -- solved:-    isSolved A.VarP{}        = True-    isSolved A.WildP{}       = True-    isSolved A.DotP{}        = True-    isSolved A.AbsurdP{}     = True-    -- impossible:-    isSolved A.DefP{}        = __IMPOSSIBLE__-    isSolved A.AsP{}         = __IMPOSSIBLE__  -- removed by asView-    isSolved A.PatternSynP{} = __IMPOSSIBLE__  -- expanded before---- | For each user-defined pattern variable in the 'Problem', check--- that the corresponding data type (if any) does not contain a--- constructor of the same name (which is not in scope); this--- \"shadowing\" could indicate an error, and is not allowed.------ Precondition: The problem has to be solved.--noShadowingOfConstructors-  :: Call -- ^ Trace, e.g., @CheckPatternShadowing clause@-  -> Problem -> TCM ()-noShadowingOfConstructors mkCall problem =-  traceCall mkCall $ do-    let pat = map (snd . asView . namedArg) $-                  problemInPat problem-        tel = map (unEl . snd . unDom) $ telToList $ problemTel problem-    zipWithM_ noShadowing pat tel -- TODO: does not work for flexible arity and projection patterns-    return ()-  where-  noShadowing (A.WildP     {}) t = return ()-  noShadowing (A.AbsurdP   {}) t = return ()-  noShadowing (A.ConP      {}) t = return ()  -- only happens for eta expanded record patterns-  noShadowing (A.RecP      {}) t = return ()  -- record pattern-  noShadowing (A.ProjP     {}) t = return ()  -- projection pattern-  noShadowing (A.DefP      {}) t = __IMPOSSIBLE__-  noShadowing (A.DotP      {}) t = return ()-  noShadowing (A.AsP       {}) t = __IMPOSSIBLE__-  noShadowing (A.LitP      {}) t = __IMPOSSIBLE__-  noShadowing (A.PatternSynP {}) t = __IMPOSSIBLE__-  noShadowing (A.VarP x)       t = do-    reportSDoc "tc.lhs.shadow" 30 $ vcat-      [ text $ "checking whether pattern variable " ++ show x ++ " shadows a constructor"-      , nest 2 $ text "type of variable =" <+> prettyTCM t-      ]-    reportSLn "tc.lhs.shadow" 70 $ "  t = " ++ show t-    t <- reduce t-    case t 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 x c-          AbstractDefn{} -> return ()-            -- 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 ()-          Function    {} -> return ()-          Record      {} -> return ()-          Constructor {} -> __IMPOSSIBLE__-          -- TODO: in the future some stuck primitives might allow constructors-          Primitive   {} -> return ()-      Var   {} -> return ()-      Pi    {} -> return ()-      Sort  {} -> return ()-      Shared p -> noShadowing (A.VarP x) $ derefPtr p-      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__---- | Check that a dot pattern matches it's instantiation.-checkDotPattern :: DotPatternInst -> TCM ()-checkDotPattern (DPI _ (Just e) v (Dom info a)) =-  traceCall (CheckDotPattern e v) $ do-  reportSDoc "tc.lhs.dot" 15 $-    sep [ text "checking dot pattern"-        , nest 2 $ prettyA e-        , nest 2 $ text "=" <+> prettyTCM v-        , nest 2 $ text ":" <+> prettyTCM a-        ]-  applyRelevanceToContext (argInfoRelevance info) $ do-    u <- checkExpr e a-    reportSDoc "tc.lhs.dot" 30 $-      sep [ text "equalTerm"-          , nest 2 $ text $ show a-          , nest 2 $ text $ show u-          , nest 2 $ text $ show v-          ]-    -- Should be ok to do noConstraints here-    noConstraints $ equalTerm a u v-checkDotPattern (DPI _ Nothing _ _) = return ()---- | Temporary data structure for 'checkLeftoverPatterns'-type Projectn  = (ProjOrigin, QName)-type Projectns = [Projectn]---- | Checks whether the dot patterns left over after splitting can be covered---   by shuffling around the dots from implicit positions. Returns the updated---   user patterns (without dot patterns).-checkLeftoverDotPatterns-  :: [NamedArg A.Pattern] -- ^ Leftover patterns after splitting is completed-  -> [Int]                -- ^ De Bruijn indices of leftover variable patterns-                          --   computed by splitting-  -> [Dom Type]           -- ^ Types of leftover patterns-  -> [DotPatternInst]     -- ^ Instantiations computed by unifier-  -> TCM ()-checkLeftoverDotPatterns ps vs as dpi = do-  reportSDoc "tc.lhs.dot" 15 $ text "checking leftover dot patterns..."-  idv <- sortBy (compare `on` length . snd) . concat <$>-           traverse gatherImplicitDotVars dpi-  reportSDoc "tc.lhs.dot" 30 $ nest 2 $-    text "implicit dotted variables:" <+>-    prettyList (map (\(i,fs) -> prettyTCM $ Var i (map (uncurry Proj) fs)) idv)-  checkUserDots ps vs as idv-  reportSDoc "tc.lhs.dot" 15 $ text "all leftover dot patterns ok!"--  where-    checkUserDots :: [NamedArg A.Pattern] -> [Int] -> [Dom Type]-                  -> [(Int,Projectns)]-                  -> TCM ()-    checkUserDots []     []     []     idv = return ()-    checkUserDots []     (_:_)  _      idv = __IMPOSSIBLE__-    checkUserDots []     _      (_:_)  idv = __IMPOSSIBLE__-    checkUserDots (_:_)  []     _      idv = __IMPOSSIBLE__-    checkUserDots (_:_)  _      []     idv = __IMPOSSIBLE__-    checkUserDots (p:ps) (v:vs) (a:as) idv = do-      idv' <- checkUserDot p v a idv-      checkUserDots ps vs as idv'--    checkUserDot :: NamedArg A.Pattern -> Int -> Dom Type-                 -> [(Int,Projectns)]-                 -> TCM [(Int,Projectns)]-    checkUserDot p v a idv = case namedArg p of-      A.DotP i o e | o == Inserted -> return idv-      -- Jesper, 2016-12-08 (Issue 1605): if the origin is Inserted, this-      -- means the dot pattern was created by expanding '...', so we don't-      -- have to complain here.-      A.DotP i o e -> do-        reportSDoc "tc.lhs.dot" 30 $ nest 2 $-          text "checking user dot pattern: " <+> prettyA e-        caseMaybeM (undotImplicitVar (v,[],unDom a) idv)-          (traceCall (CheckPattern (namedArg p) EmptyTel (unDom a)) $-             typeError $ UninstantiatedDotPattern e)-          (\idv' -> do-            u <- checkExpr e (unDom a)-            reportSDoc "tc.lhs.dot" 30 $ nest 2 $-              text "checked expression: " <+> prettyTCM u-            noConstraints $ equalTerm (unDom a) u (var v)-            return idv')-      A.VarP _     -> return idv-      A.WildP _    -> return idv-      A.AbsurdP _  -> return idv-      A.ConP _ _ _ -> __IMPOSSIBLE__-      A.LitP _     -> __IMPOSSIBLE__-      A.ProjP _ _ _-> __IMPOSSIBLE__-      A.DefP _ _ _ -> __IMPOSSIBLE__-      A.RecP _ _   -> __IMPOSSIBLE__-      A.AsP  _ _ _ -> __IMPOSSIBLE__-      A.PatternSynP _ _ _ -> __IMPOSSIBLE__--    gatherImplicitDotVars :: DotPatternInst -> TCM [(Int,Projectns)]-    gatherImplicitDotVars (DPI _ (Just _) _ _) = return [] -- Not implicit-    gatherImplicitDotVars (DPI _ Nothing u _)  = gatherVars u-      where-        gatherVars :: Term -> TCM [(Int,Projectns)]-        gatherVars u = case ignoreSharing u of-          Var i es -> return $ (i,) <$> maybeToList (allProjElims es)-          Con c _ us -> ifM (isEtaCon $ conName c)-                      {-then-} (concat <$> traverse (gatherVars . unArg) us)-                      {-else-} (return [])-          _        -> return []--    lookupImplicitDotVar :: (Int,Projectns) -> [(Int,Projectns)] -> Maybe Projectns-    lookupImplicitDotVar (i,fs) [] = Nothing-    lookupImplicitDotVar (i,fs) ((j,gs):js)-     -- Andreas, 2016-09-20, issue #2196-     -- We need to ignore the ProjOrigin!-     | i == j , Just hs <- stripPrefixBy ((==) `on` snd) fs gs = Just hs-     | otherwise = lookupImplicitDotVar (i,fs) js--    undotImplicitVar :: (Int,Projectns,Type) -> [(Int,Projectns)]-                     -> TCM (Maybe [(Int,Projectns)])-    undotImplicitVar (i,fs,a) idv = do-     reportSDoc "tc.lhs.dot" 40 $ vcat-       [ text "undotImplicitVar"-       , nest 2 $ vcat-         [ text $ "i  =  " ++ show i-         , text   "fs = " <+> sep (map (prettyTCM . snd) fs)-         , text   "a  = " <+> prettyTCM a-         , text $ "raw=  "  ++ show a-         , text $ "idv=  "  ++ show idv-         ]-       ]-     case lookupImplicitDotVar (i,fs) idv of-      Nothing -> return Nothing-      Just [] -> return $ Just $ delete (i,fs) idv-      Just rs -> caseMaybeM (isEtaRecordType a) (return Nothing) $ \(d,pars) -> do-        gs <- recFields . theDef <$> getConstInfo d-        let u = Var i (map (uncurry Proj) fs)-        is <- forM gs $ \(Arg _ g) -> do-                (_,_,b) <- fromMaybe __IMPOSSIBLE__ <$> projectTyped u a ProjSystem g-                return (i,fs++[(ProjSystem,g)],b)-        undotImplicitVars is idv--    undotImplicitVars :: [(Int,Projectns,Type)] -> [(Int,Projectns)]-                      -> TCM (Maybe [(Int,Projectns)])-    undotImplicitVars []     idv = return $ Just idv-    undotImplicitVars (i:is) idv =-      caseMaybeM (undotImplicitVar i idv)-        (return Nothing)-        (\idv' -> undotImplicitVars is idv')----- | Bind the variables in a left hand side and check that 'Hiding' of---   the patterns matches the hiding info in the type.------   Precondition: the patterns should---   all be 'A.VarP', 'A.WildP', or 'A.AbsurdP' and the---   telescope should have the same size as the pattern list.---   There could also be 'A.ConP's resulting from eta expanded implicit record---   patterns.-bindLHSVars :: [NamedArg A.Pattern] -> Telescope -> TCM a -> TCM a-bindLHSVars []        tel@ExtendTel{}  _   = do-  reportSDoc "impossible" 10 $-    text "bindLHSVars: no patterns left, but tel =" <+> prettyTCM tel-  __IMPOSSIBLE__-bindLHSVars (_ : _)   EmptyTel         _   = __IMPOSSIBLE__-bindLHSVars []        EmptyTel         ret = ret-bindLHSVars (p : ps) (ExtendTel a tel) ret = do-  -- see test/Fail/WronHidingInLHS:-  unless (getHiding p == getHiding a) $ typeError WrongHidingInLHS--  case namedArg p of-    A.VarP x      -> addContext (x, a) $ bindLHSVars ps (absBody tel) ret-    A.WildP _     -> bindDummy (absName tel)-                 -- @bindDummy underscore@ does not fix issue 819, but-                 -- introduces unwanted underscores in error messages-                 -- (Andreas, 2015-05-28)-    A.DotP _ _ _  -> bindDummy (absName tel)-    A.AbsurdP pi  -> do-      -- Andreas, 2012-03-15: allow postponement of emptyness check-      isEmptyType (getRange pi) $ unDom a-      -- OLD CODE: isReallyEmptyType $ unArg a-      bindDummy (absName tel)-    A.ConP{}        -> __IMPOSSIBLE__-    A.RecP{}        -> __IMPOSSIBLE__-    A.ProjP{}       -> __IMPOSSIBLE__-    A.DefP{}        -> __IMPOSSIBLE__-    A.AsP{}         -> __IMPOSSIBLE__-    A.LitP{}        -> __IMPOSSIBLE__-    A.PatternSynP{} -> __IMPOSSIBLE__-    where-      bindDummy s = do-        x <- if isUnderscore s then freshNoName_ else unshadowName =<< freshName_ ("." ++ argNameToString s)-        addContext (x, a) $ bindLHSVars ps (absBody tel) ret---- | Bind as patterns-bindAsPatterns :: [AsBinding] -> TCM a -> TCM a-bindAsPatterns []                ret = ret-bindAsPatterns (AsB x v a : asb) ret = do-  reportSDoc "tc.lhs.as" 10 $ text "as pattern" <+> prettyTCM x <+>-    sep [ text ":" <+> prettyTCM a-        , text "=" <+> prettyTCM v-        ]-  addLetBinding defaultArgInfo x v a $ bindAsPatterns asb ret---- | Result of checking the LHS of a clause.-data LHSResult = LHSResult-  { lhsParameters   :: Nat-    -- ^ The number of original module parameters. These are present in the-    -- the patterns.-  , lhsVarTele      :: Telescope-    -- ^ Δ : The types of the pattern variables, in internal dependency order.-    -- Corresponds to 'clauseTel'.-  , lhsPatterns     :: [NamedArg DeBruijnPattern]-    -- ^ The patterns in internal syntax.-  , lhsBodyType     :: Arg Type-    -- ^ The type of the body. Is @bσ@ if @Γ@ is defined.-    -- 'Irrelevant' to indicate the rhs must be checked in irrelevant mode.-  , lhsPatSubst     :: Substitution-    -- ^ Substitution version of @lhsPatterns@, only up to the first projection-    -- pattern. @Δ |- lhsPatSubst : Γ@. Where @Γ@ is the argument telescope of-    -- the function. This is used to update inherited dot patterns in-    -- with-function clauses.-  , lhsAsBindings   :: [AsBinding]-    -- ^ As-bindings from the left-hand side. Return instead of bound since we-    -- want them in where's and right-hand sides, but not in with-clauses-    -- (Issue 2303).-  }--instance InstantiateFull LHSResult where-  instantiateFull' (LHSResult n tel ps t sub as) = LHSResult n-    <$> instantiateFull' tel-    <*> instantiateFull' ps-    <*> instantiateFull' t-    <*> instantiateFull' sub-    <*> instantiateFull' as---- | Check a LHS. Main function.------   @checkLeftHandSide a ps a ret@ checks that user patterns @ps@ eliminate---   the type @a@ of the defined function, and calls continuation @ret@---   if successful.--checkLeftHandSide-  :: Call-     -- ^ Trace, e.g. @CheckPatternShadowing clause@-  -> Maybe QName-     -- ^ The name of the definition we are checking.-  -> [NamedArg A.Pattern]-     -- ^ The patterns.-  -> Type-     -- ^ The expected type @a = Γ → b@.-  -> Maybe Substitution-     -- ^ Module parameter substitution from with-abstraction.-  -> (LHSResult -> TCM a)-     -- ^ Continuation.-  -> TCM a-checkLeftHandSide c f ps a withSub' = Bench.billToCPS [Bench.Typing, Bench.CheckLHS] $ \ 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 <- reverse <$> getContext-  let tel = telFromList' show cxt-      cps = [ unnamed . A.VarP . fst <$> setOrigin Inserted (argFromDom d)-            | d <- cxt ]-  problem0 <- problemFromPats (cps ++ ps) (telePi tel a)-  -- Andreas, 2013-03-15 deactivating the following test allows-  -- flexible arity-  -- unless (noProblemRest problem) $ typeError $ TooManyArgumentsInLHS a--  -- We need to grab all let-bindings here (while we still have the old-  -- context). They will be rebound below once we have the new context set up.-  -- Subtle: if we're checking a with the context will be empty so we can't use-  -- 'getOpen'. On the other hand, if we're checking a with the let bindings-  -- lives in the right context already so we can use 'openThing'.-  let openLet | isNothing withSub' = getOpen-              | otherwise          = return . openThing-  oldLets <- asks $ Map.toList . envLetBindings-  reportSDoc "tc.lhs.top" 70 $ vcat-    [ text "context =" <+> inTopContext (prettyTCM tel)-    , text "cIds    =" <+> (text . show =<< getContextId)-    , text "oldLets =" <+> text (show oldLets) ]-  oldLets <- sequence [ (x,) <$> openLet b | (x, b) <- oldLets ]--  -- doing the splits:-  inTopContext $ do-    LHSState problem@(Problem pxs qs delta rest) dpi-      <- checkLHS f $ LHSState problem0 []--    unless (null $ restPats rest) $ typeError $ TooManyArgumentsInLHS a--    addContext delta $ do-      noShadowingOfConstructors c problem-      noPatternMatchingOnCodata qs--    -- f is Nothing when checking let pattern-bindings. In that case there can-    -- be no copatterns, so we don't need to worry about self.-    let self = Def (fromMaybe __IMPOSSIBLE__ f) []-    asb <- addContext delta $ recoverAsPatterns delta (telePi tel a) self (cps ++ ps) qs--    reportSDoc "tc.lhs.top" 10 $-      vcat [ text "checked lhs:"-           , nest 2 $ vcat-             [ text "pxs   = " <+> fsep (map prettyA pxs)-             , text "delta = " <+> prettyTCM delta-             , text "dpi   = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM dpi)-             , text "asb   = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM asb)-             , text "qs    = " <+> prettyList (map pretty qs)-             ]-           ]--    let b' = restType rest-    bindLHSVars (filter (isNothing . isProjP) pxs) delta $ do-      let -- Find the variable patterns that have been refined-          refinedParams = [ AsB x v (unDom a) | DPI (Just x) _ v a <- dpi ]-          asb'          = refinedParams ++ asb--      reportSDoc "tc.lhs.top" 10 $ text "asb' = " <+> (brackets $ fsep $ punctuate comma $ map prettyTCM asb')--      reportSDoc "tc.lhs.top" 10 $ text "bound pattern variables"-      reportSDoc "tc.lhs.top" 60 $ nest 2 $ text "context = " <+> ((text . show) =<< getContext)-      reportSDoc "tc.lhs.top" 10 $ nest 2 $ text "type  = " <+> prettyTCM b'-      reportSDoc "tc.lhs.top" 60 $ nest 2 $ text "type  = " <+> text (show b')--      let notProj ProjP{} = False-          notProj _       = True-                      -- Note: This works because we can't change the number of-                      --       arguments in the lhs of a with-function relative to-                      --       the parent function.-          numPats   = length $ takeWhile (notProj . namedArg) qs-          -- In the case of a non-with function the pattern substitution-          -- should be weakened by the number of non-parameter patterns to-          -- get the paramSub.-          withSub = fromMaybe (wkS (numPats - length cxt) idS) withSub'-          -- At this point we need to update the module parameters for all-          -- parent modules.-          patSub   = (map (patternToTerm . namedArg) $ reverse $ take numPats qs) ++# EmptyS-          paramSub = composeS patSub withSub-          lhsResult = LHSResult (length cxt) delta qs b' patSub asb'-      reportSDoc "tc.lhs.top" 20 $ nest 2 $ text "patSub   = " <+> text (show patSub)-      reportSDoc "tc.lhs.top" 20 $ nest 2 $ text "withSub  = " <+> text (show withSub)-      reportSDoc "tc.lhs.top" 20 $ nest 2 $ text "paramSub = " <+> text (show paramSub)--      let newLets = [ AsB x (applySubst paramSub v) (applySubst paramSub $ unDom a) | (x, (v, a)) <- oldLets ]-      reportSDoc "tc.lhs.top" 50 $ text "old let-bindings:" <+> text (show oldLets)-      reportSDoc "tc.lhs.top" 50 $ text "new let-bindings:" <+> (brackets $ fsep $ punctuate comma $ map prettyTCM newLets)--      bindAsPatterns newLets $-        applyRelevanceToContext (getRelevance b') $ updateModuleParameters paramSub $ do-        bindAsPatterns asb' $ do--          rebindLocalRewriteRules--          -- Check dot patterns-          mapM_ checkDotPattern dpi-          checkLeftoverDotPatterns pxs (downFrom $ size delta) (flattenTel delta) dpi--        -- Issue2303: don't bind asb' for the continuation (return in lhsResult instead)-        ret lhsResult---- | The loop (tail-recursive): split at a variable in the problem until problem is solved-checkLHS-  :: Maybe QName       -- ^ The name of the definition we are checking.-  -> LHSState          -- ^ The current state.-  -> TCM LHSState      -- ^ The final state after all splitting is completed-checkLHS f st@(LHSState problem dpi) = do--  problem <- insertImplicitProblem problem-  -- Note: inserting implicits no longer preserve solvedness,-  -- since we might insert eta expanded record patterns.-  if isSolvedProblem problem then return $ st { lhsProblem = problem } else do--    unlessM (optPatternMatching <$> gets getPragmaOptions) $-      typeError $ GenericError $ "Pattern matching is disabled"--    foldListT trySplit nothingToSplit $ splitProblem f problem-  where--    nothingToSplit = do-      reportSLn "tc.lhs.split" 50 $ "checkLHS: nothing to split in problem " ++ show problem-      nothingToSplitError problem--    -- Split problem rest (projection pattern, does not fail as there is no call to unifier)--    trySplit (SplitRest projPat o projType) _ = do--      -- Compute the new problem-      let Problem ps1 ip delta (ProblemRest (p:ps2) b) = problem-          -- ps'      = ps1 ++ [p]-          ps'      = ps1 -- drop the projection pattern (already splitted)-          rest     = ProblemRest ps2 (projPat $> projType)-          ip'      = ip ++ [fmap (Named Nothing . ProjP o) projPat]-          problem' = Problem ps' ip' delta rest-      -- Jump the trampolin-      st' <- updateProblemRest (LHSState problem' dpi)-      -- If the field is irrelevant, we need to continue in irr. cxt.-      -- (see Issue 939).-      applyRelevanceToContext (getRelevance projPat) $ do-        checkLHS f st'--    -- Split on literal pattern (does not fail as there is no call to unifier)--    trySplit (Split p0 (Arg _ (LitFocus lit ip a)) p1) _ = do--      -- substitute the literal in p1 and dpi-      let delta1 = problemTel p0-          delta2 = absApp (fmap problemTel p1) (Lit lit)-          rho    = singletonS (size delta2) (LitP lit)-          -- Andreas, 2015-06-13 Literals are closed, so need to raise them!-          -- rho    = liftS (size delta2) $ singletonS 0 (Lit lit)-          -- rho    = [ var i | i <- [0..size delta2 - 1] ]-          --       ++ [ raise (size delta2) $ Lit lit ]-          --       ++ [ var i | i <- [size delta2 ..] ]-          dpi'     = applyPatSubst rho dpi-          ip'      = applySubst rho ip-          rest'    = applyPatSubst rho (problemRest problem)--      -- Compute the new problem-      let ps'      = problemInPat p0 ++ problemInPat (absBody p1)-          delta'   = abstract delta1 delta2-          problem' = Problem ps' ip' delta' rest'-      st' <- updateProblemRest (LHSState problem' dpi')-      checkLHS f st'--    -- Split on constructor pattern (unifier might fail)--    trySplit (Split p0 focus@(Arg info Focus{}) p1) tryNextSplit = do-      res <- trySplitConstructor p0 focus p1-      case res of-        -- Success.  Continue checking LHS.-        Unifies st'    -> checkLHS f st'-        -- Mismatch.  Report and abort.-        NoUnify  tcerr -> throwError tcerr-        -- Unclear situation.  Try next split.-        -- If no split works, give error from first split.-        -- This is conservative, but might not be the best behavior.-        -- It might be better to collect all the errors and print all of them.-        DontKnow tcerr -> tryNextSplit `catchError` \ _ -> throwError tcerr--    whenUnifies-      :: UnificationResult' a-      -> (a -> TCM (UnificationResult' b))-      -> TCM (UnificationResult' b)-    whenUnifies res cont = do-      case res of-        Unifies a      -> cont a-        NoUnify  tcerr -> return $ NoUnify  tcerr-        DontKnow tcerr -> return $ DontKnow tcerr--    trySplitConstructor p0 (Arg info LitFocus{}) p1 = __IMPOSSIBLE__-    trySplitConstructor p0 (Arg info-             (Focus { focusCon      = c-                    , focusPatOrigin= porigin-                    , focusConArgs  = qs-                    , focusRange    = r-                    , focusOutPat   = ip-                    , focusDatatype = d-                    , focusParams   = vs-                    , focusIndices  = ws-                    , focusType     = a-                    }-             )) p1 = do-      traceCall (CheckPattern (A.ConP (ConPatInfo porigin $ PatRange r) (A.AmbQ [c]) qs)-                                       (problemTel p0)-                                       (El Prop $ Def d $ map Apply $ vs ++ ws)) $ do--        let delta1 = problemTel p0-            delta2 = problemTel $ absBody p1-        let typeOfSplitVar = Arg info a--        reportSDoc "tc.lhs.split" 10 $ sep-          [ text "checking lhs"-          , nest 2 $ text "tel =" <+> prettyTCM (problemTel problem)-          , nest 2 $ text "rel =" <+> (text $ show $ argInfoRelevance info)-          ]--        reportSDoc "tc.lhs.split" 15 $ sep-          [ text "split problem"-          , nest 2 $ vcat-            [ text "delta1 = " <+> prettyTCM delta1-            , text "typeOfSplitVar =" <+> addContext delta1 (prettyTCM typeOfSplitVar)-            , text "focusOutPat =" <+> (text . show) ip-            , text "delta2 = " <+> addContext delta1 (addContext ("x",domFromArg typeOfSplitVar) (prettyTCM delta2))-            ]-          ]--        c <- (`withRangeOf` c) <$> getConForm c-        ca <- defType <$> getConInfo c--        reportSDoc "tc.lhs.split" 20 $ nest 2 $ vcat-          [ text "ca =" <+> prettyTCM ca-          , text "vs =" <+> prettyList (map prettyTCM vs)-          ]--        -- Lookup the type of the constructor at the given parameters-        let a = ca `piApply` vs--        -- It will end in an application of the datatype-        (gamma', ca, d', us) <- do-          TelV gamma' ca@(El _ def) <- telView a-          let Def d' es = ignoreSharing def-              Just us   = allApplyElims es-          return (gamma', ca, d', us)--        -- This should be the same datatype as we split on-        unless (d == d') $ typeError $ ShouldBeApplicationOf ca d'--        reportSDoc "tc.lhs.top" 20 $ addContext delta1 $ nest 2 $ vcat-          [ text "gamma' =" <+> prettyTCM gamma'-          ]--        -- Andreas 2010-09-07  propagate relevance info to new vars-        let updRel = composeRelevance (getRelevance info)-        gamma' <- return $ mapRelevance updRel <$> gamma'--        -- Insert implicit patterns-        qs' <- insertImplicitPatterns ExpandLast qs gamma'--        unless ((size qs' :: Int) == size gamma') $-          typeError $ WrongNumberOfConstructorArguments (conName c) (size gamma') (size qs')--        let gamma = useNamesFromPattern qs' gamma'--        -- Get the type of the datatype.-        da <- (`piApply` vs) . defType <$> getConstInfo d--        -- Compute the flexible variables-        flex <- flexiblePatterns (problemInPat p0 ++ qs')--        -- Compute the constructor indices by dropping the parameters-        let us' = drop (size vs) us--        reportSDoc "tc.lhs.top" 15 $ addContext delta1 $-          sep [ text "preparing to unify"-              , nest 2 $ vcat-                [ text "c      =" <+> prettyTCM c <+> text ":" <+> prettyTCM a-                , text "d      =" <+> prettyTCM (Def d (map Apply $ vs++ws)) <+> text ":" <+> prettyTCM da-                , text "gamma  =" <+> prettyTCM gamma-                , text "gamma' =" <+> prettyTCM gamma'-                , text "vs     =" <+> brackets (fsep $ punctuate comma $ map prettyTCM vs)-                , text "us'    =" <+> addContext gamma (brackets (fsep $ punctuate comma $ map prettyTCM us'))-                , text "ws     =" <+> brackets (fsep $ punctuate comma $ map prettyTCM ws)-                ]-              ]--        -- Unify constructor target and given type (in Δ₁Γ)-        -- Given: Δ₁ ⊢ D vs : Φ → Setᵢ-        --        Δ₁ ⊢ c    : Γ → D vs' us'-        --        Δ₁ ⊢ ws   : Φ-        --        Δ₁Γ ⊢ ws' : Φ-        -- (where vs' = raise Γ vs and ws' = raise Γ ws)-        -- unification of us' and ws' in context Δ₁Γ gives us a telescope Δ₁'-        -- and a substitution ρ₀ such that-        --        Δ₁' ⊢ ρ₀ : Δ₁Γ-        --        Δ₁' ⊢ (us')ρ₀ ≡ (ws')ρ₀ : Φρ₀-        -- We can split ρ₀ into two parts ρ₁ and ρ₂, giving-        --        Δ₁' ⊢ ρ₁ : Δ₁-        --        Δ₁' ⊢ ρ₂ : Γρ₁-        -- Application of the constructor c gives-        --        Δ₁' ⊢ c ρ₂ : (D vs' us')(ρ₁;ρ₂)-        -- We have-        --        us'(ρ₁;ρ₂)-        --         ≡ us'ρ₀      (since ρ₀=ρ₁;ρ₂)-        --         ≡ ws'ρ₀      (by unification)-        --         ≡ ws ρ₁      (since ws doesn't actually depend on Γ)-        -- so     Δ₁' ⊢ c ρ₂ : D (vs)ρ₁ (ws)ρ₁-        -- Putting this together with ρ₁ gives ρ₃ = ρ₁;c ρ₂-        --        Δ₁' ⊢ ρ₁;c ρ₂ : Δ₁(x : D vs ws)-        -- and lifting over Δ₂ gives the final substitution ρ = ρ₃;Δ₂-        -- from Δ' = Δ₁';Δ₂ρ₃-        --        Δ' ⊢ ρ : Δ₁(x : D vs ws)Δ₂--        res <- unifyIndices-                 (delta1 `abstract` gamma)-                 flex-                 (raise (size gamma) da)-                 us'-                 (raise (size gamma) ws)-        whenUnifies res $ \ (delta1',rho0,es) -> do--          reportSDoc "tc.lhs.top" 15 $ text "unification successful"-          reportSDoc "tc.lhs.top" 20 $ nest 2 $ vcat-            [ text "delta1' =" <+> prettyTCM delta1'-            , text "rho0    =" <+> addContext delta1' (prettyTCM rho0)-            , text "es      =" <+> addContext delta1' (prettyTCM $ (fmap . fmap . fmap) patternToTerm es)-            ]--          -- Andreas 2014-11-25  clear 'Forced' and 'Unused'-          -- Andreas 2015-01-19  ... only after unification-          delta1' <- return $ mapRelevance ignoreForced <$> delta1'--          -- compute in patterns for delta1'-          let newPats  = applySubst rho0 $ teleArgs $ delta1 `abstract` gamma-              -- oldTypes are the types of the old pattern variables, but relative-              -- to the *new* telescope delta1'. These are needed to compute the-              -- correct types of new dot pattern instantiations.-              oldTypes = applyPatSubst rho0 $ flattenTel $ delta1 `abstract` gamma-          (p0',newDpi) <- addContext delta1' $ updateInPatterns-                            oldTypes-                            (problemInPat p0 ++ qs')-                            newPats--          reportSDoc "tc.lhs.top" 20 $ addContext delta1' $ nest 2 $ vcat-            [ text "p0'     =" <+> text (show p0')-            , text "newDpi  =" <+> brackets (fsep $ punctuate comma $ map prettyTCM newDpi)-            ]--          -- split substitution into part for Δ₁ and part for Γ-          let (rho1,rho2) = splitS (size gamma) rho0--          reportSDoc "tc.lhs.top" 20 $ addContext delta1' $ nest 2 $ vcat-            [ text "rho1    =" <+> prettyTCM rho1-            , text "rho2    =" <+> prettyTCM rho2-            ]--          -- Andreas, 2010-09-09, save the type.-          -- It is relative to Δ₁, but it should be relative to Δ₁'-          let storedPatternType = applyPatSubst rho1 typeOfSplitVar-          -- Also remember if we are a record pattern and from an implicit pattern.-          isRec <- isRecord d-          let cpi = ConPatternInfo (isRec $> porigin) (Just storedPatternType)--          -- compute final context and permutation-          let crho2   = ConP c cpi $ applySubst rho2 $-                          teleNamedArgs gamma `useOriginFrom` qs'-              rho3    = consS crho2 rho1-              delta2' = applyPatSubst rho3 delta2-              delta'  = delta1' `abstract` delta2'-              rho     = liftS (size delta2) rho3--          reportSDoc "tc.lhs.top" 20 $ addContext delta1' $ nest 2 $ vcat-            [ text "crho2   =" <+> prettyTCM crho2-            , text "rho3    =" <+> prettyTCM rho3-            , text "delta2' =" <+> prettyTCM delta2'-            ]--          reportSDoc "tc.lhs.top" 70 $ addContext delta1' $ nest 2 $ vcat-            [ text "crho2   =" <+> text (show crho2)-            , text "rho3    =" <+> text (show rho3)-            , text "delta2' =" <+> text (show delta2')-            ]--          reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat-            [ text "delta'  =" <+> prettyTCM delta'-            , text "rho     =" <+> addContext delta' (prettyTCM rho)-            ]--          -- compute new in patterns-          let ps'  = p0' ++ problemInPat (absBody p1)--          reportSDoc "tc.lhs.top" 15 $ addContext delta' $-            nest 2 $ vcat-              [ text "ps'    =" <+> brackets (fsep $ punctuate comma $ map prettyA ps')-              ]--          -- The final dpis are the new ones plus the old ones substituted by ρ-          let dpi' = applyPatSubst rho dpi ++ raise (size delta2') newDpi--          reportSDoc "tc.lhs.top" 15 $ addContext delta' $-            nest 2 $ vcat-              [ text "dpi'    =" <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi')-              ]--          -- Apply the substitution-          let ip'      = applySubst rho ip-              rest'    = applyPatSubst rho (problemRest problem)--          reportSDoc "tc.lhs.top" 15 $ addContext delta' $-            nest 2 $ vcat-              [ text "ip' =" <+> text (show ip) ]--          -- Construct the new problem-          let problem' = Problem ps' ip' delta' rest'--          -- if rest type reduces,-          -- extend the split problem by previously not considered patterns-          st'@(LHSState problem'@(Problem ps' ip' delta' rest') dpi')-            <- updateProblemRest $ LHSState problem' dpi'--          reportSDoc "tc.lhs.top" 12 $ sep-            [ text "new problem from rest"-            , nest 2 $ vcat-              [ text "ps'     =" <+> fsep (map prettyA ps')-              , text "delta'  =" <+> prettyTCM delta'-              , text "ip'     =" <+> text (show ip')-              ]-            ]-          return $ Unifies st'----- | Ensures that we are not performing pattern matching on codata.--noPatternMatchingOnCodata :: [NamedArg DeBruijnPattern] -> TCM ()-noPatternMatchingOnCodata = mapM_ (check . namedArg)-  where-  check (VarP {})   = return ()-  check (DotP {})   = return ()-  check (ProjP{})   = return ()-  check (LitP {})   = return ()  -- Literals are assumed not to be coinductive.-  check (ConP con _ ps) = do-    TelV _ t <- telView' . defType <$> do getConstInfo $ conName con-    c <- isCoinductive t-    case c of-      Nothing    -> __IMPOSSIBLE__-      Just False -> mapM_ (check . namedArg) ps-      Just True  -> typeError $-        GenericError "Pattern matching on coinductive types is not allowed"+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.LHS+  ( checkLeftHandSide+  , LHSResult(..)+  , bindAsPatterns+  , IsFlexiblePattern(..)+  , DataOrRecord+  , checkSortOfSplitVar+  ) where++import Prelude hiding ( null )++import Data.Function (on)+import Data.Maybe++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++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List (findIndex)+import qualified Data.List as List+import Data.Semigroup ( Semigroup )+import qualified Data.Semigroup as Semigroup+import Data.Map (Map)+import qualified Data.Map as Map++import Agda.Interaction.Highlighting.Generate+  ( storeDisambiguatedConstructor, storeDisambiguatedProjection, disambiguateRecordFields)+import Agda.Interaction.Options+import Agda.Interaction.Options.Lenses++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 qualified Agda.Syntax.Info as A+import Agda.Syntax.Literal+import Agda.Syntax.Position++import Agda.TypeChecking.Monad++import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.CheckInternal (checkInternal)+import Agda.TypeChecking.Datatypes hiding (isDataOrRecordType)+import Agda.TypeChecking.Errors (dropTopLevelModule)+import Agda.TypeChecking.Irrelevance+-- Prevent "Ambiguous occurrence ‘DontKnow’" when loading with ghci.+-- (DontKnow is one of the constructors of ErrorNonEmpty *and* UnifactionResult').+-- We can't explicitly hide just the constructor here because it isn't in the+-- hs-boot file.+import {-# SOURCE #-} Agda.TypeChecking.Empty (ensureEmptyType)+import Agda.TypeChecking.Patterns.Abstract+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.Utils.CallStack ( HasCallStack, withCallerCallStack )+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 (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.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)++-- | 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.+class IsFlexiblePattern a where+  maybeFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind++  isFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> m Bool+  isFlexiblePattern p =+    maybe False notOtherFlex <$> runMaybeT (maybeFlexiblePattern p)+    where+    notOtherFlex = \case+      RecordFlex fls -> all notOtherFlex fls+      ImplicitFlex   -> True+      DotFlex        -> True+      OtherFlex      -> False++instance IsFlexiblePattern A.Pattern where+  maybeFlexiblePattern p = do+    reportSDoc "tc.lhs.flex" 30 $ "maybeFlexiblePattern" <+> prettyA p+    reportSDoc "tc.lhs.flex" 60 $ "maybeFlexiblePattern (raw) " <+> (text . show . deepUnscope) p+    case p of+      A.DotP{}  -> return DotFlex+      A.VarP{}  -> return ImplicitFlex+      A.WildP{} -> return ImplicitFlex+      A.AsP _ _ p -> maybeFlexiblePattern p+      A.ConP _ cs qs | Just c <- getUnambiguous cs ->+        ifM (isNothing <$> isRecordConstructor c) (return OtherFlex) {-else-}+            (maybeFlexiblePattern qs)+      A.LitP{}  -> return OtherFlex+      _ -> mzero++instance IsFlexiblePattern (I.Pattern' a) where+  maybeFlexiblePattern p =+    case p of+      I.DotP{}  -> return DotFlex+      I.ConP _ i ps+        | conPRecord i , PatOSystem <- patOrigin (conPInfo i) -> return ImplicitFlex  -- expanded from ImplicitP+        | conPRecord i -> maybeFlexiblePattern ps+        | otherwise -> mzero+      I.VarP{}  -> mzero+      I.LitP{}  -> mzero+      I.ProjP{} -> mzero+      I.IApplyP{} -> mzero+      I.DefP{} -> mzero -- TODO Andrea check semantics++-- | Lists of flexible patterns are 'RecordFlex'.+instance IsFlexiblePattern a => IsFlexiblePattern [a] where+  maybeFlexiblePattern ps = RecordFlex <$> mapM maybeFlexiblePattern ps++instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where+  maybeFlexiblePattern = maybeFlexiblePattern . unArg++instance IsFlexiblePattern a => IsFlexiblePattern (Common.Named name a) where+  maybeFlexiblePattern = maybeFlexiblePattern . namedThing++-- | Update the given LHS state:+--   1. simplify problem equations+--   2. rename telescope variables+--   3. introduce trailing patterns+updateLHSState :: LHSState a -> TCM (LHSState a)+updateLHSState st = do+  let tel     = st ^. lhsTel+      problem = st ^. lhsProblem+  eqs' <- addContext tel $ updateProblemEqs $ problem ^. problemEqs+  tel' <- useNamesFromProblemEqs eqs' tel+  updateProblemRest $ set lhsTel tel' $ set (lhsProblem . problemEqs) eqs' st++-- | Update the user patterns in the given problem, simplifying equations+--   between constructors where possible.+updateProblemEqs+ :: [ProblemEq] -> TCM [ProblemEq]+updateProblemEqs eqs = do+  reportSDoc "tc.lhs.top" 20 $ vcat+    [ "updateProblem: equations to update"+    , nest 2 $ if null eqs then "(none)" else vcat $ map prettyTCM eqs+    ]++  eqs' <- updates eqs++  reportSDoc "tc.lhs.top" 20 $ vcat+    [ "updateProblem: new equations"+    , nest 2 $ if null eqs' then "(none)" else vcat $ map prettyTCM eqs'+    ]++  return eqs'++  where++    updates :: [ProblemEq] -> TCM [ProblemEq]+    updates = concat <.> traverse update++    update :: ProblemEq -> TCM [ProblemEq]+    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 v a) = reduce v >>= constructorForm >>= \case+      Con c ci es -> do+        let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+        -- we should only simplify equations between fully applied constructors+        contype <- getFullyAppliedConType c =<< reduce (unDom a)+        caseMaybe contype (return [eq]) $ \((d,_,pars),b) -> do+        TelV ctel _ <- telViewPath b++        -- Andrea 15/10/2020: propagate modality to constructor arguments+        let updMod = composeModality (getModality a)+        ctel <- return $ mapModality updMod <$> ctel++        let bs = instTel ctel (map unArg vs)++        p <- expandLitPattern p+        case p of+          A.AsP{} -> __IMPOSSIBLE__+          A.ConP cpi ambC ps -> do+            (c',_) <- disambiguateConstructor ambC d pars++            -- Issue #3014: If the constructor is forced but the user wrote a+            -- different constructor,that's an error. We simply keep the+            -- problem equation, this will result in a proper error message later.+            if conName c /= conName c' then return [eq] else do++            -- Insert implicit patterns+            ps <- insertImplicitPatterns ExpandLast ps ctel+            reportSDoc "tc.lhs.imp" 20 $+              "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)++            -- Check argument count and hiding (not just count: #3074)+            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 _ _ fs -> do+            axs <- map argFromDom . recFields . theDef <$> getConstInfo d++            -- Andreas, 2018-09-06, issue #3122.+            -- Associate the concrete record field names used in the record pattern+            -- to their counterpart in the record type definition.+            disambiguateRecordFields (map _nameFieldA fs) (map unArg axs)++            let cxs = map (fmap (nameConcrete . qnameName)) axs++            -- In fs omitted explicit fields are replaced by underscores,+            -- and the fields are put in the correct order.+            ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs cxs++            -- We also need to insert missing implicit or instance fields.+            ps <- insertImplicitPatterns ExpandLast ps ctel++            let eqs = zipWith3 ProblemEq (map namedArg ps) (map unArg vs) bs+            updates eqs++          _ -> return [eq]++      Lit l | A.LitP _ l' <- p , l == l' -> return []++      _ | A.EqualP{} <- p -> do+        itisone <- liftTCM primItIsOne+        ifM (tryConversion $ equalTerm (unDom a) v itisone) (return []) (return [eq])++      _ -> return [eq]++    instTel :: Telescope -> [Term] -> [Dom Type]+    instTel EmptyTel _                   = []+    instTel (ExtendTel arg tel) (u : us) = arg : instTel (absApp tel u) us+    instTel ExtendTel{} []               = __IMPOSSIBLE__+++-- | Check if a problem is solved.+--   That is, if the patterns are all variables,+--   and there is no 'problemRest'.+isSolvedProblem :: Problem a -> Bool+isSolvedProblem problem = null (problem ^. problemRestPats) &&+  problemAllVariables problem++-- | Check if a problem consists only of variable patterns.+--   (Includes the 'problemRest').+problemAllVariables :: Problem a -> Bool+problemAllVariables problem =+    all isSolved $+      map namedArg (problem ^. problemRestPats) ++ problemInPats problem+  where+    -- need further splitting:+    isSolved A.ConP{}        = False+    isSolved A.LitP{}        = False+    isSolved A.RecP{}        = False  -- record pattern+    -- solved:+    isSolved A.VarP{}        = True+    isSolved A.WildP{}       = True+    isSolved A.DotP{}        = True+    isSolved A.AbsurdP{}     = True+    -- recursive cases+    isSolved (A.AsP _ _ p)   = isSolved p+    -- impossible:+    isSolved A.ProjP{}       = __IMPOSSIBLE__+    isSolved A.DefP{}        = __IMPOSSIBLE__+    isSolved A.PatternSynP{} = __IMPOSSIBLE__  -- expanded before+    isSolved A.EqualP{}      = False -- __IMPOSSIBLE__+    isSolved A.WithP{}       = __IMPOSSIBLE__++-- | For each user-defined pattern variable in the 'Problem', check+-- that the corresponding data type (if any) does not contain a+-- constructor of the same name (which is not in scope); this+-- \"shadowing\" could indicate an error, and is not allowed.+--+-- Precondition: The problem has to be solved.++noShadowingOfConstructors :: ProblemEq -> TCM ()+noShadowingOfConstructors problem@(ProblemEq p _ (Dom{domInfo = info, unDom = El _ a})) =+  case p of+   A.WildP       {} -> return ()+   A.AbsurdP     {} -> return ()+   A.DotP        {} -> return ()+   A.EqualP      {} -> return ()+   A.AsP _ _ p      -> noShadowingOfConstructors $ problem { problemInPat = p }+   A.ConP        {} -> __IMPOSSIBLE__+   A.RecP        {} -> __IMPOSSIBLE__+   A.ProjP       {} -> __IMPOSSIBLE__+   A.DefP        {} -> __IMPOSSIBLE__+   A.LitP        {} -> __IMPOSSIBLE__+   A.PatternSynP {} -> __IMPOSSIBLE__+   A.WithP       {} -> __IMPOSSIBLE__+   -- Andreas, 2017-12-01, issue #2859.+   -- Due to parameter refinement, there can be (invisible) variable patterns from module+   -- parameters that shadow constructors.+   -- Thus, only complain about user written variable that shadow constructors.+   A.VarP A.BindName{unBind = x} -> when (getOrigin info == UserWritten) $ do+    reportSDoc "tc.lhs.shadow" 30 $ vcat+      [ text $ "checking whether pattern variable " ++ prettyShow x ++ " shadows a constructor"+      , nest 2 $ "type of variable =" <+> prettyTCM a+      , nest 2 $ "position of variable =" <+> (text . show) (getRange x)+      ]+    reportSDoc "tc.lhs.shadow" 70 $ nest 2 $ "a =" <+> pretty a++    -- 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.+          -- TODO: in the future some stuck primitives might allow constructors+      -- 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.++-- | Check that a dot pattern matches it's instantiation.+checkDotPattern :: DotPattern -> TCM ()+checkDotPattern (Dot e v (Dom{domInfo = info, unDom = a})) =+  traceCall (CheckDotPattern e v) $ do+  reportSDoc "tc.lhs.dot" 15 $+    sep [ "checking dot pattern"+        , nest 2 $ prettyA e+        , nest 2 $ "=" <+> prettyTCM v+        , nest 2 $ ":" <+> prettyTCM a+        ]+  applyModalityToContext info $ do+    u <- checkExpr e a+    reportSDoc "tc.lhs.dot" 50 $+      sep [ "equalTerm"+          , nest 2 $ pretty a+          , nest 2 $ pretty u+          , nest 2 $ pretty v+          ]+    equalTerm a u v++checkAbsurdPattern :: AbsurdPattern -> TCM ()+checkAbsurdPattern (Absurd r a) = ensureEmptyType r a++checkAnnotationPattern :: AnnotationPattern -> TCM ()+checkAnnotationPattern (Ann t a) = do+  reportSDoc "tc.lhs.ann" 15 $+    sep [ "checking type annotation in pattern"+        , nest 2 $ prettyA t+        , nest 2 $ "=" <+> prettyTCM a+        ]+  b <- isType_ t+  equalType a b++-- | After splitting is complete, we transfer the origins+--   We also transfer the locations of absurd patterns, since these haven't+--   been introduced yet in the internal pattern.+transferOrigins :: [NamedArg A.Pattern]+                -> [NamedArg DeBruijnPattern]+                -> TCM [NamedArg DeBruijnPattern]+transferOrigins ps qs = do+  reportSDoc "tc.lhs.origin" 40 $ vcat+    [ "transferOrigins"+    , nest 2 $ vcat+      [ "ps  =   " <+> prettyA ps+      , "qs  =   " <+> pretty qs+      ]+    ]+  transfers ps qs++  where+    transfers :: [NamedArg A.Pattern]+              -> [NamedArg DeBruijnPattern]+              -> TCM [NamedArg DeBruijnPattern]+    transfers [] qs+      | all notVisible qs = return $ map (setOrigin Inserted) qs+      | otherwise         = __IMPOSSIBLE__+    transfers (p : ps) [] = __IMPOSSIBLE__+    transfers (p : ps) (q : qs)+      | matchingArgs p q = do+          q' <- mapNameOf (maybe id (const . Just) $ getNameOf p) -- take NamedName from p if present+              . setOrigin (getOrigin p)+            <$> (traverse $ traverse $ transfer $ namedArg p) q+          (q' :) <$> transfers ps qs+      | otherwise = (setOrigin Inserted q :) <$> transfers (p : ps) qs++    transfer :: A.Pattern -> DeBruijnPattern -> TCM DeBruijnPattern+    transfer p q = case (asView p , q) of++      ((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 , 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 empty) fs axs+        ConP c cpi <$> transfers ps qs++      ((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 , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x++      ((asB , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u++      ((asB , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l++      _ -> return q++    patOrig :: A.Pattern -> PatOrigin+    patOrig (A.VarP x)      = PatOVar (A.unBind x)+    patOrig A.DotP{}        = PatODot+    patOrig A.ConP{}        = PatOCon+    patOrig A.RecP{}        = PatORec+    patOrig A.WildP{}       = PatOWild+    patOrig A.AbsurdP{}     = PatOAbsurd+    patOrig A.LitP{}        = PatOLit+    patOrig A.EqualP{}      = PatOCon --TODO: origin for EqualP+    patOrig A.AsP{}         = __IMPOSSIBLE__+    patOrig A.ProjP{}       = __IMPOSSIBLE__+    patOrig A.DefP{}        = __IMPOSSIBLE__+    patOrig A.PatternSynP{} = __IMPOSSIBLE__+    patOrig A.WithP{}       = __IMPOSSIBLE__++    matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool+    matchingArgs p q+      -- The arguments match if+      -- 1. they are both projections,+      | isJust (A.isProjP p) = isJust (isProjP q)+      -- 2. or they are both visible,+      | visible p && visible q = True+      -- 3. or they have the same hiding and the argument is not named,+      | sameHiding p q && isNothing (getNameOf p) = True+      -- 4. or they have the same hiding and the same name.+      | sameHiding p q && namedSame p q = True+      -- Otherwise this argument was inserted by the typechecker.+      | otherwise = False+++-- | If a user-written variable occurs more than once, it should be bound+--   to the same internal variable (or term) in all positions.+--   Returns the list of patterns with the duplicate user patterns removed.+checkPatternLinearity :: [ProblemEq] -> TCM [ProblemEq]+checkPatternLinearity eqs = do+  reportSDoc "tc.lhs.linear" 30 $ "Checking linearity of pattern variables"+  check Map.empty eqs+  where+    check :: Map A.BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]+    check _ [] = return []+    check vars (eq@(ProblemEq p u a) : eqs) = do+      reportSDoc "tc.lhs.linear" 40 $ sep+        [ "linearity: checking pattern "+        , prettyA p+        , " equal to term "+        , prettyTCM u+        , " of type "+        , prettyTCM a+        ]+      case p of+        A.VarP x -> do+          let y = A.unBind x+          reportSLn "tc.lhs.linear" 60 $+            "pattern variable " ++ prettyShow (A.nameConcrete y) ++ " with id " ++ show (A.nameId y)+          case Map.lookup x vars of+            Just (v , b) -> do+              traceCall (CheckPatternLinearityType $ A.nameConcrete y) $+                noConstraints $ equalType (unDom a) b+              traceCall (CheckPatternLinearityValue $ A.nameConcrete y) $+                noConstraints $ equalTerm (unDom a) u v+              check vars eqs+            Nothing -> (eq:) <$> do+              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.WildP{}       -> continue+        A.DotP{}        -> continue+        A.AbsurdP{}     -> continue+        A.ConP{}        -> __IMPOSSIBLE__+        A.ProjP{}       -> __IMPOSSIBLE__+        A.DefP{}        -> __IMPOSSIBLE__+        A.LitP{}        -> __IMPOSSIBLE__+        A.PatternSynP{} -> __IMPOSSIBLE__+        A.RecP{}        -> __IMPOSSIBLE__+        A.EqualP{}      -> __IMPOSSIBLE__+        A.WithP{}       -> __IMPOSSIBLE__++      where continue = (eq:) <$> check vars eqs++-- | Construct the context for a left hand side, making up out-of-scope names+--   for unnamed variables.+computeLHSContext :: [Maybe A.Name] -> Telescope -> TCM Context+computeLHSContext = go [] []+  where+    go cxt _ []        tel@ExtendTel{} = do+      reportSDoc "impossible" 10 $+        "computeLHSContext: no patterns left, but tel =" <+> prettyTCM tel+      __IMPOSSIBLE__+    go cxt _ (_ : _)   EmptyTel = __IMPOSSIBLE__+    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 = CtxVar name a+        go (e : cxt) (name : taken) xs (absBody tel)++    dummyName taken s =+      if isUnderscore s then freshNoName_+      else setNotInScope <$> freshName_ (argNameToString s)++-- | Bind as patterns+bindAsPatterns :: [AsBinding] -> TCM a -> TCM a+bindAsPatterns []                ret = ret+bindAsPatterns (AsB x v a : asb) ret = do+  reportSDoc "tc.lhs.as" 10 $ "as pattern" <+> prettyTCM x <+>+    sep [ ":" <+> prettyTCM a+        , "=" <+> prettyTCM v+        ]+  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)+  | 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+  { lhsParameters   :: Nat+    -- ^ The number of original module parameters. These are present in the+    -- the patterns.+  , lhsVarTele      :: Telescope+    -- ^ Δ : The types of the pattern variables, in internal dependency order.+    -- Corresponds to 'clauseTel'.+  , lhsPatterns     :: [NamedArg DeBruijnPattern]+    -- ^ The patterns in internal syntax.+  , lhsHasAbsurd    :: Bool+    -- ^ Whether the LHS has at least one absurd pattern.+  , lhsBodyType     :: Arg Type+    -- ^ The type of the body. Is @bσ@ if @Γ@ is defined.+    -- 'Irrelevant' to indicate the rhs must be checked in irrelevant mode.+  , lhsPatSubst     :: Substitution+    -- ^ Substitution version of @lhsPatterns@, only up to the first projection+    -- pattern. @Δ |- lhsPatSubst : Γ@. Where @Γ@ is the argument telescope of+    -- the function. This is used to update inherited dot patterns in+    -- with-function clauses.+  , lhsAsBindings   :: [AsBinding]+    -- ^ As-bindings from the left-hand side. Return instead of bound since we+    -- want them in where's and right-hand sides, but not in with-clauses+    -- (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 ixsplit) = LHSResult n+    <$> instantiateFull' tel+    <*> instantiateFull' ps+    <*> instantiateFull' abs+    <*> instantiateFull' t+    <*> instantiateFull' sub+    <*> instantiateFull' as+    <*> pure psplit+    <*> pure ixsplit++-- | Check a LHS. Main function.+--+--   @checkLeftHandSide a ps a ret@ checks that user patterns @ps@ eliminate+--   the type @a@ of the defined function, and calls continuation @ret@+--   if successful.++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]+     -- ^ The patterns.+  -> Type+     -- ^ The expected type @a = Γ → b@.+  -> Maybe Substitution+     -- ^ Module parameter substitution from with-abstraction.+  -> [ProblemEq]+     -- ^ Patterns that have been stripped away by with-desugaring.+     -- ^ These should not contain any proper matches.+  -> (LHSResult -> TCM a)+     -- ^ Continuation.+  -> TCM a+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) <$> 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 ixsplit) = do++        reportSDoc "tc.lhs.top" 20 $ vcat+          [ "lhs: final checks with remaining equations"+          , 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__++        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+            numPats  = length $ takeWhile (notProj . namedArg) qs0++            -- We have two slightly different cases here: normal function and+            -- with-function. In both cases the goal is to build a substitution+            -- from the context Γ of the previous checkpoint to the current lhs+            -- context Δ:+            --+            --    Δ ⊢ paramSub : Γ+            --+            --  * Normal function, f+            --+            --    Γ = cxt = module parameter telescope of f+            --    Ψ = non-parameter arguments of f (we have f : Γ Ψ → A)+            --    Δ   ⊢ patSub  : Γ Ψ+            --    Γ Ψ ⊢ weakSub : Γ+            --    paramSub = patSub ∘ weakSub+            --+            --  * With-function+            --+            --    Γ = lhs context of the parent clause (cxt = [])+            --    Ψ = argument telescope of with-function+            --    Θ = inserted implicit patterns not in Ψ (#2827)+            --        (this happens if the goal computes to an implicit+            --         function type after some matching in the with-clause)+            --+            --    Ψ   ⊢ withSub : Γ+            --    Δ   ⊢ patSub  : Ψ Θ+            --    Ψ Θ ⊢ weakSub : Ψ+            --    paramSub = patSub ∘ weakSub ∘ withSub+            --+            --    To compute Θ we can look at the arity of the with-function+            --    and compare it to numPats. This works since the with-function+            --    type is fully reduced.++            weakSub :: Substitution+            weakSub | isJust withSub' = wkS (max 0 $ numPats - arity_a) idS -- if numPats < arity, Θ is empty+                    | otherwise       = wkS (numPats - length cxt) idS+            withSub  = fromMaybe idS withSub'+            patSub   = map (patternToTerm . namedArg) (reverse $ take numPats qs0) ++# EmptyS impossible+            paramSub = patSub `composeS` weakSub `composeS` withSub++        eqs <- addContext delta $ checkPatternLinearity eqs++        leftovers@(LeftoverPatterns patVars asb0 dots absurds annps otherPats)+          <- addContext delta $ getLeftoverPatterns eqs++        reportSDoc "tc.lhs.leftover" 30 $ vcat+          [ "leftover patterns: " , nest 2 (addContext delta $ prettyTCM leftovers) ]++        unless (null otherPats) __IMPOSSIBLE__++        -- Get the user-written names for the pattern variables+        let (vars, asb1) = getUserVariableNames delta patVars+            asb          = asb0 ++ asb1++        -- Rename internal patterns with these names+        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) ixsplit++        -- Debug output+        reportSDoc "tc.lhs.top" 10 $+          vcat [ "checked lhs:"+               , nest 2 $ vcat+                 [ "delta   = " <+> prettyTCM delta+                 , "dots    = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM dots)+                 , "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+        reportSDoc "tc.lhs.top" 20 $ nest 2 $ "patSub   = " <+> pretty patSub+        reportSDoc "tc.lhs.top" 20 $ nest 2 $ "paramSub = " <+> pretty paramSub++        newCxt <- computeLHSContext vars delta++        updateContext paramSub (const newCxt) $ do++          reportSDoc "tc.lhs.top" 10 $ "bound pattern variables"+          reportSDoc "tc.lhs.top" 60 $ nest 2 $ "context = " <+> (pretty =<< getContextTelescope)+          reportSDoc "tc.lhs.top" 10 $ nest 2 $ "type  = " <+> prettyTCM b+          reportSDoc "tc.lhs.top" 60 $ nest 2 $ "type  = " <+> pretty b++          bindAsPatterns asb $ do++            -- Check dot patterns+            mapM_ checkDotPattern dots+            mapM_ checkAbsurdPattern absurds+            mapM_ checkAnnotationPattern annps++          -- Issue2303: don't bind asb' for the continuation (return in lhsResult instead)+          ret lhsResult++  st0 <- initLHSState tel eqs0 ps a finalChecks++  -- after we have introduced variables, we can add the patterns stripped by+  -- with-desugaring to the state.+  let withSub = fromMaybe __IMPOSSIBLE__ withSub'+  withEqs <- updateProblemEqs $ applySubst withSub strippedPats+  -- Jesper, 2017-05-13: re-check the stripped patterns here!+  inTopContext $ addContext (st0 ^. lhsTel) $+    forM_ withEqs recheckStrippedWithPattern++  let st = over (lhsProblem . problemEqs) (++ withEqs) st0++  -- doing the splits:+  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+  where+    shouldSplit :: ProblemEq -> Bool+    shouldSplit problem@(ProblemEq p v a) = case p of+      A.LitP{}    -> True+      A.RecP{}    -> True+      A.ConP{}    -> True+      A.EqualP{}  -> True++      A.VarP{}    -> False+      A.WildP{}   -> False+      A.DotP{}    -> False+      A.AbsurdP{} -> False++      A.AsP _ _ p  -> shouldSplit $ problem { problemInPat = p }++      A.ProjP{}       -> __IMPOSSIBLE__+      A.DefP{}        -> __IMPOSSIBLE__+      A.PatternSynP{} -> __IMPOSSIBLE__+      A.WithP{}       -> __IMPOSSIBLE__+++-- | 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 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+      let m = getModality target+      applyModalityToContext m $ do+        cont $ over (lhsTel . listTel)+                 (map $ inverseApplyModalityButNotQuantity m) st+        -- Andreas, 2018-10-23, issue #3309+        -- the modalities in the clause telescope also need updating.++ 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++    reportSDoc "tc.lhs.top" 30 $ vcat+      [ "LHS state: " , nest 2 (prettyTCM st) ]++    unlessM (optPatternMatching <$> getsTC getPragmaOptions) $+      unless (problemAllVariables problem) $+        typeError NeedOptionPatternMatching++    let splitsToTry = splitStrategy $ problem ^. problemEqs++    foldr trySplit trySplitRest splitsToTry >>= \case+      Right st' -> checkLHS mf st'+      -- If no split works, give error from first split.+      -- This is conservative, but might not be the best behavior.+      -- It might be better to print all the errors instead.+      Left (err:_) -> throwError err+      Left []      -> __IMPOSSIBLE__++  where++    trySplit :: ProblemEq+             -> tcm (Either [TCErr] (LHSState a))+             -> tcm (Either [TCErr] (LHSState a))+    trySplit eq tryNextSplit = runExceptT (splitArg eq) >>= \case+      Right st' -> return $ Right st'+      Left err  -> left (err:) <$> tryNextSplit++    -- If there are any remaining user patterns, try to split on them+    trySplitRest :: tcm (Either [TCErr] (LHSState a))+    trySplitRest = case problem ^. problemRestPats of+      []    -> return $ Left []+      (p:_) -> left singleton <$> runExceptT (splitRest p)++    splitArg :: ProblemEq -> ExceptT TCErr tcm (LHSState a)+    -- Split on constructor/literal pattern+    splitArg (ProblemEq p v Dom{unDom = a}) = traceCall (CheckPattern p tel a) $ do++      reportSDoc "tc.lhs.split" 30 $ sep+        [ "split looking at pattern"+        , nest 2 $ "p =" <+> prettyA p+        ]++      -- in order to split, v must be a variable.+      i <- liftTCM $ addContext tel $ ifJustM (isEtaVar v a) return $+             softTypeError $ SplitOnNonVariable v a++      let pos = size tel - (i + 1)+          (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel -- TODO:: tel' defined but not used++      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.VarP{}        -> __IMPOSSIBLE__+            A.WildP{}       -> __IMPOSSIBLE__+            A.DotP{}        -> __IMPOSSIBLE__+            A.AbsurdP{}     -> __IMPOSSIBLE__+            A.ProjP{}       -> __IMPOSSIBLE__+            A.DefP{}        -> __IMPOSSIBLE__+            A.PatternSynP{} -> __IMPOSSIBLE__+            A.WithP{}       -> __IMPOSSIBLE__+      splitOnPat p+++    splitRest :: NamedArg A.Pattern -> ExceptT TCErr tcm (LHSState a)+    splitRest p = setCurrentRange p $ do+      reportSDoc "tc.lhs.split" 20 $ sep+        [ "splitting problem rest"+        , nest 2 $ "projection pattern =" <+> prettyA p+        , nest 2 $ "eliminates type    =" <+> prettyTCM target+        ]+      reportSDoc "tc.lhs.split" 80 $ sep+        [ nest 2 $ text $ "projection pattern (raw) = " ++ show p+        ]++      -- @p@ should be a projection pattern projection from @target@+      (orig, ambProjName) <- ifJust (A.isProjP p) return $ addContext tel $ do+        block <- isBlocked target+        softTypeError $ CannotEliminateWithPattern block p (unArg target)++      (projName, comatchingAllowed, recName, projType, ai) <- suspendErrors $ do+        -- Andreas, 2018-10-18, issue #3289: postfix projections do not have hiding+        -- information for their principal argument; we do not parse @{r}.p@ and the like.+        let h = if orig == ProjPostfix then Nothing else Just $ getHiding p+        addContext tel $ disambiguateProjection h ambProjName target++      unless comatchingAllowed $ do+        hardTypeError $ ComatchingDisabledForRecord recName++      -- Compute the new rest type by applying the projection type to 'self'.+      -- Note: we cannot be in a let binding.+      let f = fromMaybe __IMPOSSIBLE__ mf+      let self = Def f $ patternsToElims ip+      target' <- traverse (`piApplyM` self) projType++      -- Compute the new state+      let projP    = applyWhen (orig == ProjPostfix) (setHiding NotHidden) $+                       Arg ai $ Named Nothing (ProjP orig projName)+          ip'      = ip ++ [projP]+          -- drop the projection pattern (already splitted)+          problem' = over problemRestPats (drop 1) problem+      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit)+++    -- Split a Partial.+    --+    -- Example for splitPartial:+    -- @+    --   g : ∀ i j → Partial (i ∨ j) A+    --   g i j (i = 1) = a i j+    --   g i j (j = 1) = b i j+    -- @+    -- leads to, in the first clause:+    -- @+    --   dom   = IsOne (i ∨ j)+    --   ts    = [(i, 1)]+    --   phi   = i+    --   sigma = [1/i]+    -- @+    -- Final clauses:+    -- @+    --   g : ∀ i j → Partial (i ∨ j) A+    --   g 1? j  .itIsOne = a 1 j+    --   g i  1? .itIsOne = b i 1+    -- @+    -- Herein, ? indicates a 'conPFallThrough' pattern.+    --+    -- Example for splitPartial:+    -- @+    --   h : ∀ i j → Partial (i & ¬ j) A+    --   h i j (i = 1) (j = 0)+    --   -- ALT: h i j (i & ¬ j = 1)+    -- @+    -- gives+    -- @+    --   dom = IsOne (i & ¬ j)+    --   ts  = [(i,1), (j,0)]  -- ALT: [(i & ¬ j, 1)]+    --   phi = i & ¬ j+    --   sigma = [1/i,0/j]+    -- @+    --+    -- Example for splitPartial:+    -- @+    --   g : ∀ i j → Partial (i ∨ j) A+    --   g i j (i ∨ j = 1) = a i j+    -- @+    -- leads to, in the first clause:+    -- @+    --   dom   = IsOne (i ∨ j)+    --   ts    = [(i ∨ j, 1)]+    --   phi   = i ∨ j+    --   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.+      -> List1 (A.Expr, A.Expr)+            -- [(φ₁ = b1),..,(φn = bn)]+      -> ExceptT TCErr tcm (LHSState a)++    splitPartial delta1 dom adelta2 ts = do++      unless (domIsFinite dom) $ liftTCM $ addContext delta1 $+        softTypeError $ SplitOnPartial dom++      tInterval <- liftTCM $ primIntervalType++      names <- liftTCM $ addContext tel $ do+        LeftoverPatterns{patternVariables = vars} <- getLeftoverPatterns $ problem ^. problemEqs+        return $ take (size delta1) $ fst $ getUserVariableNames tel vars++      -- Problem: The context does not match the checkpoints in checkLHS,+      --          however we still need a proper checkpoint substitution+      --          for checkExpr below.+      --+      -- Solution: partial splits are not allowed when there are+      --           constructor patterns (checked in checkDef), so+      --           newContext is an extension of the definition+      --           context.+      --+      -- i.e.: Given+      --+      --             Γ = context where def is checked, also last checkpoint.+      --+      --       Then+      --+      --             newContext = Γ Ξ+      --             cpSub = raiseS |Ξ|+      --+      lhsCxtSize <- asks lhsContextSize -- size of the context before checkLHS call.+      reportSDoc "tc.lhs.split.partial" 10 $ "lhsCxtSize =" <+> prettyTCM lhsCxtSize++      newContext <- liftTCM $ computeLHSContext names delta1+      reportSDoc "tc.lhs.split.partial" 10 $ "newContext =" <+> prettyTCM newContext++      let cpSub = raiseS $ size newContext - lhsCxtSize++      (gamma,sigma) <- liftTCM $ updateContext cpSub (const newContext) $ 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 (lhs, rhs)+                 t <- checkExpr lhs tInterval+                 u <- checkExpr rhs tInterval+                 reportSDoc "tc.lhs.split.partial" 10 $ text "t, u        =" <+> pretty (t, u)+                 reduce u >>= intervalView >>= \case+                   IZero -> primINeg <@> pure t+                   IOne  -> return t+                   _     -> typeError $ ExpectedIntervalLiteral rhs+         -- Example: ts = (i=0) (j=1) will result in phi = ¬ i & j+         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 -> patternViolation m)+                            (\_ sigma -> (,sigma) <$> getContextTelescope)+         case refined of+           [(gamma,sigma)] -> return (gamma,sigma)+           []              -> typeError FaceConstraintUnsatisfiable+           _               -> typeError FaceConstraintDisjunction+      itisone <- liftTCM primItIsOne+      -- substitute the literal in p1 and dpi+      reportSDoc "tc.lhs.faces" 60 $ text $ show sigma++      let oix = size adelta2 -- de brujin index of IsOne+          o_n = fromMaybe __IMPOSSIBLE__ $+            findIndex (\ x -> case namedThing (unArg x) of+                                   VarP _ x -> dbPatVarIndex x == oix+                                   _        -> False) ip+          delta2' = absApp adelta2 itisone+          delta2 = applySubst sigma delta2'+          mkConP (Con c _ [])+             = ConP c (noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)+                                              , conPFallThrough = True })+                          []+          mkConP (Var i []) = VarP defaultPatternInfo (DBPatVar "x" i)+          mkConP _          = __IMPOSSIBLE__+          rho0 = fmap mkConP sigma++          rho    = liftS (size delta2) $ consS (DotP defaultPatternInfo itisone) rho0++          delta'   = abstract gamma delta2+          eqs'     = applyPatSubst rho $ problem ^. problemEqs+          ip'      = applySubst rho ip+          target'  = applyPatSubst rho target++      -- 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]) ixsplit)+++    splitLit :: Telescope      -- The types of arguments before the one we split on+             -> Dom Type       -- The type of the literal we split on+             -> Abs Telescope  -- The types of arguments after the one we split on+             -> Literal        -- The literal written by the user+             -> ExceptT TCErr tcm (LHSState a)+    splitLit delta1 dom@Dom{domInfo = info, unDom = a} adelta2 lit = do+      let delta2 = absApp adelta2 (Lit lit)+          delta' = abstract delta1 delta2+          rho    = singletonS (size delta2) (litP lit)+          -- Andreas, 2015-06-13 Literals are closed, so no need to raise them!+          -- rho    = liftS (size delta2) $ singletonS 0 (Lit lit)+          -- rho    = [ var i | i <- [0..size delta2 - 1] ]+          --       ++ [ raise (size delta2) $ Lit lit ]+          --       ++ [ var i | i <- [size delta2 ..] ]+          eqs'     = applyPatSubst rho $ problem ^. problemEqs+          ip'      = applySubst rho ip+          target'  = applyPatSubst rho target++      -- Andreas, 2010-09-07 cannot split on irrelevant args+      unless (usableRelevance info) $+        addContext delta1 $ softTypeError $ SplitOnIrrelevant dom++      -- Andreas, 2018-10-17, we can however split on erased things+      -- if there is a single constructor (checked in Coverage).+      --+      -- Thus, no checking of (usableQuantity info) here.++      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 $ addContext delta1 $ equalType a =<< litType lit++      -- Compute the new state+      let problem' = set problemEqs eqs' problem+      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit)+++    splitCon :: Telescope      -- The types of arguments before the one we split on+             -> Dom Type       -- The type of the constructor we split on+             -> Abs Telescope  -- The types of arguments after the one we split on+             -> A.Pattern      -- The pattern written by the user+             -> Maybe AmbiguousQName  -- @Just c@ for a (possibly ambiguous) constructor @c@, or+                                      -- @Nothing@ for a record pattern+             -> ExceptT TCErr tcm (LHSState a)+    splitCon delta1 dom@Dom{domInfo = info, unDom = a} adelta2 focusPat ambC = do+      let delta2 = absBody adelta2++      reportSDoc "tc.lhs.split" 10 $ vcat+        [ "checking lhs"+        , nest 2 $ "tel =" <+> prettyTCM tel+        , nest 2 $ "rel =" <+> text (show $ getRelevance info)+        , nest 2 $ "mod =" <+> text (show $ getModality  info)+        ]++      reportSDoc "tc.lhs.split" 15 $ vcat+        [ "split problem"+        , nest 2 $ vcat+          [ "delta1 = " <+> prettyTCM delta1+          , "a      = " <+> addContext delta1 (prettyTCM a)+          , "delta2 = " <+> addContext delta1+                              (addContext ("x" :: String, dom) (prettyTCM delta2))+          ]+        ]++      -- We cannot split on (shape-)irrelevant arguments.+      reportSLn "tc.lhs.split" 30 $ "split ConP: relevance is " ++ show (getRelevance info)+      unless (usableRelevance info) $ addContext delta1 $+        softTypeError $ SplitOnIrrelevant dom++      -- Andreas, 2018-10-17, we can however split on erased things+      -- if there is a single constructor (checked in Coverage).+      --+      -- Thus, no checking of (usableQuantity info) here.++      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, s, pars, ixs) <- addContext delta1 $ isDataOrRecordType a+      let isRec = case dr of+            IsData{}   -> False+            IsRecord{} -> True++      checkMatchingAllowed d dr  -- No splitting on coinductive constructors.++      -- 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) <&> \ 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+        Just ambC -> disambiguateConstructor ambC d pars+        Nothing   -> getRecordConstructor d pars a++      -- Don't split on lazy (non-eta) constructor+      case focusPat of+        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 $ telViewPathBoundary b+      let Def d' es' = ctarget+          cixs = drop (size pars) $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es'++      -- Δ₁Γ ⊢ boundary+      reportSDoc "tc.lhs.split.con" 50 $ text "  boundary = " <+> prettyTCM boundary++      unless (d == d') {-'-} __IMPOSSIBLE__++      -- Get names for the constructor arguments from the user patterns+      gamma <- liftTCM $ case focusPat of+        A.ConP _ _ ps -> do+          ps <- insertImplicitPatterns ExpandLast ps gamma+          return $ useNamesFromPattern ps gamma+        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__++      -- Andreas 2010-09-07  propagate relevance info to new vars+      -- Andreas 2018-10-17  propagate modality+      let updMod = composeModality (getModality info)+      gamma <- return $ mapModality updMod <$> gamma++      -- Get the type of the datatype.+      da <- (`piApply` pars) . defType <$> getConstInfo d+      reportSDoc "tc.lhs.split" 30 $ "  da = " <+> prettyTCM da++      reportSDoc "tc.lhs.top" 15 $ addContext delta1 $+        sep [ "preparing to unify"+            , nest 2 $ vcat+              [ "c      =" <+> prettyTCM c <+> ":" <+> prettyTCM b+              , "d      =" <+> prettyTCM (Def d (map Apply pars)) <+> ":" <+> prettyTCM da+              , "isRec  =" <+> (text . show) isRec+              , "gamma  =" <+> prettyTCM gamma+              , "pars   =" <+> brackets (fsep $ punctuate comma $ map prettyTCM pars)+              , "ixs    =" <+> brackets (fsep $ punctuate comma $ map prettyTCM ixs)+              , "cixs   =" <+> addContext gamma (brackets (fsep $ punctuate comma $ map prettyTCM cixs))+              ]+            ]+                 -- We ignore forcing for make-case+      cforced <- ifM (viewTC eMakeCase) (return []) $+                 {-else-} defForced <$> getConstInfo (conName c)++      let delta1Gamma = delta1 `abstract` gamma+          da'  = raise (size gamma) da+          ixs' = raise (size gamma) ixs+          -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced+          -- variables.+          forced = replicate (size delta1) NotForced ++ cforced++      -- All variables are flexible.+      let flex = allFlexVars forced $ delta1Gamma++      -- Unify constructor target and given type (in Δ₁Γ)+      -- Given: Δ₁  ⊢ D pars : Φ → Setᵢ+      --        Δ₁  ⊢ c      : Γ → D pars cixs+      --        Δ₁  ⊢ ixs    : Φ+      --        Δ₁Γ ⊢ cixs   : Φ+      -- unification of ixs and cixs in context Δ₁Γ gives us a telescope Δ₁'+      -- and a substitution ρ₀ such that+      --        Δ₁' ⊢ ρ₀ : Δ₁Γ+      --        Δ₁' ⊢ (ixs)ρ₀ ≡ (cixs)ρ₀ : Φρ₀+      -- We can split ρ₀ into two parts ρ₁ and ρ₂, giving+      --        Δ₁' ⊢ ρ₁ : Δ₁+      --        Δ₁' ⊢ ρ₂ : Γρ₁+      -- Application of the constructor c gives+      --        Δ₁' ⊢ (c Γ)(ρ₀) : (D pars cixs)(ρ₁;ρ₂)+      -- We have+      --        cixs(ρ₁;ρ₂)+      --         ≡ cixs(ρ₀)   (since ρ₀=ρ₁;ρ₂)+      --         ≡ ixs(ρ₀)    (by unification)+      --         ≡ ixs(ρ₁)    (since ixs doesn't actually depend on Γ)+      -- so     Δ₁' ⊢ (c Γ)(ρ₀) : (D pars ixs)ρ₁+      -- Putting this together with ρ₁ gives ρ₃ = ρ₁;c ρ₂+      --        Δ₁' ⊢ ρ₁;(c Γ)(ρ₀) : Δ₁(x : D vs ws)+      -- and lifting over Δ₂ gives the final substitution ρ = ρ₃;Δ₂+      -- from Δ' = Δ₁';Δ₂ρ₃+      --        Δ' ⊢ ρ : Δ₁(x : D vs ws)Δ₂++      -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope+      -- TODO: should we propagate the modality in general?+      -- See also Coverage checking.+      da' <- addContext delta1Gamma $ do+             let updCoh = composeCohesion (getCohesion info)+             TelV tel dt <- telView da'+             return $ abstract (mapCohesion updCoh <$> tel) a++      let stuck b errs = softTypeError $ SplitError $+            UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs++      liftTCM (withKIfStrict $ unifyIndices genTrx delta1Gamma flex da' cixs ixs') >>= \case++        -- Mismatch.  Report and abort.+        NoUnify neg -> hardTypeError $ ImpossibleConstructor (conName c) neg++        UnifyBlocked block -> stuck (Just block) []++        -- Unclear situation.  Try next split.+        UnifyStuck errs -> stuck Nothing errs++        -- Success.+        Unifies (delta1',rho0,es) -> do++          reportSDoc "tc.lhs.top" 15 $ "unification successful"+          reportSDoc "tc.lhs.top" 20 $ nest 2 $ vcat+            [ "delta1' =" <+> prettyTCM delta1'+            , "rho0    =" <+> addContext delta1' (prettyTCM rho0)+            , "es      =" <+> addContext delta1' (prettyTCM $ (fmap . fmap . fmap) patternToTerm es)+            ]++          -- split substitution into part for Δ₁ and part for Γ+          let (rho1,rho2) = splitS (size gamma) rho0++          reportSDoc "tc.lhs.top" 20 $ addContext delta1' $ nest 2 $ vcat+            [ "rho1    =" <+> prettyTCM rho1+            , "rho2    =" <+> prettyTCM rho2+            ]++          -- Andreas, 2010-09-09, save the type.+          -- It is relative to Δ₁, but it should be relative to Δ₁'+          let a' = applyPatSubst rho1 a++          -- Also remember if we are a record pattern.+          let cpi = ConPatternInfo { conPInfo   = PatternInfo PatOCon []+                                   , conPRecord = isRec+                                   , conPFallThrough = False+                                   , conPType   = Just $ Arg info a'+                                   , conPLazy   = False } -- Don't mark eta-record matches as lazy (#4254)++          -- compute final context and substitution+          let crho    = ConP c cpi $ applySubst rho0 $ (telePatterns gamma boundary)+              rho3    = consS crho rho1+              delta2' = applyPatSubst rho3 delta2+              delta'  = delta1' `abstract` delta2'+              rho     = liftS (size delta2) rho3++          reportSDoc "tc.lhs.top" 20 $ addContext delta1' $ nest 2 $ vcat+            [ "crho    =" <+> prettyTCM crho+            , "rho3    =" <+> prettyTCM rho3+            , "delta2' =" <+> prettyTCM delta2'+            ]+          reportSDoc "tc.lhs.top" 70 $ addContext delta1' $ nest 2 $ vcat+            [ "crho    =" <+> pretty crho+            , "rho3    =" <+> pretty rho3+            , "delta2' =" <+> pretty delta2'+            ]++          reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat+            [ "delta'  =" <+> prettyTCM delta'+            , "rho     =" <+> addContext delta' (prettyTCM rho)+            ]++          -- Compute the new out patterns and target type.+          let ip'      = applySubst rho ip+              target'  = applyPatSubst rho target++          -- Update the problem equations+          let eqs' = applyPatSubst rho $ problem ^. problemEqs+              problem' = set problemEqs eqs' problem++          -- The result type's quantity is set to 0 for erased+          -- constructors, but not if the match is made in an erased+          -- position, or if the original constructor definition is+          -- not erased.+          cq <- getQuantity <$> getOriginalConstInfo (conName c)+          let target'' = mapQuantity updResMod target'+                where+                  erased = case getQuantity info of+                    Quantity0{} -> True+                    Quantity1{} -> __IMPOSSIBLE__+                    Quantityω{} -> False+                  -- either sets to Quantity0 or is the identity.+                  updResMod q =+                    case cq of+                     _ | erased  -> q+                     Quantity0{} -> composeQuantity cq q+                                 -- zero-out, preserves origin+                     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 (ixsplit || not (null ixs))++          reportSDoc "tc.lhs.top" 12 $ sep+            [ "new problem from rest"+            , nest 2 $ vcat+              [ "delta'  =" <+> prettyTCM (st' ^. lhsTel)+              , "eqs'    =" <+> addContext (st' ^. lhsTel) (prettyTCM $ st' ^. (lhsProblem . problemEqs))+              , "ip'     =" <+> addContext (st' ^. lhsTel) (pretty $ st' ^. lhsOutPat)+              ]+            ]+          return st'+++-- | Ensures that we are not performing pattern matching on coinductive constructors.++checkMatchingAllowed :: (MonadTCError m)+  => QName         -- ^ The name of the data or record type the constructor belongs to.+  -> DataOrRecord  -- ^ Information about data or (co)inductive (no-)eta-equality record.+  -> m ()+checkMatchingAllowed d = \case+  IsRecord InductionAndEta { recordInduction=ind, recordEtaEquality=eta }+    | Just CoInductive <- ind -> typeError SplitOnCoinductive+    | not $ patternMatchingAllowed eta -> typeError $ SplitOnNonEtaRecord d+    | otherwise -> return ()+  IsData -> return ()++-- | When working with a monad @m@ implementing @MonadTCM@ and @MonadError TCErr@,+--   @suspendErrors f@ performs the TCM action @f@ but catches any errors and throws+--   them in the monad @m@ instead.+suspendErrors :: (MonadTCM m, MonadError TCErr m) => TCM a -> m a+suspendErrors f = do+  ok <- liftTCM $ (Right <$> f) `catchError` (return . Left)+  either throwError return ok++-- | A more direct implementation of the specification+--   @softTypeError err == suspendErrors (typeError err)@+softTypeError :: (HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a+softTypeError err = withCallerCallStack $ \loc ->+  throwError =<< typeError' loc err++-- | A convenient alias for @liftTCM . typeError@. Throws the error directly+--   in the TCM even if there is a surrounding monad also implementing+--   @MonadError TCErr@.+hardTypeError :: (HasCallStack, MonadTCM m) => TypeError -> m a+hardTypeError = withCallerCallStack $ \loc -> liftTCM . typeError' loc++type DataOrRecord = DataOrRecord' InductionAndEta++-- | Check if the type is a data or record type and return its name,+--   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, 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 (getConstInfo d) >>= \def -> case theDef def of++      Datatype{dataPars = np, dataSort = s} -> do++        whenM (isInterval a) $ hardTypeError =<< notData++        let (pars, ixs) = splitAt np $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+        return (IsData, d, s, pars, ixs)++      Record{ recInduction, recEtaEquality' } -> do+        let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+        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 $ SplitOnAbstract d++      -- the type could be an axiom+      Axiom{} -> hardTypeError =<< notData++      -- Can't match before we have the definition+      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, ...)+      Function{}    -> hardTypeError =<< notData++      Constructor{} -> __IMPOSSIBLE__++      -- Issue #3620: Some primitives are types too.+      -- Not data though, at least currently 11/03/2018.+      Primitive{}   -> hardTypeError =<< notData++      PrimitiveSort{} -> hardTypeError =<< notData++      GeneralizableVar{} -> __IMPOSSIBLE__++    -- variable: fail softly+    Var{}      -> softTypeError =<< notData+    MetaV{}    -> __IMPOSSIBLE__  -- That is handled in @blocked@.++    -- pi or sort: fail hard+    Pi{}       -> hardTypeError =<< notData+    Sort{}     -> hardTypeError =<< notData++    Lam{}      -> __IMPOSSIBLE__+    Lit{}      -> __IMPOSSIBLE__+    Con{}      -> __IMPOSSIBLE__+    Level{}    -> __IMPOSSIBLE__+    DontCare{} -> __IMPOSSIBLE__+    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++  -- neutral type: fail softly+  StuckOn{}     -> \ _a -> softTypeError =<< notData+  AbsurdMatch{} -> \ _a -> softTypeError =<< notData++  -- missing clauses: fail hard+  -- TODO: postpone checking of the whole clause until later?+  MissingClauses{} -> \ _a -> hardTypeError =<< notData++  -- underapplied type: should not happen+  Underapplied{} -> __IMPOSSIBLE__++  where+  notData      = liftTCM $ SplitError . NotADatatype <$> buildClosure a0+  blocked b _a = softTypeError =<< do liftTCM $ SplitError . BlockedType b <$> buildClosure a0++-- | Get the constructor of the given record type together with its type.+--   Throws an error if the type is not a record type.+getRecordConstructor+  :: QName  -- ^ Name @d@ of the record type+  -> Args   -- ^ Parameters @pars@ of the record type+  -> Type   -- ^ The record type @Def d pars@ (for error reporting)+  -> TCM (ConHead, Type)+getRecordConstructor d pars a = do+  con <- (theDef <$> getConstInfo d) >>= \case+    Record{recConHead = con} -> return $ killRange con+    _ -> typeError $ ShouldBeRecordType a+  b <- (`piApply` pars) . defType <$> getConstInfo (conName con)+  return (con, b)+++-- | Disambiguate a projection based on the record type it is supposed to be+--   projecting from. Returns the unambiguous projection name and its type.+--   Throws an error if the type is not a record type.+disambiguateProjection+  :: Maybe Hiding   -- ^ Hiding info of the projection's principal argument.+                    --   @Nothing@ if 'Postfix' projection.+  -> AmbiguousQName -- ^ Name of the projection to be disambiguated.+  -> Arg Type       -- ^ Record type we are projecting from.+  -> TCM (QName, Bool, QName, Arg Type, ArgInfo)+       -- ^ @Bool@ signifies whether copattern matching is allowed at+       --   the inferred record type.+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, RecordData{ _recFields = fs, _recInduction = ind, _recEtaEquality' = eta }) -> do+      reportSDoc "tc.lhs.split" 20 $ sep+        [ "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 = ind == Just CoInductive+                    || copatternMatchingAllowed eta+      -- Try the projection candidates.+      -- First, we try to find a disambiguation that doesn't produce+      -- any new constraints.+      tryDisambiguate False fs r vs comatching $ \ _ ->+          -- If this fails, we try again with constraints, but we require+          -- the solution to be unique.+          tryDisambiguate True fs r vs comatching $ \case+            (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 :: 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+          -- From here, we have the correctly disambiguated projection.+          -- For highlighting, we remember which name we disambiguated to.+          -- This is safe here (fingers crossed) as we won't decide on a+          -- different projection even if we backtrack and come here again.+          liftTCM $ storeDisambiguatedProjection d+          return (d, comatching, r, a, ai)+        other -> failure other++    notRecord = wrongProj $ List1.head ds++    wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a+    wrongProj d = softTypeError =<< do+      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?+      -> [Dom QName]          -- Fields of record type under consideration.+      -> QName                -- Name of record type we are eliminating.+      -> Args                 -- Parameters of record type we are eliminating.+      -> QName                -- Candidate projection.+      -> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))+           -- TCState contains possibly new constraints/meta solutions.+    tryProj constraintsOk fs r vs d0 = isProjection d0 >>= \case+      -- Not a projection+      Nothing -> wrongProj d0+      Just proj -> do+        let d = projOrig proj++        -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible+        qr <- maybe (wrongProj d) return $ projProper proj++        -- If projIndex==0, then the projection is already applied+        -- to the record value (like in @open R r@), and then it+        -- is no longer a projection but a record field.+        when (null $ projLams proj) $ wrongProj d+        reportSLn "tc.lhs.split" 90 "we are a projection pattern"+        -- 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.+        reportSDoc "tc.lhs.split" 20 $ sep+          [ text $ "proj                  d0 = " ++ prettyShow d0+          , text $ "original proj         d  = " ++ prettyShow d+          ]+        -- Get the field decoration.+        -- If the projection pattern name @d@ is not a field name,+        -- we have to try the next projection name.+        -- If this was not an ambiguous projection, that's an error.+        argd <- maybe (wrongProj d) return $ List.find ((d ==) . unDom) fs++        -- Issue4998: This used to use the hiding from the principal argument, but this is not+        -- relevant for the ArgInfo of the clause rhs. We return that separately so we can set the+        -- correct hiding for the projection pattern in splitRest above.+        let ai = getArgInfo argd++        reportSDoc "tc.lhs.split" 20 $ vcat+          [ text $ "original proj relevance  = " ++ show (getRelevance argd)+          , text $ "original proj quantity   = " ++ show (getQuantity  argd)+          ]+        -- 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) $+          softTypeError $ WrongHidingInProjection d++        -- Andreas, 2016-12-31, issue #1976: Check parameters.+        let chk = checkParameters qr r vs+        mst <- suspendErrors $+          if constraintsOk then Just . snd <$> localTCStateSaving chk+          else Nothing <$ nonConstraining chk++        -- Get the type of projection d applied to "self"+        dType <- liftTCM $ defType <$> getConstInfo d  -- full type!+        reportSDoc "tc.lhs.split" 20 $ sep+          [ "we are being projected by dType = " <+> prettyTCM dType+          ]+        projType <- liftTCM $ dType `piApplyM` vs+        return (d0, (Arg ai projType, projArgInfo proj, mst))++-- | Disambiguate a constructor based on the data type it is supposed to be+--   constructing. Returns the unambiguous constructor name and its type.+--   Precondition: type should be a data/record type.+disambiguateConstructor+  :: AmbiguousQName    -- ^ The name of the constructor to be disambiguated.+  -> QName             -- ^ Name of the datatype.+  -> Args              -- ^ Parameters of the datatype+  -> TCM (ConHead, Type)+disambiguateConstructor ambC@(AmbQ cs) d pars = do+  d <- canonicalName d+  cons <- theDef <$> getConstInfo d >>= \case+    def@Datatype{} -> return $ dataCons def+    def@Record{}   -> return $ [conName $ recConHead def]+    _              -> __IMPOSSIBLE__++  -- First, try do disambiguate with nonConstraining,+  -- if that fails, try again allowing constraint/solution generation.+  tryDisambiguate False d cons $ \ _ ->+    tryDisambiguate True d cons $ \case+        ([]   , [] ) -> __IMPOSSIBLE__+        (err:_, [] ) -> throwError err+        -- If all disambiguations point to the same original constructor+        -- meaning that only the parameters may differ,+        -- then throw more specific error.+        (_    , [_]) -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs+        (_    , (d0@((c,_,_) :| _) : d1 : ds)) -> typeError $+          AmbiguousConstructor c $ fmap (conName . snd3) $ List2.concat21 $ List2 d0 d1 ds++  where+    tryDisambiguate+      :: Bool     -- May we constrain/solve metas to arrive at unique disambiguation?+      -> QName    -- Data/record type.+      -> [QName]  -- Its constructor(s).+      -> ( ( [TCErr]+           , [List1 (QName, ConHead, (Type, Maybe TCState))]+           )+           -> TCM (ConHead, Type) )  -- Failure continuation, taking+                                     -- possible disambiguations+                                     -- grouped by the original+                                     -- constructor name in 'ConHead'.+      -> TCM (ConHead, Type)  -- Unique disambiguation and its type.+    tryDisambiguate constraintsOk d cons failure = do+      reportSDoc "tc.lhs.disamb" 30 $ sep $ List.concat $+        [ [ "tryDisambiguate" ]+        , if constraintsOk then [ "(allowing new constraints)" ] else empty+        , map (nest 2 . pretty) $ List1.toList cs+        , [ "against" ]+        , map (nest 2 . pretty) cons+        ]+      disambiguations <- mapM (runExceptT . tryCon constraintsOk cons d pars) cs+      -- Q: can we be more lazy, like using the ListT monad?+      -- Andreas, 2020-06-17: Not really, since we need to make sure+      -- that only a single candidate remains, and if not,+      -- report all alternatives in the error message.+      let (errs, fits0) = List1.partitionEithers disambiguations+      reportSDoc "tc.lhs.disamb" 40 $ vcat $ do+        let hideSt (c0,c,(a,mst)) = (c0, c, (a, ("(state change)" :: String) <$ mst))+        "remaining candidates: " : map (nest 2 . prettyTCM . hideSt) fits0+      dedupCons fits0 >>= \case++        -- Single candidate remains.+        [ (c0,c,(a,mst)) :| [] ] -> do+          reportSDoc "tc.lhs.disamb" 30 $ sep $+            [ "tryDisambiguate suceeds with"+            , pretty c0+            , ":"+            , prettyTCM a+            ]+          -- Andreas, 2020-06-16, issue #4135+          -- If disambiguation succeeded with new constraints/solutions,+          -- put them into action.+          whenJust mst putTC+          -- If there are multiple candidates for the constructor pattern, exactly one of+          -- which type checks, remember our choice for highlighting info.+          when (isAmbiguous ambC) $ liftTCM $+            storeDisambiguatedConstructor (conInductive c) c0+          return (c,a)++        -- Either no candidate constructor in 'cs' type checks, or multiple candidates+        -- type check.+        groups -> failure (errs, groups)++    abstractConstructor c = softTypeError $+      AbstractConstructorNotInScope c++    wrongDatatype c d = softTypeError $+      ConstructorPatternInWrongDatatype c d++    tryCon+      :: Bool        -- Are we allowed to constrain metas?+      -> [QName]     -- Constructors of data type under consideration.+      -> QName       -- Name of data/record type we are eliminating.+      -> Args        -- Parameters of data/record type we are eliminating.+      -> QName       -- Candidate constructor.+      -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))+           -- If this candidate succeeds, return its disambiguation+           -- 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 SigCubicalNotErasure -> __IMPOSSIBLE__+      Left SigAbstract          -> abstractConstructor c+      Right def                 -> do+        let con = conSrcCon (theDef def) `withRangeOf` c+        unless (conName con `elem` cons) $ wrongDatatype c d++        -- Andreas, 2013-03-22 fixing issue 279+        -- To resolve ambiguous constructors, Agda always looks up+        -- their original definition and reconstructs the parameters+        -- from the type @Def d vs@ we check against.+        -- However, the constructor could come from a module instantiation+        -- with some of the parameters already fixed.+        -- Agda did not make sure the two parameter lists coincide,+        -- so we add a check here.+        -- I guess this issue could be solved more systematically,+        -- but the extra check here is non-invasive to the existing code.+        -- Andreas, 2016-12-31 fixing issue #1975+        -- Do this also for constructors which were originally ambiguous.+        let chk = checkConstructorParameters c d pars+        mst <- suspendErrors $+          if constraintsOk then Just . snd <$> localTCStateSaving chk+          else Nothing <$ nonConstraining chk++        -- Get the type from the original constructor.+        -- Andreas, 2020-06-17 TODO:+        -- Couldn't we return this type from checkConstructorParameters?+        cType <- (`piApply` pars) . defType <$> getConInfo con++        return (c, con, (cType, mst))++    -- This deduplication identifies different names of the same+    -- constructor, ensuring that the "ambiguous constructor" error+    -- does not fire for the case described in #4130.+    --+    -- Andreas, 2020-06-17, issue #4135:+    -- However, we need to distinguish different occurrences+    -- of the same original constructor if it is used+    -- with different data parameters, as recorded in the @Type@.+    dedupCons ::+      forall a.       [ (a, ConHead, (Type, Maybe TCState)) ]+         -> TCM [ List1 (a, ConHead, (Type, Maybe TCState)) ]+    dedupCons cands = do+      -- Group candidates by original constructor name.+      let groups = List1.groupWith (conName . snd3) cands+      -- Eliminate duplicates (same type) from groups.+      mapM (List1.nubM (cmpM `on` thd3)) groups+      where+      -- The types come possibly with their own state.+      cmpM (a1, mst1) (a2, mst2) = do+        let cmpTypes = tryConversion $ equalType a1 a2+        case (mst1, mst2) of+          (Nothing, Nothing) -> cmpTypes+          (Just st, Nothing) -> inState st cmpTypes+          (Nothing, Just st) -> inState st cmpTypes+          -- Andreas, 2020-06-17, issue #4135.+          -- If the state has diverged into two states we give up.+          -- For instance, one state may say `?0 := true`+          -- and the other `?0 := false`.+          -- The types may be both `D ?0`, which is the same+          -- but diverges in the different states.+          -- We do not check states for equality.+          --+          -- Of course, this is conservative and not maximally extensional.+          -- We might throw an ambiguity error too eagerly,+          -- but this can always be worked around.+          (Just{},  Just{})  -> return False+      inState st m = localTCState $ do putTC st; m++-- | @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@.+checkConstructorParameters :: MonadTCM tcm => QName -> QName -> Args -> tcm ()+checkConstructorParameters c d pars = do+  dc <- liftTCM $ getConstructorData c+  checkParameters dc d pars++-- | Check that given parameters match the parameters of the inferred+--   constructor/projection.+checkParameters+  :: MonadTCM tcm+  => QName  -- ^ The record/data type name of the chosen constructor/projection.+  -> QName  -- ^ The record/data type name as supplied by the type signature.+  -> Args   -- ^ The parameters.+  -> tcm ()+checkParameters dc d pars = liftTCM $ do+  a  <- reduce (Def dc [])+  case a of+    Def d0 es -> do -- compare parameters+      let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+      reportSDoc "tc.lhs.split" 40 $ vcat $+        [ "checkParameters"+        , nest 2 $ "d                   =" <+> (text . prettyShow) d+        , nest 2 $ "d0 (should be == d) =" <+> (text . prettyShow) d0+        , nest 2 $ "dc                  =" <+> (text . prettyShow) dc+        , nest 2 $ "vs                  =" <+> prettyTCM vs+        , nest 2 $ "pars                =" <+> prettyTCM pars+        ]+      -- when (d0 /= d) __IMPOSSIBLE__ -- d could have extra qualification+      t <- typeOfConst d+      compareArgs [] [] t (Def d []) vs (take (length vs) pars)+    _ -> __IMPOSSIBLE__++checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m,+                        LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)+                    => DataOrRecord -> a -> Telescope -> Maybe ty -> m ()+checkSortOfSplitVar dr a tel mtarget = 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 s]++  where+    checkPropSplit+      | IsRecord InductionAndEta { recordInduction=Nothing } <- dr = return ()+      | Just target <- mtarget = do+        reportSDoc "tc.sort.check" 20 $ "target prop:" <+> prettyTCM target+        checkIsProp target+      | otherwise              = do+          reportSDoc "tc.sort.check" 20 $ "no target prop"+          splitOnPropError dr++    checkIsProp t = runBlocked (isPropM t) >>= \case+      Left b      -> splitOnPropError dr -- TODO+      Right False -> splitOnPropError dr+      Right True  -> return ()++    checkFibrantSplit+      | IsRecord _ <- dr       = return ()+      | Just target <- mtarget = do+          reportSDoc "tc.sort.check" 20 $ "target:" <+> prettyTCM target+          checkIsFibrant target+          forM_ (telToList tel) $ \ d -> do+            let ty = snd $ unDom d+            checkIsCoFibrant ty+      | otherwise              = do+          reportSDoc "tc.sort.check" 20 $ "no target"+          splitOnFibrantError Nothing++    -- Cofibrant types are those that could be the domain of a fibrant+    -- pi type. (Notion by C. Sattler).+    checkIsCoFibrant t = isCoFibrantSort t >>= \case+      Left b      -> splitOnFibrantError' t $ Just b+      Right False -> unlessM (isInterval t) $+                       splitOnFibrantError' t $ Nothing+      Right True  -> return ()++    checkIsFibrant t = isFibrant' t >>= \case+      Left b      -> splitOnFibrantError $ Just b+      Right False -> splitOnFibrantError Nothing+      Right True  -> return ()++    splitOnPropError dr = softTypeError $ SplitInProp dr++    splitOnFibrantError' t mb = softTypeError =<< do+      liftTCM $ SortOfSplitVarError mb <$> fsep+        [ "Cannot eliminate fibrant type" , prettyTCM a+        , "unless context type", prettyTCM t, "is also fibrant."+        ]++    splitOnFibrantError mb = softTypeError =<< do+      liftTCM $ SortOfSplitVarError mb <$> fsep+        [ "Cannot eliminate fibrant type" , prettyTCM a+        , "unless target type is also fibrant"+        ]
− src/full/Agda/TypeChecking/Rules/LHS/AsPatterns.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.TypeChecking.Rules.LHS.AsPatterns-  ( recoverAsPatterns ) where--import Control.Applicative-import Control.Monad.Writer hiding ((<>))-import qualified Data.Foldable as Fold--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Concrete ()-import qualified Agda.Syntax.Abstract as A--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Rules.LHS.Problem-import Agda.TypeChecking.Rules.LHS.Implicit-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Records-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce--import Agda.Utils.Maybe-import Agda.Utils.Size-import Agda.Utils.Impossible-#include "undefined.h"--recoverAsPatterns :: Telescope -> Type -> Term -> [NamedArg A.Pattern] -> [NamedArg DeBruijnPattern] -> TCM [AsBinding]-recoverAsPatterns delta a self ps qs = do-  let es = patternsToElims qs-  as <- smashType (raise (size delta) a) self es-  ps <- insertImplicitPatternsT DontExpandLast ps a-  reportSDoc "tc.lhs.as" 30 $ vcat-    [ text "recovering as patterns"-    , nest 2 $ vcat [ text "es =" <+> prettyList (map prettyTCM es)-                    , text "as =" <+> prettyList (map prettyTCM as)-                    , text "ps =" <+> prettyList (map prettyA ps) ]-    ]-  execWriterT $ asPatterns as ps es---- ProjT stores the type of the projected field.-data ElimType = ProjT Type | ArgT Type--instance PrettyTCM ElimType where-  prettyTCM (ProjT a) = text "." <> prettyTCM a-  prettyTCM (ArgT a)  = prettyTCM a--smashType :: Type -> Term -> Elims -> TCM [ElimType]-smashType a _ [] = return []-smashType a self (e : es) =-  case e of-    Apply v -> do-      Pi a b <- ignoreSharing <$> reduce (unEl a)-      (ArgT (unDom a) :) <$> smashType (absApp b $ unArg v) (self `applyE` [e]) es-    Proj o f -> do-      a <- reduce a-      Just (_, self, a) <- projectTyped self a o f-      (ProjT a :) <$> smashType a self es--smashTel :: Telescope -> [Term] -> [Type]-smashTel _ []                       = []-smashTel (ExtendTel a tel) (v : vs) = unDom a : smashTel (absApp tel v) vs-smashTel EmptyTel{} (_:_)           = __IMPOSSIBLE__--asPatterns :: [ElimType] -> [NamedArg A.Pattern] -> [Elim] -> WriterT [AsBinding] TCM ()-asPatterns _ [] _ = return ()-asPatterns (ProjT a : as) (p : ps) (Proj{} : vs) = do-  unless (isJust $ A.maybePostfixProjP p) __IMPOSSIBLE__  -- sanity check-  ps <- lift $ insertImplicitPatternsT DontExpandLast ps a-  asPatterns as ps vs-asPatterns (ArgT a : as) (p : ps) (Apply v : vs)-  | noAsPatterns (namedArg p) = asPatterns as ps vs-  | otherwise =-    case namedArg p of-      A.AsP _ x p' -> do-        tell [AsB x (unArg v) a]-        asPatterns (ArgT a : as) (fmap (p' <$) p : ps) (Apply v : vs)-      A.ConP _ _ ps' -> do-        (_, _, tel, as', args) <- lift $ conPattern a (unArg v)-        ps' <- lift $ insertImplicitPatterns ExpandLast ps' tel-        asPatterns (map ArgT as' ++ as) (ps' ++ ps) (map Apply args ++ vs)-      A.RecP i fps -> do-        (r, c, _, as', args) <- lift $ conPattern a (unArg v)-        let fs  = zipWith (<$) (map (nameConcrete . qnameName) $ conFields c) args-        ps' <- lift $ insertMissingFields r (const $ A.WildP i) fps fs-        asPatterns (map ArgT as' ++ as) (ps' ++ ps) (map Apply args ++ vs)-      A.DefP{} -> __IMPOSSIBLE__ -- ?-      _ -> __IMPOSSIBLE__-asPatterns _ _ _ = __IMPOSSIBLE__--conPattern :: Type -> Term -> TCM (QName, ConHead, Telescope, [Type], Args)-conPattern a (Con c ci args) = do-  Just ca <- getConType c =<< reduce a-  TelV tel (El _ (Def d _)) <- telView ca-  let as = smashTel tel (map unArg args)-  return (d, c, tel, as, args)-conPattern _ _ = __IMPOSSIBLE__--noAsPatterns :: A.Pattern -> Bool-noAsPatterns p =-  case p of-    A.AsP{}         -> False-    A.ConP _ _ ps   -> noArgAsPats ps-    A.DefP _ _ ps   -> noArgAsPats ps-    A.RecP _ fs     -> all (Fold.all noAsPatterns) fs-    A.VarP{}        -> True-    A.ProjP{}       -> True-    A.WildP{}       -> True-    A.DotP{}        -> True-    A.AbsurdP{}     -> True-    A.LitP{}        -> True-    A.PatternSynP{} -> __IMPOSSIBLE__-  where-    noArgAsPats = all (noAsPatterns . namedArg)
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs view
@@ -1,97 +1,45 @@-{-# LANGUAGE CPP #-}  module Agda.TypeChecking.Rules.LHS.Implicit where  import Prelude hiding (null) -import Control.Applicative hiding (empty)-import Control.Monad (forM)+import Control.Monad.Except+import Control.Monad.IO.Class  import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Internal as I-import Agda.Syntax.Abstract (IsProjP(..)) import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Translation.InternalToAbstract (reify)  import Agda.TypeChecking.Monad import Agda.TypeChecking.Implicit import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Telescope -import Agda.TypeChecking.Rules.LHS.Problem- import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Monad -#include "undefined.h" import Agda.Utils.Impossible --- | Insert implicit patterns in a problem.-insertImplicitProblem :: Problem -> TCM Problem-insertImplicitProblem (Problem ps qs tel pr) = do-  reportSDoc "tc.lhs.imp" 15 $-    sep [ text "insertImplicits"-        , nest 2 $ text "ps  = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps-        , nest 2 $ text "tel = " <+> prettyTCM tel-        ]-  ps' <- insertImplicitPatterns ExpandLast ps tel-  reportSDoc "tc.lhs.imp" 15 $-    sep [ text "insertImplicits finished"-        , nest 2 $ text "ps'  = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps'-        ]-  return $ Problem ps' qs tel pr---- | Eta-expand implicit pattern if of record type.-expandImplicitPattern :: Type -> NamedArg A.Pattern -> TCM (NamedArg A.Pattern)-expandImplicitPattern a p = maybe (return p) return =<< expandImplicitPattern' a p---- | Try to eta-expand implicit pattern.---   Returns 'Nothing' unless dealing with a record type that has eta-expansion---   and a constructor @c@.  In this case, it returns 'Just' @c _ _ ... _@---   (record constructor applied to as many implicit patterns as there are fields).-expandImplicitPattern' :: Type -> NamedArg A.Pattern -> TCM (Maybe (NamedArg A.Pattern))-expandImplicitPattern' a p-  | A.WildP{} <- namedArg p, getHiding p /= Instance = do-     -- Eta expand implicit patterns of record type (issue 473),-     -- but not instance arguments since then they won't be found-     -- by the instance search-     caseMaybeM (isEtaRecordType =<< reduce a) (return Nothing) $ \ (d, _) -> do-       -- Andreas, 2012-06-10: only expand guarded records,-       -- otherwise we might run into an infinite loop-       def <- getRecordDef d-       -- Andreas, 2015-07-20 Since we have record patterns now, we can expand-       -- even records that do not have a constructor.-       -- -- Andreas, 2013-03-21: only expand records that have a constructor:-       -- if not (recNamedCon def) then return Nothing else do-       do-         -- generate one implicit pattern for each field-         let qs = for (recFields def) $ \ f -> implicitP $ argInfo f-         -- generate the pattern (c _ _ ... _)-         let q  = A.ConP (ConPatInfo ConOSystem patNoRange) (A.AmbQ [recCon def]) qs-         -- equip it with the name/arginfo of the original implicit pattern-             p' = updateNamedArg (const q) p   -- WAS: ((q <$) <$> p)  -- Andreas, 2013-03-21 forbiddingly cryptic-         return $ Just p'-  | otherwise = return Nothing- implicitP :: ArgInfo -> NamedArg A.Pattern implicitP info = Arg (setOrigin Inserted info) $ unnamed $ A.WildP $ PatRange $ noRange  -- | Insert implicit patterns in a list of patterns. --   Even if 'DontExpandLast', trailing SIZELT patterns are inserted.-insertImplicitPatterns :: ExpandHidden -> [NamedArg A.Pattern] ->-                          Telescope -> TCM [NamedArg A.Pattern]+insertImplicitPatterns+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => ExpandHidden -> [NamedArg A.Pattern]+  -> Telescope -> m [NamedArg A.Pattern] insertImplicitPatterns exh ps tel =-  insertImplicitPatternsT exh ps (telePi tel typeDontCare)+  insertImplicitPatternsT exh ps (telePi tel __DUMMY_TYPE__)  -- | Insert trailing SizeLt patterns, if any.-insertImplicitSizeLtPatterns :: Type -> TCM [NamedArg A.Pattern]+insertImplicitSizeLtPatterns :: PureTCM m => Type -> m [NamedArg A.Pattern] insertImplicitSizeLtPatterns t = do   -- Testing for SizeLt.  In case of blocked type, we return no.   -- We assume that on the LHS, we know the type.  (TODO: Sufficient?)@@ -102,49 +50,57 @@    -- Search for the last SizeLt type among the hidden arguments.   TelV tel _ <- telView t-  let ts = reverse $ takeWhile (not . visible) $ telToList tel-  keep <- reverse <$> dropWhileM (not <.> isSizeLt . snd . unDom) ts+  let ts = takeWhile (not . visible) $ telToList tel+  keep <- dropWhileEndM (not <.> isSizeLt . snd . unDom) ts   -- Insert implicit patterns upto (including) the last SizeLt type.-  return [ implicitP ai | Dom ai _ <- keep ]+  return $ map (implicitP . domInfo) keep  -- | Insert implicit patterns in a list of patterns. --   Even if 'DontExpandLast', trailing SIZELT patterns are inserted.-insertImplicitPatternsT :: ExpandHidden -> [NamedArg A.Pattern] -> Type ->-                           TCM [NamedArg A.Pattern]+insertImplicitPatternsT+  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)+  => ExpandHidden -> [NamedArg A.Pattern] -> Type+  -> m [NamedArg A.Pattern] insertImplicitPatternsT DontExpandLast [] a = insertImplicitSizeLtPatterns a insertImplicitPatternsT exh            ps a = do   TelV tel b <- telViewUpTo' (-1) (not . visible) a   reportSDoc "tc.lhs.imp" 20 $-    sep [ text "insertImplicitPatternsT"-        , nest 2 $ text "ps  = " <+> do-            brackets $ fsep $ punctuate comma $ map prettyA ps-        , nest 2 $ text "tel = " <+> prettyTCM tel-        , nest 2 $ text "b   = " <+> addContext tel (prettyTCM b)-        ]+    vcat [ "insertImplicitPatternsT"+         , nest 2 $ "ps  = " <+> do+             brackets $ fsep $ punctuate comma $ map prettyA ps+         , nest 2 $ "tel = " <+> prettyTCM tel+         , nest 2 $ "b   = " <+> addContext tel (prettyTCM b)+         ]+  reportSDoc "tc.lhs.imp" 70 $+    vcat [ "insertImplicitPatternsT"+         , nest 2 $ "ps  = " <+> (text . show) ps+         , nest 2 $ "tel = " <+> (text . show) tel+         , nest 2 $ "b   = " <+> (text . show) b+         ]   case ps of     [] -> insImp dummy tel-    p : ps -> do+    p : _ -> setCurrentRange p $ do       -- Andreas, 2015-05-11.       -- If p is a projection pattern, make it visible for the purpose of       -- calling insImp / insertImplicit, to get correct behavior.-      let p' = applyWhen (isJust $ isProjP p) (setHiding NotHidden) p+      let p' = applyWhen (isJust $ A.isProjP p) (setHiding NotHidden) p       hs <- insImp p' tel-      case hs of-        [] -> do-          a <- reduce a-          case ignoreSharing $ unEl a of-            Pi arg b -> do-              (p :) <$> insertImplicitPatternsT exh ps (absBody b)-            _ -> return (p : ps)-        hs -> insertImplicitPatternsT exh (hs ++ p : ps) (telePi tel b)+      -- Continue with implicit patterns inserted before @p@.+      -- The list @hs ++ ps@ cannot be empty.+      let ps0@(~(p1 : ps1)) = hs ++ ps+      reduce a >>= piOrPath >>= \case+        -- If @a@ is a function (or path) type, continue inserting after @p1@.+        Left (dom, cod) -> underAbstraction dom cod $ \b ->+          (p1 :) <$> insertImplicitPatternsT exh ps1 b+        -- Otherwise, we are done.+        Right{}     -> return ps0   where     dummy = defaultNamedArg (A.VarP __IMPOSSIBLE__)      insImp p EmptyTel = return []-    insImp p tel = case insertImplicit p $ map (argFromDom . fmap fst) $ telToList tel of+    insImp p tel = case insertImplicit p $ telToList tel of       BadImplicits   -> typeError WrongHidingInLHS       NoSuchName x   -> typeError WrongHidingInLHS       ImpInsert n    -> return $ map implicitArg n-      NoInsertNeeded -> return [] -    implicitArg h = implicitP $ setHiding h $ defaultArgInfo+    implicitArg d = implicitP $ getArgInfo d
− src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.TypeChecking.Rules.LHS.Instantiate where--import Agda.Syntax.Common-import Agda.Syntax.Internal as I hiding (Substitution)-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views ( asView )--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Substitute hiding (Substitution)-import qualified Agda.TypeChecking.Substitute as S (Substitution)-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Telescope--import Agda.TypeChecking.Rules.LHS.Problem--import Agda.Utils.List-import Agda.Utils.Permutation-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible---- | Instantiate a telescope with a substitution. Might reorder the telescope.---   @instantiateTel (Γ : Tel)(σ : Γ --> Γ) = Γσ~@---   Monadic only for debugging purposes.-instantiateTel :: Substitution -> Telescope -> TCM (Telescope, Permutation, S.Substitution, [Dom Type])-instantiateTel s tel = liftTCM $ do--  reportSDoc "tc.lhs.inst" 10 $ vcat-    [ text "instantiateTel "-    , nest 2 $ text "s    =" <+> do-        addContext tel $-          fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) s-    , nest 2 $ text "tel  =" <+> prettyTCM tel---    , nest 2 $ text "tel  =" <+> text (show tel)-    ]--{--  -- Andreas, 2013-10-27-  -- Why is normalization necessary?  Issue 234 seems to need it.-  -- But it is better done right before where it is needed (see below).--  tel <- normalise tel--  reportSDoc "tc.lhs.inst" 15 $ vcat-    [ nest 2 $ text "tel (normalized)=" <+> prettyTCM tel-    ]--}--  -- Shrinking permutation (removing Justs) (and its complement, and reverse)-  let n   = size s-      {- OLD CODE, leave as documentation-      ps  = Perm n [ i | (i, Nothing) <- zip [0..] $ reverse s ]-      psR = reverseP ps-      psC = Perm n [ i | (i, Just _)  <- zip [0..] $ reverse s ]-      -}-      deal (i, Nothing) = Left i-      deal (i, Just _ ) = Right i-      (is, isC) = mapEither deal $ zip [0..] $ reverse s-      ps  = Perm n is-      psR = reverseP ps-      psC = Perm n isC--  reportSDoc "tc.lhs.inst" 10 $ vcat-    [ nest 2 $ text $ "ps   = " ++ show ps-    , nest 2 $ text $ "psR  = " ++ show psR-    , nest 2 $ text $ "psC  = " ++ show psC-    ]--  -- s' : Substitution Γσ-  let s' =  {-'-} renameP __IMPOSSIBLE__ psR s--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "s'   =" <+> fsep (punctuate comma $ map (maybe (text "_") prettyTCM) s')--  -- rho : [Tm Γσ]Γ-  let rho = mkSubst s'--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "rho = " <+> text (show rho)--  -- tel1 : [Type Γ]Γ-  let tel1   = flattenTel tel-      names1 = teleNames tel--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $ vcat-    [ text "tel1 =" <+> brackets (fsep $ punctuate comma $ map prettyTCM tel1)---    , text "tel1 =" <+> text (show tel1)-    ]--  -- tel2 : [Type Γσ]Γ-  let tel2 = applySubst rho tel1--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "tel2 =" <+> brackets (fsep $ punctuate comma $ map prettyTCM tel2)--  -- tel3 : [Type Γσ]Γσ-  ---  -- Andreas, 2013-10-27-  -- @reorderTel@ below uses free variable analysis, so @tel3@ should be-  -- fully instantiated and normalized. (See issue 234.)-  -- Ulf, 2014-02-05: Only normalise if reordering fails!-  tel3 <- instantiateFull $ permute ps tel2-  let names3 = permute ps names1--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "tel3 =" <+> brackets (fsep $ punctuate comma $ map prettyTCM tel3)--  -- Raise error if telescope cannot be ordered.-  let failToReorder = inTopContext $ addContext names3 $ do-        err <- sep [ text "Recursive telescope in left hand side:"-                   , fsep [ parens (text (argNameToString x) <+> text ":" <+> prettyTCM t)-                          | (x, t) <- zip names3 tel3 ]-                   ]-        typeError $ GenericError $ show err-      tryNormalisedReorder = do-        tel3 <- normalise tel3-        reportSDoc "tc.lhs.inst" 30 $ text "failed to reorder unnormalised, trying again with" $$-          nest 2 (text "norm =" <+> brackets (fsep $ punctuate comma $ map prettyTCM tel3))-        p <- maybe failToReorder return . reorderTel =<< normalise tel3-        return (p, tel3)--  -- p : Permutation (Γσ -> Γσ ~)-  (p, tel3) <- maybe tryNormalisedReorder (\p -> return (p, tel3)) $ reorderTel tel3--  reportSLn "tc.lhs.inst" 10 $ "  p   = " ++ show p--  -- rho' : [Term Γσ~]Γσ-  let rho' = {-'-} renaming __IMPOSSIBLE__ (reverseP p)--  -- tel4 : [Type Γσ~]Γσ~-  let tel4   = applySubst rho' (permute p tel3)-      names4 = permute p names3--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "tel4 =" <+> brackets (fsep $ punctuate comma $ map prettyTCM tel4)--  -- tel5 = Γσ~-  let tel5 = unflattenTel names4 tel4--  reportSDoc "tc.lhs.inst" 15 $ nest 2 $-    text "tel5 =" <+> prettyTCM tel5--  -- remember the types of the instantiations-  -- itypes : [Type Γσ~]Γ*-  let itypes = applySubst rho' $ permute psC tel2--  return (tel5, composeP p ps, applySubst rho' rho, itypes)-  where--    -- Turn a Substitution ([Maybe Term]) into a substitution (S.Substitution)-    mkSubst :: [Maybe Term] -> S.Substitution-    mkSubst s = rho 0 s'-      where s'  = s-            rho i (Nothing : s) = consS (var i) $ rho (i + 1) s-            rho i (Just u  : s) = consS u $ rho i s-            rho i []            = raiseS i---- | Produce a nice error message when splitting failed-nothingToSplitError :: Problem -> TCM a-nothingToSplitError (Problem ps _ tel pr) = splitError ps tel-  where-    splitError []       EmptyTel    = do-      if null $ restPats pr then __IMPOSSIBLE__ else do-        typeError $ GenericError $ "Arguments left we cannot split on. TODO: better error message"-    splitError (_:_)    EmptyTel    = __IMPOSSIBLE__-    splitError []       ExtendTel{} = __IMPOSSIBLE__-    splitError (p : ps) (ExtendTel a tel)-      | isBad p   = traceCall (CheckPattern (strip p) EmptyTel (unDom a)) $-                      typeError $ IlltypedPattern (strip p) (unDom a)-      | otherwise = underAbstraction a tel $ \tel -> splitError ps tel-      where-        strip = snd . asView . namedArg-        isBad p = case strip p of-          A.DotP{} -> True-          A.ConP{} -> True-          A.LitP{} -> True-          A.RecP{} -> True-          A.VarP{}    -> False-          A.WildP{}   -> False-          A.AbsurdP{} -> False-          A.ProjP{}        -> __IMPOSSIBLE__  -- Projection pattern gives CannotEliminateWithPattern-          A.DefP{}        -> __IMPOSSIBLE__-          A.AsP{}         -> __IMPOSSIBLE__-          A.PatternSynP{} -> __IMPOSSIBLE__
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs view
@@ -1,34 +1,47 @@--- {-# LANGUAGE CPP #-} -module Agda.TypeChecking.Rules.LHS.Problem where+module Agda.TypeChecking.Rules.LHS.Problem+       ( FlexibleVars , FlexibleVarKind(..) , FlexibleVar(..) , allFlexVars+       , FlexChoice(..) , ChooseFlex(..)+       , ProblemEq(..) , Problem(..) , problemEqs+       , problemRestPats, problemCont, problemInPats+       , AsBinding(..) , DotPattern(..) , AbsurdPattern(..), AnnotationPattern(..)+       , LHSState(..) , lhsTel , lhsOutPat , lhsProblem , lhsTarget+       , LeftoverPatterns(..), getLeftoverPatterns, getUserVariableNames+       ) where  import Prelude hiding (null) -import Control.Applicative hiding (empty)-import Data.Foldable ( Foldable )-import Data.Maybe ( fromMaybe )-import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, mconcat)-import Data.Traversable+import Control.Monad        ( zipWithM )+import Control.Monad.Writer ( MonadWriter(..), Writer, runWriter ) +import Data.Functor (($>))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.List ( sortOn )+import Data.Semigroup ( Semigroup, (<>) )+import qualified Data.Set as Set+ import Agda.Syntax.Common-import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Abstract (ProblemEq(..)) import qualified Agda.Syntax.Abstract as A +import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce-import qualified Agda.TypeChecking.Pretty as P-import Agda.TypeChecking.Pretty hiding ((<>))+import Agda.TypeChecking.Pretty +import Agda.Utils.Lens import Agda.Utils.List+import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Permutation+import Agda.Utils.Singleton import Agda.Utils.Size-import qualified Agda.Utils.Pretty as PP+import qualified Agda.Syntax.Common.Pretty as PP -type Substitution   = [Maybe Term] type FlexibleVars   = [FlexibleVar Nat]  -- | When we encounter a flexible variable in the unifier, where did it come from?@@ -40,31 +53,42 @@       --   Saves the 'FlexibleVarKind' of its subpatterns.   | ImplicitFlex -- ^ From a hidden formal argument or underscore ('WildP').   | DotFlex      -- ^ From a dot pattern ('DotP').+  | OtherFlex    -- ^ From a non-record constructor or literal ('ConP' or 'LitP').   deriving (Eq, Show)  -- | Flexible variables are equipped with information where they come from, --   in order to make a choice which one to assign when two flexibles are unified. data FlexibleVar a = FlexibleVar-  { flexHiding :: Hiding-  , flexKind   :: FlexibleVarKind-  , flexPos    :: Maybe Int-  , flexVar    :: a+  { flexArgInfo :: ArgInfo+  , flexForced  :: IsForced+  , flexKind    :: FlexibleVarKind+  , flexPos     :: Maybe Int+  , flexVar     :: a   } deriving (Eq, Show, Functor, Foldable, Traversable) -instance LensHiding (FlexibleVar a) where-  getHiding     = flexHiding-  mapHiding f x = x { flexHiding = f (flexHiding x) }+instance LensArgInfo (FlexibleVar a) where+  getArgInfo = flexArgInfo+  setArgInfo ai fl = fl { flexArgInfo = ai }+  mapArgInfo f  fl = fl { flexArgInfo = f (flexArgInfo fl) } -defaultFlexibleVar :: a -> FlexibleVar a-defaultFlexibleVar a = FlexibleVar Hidden ImplicitFlex Nothing a+instance LensHiding (FlexibleVar a)+instance LensOrigin (FlexibleVar a)+instance LensModality (FlexibleVar a) -flexibleVarFromHiding :: Hiding -> a -> FlexibleVar a-flexibleVarFromHiding h a = FlexibleVar h ImplicitFlex Nothing a+-- UNUSED+-- defaultFlexibleVar :: a -> FlexibleVar a+-- defaultFlexibleVar a = FlexibleVar Hidden Inserted ImplicitFlex Nothing a -allFlexVars :: Telescope -> FlexibleVars-allFlexVars tel = zipWith makeFlex (downFrom $ size tel) $ telToList tel+-- UNUSED+-- flexibleVarFromHiding :: Hiding -> a -> FlexibleVar a+-- flexibleVarFromHiding h a = FlexibleVar h ImplicitFlex Nothing a++allFlexVars :: [IsForced] -> Telescope -> FlexibleVars+allFlexVars forced tel = zipWith3 makeFlex (downFrom n) (telToList tel) fs   where-    makeFlex i d = FlexibleVar (getHiding d) ImplicitFlex (Just i) i+    n  = size tel+    fs = forced ++ repeat NotForced+    makeFlex i d f = FlexibleVar (getArgInfo d) f ImplicitFlex (Just i) i  data FlexChoice = ChooseLeft | ChooseRight | ChooseEither | ExpandBoth   deriving (Eq, Show)@@ -80,7 +104,7 @@   ChooseRight  <> ChooseRight  = ChooseRight  instance Monoid FlexChoice where-  mempty = ChooseEither+  mempty  = ChooseEither   mappend = (<>)  class ChooseFlex a where@@ -94,6 +118,9 @@   chooseFlex (RecordFlex xs) y               = chooseFlex xs (repeat y)   chooseFlex x               (RecordFlex ys) = chooseFlex (repeat x) ys   chooseFlex ImplicitFlex    ImplicitFlex    = ChooseEither+  chooseFlex ImplicitFlex    _               = ChooseLeft+  chooseFlex _               ImplicitFlex    = ChooseRight+  chooseFlex OtherFlex       OtherFlex       = ChooseEither  instance ChooseFlex a => ChooseFlex [a] where   chooseFlex xs ys = mconcat $ zipWith chooseFlex xs ys@@ -104,15 +131,34 @@   chooseFlex (Just x) Nothing = ChooseRight   chooseFlex (Just x) (Just y) = chooseFlex x y +instance ChooseFlex ArgInfo where+  chooseFlex ai1 ai2 = firstChoice [ chooseFlex (getOrigin ai1) (getOrigin ai2)+                                   , chooseFlex (getHiding ai1) (getHiding ai2) ]++instance ChooseFlex IsForced where+  chooseFlex NotForced NotForced = ChooseEither+  chooseFlex NotForced Forced    = ChooseRight+  chooseFlex Forced    NotForced = ChooseLeft+  chooseFlex Forced    Forced    = ChooseEither+ instance ChooseFlex Hiding where-  chooseFlex Hidden   Hidden   = ChooseEither-  chooseFlex Hidden   _        = ChooseLeft-  chooseFlex _        Hidden   = ChooseRight-  chooseFlex Instance Instance = ChooseEither-  chooseFlex Instance _        = ChooseLeft-  chooseFlex _        Instance = ChooseRight-  chooseFlex _        _        = ChooseEither+  chooseFlex Hidden     Hidden     = ChooseEither+  chooseFlex Hidden     _          = ChooseLeft+  chooseFlex _          Hidden     = ChooseRight+  chooseFlex Instance{} Instance{} = ChooseEither+  chooseFlex Instance{} _          = ChooseLeft+  chooseFlex _          Instance{} = ChooseRight+  chooseFlex _          _          = ChooseEither +instance ChooseFlex Origin where+  chooseFlex Inserted  Inserted  = ChooseEither+  chooseFlex Inserted  _         = ChooseLeft+  chooseFlex _         Inserted  = ChooseRight+  chooseFlex Reflected Reflected = ChooseEither+  chooseFlex Reflected _         = ChooseLeft+  chooseFlex _         Reflected = ChooseRight+  chooseFlex _         _         = ChooseEither+ instance ChooseFlex Int where   chooseFlex x y = case compare x y of     LT -> ChooseLeft@@ -120,172 +166,264 @@     GT -> ChooseRight  instance (ChooseFlex a) => ChooseFlex (FlexibleVar a) where-  chooseFlex (FlexibleVar h1 f1 p1 i1) (FlexibleVar h2 f2 p2 i2) =-    firstChoice [ chooseFlex f1 f2, chooseFlex h1 h2+  chooseFlex (FlexibleVar ai1 fc1 f1 p1 i1) (FlexibleVar ai2 fc2 f2 p2 i2) =+    firstChoice [ chooseFlex f1 f2, chooseFlex fc1 fc2, chooseFlex ai1 ai2                 , chooseFlex p1 p2, chooseFlex i1 i2]-      where-        firstChoice :: [FlexChoice] -> FlexChoice-        firstChoice []                  = ChooseEither-        firstChoice (ChooseEither : xs) = firstChoice xs-        firstChoice (x            : _ ) = x +firstChoice :: [FlexChoice] -> FlexChoice+firstChoice []                  = ChooseEither+firstChoice (ChooseEither : xs) = firstChoice xs+firstChoice (x            : _ ) = x --- | State of typechecking a LHS; input to 'split'.---   [Ulf Norell's PhD, page. 35]------   In @Problem ps p delta@,---   @ps@ are the user patterns of supposed type @delta@.---   @p@ is the pattern resulting from the splitting.-data Problem' p = Problem-  { problemInPat  :: [NamedArg A.Pattern]  -- ^ User patterns.-  , problemOutPat :: p                       -- ^ Patterns after splitting.-  , problemTel    :: Telescope               -- ^ Type of in patterns.-  , problemRest   :: ProblemRest             -- ^ Patterns that cannot be typed yet.+-- | The user patterns we still have to split on.+data Problem a = Problem+  { _problemEqs      :: [ProblemEq]+    -- ^ User patterns which are typed+    --   (including the ones generated from implicit arguments).+  , _problemRestPats :: [NamedArg A.Pattern]+    -- ^ List of user patterns which could not yet be typed.+    --   Example:+    --   @+    --      f : (b : Bool) -> if b then Nat else Nat -> Nat+    --      f true          = zero+    --      f false zero    = zero+    --      f false (suc n) = n+    --   @+    --   In this sitation, for clause 2, we construct an initial problem+    --   @+    --      problemEqs      = [false = b]+    --      problemRestPats = [zero]+    --   @+    --   As we instantiate @b@ to @false@, the 'targetType' reduces to+    --   @Nat -> Nat@ and we can move pattern @zero@ over to @problemEqs@.+  , _problemCont     :: LHSState a -> TCM a+    -- ^ The code that checks the RHS.   }   deriving Show --- | The de Bruijn indices in the pattern refer to positions---   in the list of abstract patterns in the problem, counted---   from the back.-type Problem     = Problem' [NamedArg DeBruijnPattern]-type ProblemPart = Problem' ()+problemEqs :: Lens' (Problem a) [ProblemEq]+problemEqs f p = f (_problemEqs p) <&> \x -> p {_problemEqs = x} --- | User patterns that could not be given a type yet.------   Example:---   @---      f : (b : Bool) -> if b then Nat else Nat -> Nat---      f true          = zero---      f false zero    = zero---      f false (suc n) = n---   @---   In this sitation, for clause 2, we construct an initial problem---   @---      problemInPat = [false]---      problemTel   = (b : Bool)---      problemRest.restPats = [zero]---      problemRest.restType = if b then Nat else Nat -> Nat---   @---   As we instantiate @b@ to @false@, the 'restType' reduces to---   @Nat -> Nat@ and we can move pattern @zero@ over to @problemInPat@.+problemRestPats :: Lens' (Problem a) [NamedArg A.Pattern]+problemRestPats f p = f (_problemRestPats p) <&> \x -> p {_problemRestPats = x} -data ProblemRest = ProblemRest-  { restPats :: [NamedArg A.Pattern]-    -- ^ List of user patterns which could not yet be typed.-  , restType :: Arg Type-    -- ^ Type eliminated by 'restPats'.+problemCont :: Lens' (Problem a) (LHSState a -> TCM a)+problemCont f p = f (_problemCont p) <&> \x -> p {_problemCont = x}++problemInPats :: Problem a -> [A.Pattern]+problemInPats = map problemInPat . (^. problemEqs)++data AsBinding = AsB Name Term (Dom Type)+data DotPattern = Dot A.Expr Term (Dom Type)+data AbsurdPattern = Absurd Range Type+data AnnotationPattern = Ann A.Expr Type++-- | State worked on during the main loop of checking a lhs.+--   [Ulf Norell's PhD, page. 35]+data LHSState a = LHSState+  { _lhsTel     :: Telescope+    -- ^ The types of the pattern variables.+  , _lhsOutPat  :: [NamedArg DeBruijnPattern]+    -- ^ Patterns after splitting.+    --   The de Bruijn indices refer to positions in the list of abstract syntax+    --   patterns in the problem, counted from the back (right-to-left).+  , _lhsProblem :: Problem a+    -- ^ User patterns of supposed type @delta@.+  , _lhsTarget  :: Arg Type+    -- ^ Type eliminated by 'problemRestPats' in the problem.     --   Can be 'Irrelevant' to indicate that we came by     --   an irrelevant projection and, hence, the rhs must     --   be type-checked in irrelevant mode.+  , _lhsPartialSplit :: ![Maybe Int]+    -- ^ have we splitted with a PartialFocus?+  , _lhsIndexedSplit :: !Bool+    -- ^ Have we split on any indexed inductive types?   }-  deriving Show -data Focus-  = Focus-    { focusCon      :: QName-    , focusPatOrigin:: ConOrigin -- ^ Do we come from an implicit or record pattern?-    , focusConArgs  :: [NamedArg A.Pattern]-    , focusRange    :: Range-    , focusOutPat   :: [NamedArg DeBruijnPattern]-    , focusDatatype :: QName-    , focusParams   :: [Arg Term]-    , focusIndices  :: [Arg Term]-    , focusType     :: Type -- ^ Type of variable we are splitting, kept for record patterns.+lhsTel :: Lens' (LHSState a) Telescope+lhsTel f p = f (_lhsTel p) <&> \x -> p {_lhsTel = x}++lhsOutPat :: Lens' (LHSState a) [NamedArg DeBruijnPattern]+lhsOutPat f p = f (_lhsOutPat p) <&> \x -> p {_lhsOutPat = x}++lhsProblem :: Lens' (LHSState a) (Problem a)+lhsProblem f p = f (_lhsProblem p) <&> \x -> p {_lhsProblem = x}++lhsTarget :: Lens' (LHSState a) (Arg Type)+lhsTarget f p = f (_lhsTarget p) <&> \x -> p {_lhsTarget = x}++data PatVarPosition = PVLocal | PVParam+  deriving (Show, Eq)++data LeftoverPatterns = LeftoverPatterns+  { patternVariables :: IntMap [(Arg A.Name,PatVarPosition)]+  , asPatterns       :: [AsBinding]+  , dotPatterns      :: [DotPattern]+  , absurdPatterns   :: [AbsurdPattern]+  , typeAnnotations  :: [AnnotationPattern]+  , otherPatterns    :: [A.Pattern]+  }++instance Semigroup LeftoverPatterns where+  x <> y = LeftoverPatterns+    { patternVariables = IntMap.unionWith (++) (patternVariables x) (patternVariables y)+    , asPatterns       = asPatterns x ++ asPatterns y+    , dotPatterns      = dotPatterns x ++ dotPatterns y+    , absurdPatterns   = absurdPatterns x ++ absurdPatterns y+    , typeAnnotations  = typeAnnotations x ++ typeAnnotations y+    , otherPatterns    = otherPatterns x ++ otherPatterns y     }-  | LitFocus Literal [NamedArg DeBruijnPattern] Type --- | Result of 'splitProblem':  Determines position for the next split.-data SplitProblem+instance Null LeftoverPatterns where+  empty = LeftoverPatterns empty [] [] [] [] []+  null (LeftoverPatterns as bs cs ds es fs) = null as && null bs && null cs && null ds && null es && null fs -  = -- | Split on constructor pattern.-    Split-      { splitLPats   :: ProblemPart-        -- ^ The typed user patterns left of the split position.-        --   Invariant: @'problemRest' == empty@.-      , splitFocus   :: Arg Focus-        -- ^ How to split the variable at the split position.-      , splitRPats   :: Abs ProblemPart-        -- ^ The typed user patterns right of the split position.-      } -  | -- | Split on projection pattern.-    SplitRest-      { splitProjection :: Arg QName-        -- ^ The projection could be belonging to an irrelevant record field.-      , splitProjOrigin :: ProjOrigin-      , splitRestType   :: Type-      }+instance Monoid LeftoverPatterns where+  mempty  = empty+  mappend = (<>) --- | Put a typed pattern on the very left of a @SplitProblem@.-consSplitProblem-  :: NamedArg A.Pattern -- ^ @p@ A pattern.-  -> ArgName              -- ^ @x@ The name of the argument (from its type).-  -> Dom Type           -- ^ @t@ Its type.-  -> SplitProblem         -- ^ The split problem, containing 'splitLPats' @ps;xs:ts@.-  -> SplitProblem         -- ^ The result, now containing 'splitLPats' @(p,ps);(x,xs):(t,ts)@.-consSplitProblem p x dom s@SplitRest{}              = s-consSplitProblem p x dom s@Split{ splitLPats = ps } = s{ splitLPats = consProblem' ps }+instance PP.Pretty PatVarPosition where+  pretty = PP.text . show++instance PrettyTCM LeftoverPatterns where+  prettyTCM (LeftoverPatterns varp asb dotp absurdp annp otherp) = vcat+    [ "pattern variables: " <+> pretty (IntMap.toList varp)+    , "as bindings:       " <+> prettyList_ (map prettyTCM asb)+    , "dot patterns:      " <+> prettyList_ (map prettyTCM dotp)+    , "absurd patterns:   " <+> prettyList_ (map prettyTCM absurdp)+    , "type annotations:  " <+> prettyList_ (map prettyTCM annp)+    , "other patterns:    " <+> prettyList_ (map prettyA otherp)+    ]++-- | Classify remaining patterns after splitting is complete into pattern+--   variables, as patterns, dot patterns, and absurd patterns.+--   Precondition: there are no more constructor patterns.+getLeftoverPatterns+  :: forall m. (PureTCM m, MonadFresh NameId m)+  => [ProblemEq] -> m LeftoverPatterns+getLeftoverPatterns eqs = do+  reportSDoc "tc.lhs.top" 30 $ "classifying leftover patterns"+  params <- Set.fromList . teleNames <$> (lookupSection =<< currentModule)+  let isParamName x = if nameToArgName x `Set.member` params then PVParam else PVLocal+  mconcat <$> mapM (getLeftoverPattern isParamName) eqs   where-  consProblem' (Problem ps () tel pr) =-    Problem (p:ps) () (ExtendTel dom $ Abs x tel) pr+    patternVariable x i isPar = empty { patternVariables = singleton (i,[(x,isPar)]) }+    asPattern x v a      = empty { asPatterns       = singleton (AsB x v a) }+    dotPattern e v a     = empty { dotPatterns      = singleton (Dot e v a) }+    absurdPattern info a = empty { absurdPatterns   = singleton (Absurd info a) }+    otherPattern p       = empty { otherPatterns    = singleton p } --- | Instantiations of a dot pattern with a term.---   `Maybe e` if the user wrote a dot pattern .e---   `Nothing` if this is an instantiation of an implicit argument or a name.-data DotPatternInst = DPI-  { dotPatternName     :: Maybe A.Name-  , dotPatternUserExpr :: Maybe A.Expr-  , dotPatternInst     :: Term-  , dotPatternType     :: Dom Type-  }-data AsBinding      = AsB Name Term Type+    getLeftoverPattern :: (A.Name -> PatVarPosition) -> ProblemEq -> m LeftoverPatterns+    getLeftoverPattern isParamName (ProblemEq p v a) = case p of+      (A.VarP A.BindName{unBind = x}) -> isEtaVar v (unDom a) <&> \case+        Just i -> patternVariable (argFromDom a $> x) i (isParamName x)+        Nothing -> asPattern x v a+      (A.WildP r)+        | isInstance a ->+            -- Issue #7392: If the wildcard appears in an instance position+            -- and is not already bound as an instance in the context,+            -- add it as a let binding.+            ifM (isInstanceVar v $ unDom a) (return mempty) $ do+              -- TODO: avoid fresh name by assigning unique `NameId` to `WildP`s?+              x <- freshNoName (getRange r)+              return $ asPattern x v a+        | otherwise -> return mempty+      (A.AsP info A.BindName{unBind = x} p)  -> (asPattern x v a `mappend`) <$> do+        getLeftoverPattern isParamName $ ProblemEq p v a+      (A.DotP info e)   -> return $ dotPattern e v a+      (A.AbsurdP info)  -> return $ absurdPattern (getRange info) (unDom a)+      _                 -> return $ otherPattern p --- | State worked on during the main loop of checking a lhs.-data LHSState = LHSState-  { lhsProblem :: Problem-  , lhsDPI     :: [DotPatternInst]-  }+      where+        isInstanceVar :: Term -> Type -> m Bool+        isInstanceVar v a = isEtaVar v a >>= \case+            Just i -> isInstance <$> domOfBV i+            Nothing -> return False -instance Subst Term ProblemRest where-  applySubst rho p = p { restType = applySubst rho $ restType p }+-- | Build a renaming for the internal patterns using variable names from+--   the user patterns. If there are multiple user names for the same internal+--   variable, the unused ones are returned as as-bindings.+--   Names that are not also module parameters are preferred over+--   those that are.+getUserVariableNames+  :: Telescope                         -- ^ The telescope of pattern variables+  -> IntMap [(Arg A.Name,PatVarPosition)]  -- ^ The list of user names for each pattern variable+  -> ([Maybe A.Name], [AsBinding])+getUserVariableNames tel names = runWriter $+  zipWithM makeVar (flattenTel tel) (downFrom $ size tel) -instance Subst Term (Problem' p) where-  applySubst rho p = p { problemTel  = applySubst rho $ problemTel p-                       , problemRest = applySubst rho $ problemRest p }+  where+    makeVar :: Dom Type -> Int -> Writer [AsBinding] (Maybe A.Name)+    makeVar a i =+      case map fst $ sortOn ((== PVParam) . snd) (IntMap.findWithDefault [] i names) of+        [] -> return Nothing+        (z:zs) -> do+          tellAsBindings $+            -- Issue #7392: if the name that we picked comes from an instance argument+            -- but we are *not* binding it in an instance position, we should+            -- preserve the instance by *also* adding it as a let-binding.+            if isInstance z && not (isInstance a) then z:zs else zs+          return $ Just (unArg z)+      where+        -- Use hiding status of the variable as written rather than from the telescope+        tellAsBindings = tell . map (\y -> AsB (unArg y) (var i) (setHiding (getHiding y) a)) -instance Subst Term DotPatternInst where-  applySubst rho (DPI x e v a) = uncurry (DPI x e) $ applySubst rho (v,a)+instance Subst (Problem a) where+  type SubstArg (Problem a) = Term+  applySubst rho (Problem eqs rps cont) = Problem (applySubst rho eqs) rps cont -instance Subst Term AsBinding where-  applySubst rho (AsB x v a) = uncurry (AsB x) $ applySubst rho (v, a)+instance Subst AsBinding where+  type SubstArg AsBinding = Term+  applySubst rho (AsB x v a) = (\(v,a) -> AsB x v a) $ applySubst rho (v, a) -instance PrettyTCM DotPatternInst where-  prettyTCM (DPI mx me v a) = sep-    [ x <+> text "=" <+> text "." P.<> prettyA e-    , nest 2 $ prettyTCM v <+> text ":"+instance Subst DotPattern where+  type SubstArg DotPattern = Term+  applySubst rho (Dot e v a) = uncurry (Dot e) $ applySubst rho (v, a)++instance Subst AbsurdPattern where+  type SubstArg AbsurdPattern = Term+  applySubst rho (Absurd r a) = Absurd r $ applySubst rho a++instance PrettyTCM ProblemEq where+  prettyTCM (ProblemEq p v a) = sep+    [ prettyA p <+> "="+    , nest 2 $ prettyTCM v <+> ":"     , nest 2 $ prettyTCM a     ]-    where x = maybe (text "_") prettyA mx-          e = fromMaybe underscore me  instance PrettyTCM AsBinding where   prettyTCM (AsB x v a) =-    sep [ prettyTCM x P.<> text "@" P.<> parens (prettyTCM v)-        , nest 2 $ text ":" <+> prettyTCM a+    sep [ prettyTCM x <> "@" <> parens (prettyTCM v)+        , nest 2 $ ":" <+> prettyTCM a         ] +instance PrettyTCM DotPattern where+  prettyTCM (Dot e v a) = sep+    [ prettyA e <+> "="+    , nest 2 $ prettyTCM v <+> ":"+    , nest 2 $ prettyTCM a+    ]++instance PrettyTCM AbsurdPattern where+  prettyTCM (Absurd r a) = "() :" <+> prettyTCM a++instance PrettyTCM AnnotationPattern where+  prettyTCM (Ann a p) = prettyTCM p <+> ":" <+> prettyA a+ instance PP.Pretty AsBinding where   pretty (AsB x v a) =-    PP.text (show x ++ " =") PP.<+> PP.hang (PP.pretty v PP.<+> PP.text ":") 2-                                            (PP.pretty a)+    PP.pretty x PP.<+> "=" PP.<+>+      PP.hang (PP.pretty v PP.<+> ":") 2 (PP.pretty a)  instance InstantiateFull AsBinding where   instantiateFull' (AsB x v a) = AsB x <$> instantiateFull' v <*> instantiateFull' a -instance Null ProblemRest where-  null  = null . restPats-  empty = ProblemRest { restPats = [], restType = defaultArg typeDontCare }--instance Null a => Null (Problem' a) where-  null p = null (problemInPat p) && null (problemRest p)-  empty  = Problem empty empty empty empty+instance PrettyTCM (LHSState a) where+  prettyTCM (LHSState tel outPat (Problem eqs rps _) target _ _) = vcat+    [ "tel             = " <+> prettyTCM tel+    , "outPat          = " <+> addContext tel (prettyTCMPatternList outPat)+    , "problemEqs      = " <+> addContext tel (prettyList_ $ map prettyTCM eqs)+    , "problemRestPats = " <+> prettyList_ (map prettyA rps)+    , "target          = " <+> addContext tel (prettyTCM target)+    ]
src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE CPP           #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.LHS.ProblemRest where -import Data.Functor ((<$))+import Control.Monad+import Control.Monad.Except +import Data.Maybe+ import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A  import Agda.TypeChecking.Monad@@ -16,40 +20,53 @@ import Agda.TypeChecking.Rules.LHS.Problem import Agda.TypeChecking.Rules.LHS.Implicit -import Agda.Utils.Functor (($>))+import Agda.Utils.Functor import Agda.Utils.Size-import Agda.Utils.Permutation -#include "undefined.h" import Agda.Utils.Impossible --- MOVED from LHS:--- | Rename the variables in a telescope using the names from a given pattern+-- | Rename the variables in a telescope using the names from a given pattern.+--+--   If there are not at least as many patterns as entries as in the telescope,+--   the names of the remaining entries in the telescope are unchanged.+--   If there are too many patterns, there should be a type error later.+-- useNamesFromPattern :: [NamedArg A.Pattern] -> Telescope -> Telescope-useNamesFromPattern ps = telFromList . zipWith ren (map namedArg ps ++ repeat dummy) . telToList+useNamesFromPattern ps tel = telFromList (zipWith ren ps telList ++ telRemaining)   where-    dummy = A.WildP __IMPOSSIBLE__-    ren (A.VarP x) (Dom info (_, a)) | notHidden info && not (isNoName x) =-      Dom info (nameToArgName x, a)-    ren A.AbsurdP{} (Dom info (_, a)) | notHidden info = Dom info ("()", a)-    -- Andreas, 2013-03-13: inserted the following line in the hope to fix issue 819-    -- but it does not do the job, instead, it puts a lot of "_"s-    -- instead of more sensible names into error messages.-    -- ren A.WildP{}  (Dom info (_, a)) | notHidden info = Dom info ("_", a)-    ren A.PatternSynP{} _ = __IMPOSSIBLE__  -- ensure there are no syns left-    -- Andreas, 2016-05-10, issue 1848: if context variable has no name, call it "x"-    ren _ (Dom info (x, a)) | notHidden info && isNoName x =-      Dom info (stringToArgName "x", a)-    ren _ a = a+    telList = telToList tel+    telRemaining = drop (length ps) telList -- telescope entries beyond patterns+    ren (Arg ai (Named nm p)) dom@Dom{ unDom = (y, a) } =+      case p of+        -- Andreas, 2017-10-12, issue #2803, also preserve user-written hidden names.+        -- However, not if the argument is named, because then the name in the telescope+        -- is significant for implicit insertion.+        A.VarP A.BindName{unBind = x}+          | not (isNoName x)+          , visible dom || (getOrigin ai == UserWritten && isNothing nm) ->+          dom{ unDom = (nameToArgName x, a) }+        A.AbsurdP{} | visible dom -> dom{ unDom = (stringToArgName "()", a) }+        A.PatternSynP{} -> __IMPOSSIBLE__  -- ensure there are no syns left+        -- Andreas, 2016-05-10, issue 1848: if context variable has no name, call it "x"+        _ | visible dom && isNoName y -> dom{ unDom = (stringToArgName "x", a) }+          | otherwise                  -> dom +useNamesFromProblemEqs+  :: forall m. (PureTCM m, MonadFresh NameId m)+  => [ProblemEq] -> Telescope -> m Telescope+useNamesFromProblemEqs eqs tel = addContext tel $ do+  names <- fst . getUserVariableNames tel . patternVariables <$> getLeftoverPatterns eqs+  let argNames = map (fmap nameToArgName) names+  return $ renameTel argNames tel+ useOriginFrom :: (LensOrigin a, LensOrigin b) => [a] -> [b] -> [a] useOriginFrom = zipWith $ \x y -> setOrigin (getOrigin y) x  -- | Are there any untyped user patterns left?-noProblemRest :: Problem -> Bool-noProblemRest (Problem _ _ _ (ProblemRest ps _)) = null ps+noProblemRest :: Problem a -> Bool+noProblemRest (Problem _ rp _) = null rp --- | Construct an initial 'split' 'Problem' from user patterns.+-- | Construct an initial 'LHSState' from user patterns. --   Example: --   @ --@@ -65,89 +82,86 @@ --   The problem generated for the first clause of @sample@ --   with patterns @just a, just b@ would be: --   @---      problemInPat  = ["_", "just a"]---      problemOutPat = ["A", "m"]---      problemTel    = [A : Set, m : Maybe A]---      problemRest   =---        restPats    = ["just b"]---        restType    = "Case m Bool (Maybe A -> Bool)"+--      lhsTel        = [A : Set, m : Maybe A]+--      lhsOutPat     = ["A", "m"]+--      lhsProblem    = Problem ["A" = _, "just a" = "a"]+--                              ["_", "just a"]+--                              ["just b"] []+--      lhsTarget     = "Case m Bool (Maybe A -> Bool)" --   @--problemFromPats :: [NamedArg A.Pattern] -- ^ The user patterns.-  -> Type            -- ^ The type the user patterns eliminate.-  -> TCM Problem     -- ^ The initial problem constructed from the user patterns.-problemFromPats ps a = do-  -- For the initial problem, do not insert trailing implicits.-  -- This has the effect of not including trailing hidden domains in the problem telescope.-  -- In all later call to insertImplicitPatterns, we can then use ExpandLast.-  -- Ulf, 2016-04-25: Actually we do need to ExpandLast because where blocks-  -- need the implicits.-  ps <- insertImplicitPatternsT ExpandLast ps a-  -- unless (size tel0' >= size ps) $ typeError $ TooManyArgumentsInLHS a--  -- Redo the telView, in order to *not* normalize the clause type further than necessary.-  -- (See issue 734.)-  TelV tel0 b  <- telViewUpTo (length ps) a-  let gamma     = useNamesFromPattern ps tel0-      as        = telToList gamma-      (ps1,ps2) = splitAt (size as) ps-      -- now (gamma -> b) = a and |gamma| = |ps1|-      pr        = ProblemRest ps2 $ defaultArg b--      -- internal patterns start as all variables-  let ips = teleNamedArgs gamma `useOriginFrom` ps+initLHSState+  :: Telescope             -- ^ The initial telescope @delta@ of parameters.+  -> [ProblemEq]           -- ^ The problem equations inherited from the parent clause (living in @delta@).+  -> [NamedArg A.Pattern]  -- ^ The user patterns.+  -> Type                  -- ^ The type the user patterns eliminate (living in @delta@).+  -> (LHSState a -> TCM a) -- ^ Continuation for when checking the patterns is complete.+  -> TCM (LHSState a)      -- ^ The initial LHS state constructed from the user patterns.+initLHSState delta eqs ps a ret = do+  reportSDoc "tc.lhs.init" 40 $ vcat+    [ "initLHSState"+    , nest 2 $ "delta = " <+> prettyTCM delta+    , nest 2 $ "a     = " <+> addContext delta (prettyTCM a)+    ]+  let problem = Problem eqs ps ret+      qs0     = teleNamedArgs delta -      -- the initial problem for starting the splitting-      problem  = Problem ps1 ips gamma pr :: Problem-  reportSDoc "tc.lhs.problem" 10 $-    vcat [ text "checking lhs -- generated an initial split problem:"-         , nest 2 $ vcat-           [ text "ps    =" <+> fsep (map prettyA ps)-           , text "a     =" <+> prettyTCM a-           , text "xs    =" <+> text (show $ map (fst . unDom) as)-           , text "ps1   =" <+> fsep (map prettyA ps1)-        -- , text "ips   =" <+> prettyTCM ips  -- no prettyTCM instance-           , text "gamma =" <+> prettyTCM gamma-           , text "ps2   =" <+> fsep (map prettyA ps2)-           , text "b     =" <+> addContext gamma (prettyTCM b)-           ]-         ]-  return problem+  updateProblemRest $ LHSState delta qs0 problem (Arg (defaultArgInfo { argInfoModality = unitModality }) a) [] False  -- | Try to move patterns from the problem rest into the problem. --   Possible if type of problem rest has been updated to a function type.-updateProblemRest_ :: Problem -> TCM (Nat, Problem)-updateProblemRest_ p@(Problem ps0 qs0 tel0 (ProblemRest ps a)) = do-      ps <- insertImplicitPatternsT ExpandLast ps $ unArg a-      -- (Issue 734: Do only the necessary telView to preserve clause types as much as possible.)-      TelV tel b   <- telViewUpTo (length ps) $ unArg a-      let gamma     = useNamesFromPattern ps tel-          as        = telToList gamma-          (ps1,ps2) = splitAt (size as) ps-          tel1      = telFromList $ telToList tel0 ++ as-          pr        = ProblemRest ps2 (a $> b)-          qs1       = teleNamedArgs gamma `useOriginFrom` ps-          n         = size as-      reportSDoc "tc.lhs.problem" 10 $ addContext tel0 $ vcat-        [ text "checking lhs -- updated split problem:"-        , nest 2 $ vcat-          [ text "ps    =" <+> fsep (map prettyA ps)-          , text "a     =" <+> prettyTCM a-          , text "xs    =" <+> text (show $ map (fst . unDom) as)-          , text "ps1   =" <+> fsep (map prettyA ps1)-          , text "gamma =" <+> prettyTCM gamma-          , text "ps2   =" <+> fsep (map prettyA ps2)-          , text "b     =" <+> addContext gamma (prettyTCM b)-          ]-        ]-      return $ (n,) $ Problem (ps0 ++ ps1) (applySubst (raiseS n) qs0 ++ qs1) tel1 pr--updateProblemRest :: LHSState -> TCM LHSState-updateProblemRest st@LHSState { lhsProblem = p } = do-  (n, p') <- updateProblemRest_ p-  if (n == 0) then return st else do-    let tau = raiseS n-    return $ LHSState-      { lhsProblem = p'-      , lhsDPI     = applyPatSubst tau (lhsDPI st)-      }+updateProblemRest+  :: forall m a. (PureTCM m, MonadError TCErr m, MonadTrace m, MonadFresh NameId m)+  => LHSState a -> m (LHSState a)+updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit ixsplit) = addContext tel0 $ do+  ps <- insertImplicitPatternsT ExpandLast ps $ unArg a+  reportSDoc "tc.lhs.imp" 20 $+    "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)+  -- (Issue 734: Do only the necessary telView to preserve clause types as much as possible.)+  let m = length $ takeWhile (isNothing . A.isProjP) ps+  (TelV gamma b, boundary) <- telViewUpToPathBoundary' m $ unArg a+  forM_ (zip ps (telToList gamma)) $ \(p, a) ->+    unless (sameHiding p a) $ setCurrentRange p $ typeError WrongHidingInLHS+  let tel1      = useNamesFromPattern ps gamma+      n         = size tel1+      (ps1,ps2) = splitAt n ps+      tel       = telFromList $ telToList tel0 ++ telToList tel1+      qs1       = telePatterns tel1 boundary+      newEqs    = zipWith3 ProblemEq+                    (map namedArg ps1)+                    (map (patternToTerm . namedArg) qs1)+                    (flattenTel tel1 `useOriginFrom` ps1)+      tau       = raiseS n+  reportSDoc "tc.lhs.problem" 10 $ addContext tel0 $ vcat+    [ "checking lhs -- updated split problem:"+    , nest 2 $ vcat+      [ "ps    =" <+> fsep (map prettyA ps)+      , "a     =" <+> prettyTCM a+      , "tel1  =" <+> prettyTCM tel1+      , "ps1   =" <+> fsep (map prettyA ps1)+      , "ps2   =" <+> fsep (map prettyA ps2)+      , "b     =" <+> addContext tel1 (prettyTCM b)+      ]+    ]+  reportSDoc "tc.lhs.problem" 60 $ addContext tel0 $ vcat+    [ nest 2 $ vcat+      [ "ps    =" <+> (text . show) ps+      , "a     =" <+> (text . show) a+      , "tel1  =" <+> (text . show) tel1+      , "ps1   =" <+> (text . show) ps1+      , "ps2   =" <+> (text . show) ps2+      , "b     =" <+> (text . show) b+      , "qs1   =" <+> fsep (map pretty qs1)+      ]+    ]+  return $ LHSState+    { _lhsTel     = tel+    , _lhsOutPat  = applySubst tau qs0 ++ qs1+    , _lhsProblem = Problem+                   { _problemEqs      = applyPatSubst tau oldEqs ++ newEqs+                   , _problemRestPats = ps2+                   , _problemCont     = ret+                   }+    , _lhsTarget  = a $> b+    , _lhsPartialSplit = psplit+    , _lhsIndexedSplit = ixsplit+    }
− src/full/Agda/TypeChecking/Rules/LHS/Split.hs 
@@ -1,399 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Agda.TypeChecking.Rules.LHS.Split-  ( splitProblem-  ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import Control.Monad.Trans ( lift )-import Control.Monad.Trans.Maybe--import Data.Maybe (fromMaybe)-import Data.List hiding (null)-import Data.Traversable hiding (mapM, sequence)-import Data.Foldable (msum)--import Agda.Interaction.Options-import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName)--import Agda.Syntax.Common-import Agda.Syntax.Concrete (FieldAssignment'(..), nameFieldA)-import Agda.Syntax.Literal-import Agda.Syntax.Position-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Abstract (IsProjP(..), MaybePostfixProjP(..))-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views (asView)-import qualified Agda.Syntax.Info as A--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin--import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Free-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Patterns.Abstract-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope--import Agda.TypeChecking.Rules.LHS.Problem--import Agda.Utils.Except (catchError)-import Agda.Utils.Functor ((<.>))-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Tuple-import qualified Agda.Utils.Pretty as P--#include "undefined.h"-import Agda.Utils.Impossible---- | Split a problem at the first constructor pattern which is---   actually of datatype type.------   Or, if there is no constructor pattern left and the rest type---   is a record type and the first rest pattern is a projection---   pattern, split the rest type.------   Implicit patterns should have been inserted.--splitProblem ::-  Maybe QName -- ^ The definition we are checking at the moment.-  -> Problem  -- ^ The current state of the lhs patterns.-  -> ListT TCM SplitProblem-splitProblem mf (Problem ps qs tel pr) = do-  lift $ do-    reportSLn "tc.lhs.split" 20 $ "initiating splitting"-      ++ maybe "" ((" for definition " ++) . show) mf-    reportSDoc "tc.lhs.split" 30 $ sep-      [ nest 2 $ text "ps   =" <+> sep (map (P.parens <.> prettyA) ps)-      , nest 2 $ text "qs   =" <+> sep (map (P.parens <.> prettyTCM . namedArg) qs)-      , nest 2 $ text "tel  =" <+> prettyTCM tel-      ]-  splitP ps tel-  where-    -- Result splitting-    splitRest :: ProblemRest -> ListT TCM SplitProblem-    splitRest (ProblemRest (p : ps) b) | Just f <- mf = do-      lift $ reportSDoc "tc.lhs.split" 20 $ sep-        [ text "splitting problem rest"-        , nest 2 $ text "pattern         p =" <+> prettyA p-        , nest 2 $ text "eliminates type b =" <+> prettyTCM b-        ]-      lift $ reportSDoc "tc.lhs.split" 80 $ sep-        [ nest 2 $ text $ "pattern (raw)   p = " ++ show p-        ]-      -- If the pattern is not a projection pattern, that's an error.-      -- Probably then there were too many arguments.-      caseMaybe (maybePostfixProjP p) failure $ \ (o, AmbQ ds) -> do-        -- So it is a projection pattern (d = projection name), is it?-        projs <- lift $ mapMaybeM (\ d -> fmap (d,) <$> isProjection d) ds-        when (null projs) notProjP-        -- 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 (lift $ isRecordType $ unArg b) notRecord $ \(r, vs, def) -> case def of-          Record{ recFields = fs } -> do-            lift $ reportSDoc "tc.lhs.split" 20 $ sep-              [ text $ "we are of record type r  = " ++ show r-              , text   "applied to parameters vs = " <+> prettyTCM vs-              , text $ "and have fields       fs = " ++ show fs-              ]-            -- The record "self" is the definition f applied to the patterns-            let es = patternsToElims qs-            -- Note: the module parameters are already part of qs-            let self = defaultArg $ Def f [] `applyE` es-                ai   = getArgInfo p-            -- Try the projection candidates-            msum $ map (tryProj o ai self fs vs (length projs >= 2)) projs--          _ -> __IMPOSSIBLE__-      where-      failure   = lift $ typeError $ CannotEliminateWithPattern p $ unArg b-      notProjP  = lift $ typeError $ NotAProjectionPattern p-      notRecord = failure -- lift $ typeError $ ShouldBeRecordType $ unArg b-      wrongHiding :: MonadTCM tcm => QName -> tcm a-      wrongHiding d = typeError . GenericDocError =<< do-        liftTCM $ text "Wrong hiding used for projection " <+> prettyTCM d--      tryProj :: ProjOrigin -> ArgInfo -> Arg Term -> [Arg QName] -> Args -> Bool -> (QName, Projection) -> ListT TCM SplitProblem-      tryProj o ai self fs vs amb (d0, proj) = do-        -- Recoverable errors are those coming from the projection.-        -- If we have several projections (amb) we just try the next one.-        let ambErr err = if amb then mzero else err-        case proj of-          -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible-          Projection{projProper = False} -> ambErr notProjP-          Projection{projProper = True, projOrig = d, projLams = lams} -> do-            let ai = projArgInfo proj-            -- If projIndex==0, then the projection is already applied-            -- to the record value (like in @open R r@), and then it-            -- is no longer a projection but a record field.-            when (null lams) $ ambErr notProjP-            lift $ reportSLn "tc.lhs.split" 90 "we are a projection pattern"-            -- 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.-            lift $ reportSDoc "tc.lhs.split" 20 $ sep-              [ text $ "proj                  d0 = " ++ show d0-              , text $ "original proj         d  = " ++ show d-              ]-            -- Get the field decoration.-            -- If the projection pattern name @d@ is not a field name,-            -- we have to try the next projection name.-            -- If this was not an ambiguous projection, that's an error.-            argd <- maybe (ambErr failure) return $ find ((d ==) . unArg) fs-            let ai' = setRelevance (getRelevance argd) ai--            -- From here, we have the correctly disambiguated projection.-            -- Thus, we no longer catch errors.-            unless (getHiding p == getHiding ai) $ wrongHiding d--            -- For highlighting, we remember which name we disambiguated to.-            -- This is safe here (fingers crossed) as we won't decide on a-            -- different projection even if we backtrack and come here again.-            lift $ storeDisambiguatedName d0--            -- Get the type of projection d applied to "self"-            dType <- lift $ defType <$> getConstInfo d  -- full type!-            lift $ reportSDoc "tc.lhs.split" 20 $ sep-              [ text "we are              self = " <+> prettyTCM (unArg self)-              , text "being projected by dType = " <+> prettyTCM dType-              ]-            -- This should succeed, as we have the correctly disambiguated.-            lift $ SplitRest (Arg ai' d0) o <$> dType `piApplyM` (vs ++ [self])--    -- if there are no more patterns left in the problem rest, there is nothing to split:-    splitRest _ = mzero--    -- | In @splitP aps iqs tel@,-    --   @aps@ are the user patterns on which we are splitting (inPats),-    --   @ips@ are the one-hole patterns of the current split state (outPats)-    --   in one-to-one correspondence with the pattern variables-    --   recorded in @tel@.-    splitP :: [NamedArg A.Pattern]-           -> Telescope-           -> ListT TCM SplitProblem--    -- no more patterns?  pull them from the rest-    splitP []           _                      = splitRest pr-    -- patterns but no more types? that's an error-    splitP (_:_)        EmptyTel               = __IMPOSSIBLE__-    -- (we can never have an ExtendTel without Abs)-    splitP _            (ExtendTel _ NoAbs{})  = __IMPOSSIBLE__--    -- pattern with type?  Let's get to work:-    splitP ps0@(p : ps) tel0@(ExtendTel dom@(Dom ai a) xtel@(Abs x tel)) = do--      liftTCM $ reportSDoc "tc.lhs.split" 30 $ sep-        [ text "splitP looking at pattern"-        , nest 2 $ text "p   =" <+> prettyA p-        , nest 2 $ text "dom =" <+> prettyTCM dom-        ]--      -- Andreas, 2016-06-30, issue #2075: need test here!-      unless (getHiding p == getHiding ai) $ typeError WrongHidingInLHS--      -- Possible reinvokations:-      let -- 1. Redo this argument (after meta instantiation).-          tryAgain = splitP ps0 tel0-          -- 2. Try to split on next argument.-          keepGoing = consSplitProblem p x dom <$> do-            underAbstraction dom xtel $ \ tel -> splitP ps tel--      p <- lift $ expandLitPattern p-      case snd $ asView $ namedArg p of--        -- Case: projection pattern.  That's an error.-        A.ProjP{} -> typeError $-          CannotEliminateWithPattern p (telePi tel0 $ unArg $ restType pr)--        -- Case: literal pattern.-        p@(A.LitP lit)  -> do-          -- Note that, in the presence of --without-K, this branch is-          -- based on the assumption that the types of literals are-          -- not indexed.--          -- Andreas, 2010-09-07 cannot split on irrelevant args-          when (unusableRelevance $ getRelevance ai) $-            typeError $ SplitOnIrrelevant p dom--          -- Succeed if the split type is (already) equal to the type of the literal.-          ifNotM (lift $ tryConversion $ equalType a =<< litType lit)-            {- then -} keepGoing $-            {- else -} return Split-              { splitLPats   = empty-              , splitFocus   = Arg ai $ LitFocus lit qs a-              , splitRPats   = Abs x  $ Problem ps () tel __IMPOSSIBLE__-              }-              `mplus` keepGoing--        -- Case: record pattern-        p@(A.RecP _patInfo fs) -> do-          res <- lift $ tryRecordType a-          case res of-            -- Subcase: blocked-            Left Nothing -> keepGoing--            -- Subcase: not a record type or blocked on variable.-            Left (Just a') -> keepGoing  -- If not record type, error will be given later.-              -- typeError . GenericDocError =<< do-              --   lift $ text "Record pattern at non-record type " <+> prettyTCM a'--            -- Subcase: a record type (d vs)-            Right (d, vs, def) -> do-              let np = recPars def-              let (pars, ixs) = genericSplitAt np vs-              lift $ reportSDoc "tc.lhs.split" 10 $ vcat-                [ sep [ text "splitting on"-                      , nest 2 $ fsep [ prettyA p, text ":", prettyTCM dom ]-                      ]-                , nest 2 $ text "pars =" <+> fsep (punctuate comma $ map prettyTCM pars)-                , nest 2 $ text "ixs  =" <+> fsep (punctuate comma $ map prettyTCM ixs)-                ]-              let c = killRange $ conName $ recConHead def-              let -- Field names with ArgInfo.-                  axs = recordFieldNames def--              -- In es omitted explicit fields are replaced by underscores-              -- (from missingExplicits). Omitted implicit or instance fields-              -- are still left out and inserted later by computeNeighborhood.-              args <- lift $ insertMissingFields d (const $ A.WildP A.patNoRange) fs axs-              (return Split-                { splitLPats   = empty-                , splitFocus   = Arg ai $ Focus c ConORec args (getRange p) qs d pars ixs a-                , splitRPats   = Abs x  $ Problem ps () tel __IMPOSSIBLE__-                }) `mplus` keepGoing--        -- Case: constructor pattern.-        p@(A.ConP ci (A.AmbQ cs) args) -> do-          let tryInstantiate a'-                | [c] <- cs = do-                  lift $ reportSDoc "tc.lhs.split" 30 $-                    text "split ConP: type is blocked"-                    -- Type is blocked by a meta and constructor is unambiguous,-                    -- in this case try to instantiate the meta.-                  ok <- lift $ do-                    Constructor{ conData = d } <- theDef <$> getConstInfo c-                    dt     <- defType <$> getConstInfo d-                    vs     <- newArgsMeta dt-                    Sort s <- ignoreSharing . unEl <$> reduce (piApply dt vs)-                    tryConversion $ equalType a' (El s $ Def d $ map Apply vs)-                  if ok then tryAgain else keepGoing-                | otherwise = do-                  lift $ reportSDoc "tc.lhs.split" 30 $-                    text "split ConP: type is blocked and constructor is ambiguous"-                  keepGoing-          -- ifBlockedType reduces the type-          ifBlockedType a (const tryInstantiate) $ \ a' -> do-            lift $ reportSDoc "tc.lhs.split" 30 $ text "split ConP: type is " <+> prettyTCM a'-            case ignoreSharing $ unEl a' of--              -- Subcase: split type is a Def.-              Def d es    -> do--                def <- liftTCM $ theDef <$> getConstInfo d--                -- We cannot split on (shape-)irrelevant non-records.-                -- Andreas, 2011-10-04 unless allowed by option-                unless (defIsRecord def) $-                  when (unusableRelevance $ getRelevance ai) $-                  unlessM (liftTCM $ optExperimentalIrrelevance <$> pragmaOptions) $-                  typeError $ SplitOnIrrelevant p dom--                -- Check that we are at record or data type and return-                -- the number of parameters.-                let mp = case def of-                          Datatype{dataPars = np} -> Just np-                          Record{recPars = np}    -> Just np-                          _                       -> Nothing-                case mp of-                  Nothing -> keepGoing-                  Just np -> do-                    let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                    traceCall (CheckPattern p EmptyTel a) $ do  -- TODO: wrong telescope-                      -- Check that we construct something in the right datatype-                      c <- lift $ do-                          cs' <- mapM canonicalName cs-                          d'  <- canonicalName d-                          let cons def = case theDef def of-                                Datatype{dataCons = cs} -> cs-                                Record{recConHead = c}      -> [conName c]-                                _                       -> __IMPOSSIBLE__-                          cs0 <- cons <$> getConstInfo d'-                          case [ c | (c, c') <- zip cs cs', elem c' cs0 ] of-                            [c]   -> do-                              -- If constructor pattern was ambiguous,-                              -- remember our choice for highlighting info.-                              when (length cs >= 2) $ storeDisambiguatedName c-                              return c-                            []    -> typeError $ ConstructorPatternInWrongDatatype (head cs) d-                            cs    -> -- if there are more than one we give up (they might have different types)-                              typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs--                      let (pars, ixs) = genericSplitAt np vs-                      lift $ reportSDoc "tc.lhs.split" 10 $ vcat-                        [ sep [ text "splitting on"-                              , nest 2 $ fsep [ prettyA p, text ":", prettyTCM dom ]-                              ]-                        , nest 2 $ text "pars =" <+> fsep (punctuate comma $ map prettyTCM pars)-                        , nest 2 $ text "ixs  =" <+> fsep (punctuate comma $ map prettyTCM ixs)-                        ]--                      -- Andreas, 2013-03-22 fixing issue 279-                      -- To resolve ambiguous constructors, Agda always looks up-                      -- their original definition and reconstructs the parameters-                      -- from the type @Def d vs@ we check against.-                      -- However, the constructor could come from a module instantiation-                      -- with some of the parameters already fixed.-                      -- Agda did not make sure the two parameter lists coincide,-                      -- so we add a check here.-                      -- I guess this issue could be solved more systematically,-                      -- but the extra check here is non-invasive to the existing code.-                      checkParsIfUnambiguous cs d pars--                      (return Split-                        { splitLPats   = empty-                        , splitFocus   = Arg ai $ Focus c (A.patOrigin ci) args (getRange p) qs d pars ixs a-                        , splitRPats   = Abs x  $ Problem ps () tel __IMPOSSIBLE__-                        }) `mplus` keepGoing-              -- Subcase: split type is not a Def.-              _   -> keepGoing--        -- Case: neither literal nor constructor pattern.-        _ -> keepGoing----- | @checkParsIfUnambiguous [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@.-checkParsIfUnambiguous :: MonadTCM tcm => [QName] -> QName -> Args -> tcm ()-checkParsIfUnambiguous [c] d pars = liftTCM $ do-  dc <- getConstructorData c-  a  <- reduce (Def dc [])-  case ignoreSharing a of-    Def d0 es -> do -- compare parameters-      let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      reportSDoc "tc.lhs.split" 40 $-        vcat [ nest 2 $ text "d                   =" <+> prettyTCM d-             , nest 2 $ text "d0 (should be == d) =" <+> prettyTCM d0-             , nest 2 $ text "dc                  =" <+> prettyTCM dc-             ]-      -- when (d0 /= d) __IMPOSSIBLE__ -- d could have extra qualification-      t <- typeOfConst d-      compareArgs [] t (Def d []) vs (take (length vs) pars)-    _ -> __IMPOSSIBLE__-checkParsIfUnambiguous _ _ _ = return ()
src/full/Agda/TypeChecking/Rules/LHS/Unify.hs view
@@ -1,1191 +1,988 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NondecreasingIndentation   #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE ViewPatterns               #-}---- | Unification algorithm for specializing datatype indices, as described in---     \"Unifiers as Equivalences: Proof-Relevant Unification of Dependently---     Typed Data\" by Jesper Cockx, Dominique Devriese, and Frank Piessens---     (ICFP 2016).------   This is the unification algorithm used for checking the left-hand side---   of clauses (see @Agda.TypeChecking.Rules.LHS@), coverage checking (see---   @Agda.TypeChecking.Coverage@) and indirectly also for interactive case---   splitting (see @Agda.Interaction.MakeCase@).------   A unification problem (of type @UnifyState@) consists of:---   1. A telescope @varTel@ of free variables, some or all of which are---      flexible (as indicated by @flexVars@).---   2. A telescope @eqTel@ containing the types of the equations.---   3. Left- and right-hand sides for each equation:---      @varTel ⊢ eqLHS : eqTel@ and @varTel ⊢ eqRHS : eqTel@.------   The unification algorithm can end in three different ways:---   (type @UnificationResult@):---   - A *positive success* @Unifies (tel, sigma, ps)@ with @tel ⊢ sigma : varTel@,---     @tel ⊢ eqLHS [ varTel ↦ sigma ] ≡ eqRHS [ varTel ↦ sigma ] : eqTel@,---     and @tel ⊢ ps : eqTel@. In this case, @sigma;ps@ is an *equivalence*---     between the telescopes @tel@ and @varTel(eqLHS ≡ eqRHS)@.---   - A *negative success* @NoUnify err@ means that a conflicting equation---     was found (e.g an equation between two distinct constructors or a cycle).---   - A *failure* @DontKnow err@ means that the unifier got stuck.------   The unification algorithm itself consists of two parts:---   1. A *unification strategy* takes a unification problem and produces a---      list of suggested unification rules (of type @UnifyStep@). Strategies---      can be constructed by composing simpler strategies (see for example the---      definition of @completeStrategyAt@).---   2. The *unification engine* @unifyStep@ takes a unification rule and tries---      to apply it to the given state, writing the result to the UnifyOutput---      on a success.------   The unification steps (of type @UnifyStep@) are the following:---   - *Deletion* removes a reflexive equation @u =?= v : a@ if the left- and---     right-hand side @u@ and @v@ are (definitionally) equal. This rule results---     in a failure if --without-K is enabled (see \"Pattern Matching Without K\"---     by Jesper Cockx, Dominique Devriese, and Frank Piessens (ICFP 2014).---   - *Solution* solves an equation if one side is (eta-equivalent to) a---     flexible variable. In case both sides are flexible variables, the---     unification strategy makes a choice according to the @chooseFlex@---     function in @Agda.TypeChecking.Rules.LHS.Problem@.---   - *Injectivity* decomposes an equation of the form---     @c us =?= c vs : D pars is@ where @c : Δc → D pars js@ is a constructor---     of the inductive datatype @D@ into a sequence of equations---     @us =?= vs : delta@. In case @D@ is an indexed datatype,---     *higher-dimensional unification* is applied (see below).---   - *Conflict* detects absurd equations of the form---     @c₁ us =?= c₂ vs : D pars is@ where @c₁@ and @c₂@ are two distinct---     constructors of the datatype @D@.---   - *Cycle* detects absurd equations of the form @x =?= v : D pars is@ where---     @x@ is a variable of the datatype @D@ that occurs strongly rigid in @v@.---   - *EtaExpandVar* eta-expands a single flexible variable @x : R@ where @R@---     is a (eta-expandable) record type, replacing it by one variable for each---     field of @R@.---   - *EtaExpandEquation* eta-expands an equation @u =?= v : R@ where @R@ is a---     (eta-expandable) record type, replacing it by one equation for each field---     of @R@. The left- and right-hand sides of these equations are the---     projections of @u@ and @v@.---   - *LitConflict* detects absurd equations of the form @l₁ =?= l₂ : A@ where---     @l₁@ and @l₂@ are distinct literal terms.---   - *StripSizeSuc* simplifies an equation of the form---     @sizeSuc x =?= sizeSuc y : Size@ to @x =?= y : Size@.---   - *SkipIrrelevantEquation@ removes an equation between irrelevant terms.---   - *TypeConInjectivity* decomposes an equation of the form---     @D us =?= D vs : Set i@ where @D@ is a datatype. This rule is only used---     if --injective-type-constructors is enabled.------   Higher-dimensional unification (new, does not yet appear in any paper):---   If an equation of the form @c us =?= c vs : D pars is@ is encountered where---   @c : Δc → D pars js@ is a constructor of an indexed datatype---   @D pars : Φ → Set ℓ@, it is in general unsound to just simplify this---   equation to @us =?= vs : Δc@. For this reason, the injectivity rule in the---   paper restricts the indices @is@ to be distinct variables that are bound in---   the telescope @eqTel@. But we can be more general by introducing new---   variables @ks@ to the telescope @eqTel@ and equating these to @is@:---   @---       Δ₁(x : D pars is)Δ₂---        ≃---       Δ₁(ks : Φ)(x : D pars ks)(ps : is ≡Φ ks)Δ₂---   @---   Since @ks@ are distinct variables, it's now possible to apply injectivity---   to the equation @x@, resulting in the following new equation telescope:---   @---     Δ₁(ys : Δc)(ps : is ≡Φ js[Δc ↦ ys])Δ₂---   @---   Now we can solve the equations @ps@ by recursively calling the unification---   algorithm with flexible variables @Δ₁(ys : Δc)@. This is called---   *higher-dimensional unification* since we are unifying equality proofs---   rather than terms. If the higher-dimensional unification succeeds, the---   resulting telescope serves as the new equation telescope for the original---   unification problem.--module Agda.TypeChecking.Rules.LHS.Unify-  ( UnificationResult-  , UnificationResult'(..)-  , unifyIndices-  , unifyIndices_ ) where--import Prelude hiding (null)--import Control.Arrow ((***))-import Control.Applicative hiding (empty)-import Control.Monad-import Control.Monad.Plus-import Control.Monad.State-import Control.Monad.Trans.Maybe-import Control.Monad.Reader-import Control.Monad.Writer (WriterT(..), MonadWriter(..), Monoid(..))--import Data.Map (Map)-import qualified Data.Map as Map-import Data.Semigroup hiding (Arg)-import Data.List hiding (null, sort)--import Data.Typeable (Typeable)-import Data.Foldable (Foldable)-import Data.Traversable (Traversable,traverse)-import qualified Data.Traversable as Trav--import Agda.Interaction.Options (optInjectiveTypeConstructors)--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Literal-import Agda.Syntax.Position--import Agda.TypeChecking.Monad-import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Monad.Exception-import Agda.TypeChecking.Monad.Builtin (constructorForm)-import Agda.TypeChecking.Conversion -- equalTerm-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.DropArgs-import Agda.TypeChecking.Level (reallyUnLevelView)-import Agda.TypeChecking.Reduce-import qualified Agda.TypeChecking.Patterns.Match as Match-import Agda.TypeChecking.Pretty hiding ((<>))-import Agda.TypeChecking.SizedTypes (compareSizes)-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Free-import Agda.TypeChecking.Records-import Agda.TypeChecking.MetaVars (assignV, newArgsMetaCtx)-import Agda.TypeChecking.EtaContract-import Agda.Interaction.Options (optInjectiveTypeConstructors, optWithoutK)--import Agda.TypeChecking.Rules.LHS.Problem hiding (Substitution)--- import Agda.TypeChecking.SyntacticEquality--import Agda.Utils.Except-  ( Error(noMsg, strMsg)-  , MonadError(catchError, throwError)-  )-import Agda.Utils.Either-import Agda.Utils.Functor-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Size--#include "undefined.h"-import Agda.Utils.Impossible---- | Result of 'unifyIndices'.-type UnificationResult = UnificationResult'-  ( Telescope                  -- @tel@-  , PatternSubstitution        -- @sigma@ s.t. @tel ⊢ sigma : varTel@-  , [NamedArg DeBruijnPattern] -- @ps@    s.t. @tel ⊢ ps    : eqTel @-  )--data UnificationResult' a-  = Unifies  a      -- ^ Unification succeeded.-  | NoUnify  TCErr  -- ^ Terms are not unifiable.-  | DontKnow TCErr  -- ^ Some other error happened, unification got stuck.-  deriving (Typeable, Show, Functor, Foldable, Traversable)---- | Unify indices.------   In @unifyIndices_ flex a us vs@,------   @a@ is the type eliminated by @us@ and @vs@---     (usally the type of a constructor),---     need not be reduced,------   @us@ and @vs@ are the argument lists to unify,------   @flex@ is the set of flexible (instantiable) variabes in @us@ and @vs@.------   The result is the most general unifier of @us@ and @vs@.-unifyIndices_ :: MonadTCM tcm-              => Telescope-              -> FlexibleVars-              -> Type-              -> Args-              -> Args-              -> tcm (Telescope, PatternSubstitution, [NamedArg DeBruijnPattern])-unifyIndices_ tel flex a us vs = liftTCM $ do-  r <- unifyIndices tel flex a us vs-  case r of-    Unifies sub   -> return sub-    DontKnow err  -> throwError err-    NoUnify  err  -> throwError err--unifyIndices :: MonadTCM tcm-             => Telescope-             -> FlexibleVars-             -> Type-             -> Args-             -> Args-             -> tcm UnificationResult-unifyIndices tel flex a [] [] = return $ Unifies (tel, idS, [])-unifyIndices tel flex a us vs = liftTCM $ Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $ do-    reportSDoc "tc.lhs.unify" 10 $-      sep [ text "unifyIndices"-          , nest 2 $ prettyTCM tel-          , nest 2 $ addContext tel $ text $ show $ map flexVar flex-          , nest 2 $ addContext tel $ parens (prettyTCM a)-          , nest 2 $ addContext tel $ prettyList $ map prettyTCM us-          , nest 2 $ addContext tel $ prettyList $ map prettyTCM vs-          ]-    initialState    <- initUnifyState tel flex a us vs-    reportSDoc "tc.lhs.unify" 20 $ text "initial unifyState:" <+> prettyTCM initialState-    reportSDoc "tc.lhs.unify" 70 $ text "initial unifyState:" <+> text (show initialState)-    (result,output) <- runUnifyM $ unify initialState rightToLeftStrategy-    let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState)-    return $ fmap (\s -> (varTel s , unifySubst output , ps)) result--------------------------------------------------------- Equalities-------------------------------------------------------data Equality = Equal-  { eqType  :: Type-  , eqLeft  :: Term-  , eqRight :: Term-  }--instance Reduce Equality where-  reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v--eqConstructorForm :: Equality -> TCM Equality-eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v--eqUnLevel :: Equality -> TCM Equality-eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v-  where-    unLevel (Level l) = reallyUnLevelView l-    unLevel u         = return u--------------------------------------------------------- Unify state-------------------------------------------------------data UnifyState = UState-  { varTel   :: Telescope-  , flexVars :: FlexibleVars-  , eqTel    :: Telescope-  , eqLHS    :: [Arg Term]-  , eqRHS    :: [Arg Term]-  } deriving (Show)--instance Reduce UnifyState where-  reduce' (UState var flex eq lhs rhs) =-    UState <$> reduce' var-           <*> pure flex-           <*> reduce' eq-           <*> reduce' lhs-           <*> reduce' rhs--reduceVarTel :: UnifyState -> TCM UnifyState-reduceVarTel s@UState{ varTel = tel } = do-  tel <- reduce tel-  return $ s { varTel = tel }--reduceEqTel :: UnifyState -> TCM UnifyState-reduceEqTel s@UState{ eqTel = tel } = do-  tel <- reduce tel-  return $ s { eqTel = tel }--instance Normalise UnifyState where-  normalise' (UState var flex eq lhs rhs) =-    UState <$> normalise' var-           <*> pure flex-           <*> normalise' eq-           <*> normalise' lhs-           <*> normalise' rhs--normaliseVarTel :: UnifyState -> TCM UnifyState-normaliseVarTel s@UState{ varTel = tel } = do-  tel <- normalise tel-  return $ s { varTel = tel }--normaliseEqTel :: UnifyState -> TCM UnifyState-normaliseEqTel s@UState{ eqTel = tel } = do-  tel <- normalise tel-  return $ s { eqTel = tel }--instance PrettyTCM UnifyState where-  prettyTCM state = text "UnifyState" $$ nest 2 (vcat $-    [ text "variable tel:  " <+> prettyTCM gamma-    , text "flexible vars: " <+> prettyTCM (map flexVar $ flexVars state)-    , text "equation tel:  " <+> addContext gamma (prettyTCM delta)-    , text "equations:     " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state)))-    ])-    where-      gamma = varTel state-      delta = eqTel state-      prettyEquality x y = prettyTCM x <+> text "=?=" <+> prettyTCM y--initUnifyState :: Telescope -> FlexibleVars -> Type -> Args -> Args -> TCM UnifyState-initUnifyState tel flex a lhs rhs = do-  let n = size lhs-  unless (n == size rhs) __IMPOSSIBLE__-  TelV eqTel _ <- telView a-  unless (n == size eqTel) __IMPOSSIBLE__-  reduce $ UState tel flex eqTel lhs rhs--isUnifyStateSolved :: UnifyState -> Bool-isUnifyStateSolved = null . eqTel--varCount :: UnifyState -> Int-varCount = size . varTel---- | Get the type of the i'th variable in the given state-getVarType :: Int -> UnifyState -> Type-getVarType i s = if i < 0 then __IMPOSSIBLE__ else unDom $ (flattenTel $ varTel s) !! i--getVarTypeUnraised :: Int -> UnifyState -> Type-getVarTypeUnraised i s = if i < 0 then __IMPOSSIBLE__ else snd . unDom $ (telToList $ varTel s) !! i--eqCount :: UnifyState -> Int-eqCount = size . eqTel---- | Get the k'th equality in the given state. The left- and right-hand sides---   of the equality live in the varTel telescope, and the type of the equality---   lives in the varTel++eqTel telescope-getEquality :: Int -> UnifyState -> Equality-getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =-  if k < 0 then __IMPOSSIBLE__ else-    Equal (unDom $ (flattenTel eqs) !! k) (unArg $ lhs !! k) (unArg $ rhs !! k)---- | As getEquality, but with the unraised type-getEqualityUnraised :: Int -> UnifyState -> Equality-getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =-  if k < 0 then __IMPOSSIBLE__ else-    Equal (snd . unDom $ (telToList eqs) !! k)-          (unArg $ lhs !! k)-          (unArg $ rhs !! k)--getEqInfo :: Int -> UnifyState -> ArgInfo-getEqInfo k UState { eqTel = eqs } =-  if k < 0 then __IMPOSSIBLE__ else domInfo $ telToList eqs !! k---- | Add a list of equations to the front of the equation telescope-addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState-addEqs tel us vs s =-  s { eqTel = tel `abstract` eqTel s-    , eqLHS = us ++ eqLHS s-    , eqRHS = vs ++ eqRHS s-    }-  where k = size tel--addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState-addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v]------ | Instantiate the k'th variable with the given value.---   Returns Nothing if there is a cycle.-solveVar :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution)-solveVar k u s = case instantiateTelescope (varTel s) k u of-  Nothing -> Nothing-  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState-      { varTel   = tel'-      , flexVars = permuteFlex (reverseP rho) $ flexVars s-      , eqTel    = applyPatSubst sigma $ eqTel s-      , eqLHS    = applyPatSubst sigma $ eqLHS s-      , eqRHS    = applyPatSubst sigma $ eqRHS s-      }-  where-    permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars-    permuteFlex perm =-      mapMaybe $ \(FlexibleVar h k p x) ->-        FlexibleVar h k p <$> findIndex (x==) (permPicks perm)--applyUnder :: Int -> Telescope -> Term -> Telescope-applyUnder k tel u- | k < 0     = __IMPOSSIBLE__- | k == 0    = tel `apply1` u- | otherwise = case tel of-    EmptyTel         -> __IMPOSSIBLE__-    ExtendTel a tel' -> ExtendTel a $-      Abs (absName tel') $ applyUnder (k-1) (absBody tel') u--dropAt :: Int -> [a] -> [a]-dropAt _ [] = __IMPOSSIBLE__-dropAt k (x:xs)- | k < 0     = __IMPOSSIBLE__- | k == 0    = xs- | otherwise = x : dropAt (k-1) xs---- | Solve the k'th equation with the given value, which can depend on---   regular variables but not on other equation variables.-solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution)-solveEq k u s = (,sigma) $ s-    { eqTel    = applyUnder k (eqTel s) u'-    , eqLHS    = dropAt k $ eqLHS s-    , eqRHS    = dropAt k $ eqRHS s-    }-  where-    u'    = raise k u-    n     = eqCount s-    sigma = liftS (n-k-1) $ consS (DotP u') idS---- | Simplify the k'th equation with the given value (which can depend on other---   equation variables). Returns Nothing if there is a cycle.-simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution)-simplifyEq k u s = case instantiateTelescope (eqTel s) k u of-  Nothing -> Nothing-  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState-    { varTel   = varTel s-    , flexVars = flexVars s-    , eqTel    = tel'-    , eqLHS    = permute rho $ eqLHS s-    , eqRHS    = permute rho $ eqRHS s-    }--------------------------------------------------------- Unification strategies-------------------------------------------------------data UnifyStep-  = Deletion-    { deleteAt           :: Int-    , deleteType         :: Type-    , deleteLeft         :: Term-    , deleteRight        :: Term-    }-  | Solution-    { solutionAt         :: Int-    , solutionType       :: Type-    , solutionVar        :: Int-    , solutionTerm       :: Term-    }-  | Injectivity-    { injectAt           :: Int-    , injectType         :: Type-    , injectDatatype     :: QName-    , injectParameters   :: Args-    , injectIndices      :: Args-    , injectConstructor  :: ConHead-    }-  | Conflict-    { conflictAt         :: Int-    , conflictDatatype   :: QName-    , conflictParameters :: Args-    , conflictConLeft    :: ConHead-    , conflictConRight   :: ConHead-    }-  | Cycle-    { cycleAt            :: Int-    , cycleDatatype      :: QName-    , cycleParameters    :: Args-    , cycleVar           :: Int-    , cycleOccursIn      :: Term-    }-  | EtaExpandVar-    { expandVar           :: FlexibleVar Int-    , expandVarRecordType :: QName-    , expandVarParameters :: Args-    }-  | EtaExpandEquation-    { expandAt           :: Int-    , expandRecordType   :: QName-    , expandParameters   :: Args-    }-  | LitConflict-    { litConflictAt      :: Int-    , litType            :: Type-    , litConflictLeft    :: Literal-    , litConflictRight   :: Literal-    }-  | StripSizeSuc-    { stripAt            :: Int-    , stripArgLeft       :: Term-    , stripArgRight      :: Term-    }-  | SkipIrrelevantEquation-    { skipIrrelevantAt   :: Int-    }-  | TypeConInjectivity-    { typeConInjectAt    :: Int-    , typeConstructor    :: QName-    , typeConArgsLeft    :: Args-    , typeConArgsRight   :: Args-    } deriving (Show)--instance PrettyTCM UnifyStep where-  prettyTCM step = case step of-    Deletion k a u v -> text "Deletion" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "type:       " <+> text (show a)-      , text "lhs:        " <+> text (show u)-      , text "rhs:        " <+> text (show v)-      ])-    Solution k a i u -> text "Solution" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "type:       " <+> text (show a)-      , text "variable:   " <+> text (show i)-      , text "term:       " <+> text (show u)-      ])-    Injectivity k a d pars ixs c -> text "Injectivity" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "type:       " <+> text (show a)-      , text "datatype:   " <+> text (show d)-      , text "parameters: " <+> text (show pars)-      , text "indices:    " <+> text (show ixs)-      , text "constructor:" <+> text (show c)-      ])-    Conflict k d pars c1 c2 -> text "Conflict" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "datatype:   " <+> text (show d)-      , text "parameters: " <+> text (show pars)-      , text "con1:       " <+> text (show c1)-      , text "con2:       " <+> text (show c2)-      ])-    Cycle k d pars i u -> text "Cycle" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "datatype:   " <+> text (show d)-      , text "parameters: " <+> text (show pars)-      , text "variable:   " <+> text (show i)-      , text "term:       " <+> text (show u)-      ])-    EtaExpandVar fi r pars -> text "EtaExpandVar" $$ nest 2 (vcat $-      [ text "variable:   " <+> text (show fi)-      , text "record type:" <+> text (show r)-      , text "parameters: " <+> text (show pars)-      ])-    EtaExpandEquation k r pars -> text "EtaExpandVar" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "record type:" <+> text (show r)-      , text "parameters: " <+> text (show pars)-      ])-    LitConflict k a u v -> text "LitConflict" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "type:       " <+> text (show a)-      , text "lhs:        " <+> text (show u)-      , text "rhs:        " <+> text (show v)-      ])-    StripSizeSuc k u v -> text "StripSizeSuc" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "lhs:        " <+> text (show u)-      , text "rhs:        " <+> text (show v)-      ])-    SkipIrrelevantEquation k -> text "SkipIrrelevantEquation" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      ])-    TypeConInjectivity k d us vs -> text "TypeConInjectivity" $$ nest 2 (vcat $-      [ text "position:   " <+> text (show k)-      , text "datatype:   " <+> text (show d)-      , text "lhs:        " <+> text (show us)-      , text "rhs:        " <+> text (show vs)-      ])--type UnifyStrategy = UnifyState -> ListT TCM UnifyStep--leftToRightStrategy :: UnifyStrategy-leftToRightStrategy s =-    msum (for [0..n-1] $ \k -> completeStrategyAt k s)-  where n = size $ eqTel s--rightToLeftStrategy :: UnifyStrategy-rightToLeftStrategy s =-    msum (for (downFrom n) $ \k -> completeStrategyAt k s)-  where n = size $ eqTel s--completeStrategyAt :: Int -> UnifyStrategy-completeStrategyAt k s = msum $ map (\strat -> strat k s) $-    [ skipIrrelevantStrategy-    , basicUnifyStrategy-    , literalStrategy-    , dataStrategy-    , etaExpandVarStrategy-    , etaExpandEquationStrategy-    , injectiveTypeConStrategy-    , simplifySizesStrategy-    , checkEqualityStrategy-    ]---- | Returns true if the variables 0..k-1 don't occur in x-isHom :: (Free' a All, Subst Term a) => Int -> a -> Maybe a-isHom n x = do-  guard $ getAll $ runFree (\ (i,_) -> All (i >= n)) IgnoreNot x-  return $ raise (-n) x---- | 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.-isEtaVar :: Term -> Type -> TCM (Maybe Int)-isEtaVar u a = runMaybeT $ isEtaVarG u a Nothing []-  where-    -- Checks whether the term u (of type a) is beta-eta-equivalent to-    -- `Var i es`, and returns i if it is. If the argument mi is `Just i'`,-    -- then i and i' are also required to be equal (else Nothing is returned).-    isEtaVarG :: Term -> Type -> Maybe Int -> [Elim' Int] -> MaybeT TCM Int-    isEtaVarG u a mi es = do-      (u, a) <- liftTCM $ reduce (u, a)-      liftTCM $ reportSDoc "tc.lhs.unify" 80 $ text "isEtaVarG" <+> nest 2 (sep-        [ text "u  = " <+> text (show u)-        , text "a  = " <+> prettyTCM a-        , text "mi = " <+> text (show mi)-        , text "es = " <+> prettyList (map (text . show) es)-        ])-      case (ignoreSharing u, ignoreSharing $ unEl a) of-        (Var i' es', _) -> do-          guard $ mi == (i' <$ mi)-          b <- liftTCM $ typeOfBV i'-          areEtaVarElims (var i') b es' es-          return i'-        (_, Def d pars) -> do-          guard =<< do liftTCM $ isEtaRecord d-          fs <- liftTCM $ map unArg . recFields . theDef <$> getConstInfo d-          is <- forM fs $ \f -> do-            let o = ProjSystem-            (_, _, fa) <- MaybeT $ projectTyped u a o f-            isEtaVarG (u `applyE` [Proj o f]) fa mi (es ++ [Proj o f])-          case (mi, is) of-            (Just i, _)     -> return i-            (Nothing, [])   -> mzero-            (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'-        _ -> mzero--    -- `areEtaVarElims u a es es'` checks whether the given elims es (as applied-    -- to the term u of type a) are beta-eta-equal to either projections or-    -- variables with de Bruijn indices given by es'.-    areEtaVarElims :: Term -> Type -> Elims -> [Elim' Int] -> MaybeT TCM ()-    areEtaVarElims u a []    []    = return ()-    areEtaVarElims u a []    (_:_) = mzero-    areEtaVarElims u a (_:_) []    = mzero-    areEtaVarElims u a (Proj o f : es) (Proj _ f' : es') = do-      guard $ f == f'-      a       <- liftTCM $ reduce a-      (_, _, fa) <- MaybeT $ projectTyped u a o f-      areEtaVarElims (u `applyE` [Proj o f]) fa es es'-    -- These two cases can occur only when we're looking at two different-    -- variables (i.e. one of function type and the other of record type) so-    -- it's definitely not the variable we're looking for (or someone is playing-    -- Jedi mind tricks on us)-    areEtaVarElims u a (Proj{}  : _ ) (Apply _ : _  ) = mzero-    areEtaVarElims u a (Apply _ : _ ) (Proj{}  : _  ) = mzero-    areEtaVarElims u a (Apply v : es) (Apply i : es') = do-      ifNotPiType a (const mzero) $ \dom cod -> do-      _ <- isEtaVarG (unArg v) (unDom dom) (Just $ unArg i) []-      areEtaVarElims (u `apply` [fmap var i]) (cod `absApp` var (unArg i)) es es'--findFlexible :: Int -> FlexibleVars -> Maybe (FlexibleVar Nat)-findFlexible i flex =-  let flex'      = map flexVar flex-      flexible i = i `elem` flex'-  in find ((i ==) . flexVar) flex--basicUnifyStrategy :: Int -> UnifyStrategy-basicUnifyStrategy k s = do-  Equal a u v <- liftTCM $ eqUnLevel (getEquality k s)-  ha <- mfromMaybe $ isHom n a-  (mi, mj) <- liftTCM $ addContext (varTel s) $ (,) <$> isEtaVar u ha <*> isEtaVar v ha-  liftTCM $ reportSDoc "tc.lhs.unify" 30 $ text "isEtaVar results: " <+> text (show [mi,mj])-  case (mi, mj) of-    (Just i, Just j)-     | i == j -> return $ Deletion k ha (var i) (var i)-    (Just i, Just j)-     | Just fi <- findFlexible i flex-     , Just fj <- findFlexible j flex -> do-       let choice = chooseFlex fi fj-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ text "fi = " <+> text (show fi)-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ text "fj = " <+> text (show fj)-       liftTCM $ reportSDoc "tc.lhs.unify" 40 $ text "chooseFlex: " <+> text (show choice)-       case choice of-         ChooseLeft   -> return $ Solution k ha i v-         ChooseRight  -> return $ Solution k ha j u-         ExpandBoth   -> mzero -- This should be taken care of by etaExpandEquationStrategy-         ChooseEither -> return $ Solution k ha j u-    (Just i, _)-     | Just _ <- findFlexible i flex -> return $ Solution k ha i v-    (_, Just j)-     | Just _ <- findFlexible j flex -> return $ Solution k ha j u-    _ -> mzero-  where-    flex = flexVars s-    n = eqCount s--dataStrategy :: Int -> UnifyStrategy-dataStrategy k s = do-  Equal a u v <- liftTCM $ eqConstructorForm =<< eqUnLevel (getEqualityUnraised k s)-  case ignoreSharing $ unEl a of-    Def d es -> do-      npars <- mcatMaybes $ liftTCM $ getNumberOfParameters d-      let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      hpars <- mfromMaybe $ isHom k pars-      liftTCM $ reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $-        text "Found equation at datatype " <+> prettyTCM d-         <+> text " with (homogeneous) parameters " <+> prettyTCM hpars-      case (ignoreSharing u, ignoreSharing v) of-        (MetaV m es, Con c ci _   ) -> do-          us <- mcatMaybes $ liftTCM $ addContext (varTel s) $ instMetaCon m es d hpars c ci-          return $ Injectivity k a d hpars ixs c-        (Con c ci _   , MetaV m es) -> do-          vs <- mcatMaybes $ liftTCM $ addContext (varTel s) $ instMetaCon m es d hpars c ci-          return $ Injectivity k a d hpars ixs c-        (Con c _ _   , Con c' _ _  ) | c == c' -> return $ Injectivity k a d hpars ixs c-        (Con c _ _   , Con c' _ _  ) -> return $ Conflict k d hpars c c'-        (Var i []  , v         ) -> ifOccursStronglyRigid i v $ return $ Cycle k d hpars i v-        (u         , Var j []  ) -> ifOccursStronglyRigid j u $ return $ Cycle k d hpars j u-        _ -> mzero-    _ -> mzero-  where-    ifOccursStronglyRigid i u ret = case occurrence i u of-      StronglyRigid -> ret-      NoOccurrence  -> mzero-      _ -> do-        u <- liftTCM $ normalise u-        case occurrence i u of-          StronglyRigid -> ret-          _ -> mzero--    -- Instantiate the meta with a constructor applied to fresh metas-    -- Returns the fresh metas if successful-    instMetaCon :: MetaId -> Elims -> QName -> Args -> ConHead -> ConInfo -> TCM (Maybe Args)-    instMetaCon m es d pars c ci = do-      caseMaybe (allApplyElims es) (return Nothing) $ \ us -> do-        ifNotM (asks envAssignMetas) (return Nothing) $ {-else-} tryMaybe $ do-          reportSDoc "tc.lhs.unify" 60 $-            text "Trying to instantiate the meta" <+> prettyTCM (MetaV m es) <+>-            text "with the constructor" <+> prettyTCM c <+> text "applied to fresh metas"-          margs <- do-            -- The new metas should have the same dependencies as the original meta-            mv <- lookupMeta m--            ctype <- (`piApply` pars) . defType <$> liftTCM (getConstInfo $ conName c)-            reportSDoc "tc.lhs.unify" 80 $ text "Type of constructor: " <+> prettyTCM ctype-            withMetaInfo' mv $ do-              let perm = mvPermutation mv-              reportSDoc "tc.lhs.unify" 100 $ vcat-                [ text "Permutation of meta: " <+> prettyTCM perm-                ]-              cxt <- instantiateFull =<< getContextTelescope-              reportSDoc "tc.lhs.unify" 100 $ do-                let flat = flattenTel cxt-                let badRen  :: Substitution = renaming __IMPOSSIBLE__ perm-                let goodRen :: Substitution = renaming __IMPOSSIBLE__ $ flipP perm-                vcat-                  [ text "Context of meta: " <+> (inTopContext $ prettyTCM cxt)-                  , text "Flattened:       " <+> prettyTCM flat-                  , text "Flattened (raw): " <+> text (show flat)-                  , text "Bad renaming:    " <+> text (show badRen)-                  , text "Good renaming:   " <+> text (show goodRen)-                  , text "Raw permutation: " <+> prettyTCM (permute perm flat)-                  ]-              let tel = permuteTel perm cxt-              reportSDoc "tc.lhs.unify" 100 $ text "Context tel (for new metas): " <+> prettyTCM tel-              -- important: create the meta in the same environment as the original meta-              newArgsMetaCtx ctype tel perm us-          reportSDoc "tc.lhs.unify" 80 $ text "Generated meta args: " <+> prettyTCM margs-          noConstraints $ assignV DirEq m us (Con c ci margs)-          return margs--checkEqualityStrategy :: Int -> UnifyStrategy-checkEqualityStrategy k s = do-  let Equal a u v = getEquality k s-      n = eqCount s-  ha <- mfromMaybe $ isHom n a-  return $ Deletion k ha u v--literalStrategy :: Int -> UnifyStrategy-literalStrategy k s = do-  eq <- liftTCM $ eqUnLevel $ getEquality k s-  case eq of-    Equal a u@(Lit l1) v@(Lit l2)-     | l1 == l2  -> return $ Deletion k a u u -- TODO: wrong context of a, but does it matter?-     | otherwise -> return $ LitConflict k a l1 l2 -- same problem here-    _ -> mzero--etaExpandVarStrategy :: Int -> UnifyStrategy-etaExpandVarStrategy k s = do-  Equal a u v <- liftTCM $ eqUnLevel (getEquality k s)-  shouldEtaExpand u a s `mplus` shouldEtaExpand v a s-  where-    -- TODO: use IsEtaVar to check if the term is a variable-    shouldEtaExpand :: Term -> Type -> UnifyStrategy-    shouldEtaExpand (Var i es) a s = do-      fi       <- mfromMaybe $ findFlexible i (flexVars s)-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $-        text "Found flexible variable " <+> text (show i)-      ps       <- mfromMaybe $ allProjElims es-      guard $ not $ null ps-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $-        text "with projections " <+> prettyTCM (map snd ps)-      let b = getVarTypeUnraised (varCount s - 1 - i) s-      (d, pars) <- mcatMaybes $ liftTCM $ isEtaRecordType b-      liftTCM $ reportSDoc "tc.lhs.unify" 50 $-        text "at record type " <+> prettyTCM d-      return $ EtaExpandVar fi d pars-    shouldEtaExpand _ _ _ = mzero--etaExpandEquationStrategy :: Int -> UnifyStrategy-etaExpandEquationStrategy k s = do-  let Equal a u v = getEqualityUnraised k s-  (d, pars) <- mcatMaybes $ liftTCM $ addContext tel $ isEtaRecordType a-  sing <- liftTCM $ (Right True ==) <$> isSingletonRecord d pars-  projLeft <- liftTCM $ shouldProject u-  projRight <- liftTCM $ shouldProject v-  guard $ sing || projLeft || projRight-  return $ EtaExpandEquation k d pars-  where-    shouldProject :: Term -> TCM Bool-    shouldProject u = case ignoreSharing u of-      Def f es   -> usesCopatterns f-      Con c _ _  -> isJust <$> isRecordConstructor (conName c)--      Var _ _    -> return False-      Lam _ _    -> __IMPOSSIBLE__-      Lit _      -> __IMPOSSIBLE__-      Pi _ _     -> __IMPOSSIBLE__-      Sort _     -> __IMPOSSIBLE__-      Level _    -> __IMPOSSIBLE__-      MetaV _ _  -> return False-      DontCare _ -> return False-      Shared _   -> __IMPOSSIBLE__--    tel = varTel s `abstract` telFromList (take k $ telToList $ eqTel s)--simplifySizesStrategy :: Int -> UnifyStrategy-simplifySizesStrategy k s = do-  isSizeName <- liftTCM isSizeNameTest-  let Equal a u v = getEquality k s-  case ignoreSharing $ unEl a of-    Def d _ -> do-      guard $ isSizeName d-      su <- liftTCM $ sizeView u-      sv <- liftTCM $ sizeView v-      case (su, sv) of-        (SizeSuc u, SizeSuc v) -> return $ StripSizeSuc k u v-        (SizeSuc u, SizeInf  ) -> return $ StripSizeSuc k u v-        (SizeInf  , SizeSuc v) -> return $ StripSizeSuc k u v-        _ -> mzero-    _ -> mzero--injectiveTypeConStrategy :: Int -> UnifyStrategy-injectiveTypeConStrategy k s = do-  injTyCon <- liftTCM $ optInjectiveTypeConstructors <$> pragmaOptions-  guard injTyCon-  eq <- liftTCM $ eqUnLevel $ getEquality k s-  case eq of-    Equal a u@(ignoreSharing -> Def d es) v@(ignoreSharing -> Def d' es') | d == d' -> do-      -- d must be a data, record or axiom-      def <- liftTCM $ getConstInfo d-      guard $ case theDef def of-                Datatype{} -> True-                Record{}   -> True-                Axiom{}    -> True-                AbstractDefn -> False -- True triggers issue #2250-                Function{}   -> False-                Primitive{}  -> False-                Constructor{}-> __IMPOSSIBLE__  -- Never a type!-      let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-          vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'-      return $ TypeConInjectivity k d us vs-    _ -> mzero--skipIrrelevantStrategy :: Int -> UnifyStrategy-skipIrrelevantStrategy k s = do-  let i = getEqInfo k s-  guard $ isIrrelevant i-  return $ SkipIrrelevantEquation k---------------------------------------------------------- Actually doing the unification-------------------------------------------------------data UnifyLogEntry-  = UnificationDone  UnifyState-  | UnificationStep  UnifyState UnifyStep--type UnifyLog = [UnifyLogEntry]--data UnifyOutput = UnifyOutput-  { unifySubst :: PatternSubstitution-  , unifyProof :: PatternSubstitution-  , unifyLog   :: UnifyLog-  }--instance Semigroup UnifyOutput where-  x <> y = UnifyOutput-    { unifySubst = unifySubst y `composeS` unifySubst x-    , unifyProof = unifyProof y `composeS` unifyProof x-    , unifyLog   = unifyLog x ++ unifyLog y-    }--instance Monoid UnifyOutput where-  mempty  = UnifyOutput IdS IdS []-  mappend = (<>)--type UnifyM a = WriterT UnifyOutput TCM a--tellUnifySubst :: PatternSubstitution -> UnifyM ()-tellUnifySubst sub = tell $ UnifyOutput sub IdS []--tellUnifyProof :: PatternSubstitution -> UnifyM ()-tellUnifyProof sub = tell $ UnifyOutput IdS sub []--writeUnifyLog :: UnifyLogEntry -> UnifyM ()-writeUnifyLog x = tell $ UnifyOutput IdS IdS [x]--runUnifyM :: UnifyM a -> TCM (a,UnifyOutput)-runUnifyM = runWriterT--unifyStep :: UnifyState -> UnifyStep -> UnifyM (UnificationResult' UnifyState)--unifyStep s Deletion{ deleteAt = k , deleteType = a , deleteLeft = u , deleteRight = v } = do-    liftTCM $ addContext (varTel s) $ noConstraints $ dontAssignMetas $ equalTerm a u v-    ifM (liftTCM $ optWithoutK <$> pragmaOptions)-    {-then-} (DontKnow <$> liftTCM withoutKErr)-    {-else-} (do-      let (s', sigma) = solveEq k u s-      tellUnifyProof sigma-      Unifies <$> liftTCM (reduceEqTel s'))-  `catchError` \err -> return $ DontKnow err-  where-    withoutKErr = addContext (varTel s) $ typeError_ $ WithoutKError a u u--unifyStep s Solution{ solutionAt = k , solutionType = a , solutionVar = i , solutionTerm = u } = do-  let m = varCount s-  caseMaybeM (trySolveVar (m-1-i) u s) (DontKnow <$> err) $ \(s',sub) -> do-    tellUnifySubst sub-    let (s'', sigma) = solveEq k (applyPatSubst sub u) s'-    tellUnifyProof sigma-    Unifies <$> liftTCM (reduce s'')-  where-    trySolveVar i u s = case solveVar i u s of-      Just x  -> return $ Just x-      Nothing -> do-        u <- liftTCM $ normalise u-        s <- liftTCM $ normaliseVarTel s-        return $ solveVar i u s-    err = addContext (varTel s) $ typeError_ $ UnificationRecursiveEq a i u--unifyStep s (Injectivity k a d pars ixs c) = do-  withoutK <- liftTCM $ optWithoutK <$> pragmaOptions-  let n = eqCount s--  -- Get constructor telescope and target indices-  ctype <- (`piApply` pars) . defType <$> liftTCM (getConInfo c)-  reportSDoc "tc.lhs.unify" 40 $ text "Constructor type: " <+> prettyTCM ctype-  TelV ctel ctarget <- liftTCM $ telView ctype-  let cixs = case ignoreSharing $ unEl ctarget of-               Def d' es | d == d' ->-                 let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                 in  drop (length pars) args-               _ -> __IMPOSSIBLE__--  -- Get index telescope of the datatype-  dtype    <- (`piApply` pars) . defType <$> liftTCM (getConstInfo d)-  reportSDoc "tc.lhs.unify" 40 $ text "Datatype type: " <+> prettyTCM dtype--  -- Split equation telescope into parts before and after current equation-  let (eqListTel1, _ : eqListTel2) = genericSplitAt k $ telToList $ eqTel s-      (eqTel1, eqTel2) = (telFromList eqListTel1, telFromList eqListTel2)--  -- This is where the magic of higher-dimensional unification happens-  -- We need to generalize the indices `ixs` to the target indices of the-  -- constructor `cixs`. This is done by calling the unification algorithm-  -- recursively (this doesn't get stuck in a loop because a type should-  -- never be indexed over itself). Note the similarity with the-  -- computeNeighbourhood function in Agda.TypeChecking.Coverage.-  res <- liftTCM $ addContext (varTel s) $ unifyIndices-           (eqTel1 `abstract` ctel)-           (allFlexVars $ eqTel1 `abstract` ctel)-           dtype-           (raise (size ctel) ixs)-           (raiseFrom (size ctel) (size eqTel1) cixs)-  case res of-    -- Higher-dimensional unification can never end in a conflict,-    -- because `cong c1 ...` and `cong c2 ...` don't even have the-    -- same type for distinct constructors c1 and c2.-    NoUnify _ -> __IMPOSSIBLE__--    -- TODO: we could still make progress here if not --without-K,-    -- but I'm not sure if it's necessary.-    DontKnow _ -> liftTCM $ DontKnow <$> err--    Unifies (eqTel1', rho0, _) -> do-      -- Split ps0 into parts for eqTel1 and ctel-      let (rho1, rho2) = splitS (size ctel) rho0--      -- Compute new equation telescope context and substitution-      let ceq     = ConP c noConPatternInfo $ applySubst rho2 $ teleNamedArgs ctel-          rho3    = consS ceq rho1-          eqTel2' = applyPatSubst rho3 eqTel2-          eqTel'  = eqTel1' `abstract` eqTel2'-          rho     = liftS (size eqTel2) rho3--      tellUnifyProof rho--      eqTel' <- liftTCM $ reduce eqTel'--      -- Compute new lhs and rhs by matching the old ones against rho-      (lhs', rhs') <- liftTCM . reduce =<< do-        let ps = applySubst rho $ teleNamedArgs $ eqTel s-        (lhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqLHS s-        (rhsMatch, _) <- liftTCM $ runReduceM $ Match.matchPatterns ps $ eqRHS s-        case (lhsMatch, rhsMatch) of-          (Match.Yes _ lhs', Match.Yes _ rhs') -> return-            (reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') lhs',-             reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') rhs')-          _ -> __IMPOSSIBLE__--      return $ Unifies $ s { eqTel = eqTel' , eqLHS = lhs' , eqRHS = rhs' }--  where-    err :: TCM TCErr-    err = let n           = eqCount s-              Equal a u v = getEquality k s-          in addContext (varTel s `abstract` eqTel s) $ typeError_-               (UnifyIndicesNotVars a (raise n u) (raise n v) (raise (n-k) ixs))--unifyStep s Conflict-  { conflictConLeft    = c-  , conflictConRight   = c'-  } = NoUnify <$> addContext (varTel s)-        (typeError_ $ UnifyConflict c c')--unifyStep s Cycle-  { cycleVar        = i-  , cycleOccursIn   = u-  } = NoUnify <$> addContext (varTel s)-        (typeError_ $ UnifyCycle i u)--unifyStep s EtaExpandVar{ expandVar = fi, expandVarRecordType = d , expandVarParameters = pars } = do-  delta   <- liftTCM $ (`apply` pars) <$> getRecordFieldTypes d-  c       <- liftTCM $ getRecordConstructor d-  let nfields         = size delta-      (varTel', rho)  = expandTelescopeVar (varTel s) (m-1-i) delta c-      projectFlexible = [ FlexibleVar (flexHiding fi) (projFlexKind j) (flexPos fi) (i+j) | j <- [0..nfields-1] ]-  tellUnifySubst $ rho-  Unifies <$> liftTCM (reduce $ UState-    { varTel   = varTel'-    , flexVars = projectFlexible ++ liftFlexibles nfields (flexVars s)-    , eqTel    = applyPatSubst rho $ eqTel s-    , eqLHS    = applyPatSubst rho $ eqLHS s-    , eqRHS    = applyPatSubst rho $ eqRHS s-    })-  where-    i = flexVar fi-    m = varCount s-    n = eqCount s--    projFlexKind :: Int -> FlexibleVarKind-    projFlexKind j = case flexKind fi of-      RecordFlex ks -> fromMaybe ImplicitFlex $ ks !!! j-      ImplicitFlex  -> ImplicitFlex-      DotFlex       -> DotFlex--    liftFlexible :: Int -> Int -> Maybe Int-    liftFlexible n j = if j == i then Nothing else Just (if j > i then j + (n-1) else j)--    liftFlexibles :: Int -> FlexibleVars -> FlexibleVars-    liftFlexibles n fs = catMaybes $ map (traverse $ liftFlexible n) fs--unifyStep s EtaExpandEquation{ expandAt = k, expandRecordType = d, expandParameters = pars } = do-  delta <- liftTCM $ (`apply` pars) <$> getRecordFieldTypes d-  c     <- liftTCM $ getRecordConstructor d-  lhs   <- expandKth $ eqLHS s-  rhs   <- expandKth $ eqRHS s-  let (tel, sigma) = expandTelescopeVar (eqTel s) k delta c-  tellUnifyProof sigma-  Unifies <$> liftTCM (reduceEqTel $ s-    { eqTel    = tel-    , eqLHS    = lhs-    , eqRHS    = rhs-    })-  where-    expandKth us = do-      let (us1,v:us2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt k us-      vs <- liftTCM $ snd <$> etaExpandRecord d pars (unArg v)-      vs <- liftTCM $ reduce vs-      return $ us1 ++ vs ++ us2--unifyStep s LitConflict-  { litType          = a-  , litConflictLeft  = l-  , litConflictRight = l'-  } = NoUnify <$> addContext (varTel s)-        (typeError_ $ UnequalTerms CmpEq (Lit l) (Lit l') a)--unifyStep s (StripSizeSuc k u v) = do-  sizeTy <- liftTCM sizeType-  sizeSu <- liftTCM $ sizeSuc 1 (var 0)-  let n          = eqCount s-      sub        = liftS (n-k-1) $ consS sizeSu $ raiseS 1-      eqFlatTel  = flattenTel $ eqTel s-      eqFlatTel' = applySubst sub $ updateAt k (fmap $ const sizeTy) $ eqFlatTel-      eqTel'     = unflattenTel (teleNames $ eqTel s) eqFlatTel'-  -- TODO: tellUnifyProof sub-  -- but sizeSu is not a constructor, so sub is not a PatternSubstitution!-  return $ Unifies $ s-    { eqTel = eqTel'-    , eqLHS = updateAt k (const $ defaultArg u) $ eqLHS s-    , eqRHS = updateAt k (const $ defaultArg v) $ eqRHS s-    }--unifyStep s (SkipIrrelevantEquation k) = do-  let lhs = eqLHS s-      (s', sigma) = solveEq k (DontCare $ unArg $ lhs !! k) s-  tellUnifyProof sigma-  return $ Unifies s'--unifyStep s (TypeConInjectivity k d us vs) = do-  dtype <- defType <$> liftTCM (getConstInfo d)-  TelV dtel _ <- liftTCM $ telView dtype-  let n   = eqCount s-      m   = size dtel-      deq = Def d $ map Apply $ teleArgs dtel-  -- TODO: tellUnifyProof ???-  -- but d is not a constructor...-  Unifies <$> liftTCM (reduceEqTel $ s-    { eqTel = dtel `abstract` applyUnder k (eqTel s) (raise k deq)-    , eqLHS = us ++ dropAt k (eqLHS s)-    , eqRHS = vs ++ dropAt k (eqRHS s)-    })--unify :: UnifyState -> UnifyStrategy -> UnifyM (UnificationResult' UnifyState)-unify s strategy = if isUnifyStateSolved s-                   then return $ Unifies s-                   else tryUnifyStepsAndContinue (strategy s)-  where-    tryUnifyStepsAndContinue :: ListT TCM UnifyStep -> UnifyM (UnificationResult' UnifyState)-    tryUnifyStepsAndContinue steps = do-      x <- foldListT tryUnifyStep failure $ liftListT lift steps-      case x of-        Unifies s'   -> unify s' strategy-        NoUnify err  -> return $ NoUnify err-        DontKnow err -> return $ DontKnow err--    tryUnifyStep :: UnifyStep-                 -> UnifyM (UnificationResult' UnifyState)-                 -> UnifyM (UnificationResult' UnifyState)-    tryUnifyStep step fallback = do-      reportSDoc "tc.lhs.unify" 20 $ text "trying unifyStep" <+> prettyTCM step-      x <- unifyStep s step-      case x of-        Unifies s'   -> do-          reportSDoc "tc.lhs.unify" 20 $ text "unifyStep successful."-          reportSDoc "tc.lhs.unify" 20 $ text "new unifyState:" <+> prettyTCM s'-          writeUnifyLog $ UnificationStep s step-          return x-        NoUnify{}    -> return x-        DontKnow err -> do-          y <- fallback-          case y of-            DontKnow{} -> return x-            _          -> return y--    failure :: UnifyM (UnificationResult' a)-    failure = do-      err <- addContext (varTel s) $ typeError_ $-               UnificationStuck (eqTel s) (map unArg $ eqLHS s) (map unArg $ eqRHS s)-      return $ DontKnow err+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++-- | Unification algorithm for specializing datatype indices, as described in+--     \"Unifiers as Equivalences: Proof-Relevant Unification of Dependently+--     Typed Data\" by Jesper Cockx, Dominique Devriese, and Frank Piessens+--     (ICFP 2016).+--+--   This is the unification algorithm used for checking the left-hand side+--   of clauses (see @Agda.TypeChecking.Rules.LHS@), coverage checking (see+--   @Agda.TypeChecking.Coverage@) and indirectly also for interactive case+--   splitting (see @Agda.Interaction.MakeCase@).+--+--   A unification problem (of type @UnifyState@) consists of:+--+--   1. A telescope @varTel@ of free variables, some or all of which are+--      flexible (as indicated by @flexVars@).+--+--   2. A telescope @eqTel@ containing the types of the equations.+--+--   3. Left- and right-hand sides for each equation:+--      @varTel ⊢ eqLHS : eqTel@ and @varTel ⊢ eqRHS : eqTel@.+--+--   The unification algorithm can end in three different ways:+--   (type @UnificationResult@):+--+--   - A *positive success* @Unifies (tel, sigma, ps)@ with @tel ⊢ sigma : varTel@,+--     @tel ⊢ eqLHS [ varTel ↦ sigma ] ≡ eqRHS [ varTel ↦ sigma ] : eqTel@,+--     and @tel ⊢ ps : eqTel@. In this case, @sigma;ps@ is an *equivalence*+--     between the telescopes @tel@ and @varTel(eqLHS ≡ eqRHS)@.+--+--   - A *negative success* @NoUnify err@ means that a conflicting equation+--     was found (e.g an equation between two distinct constructors or a cycle).+--+--   - A *failure* @UnifyStuck err@ means that the unifier got stuck.+--+--   The unification algorithm itself consists of two parts:+--+--   1. A *unification strategy* takes a unification problem and produces a+--      list of suggested unification rules (of type @UnifyStep@). Strategies+--      can be constructed by composing simpler strategies (see for example the+--      definition of @completeStrategyAt@).+--+--   2. The *unification engine* @unifyStep@ takes a unification rule and tries+--      to apply it to the given state, writing the result to the UnifyOutput+--      on a success.+--+--   The unification steps (of type @UnifyStep@) are the following:+--+--   - *Deletion* removes a reflexive equation @u =?= v : a@ if the left- and+--     right-hand side @u@ and @v@ are (definitionally) equal. This rule results+--     in a failure if --without-K is enabled (see \"Pattern Matching Without K\"+--     by Jesper Cockx, Dominique Devriese, and Frank Piessens (ICFP 2014).+--+--   - *Solution* solves an equation if one side is (eta-equivalent to) a+--     flexible variable. In case both sides are flexible variables, the+--     unification strategy makes a choice according to the @chooseFlex@+--     function in @Agda.TypeChecking.Rules.LHS.Problem@.+--+--   - *Injectivity* decomposes an equation of the form+--     @c us =?= c vs : D pars is@ where @c : Δc → D pars js@ is a constructor+--     of the inductive datatype @D@ into a sequence of equations+--     @us =?= vs : delta@. In case @D@ is an indexed datatype,+--     *higher-dimensional unification* is applied (see below).+--+--   - *Conflict* detects absurd equations of the form+--     @c₁ us =?= c₂ vs : D pars is@ where @c₁@ and @c₂@ are two distinct+--     constructors of the datatype @D@.+--+--   - *Cycle* detects absurd equations of the form @x =?= v : D pars is@ where+--     @x@ is a variable of the datatype @D@ that occurs strongly rigid in @v@.+--+--   - *EtaExpandVar* eta-expands a single flexible variable @x : R@ where @R@+--     is a (eta-expandable) record type, replacing it by one variable for each+--     field of @R@.+--+--   - *EtaExpandEquation* eta-expands an equation @u =?= v : R@ where @R@ is a+--     (eta-expandable) record type, replacing it by one equation for each field+--     of @R@. The left- and right-hand sides of these equations are the+--     projections of @u@ and @v@.+--+--   - *LitConflict* detects absurd equations of the form @l₁ =?= l₂ : A@ where+--     @l₁@ and @l₂@ are distinct literal terms.+--+--   - *StripSizeSuc* simplifies an equation of the form+--     @sizeSuc x =?= sizeSuc y : Size@ to @x =?= y : Size@.+--+--   - *SkipIrrelevantEquation@ removes an equation between irrelevant terms.+--+--   - *TypeConInjectivity* decomposes an equation of the form+--     @D us =?= D vs : Set i@ where @D@ is a datatype. This rule is only used+--     if --injective-type-constructors is enabled.+--+--   Higher-dimensional unification (new, does not yet appear in any paper):+--   If an equation of the form @c us =?= c vs : D pars is@ is encountered where+--   @c : Δc → D pars js@ is a constructor of an indexed datatype+--   @D pars : Φ → Set ℓ@, it is in general unsound to just simplify this+--   equation to @us =?= vs : Δc@. For this reason, the injectivity rule in the+--   paper restricts the indices @is@ to be distinct variables that are bound in+--   the telescope @eqTel@. But we can be more general by introducing new+--   variables @ks@ to the telescope @eqTel@ and equating these to @is@:+--   @+--       Δ₁(x : D pars is)Δ₂+--        ≃+--       Δ₁(ks : Φ)(x : D pars ks)(ps : is ≡Φ ks)Δ₂+--   @+--   Since @ks@ are distinct variables, it's now possible to apply injectivity+--   to the equation @x@, resulting in the following new equation telescope:+--   @+--     Δ₁(ys : Δc)(ps : is ≡Φ js[Δc ↦ ys])Δ₂+--   @+--   Now we can solve the equations @ps@ by recursively calling the unification+--   algorithm with flexible variables @Δ₁(ys : Δc)@. This is called+--   *higher-dimensional unification* since we are unifying equality proofs+--   rather than terms. If the higher-dimensional unification succeeds, the+--   resulting telescope serves as the new equation telescope for the original+--   unification problem.++module Agda.TypeChecking.Rules.LHS.Unify+  ( UnificationResult+  , UnificationResult'(..)+  , NoLeftInv(..)+  , unifyIndices'+  , unifyIndices ) where++import Prelude hiding (null)++import Control.Monad.State  ( gets, modify, evalStateT )+import Control.Monad.Writer ( WriterT(..), MonadWriter(..) )+import Control.Monad.Except ( runExceptT )++import Data.Semigroup hiding (Arg)+import qualified Data.List as List+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++import qualified Agda.Benchmarking as Bench++import Agda.Interaction.Options (optInjectiveTypeConstructors)++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Conversion.Pure (pureEqualTermB, pureEqualTypeB)+import Agda.TypeChecking.Constraints ()+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Reduce+import qualified Agda.TypeChecking.Patterns.Match as Match+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Precompute+import Agda.TypeChecking.Free.Reduce+import Agda.TypeChecking.Records++import Agda.TypeChecking.Rules.LHS.Problem+import Agda.TypeChecking.Rules.LHS.Unify.Types+import Agda.TypeChecking.Rules.LHS.Unify.LeftInverse++import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.PartialOrd+import Agda.Utils.Singleton+import Agda.Utils.Size++import Agda.Utils.Impossible+++-- | Result of 'unifyIndices'.+type UnificationResult = UnificationResult'+  ( Telescope                  -- @tel@+  , PatternSubstitution        -- @sigma@ s.t. @tel ⊢ sigma : varTel@+  , [NamedArg DeBruijnPattern] -- @ps@    s.t. @tel ⊢ ps    : eqTel @+  )++type FullUnificationResult = UnificationResult'+  ( Telescope                  -- @tel@+  , PatternSubstitution        -- @sigma@ s.t. @tel ⊢ sigma : varTel@+  , [NamedArg DeBruijnPattern] -- @ps@    s.t. @tel ⊢ ps    : eqTel @+  , Either NoLeftInv (Substitution, Substitution) -- (τ,leftInv)+  )++data UnificationResult' a+  = Unifies  a                        -- ^ Unification succeeded.+  | NoUnify  NegativeUnification      -- ^ Terms are not unifiable.+  | UnifyBlocked Blocker              -- ^ Unification got blocked on a metavariable+  | UnifyStuck   [UnificationFailure] -- ^ Some other error happened, unification got stuck.+  deriving (Show, Functor, Foldable, Traversable)++-- | Unify indices.+--+--   In @unifyIndices gamma flex a us vs@,+--+--   * @us@ and @vs@ are the argument lists to unify, eliminating type @a@.+--+--   * @gamma@ is the telescope of free variables in @us@ and @vs@.+--+--   * @flex@ is the set of flexible (instantiable) variabes in @us@ and @vs@.+--+--   The result is the most general unifier of @us@ and @vs@.+unifyIndices+  :: Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse?+  -> Telescope       -- ^ @gamma@+  -> FlexibleVars    -- ^ @flex@+  -> Type            -- ^ @a@+  -> Args            -- ^ @us@+  -> Args            -- ^ @vs@+  -> TCM UnificationResult+unifyIndices linv tel flex a us vs =+  Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $+    fmap (\(a,b,c,_) -> (a,b,c)) <$> unifyIndices' linv tel flex a us vs++unifyIndices'+  :: Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse?+  -> Telescope     -- ^ @gamma@+  -> FlexibleVars  -- ^ @flex@+  -> Type          -- ^ @a@+  -> Args          -- ^ @us@+  -> Args          -- ^ @vs@+  -> TCM FullUnificationResult+unifyIndices' linv tel flex a [] [] = return $ Unifies (tel, idS, [], Right (idS, raiseS 1))+unifyIndices' linv tel flex a us vs = do+    reportSDoc "tc.lhs.unify" 10 $+      sep [ "unifyIndices"+          , ("tel  =" <+>) $ nest 2 $ prettyTCM tel+          , ("flex =" <+>) $ nest 2 $ addContext tel $ text $ show $ map flexVar flex+          , ("a    =" <+>) $ nest 2 $ addContext tel $ parens (prettyTCM a)+          , ("us   =" <+>) $ nest 2 $ addContext tel $ prettyList $ map prettyTCM us+          , ("vs   =" <+>) $ nest 2 $ addContext tel $ prettyList $ map prettyTCM vs+          ]+    initialState    <- initUnifyState tel flex a us vs+    reportSDoc "tc.lhs.unify" 20 $ "initial unifyState:" <+> prettyTCM initialState+    (result,log) <- runUnifyLogT $ unify initialState rightToLeftStrategy+    forM result $ \ s -> do -- Unifies case+        let output = mconcat [output | (UnificationStep _ _ output,_) <- log ]+        let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState)+        tauInv <- do+          strict     <- asksTC envSplitOnStrict+          cubicalCompatible <- cubicalCompatibleOption+          withoutK <- withoutKOption+          case linv of+            Just reason -> pure (Left reason)+            Nothing+              | strict            -> pure (Left SplitOnStrict)+              | cubicalCompatible -> buildLeftInverse initialState log+              | withoutK          -> pure (Left NoCubical)+              | otherwise         -> pure (Left WithKEnabled)+        reportSDoc "tc.lhs.unify" 20 $ "ps:" <+> pretty ps+        return $ (varTel s, unifySubst output, ps, tauInv)++++type UnifyStrategy = UnifyState -> ListT TCM UnifyStep+++--UNUSED Liang-Ting Chen 2019-07-16+--leftToRightStrategy :: UnifyStrategy+--leftToRightStrategy s =+--    msum (for [0..n-1] $ \k -> completeStrategyAt k s)+--  where n = size $ eqTel s++rightToLeftStrategy :: UnifyStrategy+rightToLeftStrategy s =+    msum (for (downFrom n) $ \k -> completeStrategyAt k s)+  where n = size $ eqTel s++completeStrategyAt :: Int -> UnifyStrategy+completeStrategyAt k s = msum $ map (\strat -> strat k s) $+-- ASR (2021-02-07). The below eta-expansions are required by GHC >=+-- 9.0.1 (see Issue #4955).+    [ (\n -> skipIrrelevantStrategy n)+    , (\n -> basicUnifyStrategy n)+    , (\n -> literalStrategy n)+    , (\n -> dataStrategy n)+    , (\n -> etaExpandVarStrategy  n)+    , (\n -> etaExpandEquationStrategy n)+    , (\n -> injectiveTypeConStrategy n)+    , (\n -> injectivePragmaStrategy n)+    , (\n -> simplifySizesStrategy n)+    , (\n -> checkEqualityStrategy n)+    ]++-- | @isHom n x@ returns x lowered by n if the variables 0..n-1 don't occur in x.+--+-- This is naturally sensitive to normalization.+isHom :: (Free a, Subst a) => Int -> a -> Maybe a+isHom n x = do+  guard $ getAll $ runFree (All . (>= n)) IgnoreNot x+  return $ raise (-n) x++findFlexible :: Int -> FlexibleVars -> Maybe (FlexibleVar Nat)+findFlexible i flex = List.find ((i ==) . flexVar) flex++basicUnifyStrategy :: Int -> UnifyStrategy+basicUnifyStrategy k s = do+  Equal dom@Dom{unDom = a} u v <- eqUnLevel (getEquality k s)+    -- Andreas, 2019-02-23: reduce equality for the sake of isHom?+  ha <- fromMaybeMP $ isHom n a+  (mi, mj) <- addContext (varTel s) $ (,) <$> isEtaVar u ha <*> isEtaVar v ha+  reportSDoc "tc.lhs.unify" 30 $ "isEtaVar results: " <+> text (show [mi,mj])+  case (mi, mj) of+    (Just i, Just j)+     | i == j -> mzero -- Taken care of by checkEqualityStrategy+    (Just i, Just j)+     | Just fi <- findFlexible i flex+     , Just fj <- findFlexible j flex -> do+       let choice = chooseFlex fi fj+           firstTryLeft  = msum [ return (Solution k dom{unDom = ha} fi v left)+                                , return (Solution k dom{unDom = ha} fj u right)]+           firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u right)+                                , return (Solution k dom{unDom = ha} fi v left)]+       reportSDoc "tc.lhs.unify" 40 $ "fi = " <+> text (show fi)+       reportSDoc "tc.lhs.unify" 40 $ "fj = " <+> text (show fj)+       reportSDoc "tc.lhs.unify" 40 $ "chooseFlex: " <+> text (show choice)+       case choice of+         ChooseLeft   -> firstTryLeft+         ChooseRight  -> firstTryRight+         ExpandBoth   -> mzero -- This should be taken care of by etaExpandEquationStrategy+         ChooseEither -> firstTryRight+    (Just i, _)+     | Just fi <- findFlexible i flex -> return $ Solution k dom{unDom = ha} fi v left+    (_, Just j)+     | Just fj <- findFlexible j flex -> return $ Solution k dom{unDom = ha} fj u right+    _ -> mzero+  where+    flex = flexVars s+    n = eqCount s+    left = Left (); right = Right ()++dataStrategy :: Int -> UnifyStrategy+dataStrategy k s = do+  Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< getReducedEqualityUnraised k s+  sortOk <- reduce (getSort a) <&> \case+    Type{} -> True+    Inf{}  -> True+    SSet{} -> True+    _      -> False+  case unEl a of+    Def d es | sortOk -> do+      npars <- catMaybesMP $ getNumberOfParameters d+      let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es+      reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $+        "Found equation at datatype " <+> prettyTCM d+         <+> " with parameters " <+> prettyTCM (raise (size (eqTel s) - k) pars)+      case (u, v) of+        (Con c _ _   , Con c' _ _  ) | c == c' -> return $ Injectivity k a d pars ixs c+        (Con c _ _   , Con c' _ _  ) -> return $ Conflict k a d pars u v+        (Var i []  , v         ) -> ifOccursStronglyRigid i v $ return $ Cycle k a d pars i v+        (u         , Var j []  ) -> ifOccursStronglyRigid j u $ return $ Cycle k a d pars j u+        _ -> mzero+    _ -> mzero+  where+    ifOccursStronglyRigid i u ret = do+        -- Call forceNotFree to reduce u as far as possible+        -- around any occurrences of i+        (_ , u) <- forceNotFree (singleton i) u+        case flexRigOccurrenceIn i u of+          Just StronglyRigid -> ret+          _ -> mzero++checkEqualityStrategy :: Int -> UnifyStrategy+checkEqualityStrategy k s = do+  let Equal Dom{unDom = a} u v = getEquality k s+      n = eqCount s+  ha <- fromMaybeMP $ isHom n a+  return $ Deletion k ha u v++literalStrategy :: Int -> UnifyStrategy+literalStrategy k s = do+  let n = eqCount s+  Equal Dom{unDom = a} u v <- eqUnLevel $ getEquality k s+  ha <- fromMaybeMP $ isHom n a+  (u, v) <- reduce (u, v)+  case (u , v) of+    (Lit l1 , Lit l2)+     | l1 == l2  -> return $ Deletion k ha u v+     | otherwise -> return $ LitConflict k ha l1 l2+    _ -> mzero++etaExpandVarStrategy :: Int -> UnifyStrategy+etaExpandVarStrategy k s = do+  Equal Dom{unDom = a} u v <- eqUnLevel =<< getReducedEquality k s+  shouldEtaExpand u v a s `mplus` shouldEtaExpand v u a s+  where+    -- TODO: use IsEtaVar to check if the term is a variable+    shouldEtaExpand :: Term -> Term -> Type -> UnifyStrategy+    shouldEtaExpand (Var i es) v a s = do+      fi       <- fromMaybeMP $ findFlexible i (flexVars s)+      reportSDoc "tc.lhs.unify" 50 $+        "Found flexible variable " <+> text (show i)+      -- Issue 2888: Do this if there are only projections or if it's a singleton+      -- record or if it's unified against a record constructor term. Basically+      -- we need to avoid EtaExpandEquation if EtaExpandVar is possible, or the+      -- forcing translation is unhappy.+      let k  = varCount s - 1 - i -- position of var i in telescope+          b0 = unDom $ getVarTypeUnraised k s+      b         <- addContext (telFromList $ take k $ telToList $ varTel s) $ reduce b0+      (d, pars) <- catMaybesMP $ isEtaRecordType b+      ps        <- fromMaybeMP $ allProjElims es+      guard =<< orM+        [ pure $ not $ null ps+        , isRecCon v  -- is the other term a record constructor?+        , (Right True ==) <$> runBlocked (isSingletonRecord d pars)+        ]+      reportSDoc "tc.lhs.unify" 50 $+        "with projections " <+> prettyTCM (map snd ps)+      reportSDoc "tc.lhs.unify" 50 $+        "at record type " <+> prettyTCM d+      return $ EtaExpandVar fi d pars+    shouldEtaExpand _ _ _ _ = mzero++    isRecCon (Con c _ _) = isJust <$> isRecordConstructor (conName c)+    isRecCon _           = return False++etaExpandEquationStrategy :: Int -> UnifyStrategy+etaExpandEquationStrategy k s = do+  -- Andreas, 2019-02-23, re #3578, is the following reduce redundant?+  Equal Dom{unDom = a} u v <- getReducedEqualityUnraised k s+  (d, pars) <- catMaybesMP $ addContext tel $ isEtaRecordType a+  guard =<< orM+    [ (Right True ==) <$> runBlocked (isSingletonRecord d pars)+    , shouldProject u+    , shouldProject v+    ]+  return $ EtaExpandEquation k d pars+  where+    shouldProject :: PureTCM m => Term -> m Bool+    shouldProject = \case+      Def f es   -> usesCopatterns f+      Con c _ _  -> isJust <$> isRecordConstructor (conName c)++      Var _ _    -> return False+      Lam _ _    -> __IMPOSSIBLE__+      Lit _      -> __IMPOSSIBLE__+      Pi _ _     -> __IMPOSSIBLE__+      Sort _     -> __IMPOSSIBLE__+      Level _    -> __IMPOSSIBLE__+      MetaV _ _  -> return False+      DontCare _ -> return False+      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++    tel = varTel s `abstract` telFromList (take k $ telToList $ eqTel s)++simplifySizesStrategy :: Int -> UnifyStrategy+simplifySizesStrategy k s = do+  isSizeName <- isSizeNameTest+  Equal Dom{unDom = a} u v <- getReducedEquality k s+  case unEl a of+    Def d _ -> do+      guard $ isSizeName d+      su <- sizeView u+      sv <- sizeView v+      case (su, sv) of+        (SizeSuc u, SizeSuc v) -> return $ StripSizeSuc k u v+        (SizeSuc u, SizeInf  ) -> return $ StripSizeSuc k u v+        (SizeInf  , SizeSuc v) -> return $ StripSizeSuc k u v+        _ -> mzero+    _ -> mzero++injectiveTypeConStrategy :: Int -> UnifyStrategy+injectiveTypeConStrategy k s = do+  injTyCon <- optInjectiveTypeConstructors <$> pragmaOptions+  guard injTyCon+  eq <- eqUnLevel =<< getReducedEquality k s+  case eq of+    Equal a u@(Def d es) v@(Def d' es') | d == d' -> do+      -- d must be a data, record or axiom+      def <- getConstInfo d+      guard $ case theDef def of+                Datatype{} -> True+                Record{}   -> True+                Axiom{}    -> True+                DataOrRecSig{} -> True+                AbstractDefn{} -> False -- True triggers issue #2250+                Function{}   -> False+                Primitive{}  -> False+                PrimitiveSort{} -> __IMPOSSIBLE__+                GeneralizableVar{} -> __IMPOSSIBLE__+                Constructor{} -> __IMPOSSIBLE__  -- Never a type!+      let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'+      return $ TypeConInjectivity k d us vs+    _ -> mzero++injectivePragmaStrategy :: Int -> UnifyStrategy+injectivePragmaStrategy k s = do+  eq <- eqUnLevel =<< getReducedEquality k s+  case eq of+    Equal a u@(Def d es) v@(Def d' es') | d == d' -> do+      -- d must have an injective pragma+      def <- getConstInfo d+      guard $ defInjective def+      let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+          vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es'+      return $ TypeConInjectivity k d us vs+    _ -> mzero++skipIrrelevantStrategy :: Int -> UnifyStrategy+skipIrrelevantStrategy k s = do+  let Equal a _ _ = getEquality k s                                 -- reduce not necessary+  addContext (varTel s `abstract` eqTel s) $+    guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a)  -- reduction takes place here+  -- TODO: do something in case the above is blocked (i.e. `Left b`)+  return $ SkipIrrelevantEquation k+++----------------------------------------------------+-- Actually doing the unification+----------------------------------------------------++unifyStep+  :: UnifyState -> UnifyStep -> UnifyStepT TCM (UnificationResult' UnifyState)+unifyStep s Deletion{ deleteAt = k , deleteType = a , deleteLeft = u , deleteRight = v } = do+    -- Check definitional equality of u and v+    isReflexive <- addContext (varTel s) $ pureEqualTermB a u v+    withoutK <- withoutKOption+    splitOnStrict <- asksTC envSplitOnStrict+    case isReflexive of+      Left block   -> return $ UnifyBlocked block+      Right False  -> return $ UnifyStuck []+      Right True | withoutK && not splitOnStrict+                   -> return $ UnifyStuck [UnifyReflexiveEq (varTel s) a u]+      Right True   -> do+        let (s', sigma) = solveEq k u s+        tellUnifyProof sigma+        Unifies <$> lensEqTel reduce s'++unifyStep s step@Solution{} = solutionStep RetryNormalised s step++unifyStep s (Injectivity k a d pars ixs c) = do+  ifM (consOfHIT $ conName c) (return $ UnifyStuck []) $ do+  withoutK <- withoutKOption++  -- Split equation telescope into parts before and after current equation+  let (eqListTel1, _ : eqListTel2) = splitAt k $ telToList $ eqTel s+      (eqTel1, eqTel2) = (telFromList eqListTel1, telFromList eqListTel2)++  -- Get constructor telescope and target indices+  cdef  <- getConInfo c+  let ctype  = defType cdef `piApply` pars+  addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $+    "Constructor type: " <+> prettyTCM ctype+  TelV ctel ctarget <- addContext (varTel s `abstract` eqTel1) $ telView ctype+  let cixs = case unEl ctarget of+               Def d' es | d == d' ->+                 let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+                 in  drop (length pars) args+               _ -> __IMPOSSIBLE__++  -- Get index telescope of the datatype+  dtype    <- (`piApply` pars) . defType <$> getConstInfo d+  addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $+    "Datatype type: " <+> prettyTCM dtype++  -- This is where the magic of higher-dimensional unification happens+  -- We need to generalize the indices `ixs` to the target indices of the+  -- constructor `cixs`. This is done by calling the unification algorithm+  -- recursively (this doesn't get stuck in a loop because a type should+  -- never be indexed over itself). Note the similarity with the+  -- computeNeighbourhood function in Agda.TypeChecking.Coverage.+  let hduTel = eqTel1 `abstract` ctel+      notforced = replicate (size hduTel) NotForced++  -- The left inverse computed here is not actually used when computing+  -- a left inverse for the overall match, so as a slight optimisation+  -- we just don't bother computing it. __IMPOSSIBLE__ because that+  -- field in the result is never evaluated.+  res <- lift $ addContext (varTel s) $ unifyIndices' (Just __IMPOSSIBLE__)+           hduTel+           (allFlexVars notforced hduTel)+           (raise (size ctel) dtype)+           (raise (size ctel) ixs)+           cixs+  case res of+    -- Higher-dimensional unification can never end in a conflict,+    -- because `cong c1 ...` and `cong c2 ...` don't even have the+    -- same type for distinct constructors c1 and c2.+    NoUnify _ -> __IMPOSSIBLE__++    -- Higher-dimensional unification is blocked: propagate+    UnifyBlocked block -> return $ UnifyBlocked block++    -- Higher-dimensional unification has failed. If not --without-K,+    -- we can simply ignore the higher-dimensional equations and+    -- simplify the equation as in the non-indexed case.+    UnifyStuck _ | not withoutK -> do+      -- using the same variable names as in the case where hdu succeeds.+      let eqTel1' = eqTel1 `abstract` ctel+          rho1    = raiseS (size ctel)+          ceq     = ConP c noConPatternInfo $ teleNamedArgs ctel+          rho3    = consS ceq rho1+          eqTel2' = applyPatSubst rho3 eqTel2+          eqTel'  = eqTel1' `abstract` eqTel2'+          rho     = liftS (size eqTel2) rho3++      tellUnifyProof rho++      eqTel' <- addContext (varTel s) $ reduce eqTel'++      -- Compute new lhs and rhs by matching the old ones against rho+      (lhs', rhs') <- addContext (varTel s) $ do+        let ps = applySubst rho $ teleNamedArgs $ eqTel s+        (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s+        (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s+        case (lhsMatch, rhsMatch) of+          (Match.Yes _ lhs', Match.Yes _ rhs') -> return+            (reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') lhs',+             reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') rhs')+          _ -> __IMPOSSIBLE__++      return $ Unifies $ s { eqTel = eqTel' , eqLHS = lhs' , eqRHS = rhs' }+++    UnifyStuck _ -> let n           = eqCount s+                        Equal Dom{unDom = a} u v = getEquality k s+                    in return $ UnifyStuck [UnifyIndicesNotVars+                         (varTel s `abstract` eqTel s) a+                         (raise n u) (raise n v) (raise (n-k) ixs)]++    Unifies (eqTel1', rho0, _, _) -> do+      -- Split ps0 into parts for eqTel1 and ctel+      let (rho1, rho2) = splitS (size ctel) rho0++      -- Compute new equation telescope context and substitution+      let ceq     = ConP c noConPatternInfo $ applySubst rho2 $ teleNamedArgs ctel+          rho3    = consS ceq rho1+          eqTel2' = applyPatSubst rho3 eqTel2+          eqTel'  = eqTel1' `abstract` eqTel2'+          rho     = liftS (size eqTel2) rho3++      tellUnifyProof rho++      eqTel' <- addContext (varTel s) $ reduce eqTel'++      -- Compute new lhs and rhs by matching the old ones against rho+      (lhs', rhs') <- addContext (varTel s) $ do+        let ps = applySubst rho $ teleNamedArgs $ eqTel s+        (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s+        (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s+        case (lhsMatch, rhsMatch) of+          (Match.Yes _ lhs', Match.Yes _ rhs') -> return+            (reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') lhs',+             reverse $ Match.matchedArgs __IMPOSSIBLE__ (size eqTel') rhs')+          _ -> __IMPOSSIBLE__++      return $ Unifies $ s { eqTel = eqTel' , eqLHS = lhs' , eqRHS = rhs' }++unifyStep s Conflict+  { conflictLeft  = u+  , conflictRight = v+  } =+  case u of+    Con h _ _ -> do+      ifM (consOfHIT $ conName h) (return $ UnifyStuck []) $ do+        return $ NoUnify $ UnifyConflict (varTel s) u v+    _ -> __IMPOSSIBLE__+unifyStep s Cycle+  { cycleVar        = i+  , cycleOccursIn   = u+  } =+  case u of+    Con h _ _ -> do+      ifM (consOfHIT $ conName h) (return $ UnifyStuck []) $ do+        return $ NoUnify $ UnifyCycle (varTel s) i u+    _ -> __IMPOSSIBLE__++unifyStep s EtaExpandVar{ expandVar = fi, expandVarRecordType = d , expandVarParameters = pars } = do+  recd <- fromMaybe __IMPOSSIBLE__ <$> isRecord d+  let delta = _recTel recd `apply` pars+      c     = _recConHead recd+  let nfields         = size delta+      (varTel', rho)  = expandTelescopeVar (varTel s) (m-1-i) delta c+      projectFlexible = [ FlexibleVar (getArgInfo fi) (flexForced fi) (projFlexKind j) (flexPos fi) (i + j) | j <- [0 .. nfields - 1] ]+  tellUnifySubst $ rho+  return $ Unifies $ UState+    { varTel   = varTel'+    , flexVars = projectFlexible ++ liftFlexibles nfields (flexVars s)+    , eqTel    = applyPatSubst rho $ eqTel s+    , eqLHS    = applyPatSubst rho $ eqLHS s+    , eqRHS    = applyPatSubst rho $ eqRHS s+    }+  where+    i = flexVar fi+    m = varCount s++    projFlexKind :: Int -> FlexibleVarKind+    projFlexKind j = case flexKind fi of+      RecordFlex ks -> indexWithDefault ImplicitFlex ks j+      ImplicitFlex  -> ImplicitFlex+      DotFlex       -> DotFlex+      OtherFlex     -> OtherFlex++    liftFlexible :: Int -> Int -> Maybe Int+    liftFlexible n j = if j == i then Nothing else Just (if j > i then j + (n-1) else j)++    liftFlexibles :: Int -> FlexibleVars -> FlexibleVars+    liftFlexibles n fs = mapMaybe (traverse $ liftFlexible n) fs++unifyStep s EtaExpandEquation{ expandAt = k, expandRecordType = d, expandParameters = pars } = do+  recd  <- fromMaybe __IMPOSSIBLE__ <$> isRecord d+  let delta = _recTel recd `apply` pars+      c     = _recConHead recd+  lhs   <- expandKth $ eqLHS s+  rhs   <- expandKth $ eqRHS s+  let (tel, sigma) = expandTelescopeVar (eqTel s) k delta c+  tellUnifyProof sigma+  Unifies <$> do+   lensEqTel reduce $ s+    { eqTel    = tel+    , eqLHS    = lhs+    , eqRHS    = rhs+    }+  where+    expandKth us = do+      let (us1,v:us2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt k us+      vs <- snd <$> etaExpandRecord d pars (unArg v)+      vs <- reduce vs+      return $ us1 ++ vs ++ us2++unifyStep s LitConflict+  { litType          = a+  , litConflictLeft  = l+  , litConflictRight = l'+  } = return $ NoUnify $ UnifyConflict (varTel s) (Lit l) (Lit l')++unifyStep s (StripSizeSuc k u v) = do+  sizeTy <- sizeType+  sizeSu <- sizeSuc 1 (var 0)+  let n          = eqCount s+      sub        = liftS (n-k-1) $ consS sizeSu $ raiseS 1+      eqFlatTel  = flattenTel $ eqTel s+      eqFlatTel' = applySubst sub $ updateAt k (fmap $ const sizeTy) $ eqFlatTel+      eqTel'     = unflattenTel (teleNames $ eqTel s) eqFlatTel'+  -- TODO: tellUnifyProof sub+  -- but sizeSu is not a constructor, so sub is not a PatternSubstitution!+  return $ Unifies $ s+    { eqTel = eqTel'+    , eqLHS = updateAt k (const $ defaultArg u) $ eqLHS s+    , eqRHS = updateAt k (const $ defaultArg v) $ eqRHS s+    }++unifyStep s (SkipIrrelevantEquation k) = do+  let lhs = eqLHS s+      (s', sigma) = solveEq k (DontCare $ unArg $ indexWithDefault __IMPOSSIBLE__ lhs k) s+  tellUnifyProof sigma+  return $ Unifies s'++unifyStep s (TypeConInjectivity k d us vs) = do+  dtype <- defType <$> getConstInfo d+  TelV dtel _ <- telView dtype+  let deq = Def d $ map Apply $ teleArgs dtel+  -- TODO: tellUnifyProof ???+  -- but d is not a constructor...+  Unifies <$> do+   lensEqTel reduce $ s+    { eqTel = dtel `abstract` applyUnder k (eqTel s) (raise k deq)+    , eqLHS = us ++ dropAt k (eqLHS s)+    , eqRHS = vs ++ dropAt k (eqRHS s)+    }++data RetryNormalised = RetryNormalised | DontRetryNormalised+  deriving (Eq, Show)++solutionStep+  :: (PureTCM m, MonadWriter UnifyOutput m)+  => RetryNormalised+  -> UnifyState+  -> UnifyStep+  -> m (UnificationResult' UnifyState)+solutionStep retry s+  step@Solution{ solutionAt   = k+               , solutionType = dom@Dom{ unDom = a }+               , solutionVar  = fi@FlexibleVar{ flexVar = i }+               , solutionTerm = u } = do+  let m = varCount s++  -- Now we have to be careful about forced variables in `u`. If they appear+  -- in pattern positions we need to bind them there rather in their forced positions. We can safely+  -- ignore non-pattern positions and forced pattern positions, because in that case there will be+  -- other equations where the variable can be bound.+  -- NOTE: If we're doing make-case we ignore forced variables. This is safe since we take the+  -- result of unification and build user clauses that will be checked again with forcing turned on.+  inMakeCase <- viewTC eMakeCase+  let forcedVars | inMakeCase = IntMap.empty+                 | otherwise  = IntMap.fromList [ (flexVar fi, getModality fi) | fi <- flexVars s,+                                                                                 flexForced fi == Forced ]+  (p, bound) <- patternBindingForcedVars forcedVars u++  -- To maintain the invariant that each variable in varTel is bound exactly once in the pattern+  -- substitution we need to turn the bound variables in `p` into dot patterns in the rest of the+  -- substitution.+  let dotSub = foldr composeS idS [ inplaceS i (dotP (Var i [])) | i <- IntMap.keys bound ]++  -- We moved the binding site of some forced variables, so we need to update their modalities in+  -- the telescope. The new modality is the combination of the modality of the variable we are+  -- instantiating and the modality of the binding site in the pattern (returned by+  -- patternBindingForcedVars).+  let updModality md vars tel+        | IntMap.null vars = tel+        | otherwise        = telFromList $ zipWith upd (downFrom $ size tel) (telToList tel)+        where+          upd i a | Just md' <- IntMap.lookup i vars = setModality (composeModality md md') a+                  | otherwise                        = a+  s <- return $ s { varTel = updModality (getModality fi) bound (varTel s) }++  reportSDoc "tc.lhs.unify.force" 45 $ vcat+    [ "forcedVars =" <+> pretty (IntMap.keys forcedVars)+    , "u          =" <+> prettyTCM u+    , "p          =" <+> prettyTCM p+    , "bound      =" <+> pretty (IntMap.keys bound)+    , "dotSub     =" <+> pretty dotSub ]++  -- Check that the type of the variable is equal to the type of the equation+  -- (not just a subtype), otherwise we cannot instantiate (see Issue 2407).+  let dom'@Dom{ unDom = a' } = getVarType (m-1-i) s+  equalTypes <- addContext (varTel s) $ do+    reportSDoc "tc.lhs.unify" 45 $ "Equation type: " <+> prettyTCM a+    reportSDoc "tc.lhs.unify" 45 $ "Variable type: " <+> prettyTCM a'+    pureEqualTypeB a a'++  -- The conditions on the relevances are as follows (see #2640):+  -- - If the type of the equation is relevant, then the solution must be+  --   usable in a relevant position.+  -- - If the type of the equation is (shape-)irrelevant, then the solution+  --   must be usable in a μ-relevant position where μ is the relevance+  --   of the variable being solved.+  --+  -- Jesper, Andreas, 2018-10-17: the quantity of the equation is morally+  -- always @Quantity0@, since the indices of the data type are runtime erased.+  -- Thus, we need not change the quantity of the solution.+  envmod <- currentModality+  let eqrel  = getRelevance dom+      eqmod  = getModality dom+      varmod = getModality dom'+      mod    = applyUnless (shapeIrrelevant `moreRelevant` eqrel) (setRelevance eqrel)+             $ applyUnless (usableQuantity envmod) (setQuantity zeroQuantity)+             $ varmod+  reportSDoc "tc.lhs.unify" 65 $ text $ "Equation modality: " ++ show (getModality dom)+  reportSDoc "tc.lhs.unify" 65 $ text $ "Variable modality: " ++ show varmod+  reportSDoc "tc.lhs.unify" 65 $ text $ "Solution must be usable in a " ++ show mod ++ " position."+  -- Andreas, 2018-10-18+  -- Currently, the modality check has problems with meta-variables created in the type signature,+  -- and thus, in quantity 0, that get into terms using the unifier, and there are checked to be+  -- non-erased, i.e., have quantity ω.+  -- Ulf, 2019-12-13. We still do it though.+  -- Andrea, 2020-10-15: It looks at meta instantiations now.+  eusable <- addContext (varTel s) $ runExceptT $ usableMod mod u+  caseEitherM (return eusable) (return . UnifyBlocked) $ \ usable -> do++  reportSDoc "tc.lhs.unify" 45 $ "Modality ok: " <+> prettyTCM usable+  unless usable $ reportSDoc "tc.lhs.unify" 65 $ "Rejected solution: " <+> prettyTCM u++  -- We need a Flat equality to solve a Flat variable.+  -- This also ought to take care of the need for a usableCohesion check.+  if not (getCohesion eqmod `moreCohesion` getCohesion varmod) then return $ UnifyStuck [] else do++  case equalTypes of+    Left block  -> return $ UnifyBlocked block+    Right False -> return $ UnifyStuck []+    Right True | usable ->+      case solveVar (m - 1 - i) p s of+        Nothing | retry == RetryNormalised -> do+          u <- normalise u+          s <- lensVarTel normalise s+          solutionStep DontRetryNormalised s step{ solutionTerm = u }+        Nothing ->+          return $ UnifyStuck [UnifyRecursiveEq (varTel s) a i u]+        Just (s', sub) -> do+          let rho = sub `composeS` dotSub+          tellUnifySubst rho+          let (s'', sigma) = solveEq k (applyPatSubst rho u) s'+          tellUnifyProof sigma+          return $ Unifies s''+          -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce+          -- Unifies <$> liftTCM (reduce s'')+    Right True -> return $ UnifyStuck [UnifyUnusableModality (varTel s) a i u mod]+solutionStep _ _ _ = __IMPOSSIBLE__++unify :: UnifyState -> UnifyStrategy -> UnifyLogT TCM (UnificationResult' UnifyState)+unify s strategy = if isUnifyStateSolved s+                   then return $ Unifies s+                   else tryUnifyStepsAndContinue (strategy s)+  where+    tryUnifyStepsAndContinue+      :: ListT TCM UnifyStep -> UnifyLogT TCM (UnificationResult' UnifyState)+    tryUnifyStepsAndContinue steps = do+      x <- foldListT tryUnifyStep failure (liftListT lift steps)+      case x of+        Unifies s'     -> unify s' strategy+        NoUnify err    -> return $ NoUnify err+        UnifyBlocked b -> return $ UnifyBlocked b+        UnifyStuck err -> return $ UnifyStuck err++    tryUnifyStep :: UnifyStep+                 -> UnifyLogT TCM (UnificationResult' UnifyState)+                 -> UnifyLogT TCM (UnificationResult' UnifyState)+    tryUnifyStep step fallback = do+      addContext (varTel s) $+        reportSDoc "tc.lhs.unify" 20 $ "trying unifyStep" <+> prettyTCM step+      (x, output) <- lift $ runWriterT $ unifyStep s step+      case x of+        Unifies s'   -> do+          reportSDoc "tc.lhs.unify" 20 $ "unifyStep successful."+          reportSDoc "tc.lhs.unify" 20 $ "new unifyState:" <+> prettyTCM s'+          -- tell output+          writeUnifyLog $ (UnificationStep s step output,s')+          return x+        NoUnify{}       -> return x+        UnifyBlocked b1 -> do+          y <- fallback+          case y of+            UnifyStuck _    -> return $ UnifyBlocked b1+            UnifyBlocked b2 -> return $ UnifyBlocked $ unblockOnEither b1 b2+            _               -> return y+        UnifyStuck err1 -> do+          y <- fallback+          case y of+            UnifyStuck err2 -> return $ UnifyStuck $ err1 ++ err2+            _               -> return y++    failure :: Monad m => m (UnificationResult' a)+    failure = return $ UnifyStuck []++-- | Turn a term into a pattern while binding as many of the given forced variables as possible (in+--   non-forced positions).+patternBindingForcedVars :: PureTCM m => IntMap Modality -> Term -> m (DeBruijnPattern, IntMap Modality)+patternBindingForcedVars forced v = do+  let v' = precomputeFreeVars_ v+  runWriterT (evalStateT (go unitModality v') forced)+  where+    noForced v = gets $ IntSet.disjoint (precomputedFreeVars v) . IntMap.keysSet++    bind md i = do+      gets (IntMap.lookup i) >>= \case+        Just md' | related md POLE md' -> do+          -- The new binding site must be more relevant (more relevant = smaller).+          -- "The forcing analysis guarantees that there exists such a position."+          -- Really? Andreas, 2021-08-18, issue #5506+          tell   $ IntMap.singleton i md+          modify $ IntMap.delete i+          return $ varP (deBruijnVar i)+        _ -> return $ dotP (Var i [])++    go md v = ifM (noForced v) (return $ dotP v) $ do+      v' <- lift $ lift $ reduce v+      case v' of+        Var i [] -> bind md i  -- we know i is forced+        Con c ci es+          | Just vs <- allApplyElims es -> do+            fs <- defForced <$> getConstInfo (conName c)+            let goArg Forced    v = return $ fmap (unnamed . dotP) v+                goArg NotForced v = fmap unnamed <$> traverse (go $ composeModality md $ getModality v) v+            (ps, bound) <- listen $ zipWithM goArg (fs ++ repeat NotForced) vs+            if IntMap.null bound+              then return $ dotP v  -- bound nothing+              else do+                let cpi = (toConPatternInfo ci) { conPLazy   = True } -- Not setting conPType. Is this a problem?+                return $ ConP c cpi $ map (setOrigin Inserted) ps+          | otherwise -> return $ dotP v   -- Higher constructor (es has IApply)++        -- Non-pattern positions+        Var _ (_:_) -> return $ dotP v+        Lam{}       -> return $ dotP v+        Pi{}        -> return $ dotP v+        Def{}       -> return $ dotP v+        MetaV{}     -> return $ dotP v+        Sort{}      -> return $ dotP v+        Level{}     -> return $ dotP v+        DontCare{}  -> return $ dotP v+        Dummy{}     -> return $ dotP v+        Lit{}       -> return $ dotP v+          -- Andreas, 2023-08-20, issue #6767+          -- The last case is not __IMPOSSIBLE__ (regresssion in 2.6.2).+          -- It would be if we had reduced to `constructorForm`,+          -- however, turning a `LitNat` into constructors would only result in churn,+          -- since literals have no variables that could be bound.
+ src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.LHS.Unify.LeftInverse where++import Prelude hiding ((!!), null)++import Control.Monad+import Control.Monad.State+import Control.Monad.Except++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Names+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Records++import Agda.TypeChecking.Rules.LHS.Problem+import Agda.TypeChecking.Rules.LHS.Unify.Types++import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Size++import Agda.Utils.Impossible++instance PrettyTCM NoLeftInv where+  prettyTCM (UnsupportedYet s) = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is not yet supported"+  prettyTCM UnsupportedCxt     = fwords "it relies on higher-dimensional unification, which is not yet supported"+  prettyTCM (Illegal s)        = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is incompatible with" ++ [text "Cubical Agda"]+  prettyTCM NoCubical          = fwords "Cubical Agda is disabled"+  prettyTCM WithKEnabled       = fwords "The K rule is enabled"+  prettyTCM SplitOnStrict      = fwords "It splits on a type in SSet"+  prettyTCM SplitOnFlat        = fwords "It splits on a @♭ argument"++data NoLeftInv+  = UnsupportedYet {badStep :: UnifyStep}+  | Illegal        {badStep :: UnifyStep}+  | NoCubical+  | WithKEnabled+  | SplitOnStrict  -- ^ splitting on a Strict Set.+  | SplitOnFlat    -- ^ splitting on a @♭ argument+  | UnsupportedCxt+  deriving Show++buildLeftInverse :: (PureTCM tcm, MonadError TCErr tcm) => UnifyState -> UnifyLog -> tcm (Either NoLeftInv (Substitution, Substitution))+buildLeftInverse s0 log = do+  reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do+    cubical <- cubicalOption+    "cubical:" <+> text (show cubical)+  reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do+    pathp <- getTerm' builtinPathP+    "pathp:" <+> text (show $ isJust pathp)+  let cond = andM+       -- TODO: handle open contexts: they happen during "higher dimensional" unification,+       --       in injectivity cases.+       [+         null <$> getContext+       ]+  ifNotM cond (return $ Left UnsupportedCxt) $ do+  equivs <- forM log $ uncurry buildEquiv+  case sequence equivs of+    Left no -> do+      reportSDoc "tc.lhs.unify.inv.badstep" 20 $ "No Left Inverse:" <+> prettyTCM (badStep no)+      return (Left no)+    Right xs -> do+    -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ+    -- Γ,φ,us =_Δ vs, i : I ⊢ leftInv0 : Γ,φ,us =_Δ vs+    -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,φ,refls][τ0] = IdS : Γ,φ,us =_Δ vs+    (tau0,leftInv0) <- case xs of+      [] -> return (idS,raiseS 1)+      xs -> do+        let+            loop [] = __IMPOSSIBLE__+            loop [x] = return $ fst x+            loop (x:xs) = do+              r <- loop xs+              uncurry composeRetract x r+        (_,_,tau,leftInv) <- loop xs+        return (tau,leftInv)+    -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ+    -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,1,refls][τ] = idS : Γ,φ,us =_Δ vs+    let tau = tau0 `composeS` raiseS 1+    unview <- intervalUnview'+    let replaceAt n x xs = xs0 ++ x:xs1+                where (xs0,_:xs1) = splitAt n xs+    let max r s = unview $ IMax (argN r) (argN s)+        neg r = unview $ INeg (argN r)+    let phieq = neg (var 0) `max` var (size (eqTel s0) + 1)+                       -- I + us =_Δ vs -- inplaceS+    let leftInv = termsS __IMPOSSIBLE__ $ replaceAt (size (varTel s0)) phieq $ map (lookupS leftInv0) $ downFrom (size (varTel s0) + 1 + size (eqTel s0))+    let working_tel = abstract (varTel s0) (ExtendTel __DUMMY_DOM__ $ Abs "phi0" $ (eqTel s0))+    reportSDoc "tc.lhs.unify.inv" 20 $ "=== before mod"+    do+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0    :" <+> prettyTCM tau0+        addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0:  " <+> prettyTCM leftInv0++    reportSDoc "tc.lhs.unify.inv" 20 $ "=== after mod"+    do+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM tau+        addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv:   " <+> prettyTCM leftInv++    return $ Right (tau,leftInv)++type Retract = (Telescope, Substitution, Substitution, Substitution)+     -- Γ (the problem, including equalities),+     -- Δ ⊢ ρ : Γ+     -- Γ ⊢ τ : Δ+     -- Γ, i : I ⊢ leftInv : Γ, such that (λi. leftInv) : ρ[τ] = id_Γ++--- Γ ⊢ us : Δ   Γ ⊢ termsS e us : Δ+termsS ::  DeBruijn a => Impossible -> [a] -> Substitution' a+termsS e xs = reverse xs ++# EmptyS e++composeRetract :: (PureTCM tcm, MonadError TCErr tcm, MonadDebug tcm,HasBuiltins tcm, MonadAddContext tcm) => Retract -> Term -> Retract -> tcm Retract+composeRetract (prob0,rho0,tau0,leftInv0) phi0 (prob1,rho1,tau1,leftInv1) = do+  reportSDoc "tc.lhs.unify.inv" 20 $ "=== composing"+  reportSDoc "tc.lhs.unify.inv" 20 $ "Γ0   :" <+> prettyTCM prob0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0  :" <+> prettyTCM tau0+  reportSDoc "tc.lhs.unify.inv" 20 $ "Γ1   :" <+> prettyTCM prob1+  addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau1  :" <+> prettyTCM tau1+++  {-+  Γ0 = prob0+  S0 ⊢ ρ0 : Γ0+  Γ0 ⊢ τ0 : S0+  Γ0 ⊢ leftInv0 : ρ0[τ0] = idΓ0+  Γ0 ⊢ φ0+  Γ0,φ0 ⊢ leftInv0 = refl++  Γ1 = prob1+  S1 ⊢ ρ1 : Γ1+  Γ1 ⊢ τ1 : S1+  Γ1 ⊢ leftInv1 : ρ1[τ1] = idΓ1+  Γ1 ⊢ φ1 = φ0[τ0] (**)+  Γ1,φ1 ⊢ leftInv1 = refl+  S0 = Γ1++  (**) implies?+  Γ0,φ0 ⊢ leftInv1[τ0] = refl  (*)+++  S1 ⊢ ρ := ρ0[ρ1] : Γ0+  Γ0 ⊢ τ := τ1[τ0] : S1+  -}++  let prob = prob0+  let rho = rho1 `composeS` rho0+  let tau = tau0 `composeS` tau1++  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau  :" <+> prettyTCM tau++  {-+  Γ0 ⊢ leftInv : ρ[τ] = idΓ0+  Γ0 ⊢ leftInv : ρ0[ρ1[τ1]][τ0] = idΓ0+  Γ0 ⊢ step0 := ρ0[leftInv1[τ0]] : ρ0[ρ1[τ1]][τ0] = ρ0[τ0]++  Γ0,φ0 ⊢ step0 = refl     by (*)+++  Γ0 ⊢ leftInv := step0 · leftInv0 : ρ0[ρ1[τ1]][τ0] = idΓ0++  Γ0 ⊢ leftInv := tr (\ i → ρ0[ρ1[τ1]][τ0] = leftInv0[i]) φ0 step0+  Γ0,φ0 ⊢ leftInv = refl  -- because it will become step0, which is refl when φ0++  Γ0, i : I ⊢ hcomp {Γ0} (\ j → \ { (i = 0) -> ρ0[ρ1[τ1]][τ0]+                                  ; (i = 1) -> leftInv0[j]+                                  ; (φ0 = 1) -> γ0+                                  })+                         (step0[i])+++++  -}+  let step0 = liftS 1 tau0 `composeS` leftInv1 `composeS` rho0++  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0  :" <+> prettyTCM leftInv0+  addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rho0  :" <+> prettyTCM rho0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0  :" <+> prettyTCM tau0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rhos0[tau0]  :" <+> prettyTCM (tau0 `composeS` rho0)++  addContext prob1 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv1  :" <+> prettyTCM leftInv1+  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "step0  :" <+> prettyTCM step0++  interval <- primIntervalType+  max <- primIMax+  neg <- primINeg+  result <- sequenceA <$> do+    addContext prob0 $ runNamesT (teleNames prob0) $ do+             phi <- open phi0+             g0 <- open $ raise (size prob0) prob0+             step0 <- open $ Abs "i" $ step0 `applySubst` teleArgs prob0+             leftInv0 <- open $ Abs "i" $ map unArg $ leftInv0 `applySubst` teleArgs prob0+             bind "i" $ \ i -> addContext ("i" :: String, defaultDom interval) $ do+              tel <- bind "_" $ \ (_ :: NamesT tcm Term) -> g0+              step0i <- lazyAbsApp <$> step0 <*> i+              face <- pure max <@> (pure neg <@> i) <@> phi+              leftInv0 <- leftInv0+              i <- i+              -- this composition could be optimized further whenever step0i is actually constant in i.+              lift $ runExceptT (map unArg <$> transpSysTel' True tel [(i, leftInv0)] face step0i)+  leftInv <- case result of+    Right x  -> pure x+    Left cl -> do+      reportSDoc "impossible" 10 $ vcat+        [ "transpSysTel' errored with term"+        , prettyTCM cl+        ]+      __IMPOSSIBLE__++  let sigma = termsS __IMPOSSIBLE__ $ absBody leftInv+  verboseS "tc.lhs.unify.inv" 20 do+    addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) do+      reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv    :" <+> prettyTCM (absBody leftInv)+      reportSDoc "tc.lhs.unify.inv" 40 $ "leftInv    :" <+> pretty (absBody leftInv)+      reportSDoc "tc.lhs.unify.inv" 40 $ "leftInvSub :" <+> pretty sigma+  return (prob, rho, tau, sigma)++buildEquiv :: forall tcm. (PureTCM tcm, MonadError TCErr tcm) => UnifyLogEntry -> UnifyState -> tcm (Either NoLeftInv (Retract,Term))+buildEquiv (UnificationStep st step@(Solution k ty fx tm side) output) next = runExceptT $ do+        let+          errorToUnsupported :: ExceptT a tcm b -> ExceptT NoLeftInv tcm b+          errorToUnsupported m = withExceptT (\ _ -> UnsupportedYet step) m+        reportSDoc "tc.lhs.unify.inv" 20 $ "step unifyState:" <+> prettyTCM st+        reportSDoc "tc.lhs.unify.inv" 20 $ "step step:" <+> addContext (varTel st) (prettyTCM step)+        unview <- intervalUnview'+        cxt <- getContextTelescope+        reportSDoc "tc.lhs.unify.inv" 20 $ "context:" <+> prettyTCM cxt+        let+          -- k counds in eqs from the left+          m = varCount st+          gamma = varTel st+          eqs = eqTel st+          u = eqLHS st !! k+          v = eqRHS st !! k+          x = flexVar fx+          neqs = size eqs+          phis = 1 -- neqs+        interval <- lift $ primIntervalType+         -- Γ, φs : I^phis+        let gamma_phis = abstract gamma $ telFromList $+              map (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1]+        working_tel <- abstract gamma_phis <$>+          errorToUnsupported (pathTelescope' (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st))+        reportSDoc "tc.lhs.unify.inv" 20 $ vcat+          [ "working tel:" <+> prettyTCM (working_tel :: Telescope)+          , addContext working_tel $ "working tel args:" <+> prettyTCM (teleArgs working_tel :: [Arg Term])+          ]+        (tau,leftInv,phi) <- addContext working_tel $ runNamesT [] $ do+          let raiseFrom tel x = raise (size working_tel - size tel) x+          u <- open . raiseFrom gamma . unArg $ u+          v <- open . raiseFrom gamma . unArg $ v+          -- φ+          let phi = raiseFrom gamma_phis $ var 0+          -- working_tel ⊢ γ₁,x,γ₂,φ,eqs+          let all_args = teleArgs working_tel+          -- Γ₁,x : A,Γ₂+--          gamma <- open $ raiseFrom EmptyTel gamma+          -- -- γ₁,x,γ₂,φ,eqs : W+          -- working_tel <- open $ raiseFrom EmptyTel working_tel++          -- eq_tel <- open $ raiseFrom gamma (eqTel st)++          -- [lhs,rhs] <- mapM (open . raiseFrom gamma) [eqLHS st,eqRHS st]+          let bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2)+          -- . ⊢ Γ₁  ,  γ₁. (x : A),Γ₂,φ : I,[lhs ≡ rhs]+          let (gamma1, xxi) = bindSplit $ splitTelescopeAt (size gamma - x - 1) working_tel+          let (gamma1_args,xxi_args) = splitAt (size gamma1) all_args+              (_x_arg:xi_args) = xxi_args+              (x_arg:xi0,k_arg:xi1) = splitAt ((size gamma - size gamma1) + phis + k) xxi_args+              -- W ⊢ (x : A),Γ₂,φ : I,[lhs ≡ rhs]+          let+            xxi_here :: Telescope+            xxi_here = absAppN xxi $ map unArg gamma1_args+          --                                                      x:A,Γ₂                φ+          let (xpre,krest) = bindSplit $ splitTelescopeAt ((size gamma - size gamma1) + phis + k) xxi_here+          k_arg <- open $ unArg k_arg+          xpre <- open xpre+          krest <- open krest+          delta <- bindN ["x","eq"] $ \ [x,eq] -> do+                     let pre = apply1 <$> xpre <*> x+                     abstractN pre $ \ args ->+                       apply1 <$> applyN krest (x:args) <*> eq+--          let delta_zero = absAppN delta $ map unArg [x_arg,k_arg]+          let d_zero_args = xi0 ++ xi1+          reportSDoc "tc.lhs.unify.inv" 20 $ "size delta:" <+> text (show $ size $ unAbsN delta)+          reportSDoc "tc.lhs.unify.inv" 20 $ "size d0args:" <+> text (show $ size d_zero_args)+          let appSide = case side of+                          Left{} -> id+                          Right{} -> unview . INeg . argN+          let+                  -- csingl :: NamesT tcm Term -> NamesT tcm [Arg Term]+                  csingl i = mapM (fmap defaultArg) $ csingl' i+                  -- csingl' :: NamesT tcm Term -> [NamesT tcm Term]+                  csingl' i = [ k_arg <@@> (u, v, appSide <$> i)+                              , lam "j" $ \ j ->+                                  let r i j = case side of+                                            Left{} -> unview (IMax (argN j) (argN i))+                                            Right{} -> unview (IMin (argN j) (argN . unview $ INeg $ argN i))+                                  in k_arg <@@> (u, v, r <$> i <*> j)+                              ]+          let replaceAt n x xs = xs0 ++ x:xs1+                where (xs0,_:xs1) = splitAt n xs+              dropAt n xs = xs0 ++ xs1+                where (xs0,_:xs1) = splitAt n xs+          delta <- open delta+          d <- bind "i" $ \ i -> applyN delta (csingl' i)++          -- Andrea 06/06/2018+          -- We do not actually add a transp/fill if the family is+          -- constant (TODO: postpone for metas) This is so variables+          -- whose types do not depend on "x" are left alone, in+          -- particular those the solution "t" depends on.+          --+          -- We might want to instead use the info discovered by the+          -- solver when checking if "t" depends on "x" to decide what+          -- to transp and what not to.+          let flag = True+                 {-   φ -}+          tau <- {-dropAt (size gamma - 1 + k) .-} (gamma1_args ++) <$>+                                                   lift (errorToUnsupported (transpTel' flag d phi d_zero_args))+          reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM (map (setHiding NotHidden) tau)+          leftInv <- do+            gamma1_args <- open gamma1_args+            phi <- open phi+            -- xxi_here <- open xxi_here+            -- (xi_here_f :: Abs Telescope) <- bind "i" $ \ i -> apply <$> xxi_here <*> (take 1 `fmap` csingl i)+            -- xi_here_f <- open xi_here_f+            -- xi_args <- open xi_args+            -- xif <- bind "i" $ \ i -> do+            --                      m <- (runExceptT <$> (trFillTel' flag <$> xi_here_f <*> phi <*> xi_args <*> i))+            --                      either __IMPOSSIBLE__ id <$> lift m+            -- xif <- open xif++            xi0 <- open xi0+            xi1 <- open xi1+            delta0 <- bind "i" $ \ i -> apply <$> xpre <*> (take 1 `fmap` csingl i)+            delta0 <- open delta0+            xi0f <- bind "i" $ \ i -> do+                                 m <- trFillTel' flag <$> delta0 <*> phi <*> xi0 <*> i+                                 lift (errorToUnsupported m)+            xi0f <- open xi0f++            delta1 <- bind "i" $ \ i -> do++                   args <- mapM (open . unArg) =<< (lazyAbsApp <$> xi0f <*> i)+                   apply <$> applyN krest (take 1 (csingl' i) ++ args) <*> (drop 1 `fmap` csingl i)+            delta1 <- open delta1+            xi1f <- bind "i" $ \ i -> do+                                 m <- trFillTel' flag <$> delta1 <*> phi <*> xi1 <*> i+                                 lift (errorToUnsupported m)+            xi1f <- open xi1f+            fmap absBody $ bind "i" $ \ i' -> do+              let (+++) m = liftM2 (++) m+                  i = cl (lift primINeg) <@> i'+--              replaceAt (size gamma + k) <$> (fmap defaultArg $ cl primIMax <@> phi <@> i) <*> do+              do+                gamma1_args +++ (take 1 `fmap` csingl i +++ ((lazyAbsApp <$> xi0f <*> i) +++ (drop 1 `fmap` csingl i +++ (lazyAbsApp <$> xi1f <*> i))))+          return (tau,leftInv,phi)+        iz <- lift $ primIZero+        io <- lift $ primIOne+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM (map (setHiding NotHidden) tau)+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tauS   :" <+> prettyTCM (termsS __IMPOSSIBLE__ $ map unArg tau)+        addContext working_tel $ addContext ("r" :: String, defaultDom interval)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv:   " <+> prettyTCM (map (setHiding NotHidden) leftInv)+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[0]:" <+> (prettyTCM =<< reduce (subst 0 iz $ map (setHiding NotHidden) leftInv))+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[1]:" <+> (prettyTCM =<< reduce  (subst 0 io $ map (setHiding NotHidden) leftInv))+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "[rho]tau :" <+>+                                                                                  -- k   φ+          prettyTCM (applySubst (termsS __IMPOSSIBLE__ $ map unArg tau) $ fromPatternSubstitution+                                                                      $ raise (size (eqTel st) - 1{-k-} + phis {-neqs{-φs-} - 1{-φ0-}-})+                                                                      $ unifySubst output)+        reportSDoc "tc.lhs.unify.inv" 20 $ "."+        let rho0 = fromPatternSubstitution $ unifySubst output+        addContext (varTel next) $ addContext (eqTel next) $ reportSDoc "tc.lhs.unify.inv" 20 $+          "prf :" <+> prettyTCM (fromPatternSubstitution $ unifyProof output)+        let c0 = Lam defaultArgInfo $ Abs "i" $ raise 1 $ lookupS (fromPatternSubstitution $ unifyProof output) (neqs - k - 1)+        let c = liftS (size $ eqTel next) (raiseS 1) `applySubst` c0+        addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+          reportSDoc "tc.lhs.unify.inv" 20 $ "c :" <+> prettyTCM c+--        let rho = liftS (neqs - k - 1) $ consS (raise (1 + k) c) $ liftS (1 + k) rho0+        let rho = singletonS (neqs - k - 1) c  `composeS` liftS (1 + neqs) rho0+        reportSDoc "tc.lhs.unify.inv" 20 $ text "old_sizes: " <+> pretty (size $ varTel st, size $ eqTel st)+        reportSDoc "tc.lhs.unify.inv" 20 $ text "new_sizes: " <+> pretty (size $ varTel next, size $ eqTel next)+--        addContext (abstract (varTel next) $ ExtendTel __DUMMY_DOM__ (Abs "φ" $ raise 1 $ eqTel next)) $+        addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+          reportSDoc "tc.lhs.unify.inv" 20 $ "rho   :" <+> prettyTCM rho+        return $ ((working_tel+                 , rho+                 , termsS __IMPOSSIBLE__ $ map unArg tau+                 , termsS __IMPOSSIBLE__ $ map unArg leftInv)+                 , phi)+buildEquiv (UnificationStep st step@(EtaExpandVar fv _d _args) output) next = fmap Right $ do+        reportSDoc "tc.lhs.unify.inv" 20 "buildEquiv EtaExpandVar"+        let+          gamma = varTel st+          eqs = eqTel st+          x = flexVar fv+          neqs = size eqs+          phis = 1+        interval <- primIntervalType+         -- Γ, φs : I^phis+        let gamma_phis = abstract gamma $ telFromList $+              map (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1]+        working_tel <- abstract gamma_phis <$>+          pathTelescope (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st)+        let raiseFrom tel x = (size working_tel - size tel) + x+        let phi = var $ raiseFrom gamma_phis 0++        caseMaybeM (expandRecordVar (raiseFrom gamma x) working_tel) __IMPOSSIBLE__ $ \ (_,tau,rho,_) -> do+          reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau    :" <+> prettyTCM tau+          return $ ((working_tel,rho,tau,raiseS 1),phi)++buildEquiv (UnificationStep st step output) _ = do+  reportSDoc "tc.lhs.unify.inv" 20 $ "steps"+  let illegal     = return $ Left $ Illegal step+      unsupported = return $ Left $ UnsupportedYet step+  case step of+    Deletion{}           -> illegal+    TypeConInjectivity{} -> illegal+    -- These should end up in a NoUnify+    Conflict{}    -> __IMPOSSIBLE__+    LitConflict{} -> __IMPOSSIBLE__+    Cycle{}       -> __IMPOSSIBLE__+    _ -> unsupported++{-# SPECIALIZE explainStep :: UnifyStep -> TCM Doc #-}+explainStep :: MonadPretty m => UnifyStep -> m Doc+explainStep Injectivity{injectConstructor = ch} =+  "injectivity of the data constructor" <+> prettyTCM (conName ch)+explainStep TypeConInjectivity{} = "injectivity of type constructors"+explainStep Deletion{}           = "the K rule"+explainStep Solution{}           = "substitution in Setω"+-- Note: this is the actual reason that a Solution step can fail, rather+-- than the explanation for the actual step+explainStep Conflict{}          = "the disjointness of data constructors"+explainStep LitConflict{}       = "the disjointness of literal values"+explainStep Cycle{}             = "the impossibility of cyclic values"+explainStep EtaExpandVar{}      = "eta-expansion of variables"+explainStep EtaExpandEquation{} = "eta-expansion of equations"+explainStep StripSizeSuc{}      = "the injectivity of size successors"+explainStep SkipIrrelevantEquation{} = "ignoring irrelevant equations"
+ src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs view
@@ -0,0 +1,480 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Rules.LHS.Unify.Types where++import Prelude hiding (null)++import Control.Monad+import Control.Monad.Writer (WriterT(..), MonadWriter(..))++import Data.Foldable (toList)+import Data.DList (DList)+import qualified Data.List as List++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.Monad+import Agda.TypeChecking.Level (reallyUnLevelView)+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.TypeChecking.Rules.LHS.Problem++import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible++----------------------------------------------------+-- Equalities+----------------------------------------------------++data Equality = Equal+  { _eqType  :: Dom Type+  , _eqLeft  :: Term+  , _eqRight :: Term+  }++-- Jesper, 2020-01-19: The type type lives in the context of the+-- variables+equations, while the lhs/rhs only depend on the+-- variables, so there is no way to give a correct Reduce instance.+-- WRONG:+-- instance Reduce Equality where+--   reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v++eqConstructorForm :: HasBuiltins m => Equality -> m Equality+eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v++eqUnLevel :: (HasBuiltins m, HasOptions m) => Equality -> m Equality+eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v+  where+    unLevel (Level l) = reallyUnLevelView l+    unLevel u         = return u++----------------------------------------------------+-- Unify state+----------------------------------------------------++data UnifyState = UState+  { varTel   :: Telescope     -- ^ Don't reduce!+  , flexVars :: FlexibleVars+  , eqTel    :: Telescope     -- ^ Can be reduced eagerly.+  , eqLHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).+  , eqRHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).+  } deriving (Show)+-- Issues #3578 and #4125: avoid unnecessary reduction in unifier.++lensVarTel   :: Lens' UnifyState Telescope+lensVarTel   f s = f (varTel s) <&> \ tel -> s { varTel = tel }+{-# INLINE lensVarTel #-}+--UNUSED Liang-Ting Chen 2019-07-16+--lensFlexVars :: Lens' UnifyState FlexibleVars+--lensFlexVars f s = f (flexVars s) <&> \ flex -> s { flexVars = flex }++lensEqTel    :: Lens' UnifyState Telescope+lensEqTel    f s = f (eqTel s) <&> \ x -> s { eqTel = x }+{-# INLINE lensEqTel #-}++--UNUSED Liang-Ting Chen 2019-07-16+--lensEqLHS    :: Lens' UnifyState Args+--lensEqLHS    f s = f (eqLHS s) <&> \ x -> s { eqLHS = x }++--UNUSED Liang-Ting Chen 2019-07-16+--lensEqRHS    :: Lens' UnifyState Args+--lensEqRHS    f s = f (eqRHS s) <&> \ x -> s { eqRHS = x }++-- UNUSED Andreas, 2019-10-14+-- instance Reduce UnifyState where+--   reduce' (UState var flex eq lhs rhs) =+--     UState <$> reduce' var+--            <*> pure flex+--            <*> reduce' eq+--            <*> reduce' lhs+--            <*> reduce' rhs++-- Andreas, 2019-10-14, issues #3578 and #4125:+-- | Don't ever reduce the whole 'varTel', as it will destroy+-- readability of the context in interactive editing!+-- To make sure this insight is not lost, the following+-- dummy instance should prevent a proper 'Reduce' instance for 'UnifyState'.+instance Reduce UnifyState where+  reduce' = __IMPOSSIBLE__++--UNUSED Liang-Ting Chen 2019-07-16+--reduceEqTel :: UnifyState -> TCM UnifyState+--reduceEqTel = lensEqTel reduce++-- UNUSED Andreas, 2019-10-14+-- instance Normalise UnifyState where+--   normalise' (UState var flex eq lhs rhs) =+--     UState <$> normalise' var+--            <*> pure flex+--            <*> normalise' eq+--            <*> normalise' lhs+--            <*> normalise' rhs++instance PrettyTCM UnifyState where+  prettyTCM state = "UnifyState" $$ nest 2 (vcat $+    [ "variable tel:  " <+> prettyTCM gamma+    , "flexible vars: " <+> pshow (map flexVarF $ flexVars state)+    , "equation tel:  " <+> addContext gamma (prettyTCM delta)+    , "equations:     " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state)))+    ])+    where+      flexVarF fi = (flexVar fi, flexForced fi)+      gamma = varTel state+      delta = eqTel state+      prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y++initUnifyState+  :: PureTCM m+  => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState+initUnifyState tel flex a lhs rhs = do+  (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs)+  let n = size lhs+  unless (n == size rhs) __IMPOSSIBLE__+  TelV eqTel _ <- telView a+  unless (n == size eqTel) __IMPOSSIBLE__+  return $ UState tel flex eqTel lhs rhs+  -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce+  -- reduce $ UState tel flex eqTel lhs rhs++isUnifyStateSolved :: UnifyState -> Bool+isUnifyStateSolved = null . eqTel++varCount :: UnifyState -> Int+varCount = size . varTel++-- | Get the type of the i'th variable in the given state+getVarType :: Int -> UnifyState -> Dom Type+getVarType i s = indexWithDefault __IMPOSSIBLE__ (flattenTel $ varTel s) i++getVarTypeUnraised :: Int -> UnifyState -> Dom Type+getVarTypeUnraised i s = snd <$> indexWithDefault __IMPOSSIBLE__ (telToList $ varTel s) i++eqCount :: UnifyState -> Int+eqCount = size . eqTel++-- | Get the k'th equality in the given state. The left- and right-hand sides+--   of the equality live in the varTel telescope, and the type of the equality+--   lives in the varTel++eqTel telescope+getEquality :: Int -> UnifyState -> Equality+getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =+    Equal (indexWithDefault __IMPOSSIBLE__ (flattenTel eqs) k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)++getReducedEquality+  :: (MonadReduce m, MonadAddContext m)+  => Int -> UnifyState -> m Equality+getReducedEquality k s = do+  let Equal a u v = getEquality k s+  addContext (varTel s) $ Equal+    <$> addContext (eqTel s) (reduce a)+    <*> reduce u+    <*> reduce v++-- | As getEquality, but with the unraised type+getEqualityUnraised :: Int -> UnifyState -> Equality+getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =+    Equal (snd <$> indexWithDefault __IMPOSSIBLE__ (telToList eqs) k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)++getReducedEqualityUnraised+  :: (MonadReduce m, MonadAddContext m)+  => Int -> UnifyState -> m Equality+getReducedEqualityUnraised k s = do+  let Equal a u v = getEqualityUnraised k s+  addContext (varTel s) $ Equal+    <$> addContext (telFromList $ take k $ telToList $ eqTel s) (reduce a)+    <*> reduce u+    <*> reduce v++--UNUSED Liang-Ting Chen 2019-07-16+--getEqInfo :: Int -> UnifyState -> ArgInfo+--getEqInfo k UState { eqTel = eqs } =+--  domInfo $ indexWithDefault __IMPOSSIBLE__ (telToList eqs) k+--+---- | Add a list of equations to the front of the equation telescope+--addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState+--addEqs tel us vs s =+--  s { eqTel = tel `abstract` eqTel s+--    , eqLHS = us ++ eqLHS s+--    , eqRHS = vs ++ eqRHS s+--    }+--  where k = size tel+--+--addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState+--addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v]++++-- | Instantiate the k'th variable with the given value.+--   Returns Nothing if there is a cycle.+solveVar :: Int             -- ^ Index @k@+         -> DeBruijnPattern -- ^ Solution @u@+         -> UnifyState -> Maybe (UnifyState, PatternSubstitution)+solveVar k u s = case instantiateTelescope (varTel s) k u of+  Nothing -> Nothing+  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState+      { varTel   = tel'+      , flexVars = permuteFlex (reverseP rho) $ flexVars s+      , eqTel    = applyPatSubst sigma $ eqTel s+      , eqLHS    = applyPatSubst sigma $ eqLHS s+      , eqRHS    = applyPatSubst sigma $ eqRHS s+      }+  where+    permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars+    permuteFlex perm =+      mapMaybe $ \(FlexibleVar ai fc k p x) ->+        FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm)++applyUnder :: Int -> Telescope -> Term -> Telescope+applyUnder k tel u+ | k < 0     = __IMPOSSIBLE__+ | k == 0    = tel `apply1` u+ | otherwise = case tel of+    EmptyTel         -> __IMPOSSIBLE__+    ExtendTel a tel' -> ExtendTel a $+      Abs (absName tel') $ applyUnder (k-1) (absBody tel') u++dropAt :: Int -> [a] -> [a]+dropAt _ [] = __IMPOSSIBLE__+dropAt k (x:xs)+ | k < 0     = __IMPOSSIBLE__+ | k == 0    = xs+ | otherwise = x : dropAt (k-1) xs++-- | Solve the k'th equation with the given value, which can depend on+--   regular variables but not on other equation variables.+solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution)+solveEq k u s = (,sigma) $ s+    { eqTel    = applyUnder k (eqTel s) u'+    , eqLHS    = dropAt k $ eqLHS s+    , eqRHS    = dropAt k $ eqRHS s+    }+  where+    u'    = raise k u+    n     = eqCount s+    sigma = liftS (n-k-1) $ consS (dotP u') idS++--UNUSED Liang-Ting Chen 2019-07-16+---- | Simplify the k'th equation with the given value (which can depend on other+----   equation variables). Returns Nothing if there is a cycle.+--simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution)+--simplifyEq k u s = case instantiateTelescope (eqTel s) k u of+--  Nothing -> Nothing+--  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState+--    { varTel   = varTel s+--    , flexVars = flexVars s+--    , eqTel    = tel'+--    , eqLHS    = permute rho $ eqLHS s+--    , eqRHS    = permute rho $ eqRHS s+--    }+--+----------------------------------------------------+-- Unification strategies+----------------------------------------------------++data UnifyStep+  = Deletion+    { deleteAt           :: Int+    , deleteType         :: Type+    , deleteLeft         :: Term+    , deleteRight        :: Term+    }+  | Solution+    { solutionAt         :: Int+    , solutionType       :: Dom Type+    , solutionVar        :: FlexibleVar Int+    , solutionTerm       :: Term+    , solutionSide       :: Either () ()+      -- ^ side of the equation where the variable is.+    }+  | Injectivity+    { injectAt           :: Int+    , injectType         :: Type+    , injectDatatype     :: QName+    , injectParameters   :: Args+    , injectIndices      :: Args+    , injectConstructor  :: ConHead+    }+  | Conflict+    { conflictAt         :: Int+    , conflictType       :: Type+    , conflictDatatype   :: QName+    , conflictParameters :: Args+    , conflictLeft       :: Term+    , conflictRight      :: Term+    }+  | Cycle+    { cycleAt            :: Int+    , cycleType          :: Type+    , cycleDatatype      :: QName+    , cycleParameters    :: Args+    , cycleVar           :: Int+    , cycleOccursIn      :: Term+    }+  | EtaExpandVar+    { expandVar           :: FlexibleVar Int+    , expandVarRecordType :: QName+    , expandVarParameters :: Args+    }+  | EtaExpandEquation+    { expandAt           :: Int+    , expandRecordType   :: QName+    , expandParameters   :: Args+    }+  | LitConflict+    { litConflictAt      :: Int+    , litType            :: Type+    , litConflictLeft    :: Literal+    , litConflictRight   :: Literal+    }+  | StripSizeSuc+    { stripAt            :: Int+    , stripArgLeft       :: Term+    , stripArgRight      :: Term+    }+  | SkipIrrelevantEquation+    { skipIrrelevantAt   :: Int+    }+  | TypeConInjectivity+    { typeConInjectAt    :: Int+    , typeConstructor    :: QName+    , typeConArgsLeft    :: Args+    , typeConArgsRight   :: Args+    } deriving (Show)++instance PrettyTCM UnifyStep where+  prettyTCM step = case step of+    Deletion k a u v -> "Deletion" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    Solution k a i u s -> "Solution" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "variable:   " <+> text (show (flexVar i, flexPos i, flexForced i, flexKind i))+      , "term:       " <+> prettyTCM u+      , "side:       " <+> text (show s)+      ])+    Injectivity k a d pars ixs c -> "Injectivity" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "indices:    " <+> prettyList_ (map prettyTCM ixs)+      , "constructor:" <+> prettyTCM c+      ])+    Conflict k a d pars u v -> "Conflict" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    Cycle k a d pars i u -> "Cycle" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "variable:   " <+> text (show i)+      , "term:       " <+> prettyTCM u+      ])+    EtaExpandVar fi r pars -> "EtaExpandVar" $$ nest 2 (vcat $+      [ "variable:   " <+> text (show fi)+      , "record type:" <+> prettyTCM r+      , "parameters: " <+> prettyTCM pars+      ])+    EtaExpandEquation k r pars -> "EtaExpandEquation" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "record type:" <+> prettyTCM r+      , "parameters: " <+> prettyTCM pars+      ])+    LitConflict k a u v -> "LitConflict" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    StripSizeSuc k u v -> "StripSizeSuc" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    SkipIrrelevantEquation k -> "SkipIrrelevantEquation" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      ])+    TypeConInjectivity k d us vs -> "TypeConInjectivity" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "datatype:   " <+> prettyTCM d+      , "lhs:        " <+> prettyList_ (map prettyTCM us)+      , "rhs:        " <+> prettyList_ (map prettyTCM vs)+      ])+++----------------------------------------------------+-- Unify Log and monad+----------------------------------------------------++data UnifyLogEntry+ -- = UnificationDone  UnifyState+  = UnificationStep UnifyState UnifyStep UnifyOutput++type UnifyLog = [(UnifyLogEntry,UnifyState)]++-- | This variant of 'UnifyLog' is used to ensure that 'tell' is not+-- expensive.+type UnifyLog' = DList (UnifyLogEntry, UnifyState)++-- Given varΓ ⊢ eqΓ, varΓ ⊢ us, vs : eqΓ+data UnifyOutput = UnifyOutput+  { unifySubst :: PatternSubstitution -- varΓ' ⊢ σ : varΓ+  , unifyProof :: PatternSubstitution -- varΓ',eqΓ' ⊢ ps : eqΓ[σ]+                                      -- varΓ', us' =_eqΓ' vs' ⊢ ap(ps) : us[σ] =_{eqΓ[σ]} vs[σ]+--  , unifyLog   :: UnifyLog+  }++instance Semigroup UnifyOutput where+  x <> y = UnifyOutput+    { unifySubst = unifySubst y `composeS` unifySubst x+    , unifyProof = unifyProof y `composeS` unifyProof x+--    , unifyLog   = unifyLog x ++ unifyLog y+    }++instance Monoid UnifyOutput where+  mempty  = UnifyOutput IdS IdS -- []+  mappend = (<>)++type UnifyLogT m a = WriterT UnifyLog' m a++type UnifyStepT m a = WriterT UnifyOutput m a++tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()+tellUnifySubst sub = tell $ UnifyOutput sub IdS++tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()+tellUnifyProof sub = tell $ UnifyOutput IdS sub++writeUnifyLog ::+  MonadWriter UnifyLog' m => (UnifyLogEntry, UnifyState) -> m ()+writeUnifyLog x = tell (singleton x) -- UnifyOutput IdS IdS [x]++runUnifyLogT :: Functor m => UnifyLogT m a -> m (a, UnifyLog)+runUnifyLogT m = mapSnd toList <$> runWriterT m
src/full/Agda/TypeChecking/Rules/Record.hs view
@@ -1,43 +1,54 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} +{-# LANGUAGE NondecreasingIndentation   #-}+ module Agda.TypeChecking.Rules.Record where -import Prelude hiding (null)+import Prelude hiding (null, not, (&&), (||)) -import Control.Applicative hiding (empty)-import Control.Monad import Data.Maybe import qualified Data.Set as Set  import Agda.Interaction.Options  import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Abstract.Views as A import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position import qualified Agda.Syntax.Info as Info  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Primitive import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Reduce import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty import Agda.TypeChecking.Polarity-import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Warnings+import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile+import Agda.TypeChecking.InstanceArguments -import Agda.TypeChecking.Rules.Data ( bindParameters, fitsIn, forceSort)+import Agda.TypeChecking.Rules.Data+  ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters+  , checkDataSort, fitsIn, forceSort+  , defineCompData, defineKanOperationForFields+  ) import Agda.TypeChecking.Rules.Term ( isType_ ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkDecl) +import Agda.Utils.Boolean+import Agda.Utils.Function ( applyWhen )+import Agda.Utils.Lens+import Agda.Utils.List (headWithDefault)+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Permutation+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -52,52 +63,68 @@ -- --     [@ps@]      Record parameters. -----     [@contel@]  Approximate type of constructor (@fields@ -> Set).+--     [@contel@]  Approximate type of constructor (@fields@ -> dummy). --                 Does not include record parameters. -- --     [@fields@]  List of field signatures. -- checkRecDef-  :: Info.DefInfo              -- ^ Position and other info.+  :: A.DefInfo                 -- ^ Position and other info.   -> QName                     -- ^ Record type identifier.-  -> Maybe (Ranged Induction)  -- ^ Optional: (co)inductive declaration.-  -> Maybe Bool                -- ^ Optional: user specified eta/no-eta-  -> Maybe QName               -- ^ Optional: constructor name.-  -> [A.LamBinding]            -- ^ Record parameters.-  -> A.Expr                    -- ^ Approximate type of constructor (@fields@ -> Set).+  -> UniverseCheck             -- ^ Check universes?+  -> A.RecordDirectives        -- ^ (Co)Inductive, (No)Eta, (Co)Pattern, Constructor?+  -> A.DataDefParams           -- ^ Record parameters.+  -> A.Expr                    -- ^ Approximate type of constructor (@fields@ -> dummy).                                --   Does not include record parameters.   -> [A.Field]                 -- ^ Field signatures.   -> TCM ()-checkRecDef i name ind eta con ps contel fields =-  traceCall (CheckRecDef (getRange name) (qnameName name) ps fields) $ do+checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel0 fields = do++  -- Andreas, 2022-10-06, issue #6165:+  -- The target type of the constructor is a meaningless dummy expression which does not type-check.+  -- We replace it by Set/Type (builtinSet) which is still incorrect but type-checks.+  -- It will be fixed after type-checking.+  aType <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+  let contel = A.unPiView . (\ (A.PiView tels _) -> A.PiView tels aType) . A.piView $ contel0++  traceCall (CheckRecDef (getRange name) name ps fields) $ do     reportSDoc "tc.rec" 10 $ vcat-      [ text "checking record def" <+> prettyTCM name-      , nest 2 $ text "ps ="     <+> prettyList (map prettyAs ps)-      , nest 2 $ text "contel =" <+> prettyA contel-      , nest 2 $ text "fields =" <+> prettyA (map Constr fields)+      [ "checking record def" <+> prettyTCM name+      , nest 2 $ "ps ="     <+> prettyList (map prettyA ps)+      , nest 2 $ "contel =" <+> prettyA contel+      , nest 2 $ "fields =" <+> prettyA (map Constr fields)       ]     -- get type of record-    t <- instantiateFull =<< typeOfConst name-    bindParameters ps t $ \tel t0 -> do+    def <- instantiateDef =<< getConstInfo name+    t   <- instantiateFull $ defType def+    let npars =+          case theDef def of+            DataOrRecSig n -> n+            _              -> __IMPOSSIBLE__ +    -- If the record type is erased, then hard compile-time mode is+    -- entered.+    setHardCompileTimeModeIfErased' def $ do++    parNames <- getGeneralizedParameters gpars name++    bindGeneralizedParameters parNames t $ \ gtel t0 ->+     bindParameters (npars - length parNames) ps t0 $ \ ptel t0 -> do++      let tel = abstract gtel ptel+       -- Generate type of constructor from field telescope @contel@,       -- which is the approximate constructor type (target missing).        -- Check and evaluate field types.-      reportSDoc "tc.rec" 15 $ text "checking fields"-      -- WRONG: contype <- workOnTypes $ killRange <$> (instantiateFull =<< isType_ contel)-      contype <- instantiateFull =<< isType_ contel+      reportSDoc "tc.rec" 15 $ "checking fields"+      contype <- workOnTypes $ instantiateFull =<< isType_ contel       reportSDoc "tc.rec" 20 $ vcat-        [ text "contype = " <+> prettyTCM contype ]+        [ "contype = " <+> prettyTCM contype ]        -- compute the field telescope (does not include record parameters)       let TelV ftel _ = telView' contype -          -- A record is irrelevant if all of its fields are.-          -- In this case, the associated module parameter will be irrelevant.-          -- See issue 392.-          recordRelevance = minimum $ Irrelevant : (map getRelevance $ telToList ftel)-       -- Compute correct type of constructor        -- t = tel -> t0 where t0 must be a sort s@@ -105,9 +132,15 @@       unless (null idxTel) $ typeError $ ShouldBeASort t0       s <- forceSort s +      -- needed for impredicative Prop (not implemented yet)+      -- ftel <- return $+      --   if s == Prop+      --   then telFromList $ map (setRelevance Irrelevant) $ telToList ftel+      --   else ftel+       reportSDoc "tc.rec" 20 $ do         gamma <- getContextTelescope  -- the record params (incl. module params)-        text "gamma = " <+> inTopContext (prettyTCM gamma)+        "gamma = " <+> inTopContext (prettyTCM gamma)        -- record type (name applied to parameters)       rect <- El s . Def name . map Apply <$> getContextArgs@@ -119,24 +152,24 @@         -- NB: contype does not contain the parameter telescope        -- Obtain name of constructor (if present).-      (hasNamedCon, conName, conInfo) <- case con of-        Just c  -> return (True, c, i)-        Nothing -> do-          m <- killRange <$> currentModule-          c <- qualify m <$> freshName_ ("recCon-NOT-PRINTED" :: String)-          return (False, c, i)+      (hasNamedCon, conName) <- case con of+        A.NamedRecCon c -> return (True, c)+        A.FreshRecCon c -> return (False, c)        -- Add record type to signature.-      reportSDoc "tc.rec" 15 $ text "adding record type to signature"+      reportSDoc "tc.rec" 15 $ "adding record type to signature"        etaenabled <- etaEnabled -      let getName :: A.Declaration -> [Arg QName]-          getName (A.Field _ x arg)    = [x <$ arg]+      let getName :: A.Declaration -> [Dom QName]+          getName (A.Field _ x arg)    = [x <$ domFromArg arg]           getName (A.ScopedDecl _ [f]) = getName f           getName _                    = [] -          fs = concatMap getName fields+          setTactic dom f = f { domTactic = domTactic dom }++          fs = zipWith setTactic (telToList ftel) $ concatMap getName fields+           -- indCo is what the user wrote: inductive/coinductive/Nothing.           -- We drop the Range.           indCo = rangedThing <$> ind@@ -145,12 +178,31 @@           -- Andreas, 2016-09-20, issue #2197.           -- Eta is inferred by the positivity checker.           -- We should turn it off until it is proven to be safe.-          haveEta      = maybe (Inferred False) Specified eta-          -- haveEta      = maybe (Inferred $ conInduction == Inductive && etaenabled) Specified eta-          con = ConHead conName conInduction $ map unArg fs+          noEta    = Inferred $ NoEta patCopat+          haveEta0 = maybe noEta Specified eta+          con = ConHead conName (IsRecord patCopat) conInduction $ map argFromDom fs -      reportSDoc "tc.rec" 30 $ text "record constructor is " <+> text (show con)+          -- A record is irrelevant if all of its fields are.+          -- In this case, the associated module parameter will be irrelevant.+          -- See issue #392.+          -- Unless it's been declared coinductive or no-eta-equality (#2607).+          recordRelevance+            | Just NoEta{} <- eta         = relevant+            | CoInductive <- conInduction = relevant+            | null (telToList ftel)       = relevant    -- #6270: eta unit types don't need to be irrelevant+            | otherwise                   = minimum $ irrelevant : map getRelevance (telToList ftel) +      -- Andreas, 2017-01-26, issue #2436+      -- Disallow coinductive records with eta-equality+      -- Andreas, 2024-06-14, PR #7300+      -- Just make this a deadcode warning.+      haveEta <-+        if (conInduction == CoInductive && theEtaEquality haveEta0 == YesEta) then do+          noEta <$ do+            setCurrentRange eta0 $ warning $ CoinductiveEtaRecord name+        else pure haveEta0+      reportSDoc "tc.rec" 30 $ "record constructor is " <+> prettyTCM con+       -- Add the record definition.        -- Andreas, 2016-06-17, Issue #2018:@@ -160,9 +212,8 @@       -- we make sure we get the original names!       let npars = size tel           telh  = fmap hideAndRelParams tel-      escapeContext npars $ do-        addConstant name $-          defaultDefn defaultArgInfo name t $+      escapeContext impossible npars $ do+        addConstant' name defaultArgInfo t $             Record               { recPars           = npars               , recClause         = Nothing@@ -172,33 +223,55 @@               , recTel            = telh `abstract` ftel               , recAbstr          = Info.defAbstract i               , recEtaEquality'   = haveEta+              , recPatternMatching= patCopat               , recInduction      = indCo                   -- We retain the original user declaration [(co)inductive]                   -- in case the record turns out to be recursive.               -- Determined by positivity checker:-              , recRecursive      = False-              , recMutual         = []+              , recMutual         = Nothing+              -- Determined by the termination checker:+              , recTerminates     = Nothing+              , recComp           = emptyCompKit -- filled in later               } +        erasure <- optErasure <$> pragmaOptions         -- Add record constructor to signature-        addConstant conName $-          defaultDefn defaultArgInfo conName (telh `abstract` contype) $+        addConstant' conName defaultArgInfo+             -- If --erasure is used, then the parameters are erased+             -- in the constructor's type.+            (applyWhen erasure (fmap $ applyQuantity zeroQuantity) telh+             `abstract` contype) $             Constructor               { conPars   = npars+              , conArity  = size fs               , conSrcCon = con               , conData   = name-              , conAbstr  = Info.defAbstract conInfo-              , conInd    = conInduction-              , conErased = []+              , conAbstr  = Info.defAbstract i+              , conComp   = emptyCompKit  -- filled in later+              , conProj   = Nothing       -- filled in later+              , conForced = []+              , conErased = Nothing+              , conErasure = erasure+              , conInline  = False               }        -- Declare the constructor as eligible for instance search-      when (Info.defInstance i == InstanceDef) $ do-        addNamedInstance conName name+      case Info.defInstance i of+        InstanceDef r -> setCurrentRange r $ do+          -- Andreas, 2020-01-28, issue #4360:+          -- Use addTypedInstance instead of addNamedInstance+          -- to detect unusable instances.+          addTypedInstance conName contype+          -- addNamedInstance conName name+        NotInstanceDef -> pure ()        -- Check that the fields fit inside the sort-      contype `fitsIn` s+      _ <- fitsIn IsRecord_ conName uc [] contype s +      -- Check that the sort admits record declarations.+      checkDataSort name s++       {- Andreas, 2011-04-27 WRONG because field types are checked again          and then non-stricts should not yet be irrelevant @@ -208,19 +281,19 @@  {- Andreas, 2013-09-13 DEBUGGING the debug printout       reportSDoc "tc.rec" 80 $ sep-        [ text "current module record telescope"+        [ "current module record telescope"         , nest 2 $ (prettyTCM =<< getContextTelescope)         ]       reportSDoc "tc.rec" 80 $ sep-        [ text "current module record telescope"+        [ "current module record telescope"         , nest 2 $ (text . show =<< getContextTelescope)         ]       reportSDoc "tc.rec" 80 $ sep-        [ text "current module record telescope"+        [ "current module record telescope"         , nest 2 $ (inTopContext . prettyTCM =<< getContextTelescope)         ]       reportSDoc "tc.rec" 80 $ sep-        [ text "current module record telescope"+        [ "current module record telescope"         , nest 2 $ do            tel <- getContextTelescope            text (show tel) $+$ do@@ -229,58 +302,258 @@                telA <- reify tel                text (show telA) $+$ do                ctx <- getContextTelescope-               text "should be empty:" <+> prettyTCM ctx+               "should be empty:" <+> prettyTCM ctx         ] -}        let info = setRelevance recordRelevance defaultArgInfo-          addRecordVar = addContext' ("", Dom info rect)-          -- the record variable has the empty name by intention, see issue 208+          addRecordVar =+            addRecordNameContext (setArgInfo info $ defaultDom rect)        let m = qnameToMName name  -- Name of record module. +      eraseRecordParameters <- optEraseRecordParameters <$> pragmaOptions+      let maybeErase :: forall a. LensQuantity a => a -> a+          maybeErase | eraseRecordParameters = setQuantity zeroQuantity+                     | otherwise             = id+       -- Andreas, 2016-02-09 setting all parameters hidden in the record       -- section telescope changes the semantics, see e.g.       -- test/Succeed/RecordInParModule.       -- Ulf, 2016-03-02 but it's the right thing to do (#1759)-      modifyContext (modifyContextEntries hideOrKeepInstance) $ addRecordVar $ do+      modifyContextInfo (hideOrKeepInstance . maybeErase) $ addRecordVar $ do          -- Add the record section.          reportSDoc "tc.rec.def" 10 $ sep-          [ text "record section:"+          [ "record section:"           , nest 2 $ sep             [ prettyTCM m <+> (inTopContext . prettyTCM =<< getContextTelescope)-            , fsep $ punctuate comma $ map (text . show . getName) fields+            , fsep $ punctuate comma $ map (return . P.pretty . map argFromDom . getName) fields             ]           ]         reportSDoc "tc.rec.def" 15 $ nest 2 $ vcat-          [ text "field tel =" <+> escapeContext 1 (prettyTCM ftel)+          [ "field tel =" <+> escapeContext impossible 1 (prettyTCM ftel)           ]         addSection m        -- Andreas, 2016-02-09, Issue 1815 (see also issue 1759).       -- For checking the record declarations, hide the record parameters       -- and the parameters of the parent modules.-      modifyContext (modifyContextEntries hideOrKeepInstance) $ addRecordVar $ do+      modifyContextInfo (hideOrKeepInstance . maybeErase) $ do+        -- If --erasure is used, then the parameters are erased in the+        -- types of the projections.+        erasure <- optErasure <$> pragmaOptions+        params  <- applyWhen erasure (fmap $ applyQuantity zeroQuantity) <$> getContext          -- Check the types of the fields and the other record declarations.-        withCurrentModule m $ do+        addRecordVar $ withCurrentModule m $ do            -- Andreas, 2013-09-13, 2016-01-06.           -- Argument telescope for the projections: all parameters are hidden.           -- This means parameters of the parent modules and of the current           -- record type.           -- See test/Succeed/ProjectionsTakeModuleTelAsParameters.agda.-          tel' <- getContextTelescope-          setDefaultModuleParameters m-          checkRecordProjections m name hasNamedCon con tel' (raise 1 ftel) fields+          tel' <- do+            r <- headWithDefault __IMPOSSIBLE__ <$> getContext+            return $ contextToTel $ r : params+          setModuleCheckpoint m+          checkRecordProjections m name hasNamedCon con tel' ftel fields -        -- Andreas 2012-02-13: postpone polarity computation until after positivity check-        -- computePolarity name -      return ()+      -- we define composition here so that the projections are already in the signature.+      whenM cubicalCompatibleOption do+        escapeContext impossible npars do+          addCompositionForRecord name haveEta con tel (map argFromDom fs) ftel rect +      -- The confluence checker needs to know what symbols match against+      -- the constructor.+      modifySignature $ updateDefinition conName $ \def ->+        def { defMatchable = Set.fromList $ map unDom fs }++  where+  -- Andreas, 2020-04-19, issue #4560+  -- If the user declared the record constructor as @pattern@,+  -- then switch on pattern matching for no-eta-equality.+  -- Default is no pattern matching, but definition by copatterns instead.+  patCopat = maybe CopatternMatching (const PatternMatching) pat+  eta      = ((patCopat <$) . rangedThing) <$> eta0+++addCompositionForRecord+  :: QName       -- ^ Datatype name.+  -> EtaEquality+  -> ConHead+  -> Telescope   -- ^ @Γ@ parameters.+  -> [Arg QName] -- ^ Projection names.+  -> Telescope   -- ^ @Γ ⊢ Φ@ field types.+  -> Type        -- ^ @Γ ⊢ T@ target type.+  -> TCM ()+addCompositionForRecord name eta con tel fs ftel rect = do+  cxt <- getContextTelescope+  inTopContext $ do++    -- Record has no fields: attach composition data to record constructor+    if null fs then do+      kit <- defineCompData name con (abstract cxt tel) [] ftel rect empty+      modifySignature $ updateDefinition (conName con) $ updateTheDef $ \case+        r@Constructor{} -> r { conComp = kit, conProj = Just [] }  -- no projections+        _ -> __IMPOSSIBLE__++    -- No-eta record with pattern matching (i.e., withOUT copattern+    -- matching): define composition as for a data type, attach it to+    -- the record.+    else if theEtaEquality eta == NoEta PatternMatching then do+      kit <- defineCompData name con (abstract cxt tel) (unArg <$> fs) ftel rect empty+      modifySignature $ updateDefinition name $ updateTheDef $ \case+        r@Record{} -> r { recComp = kit }+        _ -> __IMPOSSIBLE__++    -- Record has fields: attach composition data to record type+    else do+      -- If record has irrelevant fields but irrelevant projections are disabled,+      -- we cannot generate composition data.+      kit <- ifM (return (any isIrrelevant fs)+                  `and2M` do not . optIrrelevantProjections <$> pragmaOptions)+        {-then-} (return emptyCompKit)+        {-else-} (defineCompKitR name (abstract cxt tel) ftel fs rect)+      modifySignature $ updateDefinition name $ updateTheDef $ \case+        r@Record{} -> r { recComp = kit }+        _          -> __IMPOSSIBLE__++defineCompKitR ::+    QName          -- ^ some name, e.g. record name+  -> Telescope   -- ^ param types Δ+  -> Telescope   -- ^ fields' types Δ ⊢ Φ+  -> [Arg QName] -- ^ fields' names+  -> Type        -- ^ record type Δ ⊢ T+  -> TCM CompKit+defineCompKitR name params fsT fns rect = do+  required <- mapM getTerm'+        [ someBuiltin builtinInterval+        , someBuiltin builtinIZero+        , someBuiltin builtinIOne+        , someBuiltin builtinIMin+        , someBuiltin builtinIMax+        , someBuiltin builtinINeg+        , someBuiltin builtinPOr+        , someBuiltin builtinItIsOne+        ]+  reportSDoc "tc.rec.cxt" 30 $ prettyTCM params+  reportSDoc "tc.rec.cxt" 30 $ prettyTCM fsT+  reportSDoc "tc.rec.cxt" 30 $ pretty rect+  if not $ all isJust required then return $ emptyCompKit else do+    transp <- whenDefined [builtinTrans]              (defineKanOperationR DoTransp name params fsT fns rect)+    hcomp  <- whenDefined [builtinTrans,builtinHComp] (defineKanOperationR DoHComp name params fsT fns rect)+    return $ CompKit+      { nameOfTransp = transp+      , nameOfHComp  = hcomp+      }+  where+    whenDefined xs m = do+      xs <- mapM getTerm' xs+      if all isJust xs then m else return Nothing+++defineKanOperationR+  :: Command+  -> QName       -- ^ some name, e.g. record name+  -> Telescope   -- ^ param types Δ+  -> Telescope   -- ^ fields' types Δ ⊢ Φ+  -> [Arg QName] -- ^ fields' names+  -> Type        -- ^ record type Δ ⊢ T+  -> TCM (Maybe QName)+defineKanOperationR cmd name params fsT fns rect = do+  let project = (\ t fn -> t `applyE` [Proj ProjSystem fn])+  stuff <- fmap fst <$> defineKanOperationForFields cmd Nothing project name params fsT fns rect++  caseMaybe stuff (return Nothing) $ \ (theName, gamma, rtype, clause_types, bodies) -> do+  -- phi = 1 clause+  c' <- do+           io <- primIOne+           Just io_name <- getBuiltinName' builtinIOne+           one <- primItIsOne+           tInterval <- primIntervalType+           let+              (ix,rhs) =+                case cmd of+                  -- TranspRArgs = phi : I, a0 : ..+                  -- Γ = Δ^I , CompRArgs+                  -- pats = ... | phi = i1+                  -- body = a0+                  DoTransp -> (1,Var 0 [])+                  -- HCompRArgs = phi : I, u : .., a0 : ..+                  -- Γ = Δ, CompRArgs+                  -- pats = ... | phi = i1+                  -- body = u i1 itIsOne+                  DoHComp  -> (2,Var 1 [] `apply` [argN io, setRelevance irrelevant $ argN one])++              p = ConP (ConHead io_name IsData Inductive [])+                       (noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)+                                         , conPFallThrough = True })+                         []++              -- gamma, rtype++              s = singletonS ix p++              pats :: [NamedArg DeBruijnPattern]+              pats = s `applySubst` teleNamedArgs gamma++              t :: Type+              t = s `applyPatSubst` rtype++              gamma' :: Telescope+              gamma' = unflattenTel (ns0 ++ ns1) $ s `applyPatSubst` (g0 ++ g1)+               where+                (g0,_:g1) = splitAt (size gamma - 1 - ix) $ flattenTel gamma+                (ns0,_:ns1) = splitAt (size gamma - 1 - ix) $ teleNames gamma++              c = Clause { clauseFullRange = noRange+                         , clauseLHSRange  = noRange+                         , clauseTel       = gamma'+                         , namedClausePats = pats+                         , clauseBody      = Just $ rhs+                         , clauseType      = Just $ argN t+                         , clauseCatchall    = empty+                         , clauseRecursive   = Just False  -- definitely non-recursive!+                         , clauseUnreachable = Just False+                         , clauseEllipsis    = NoEllipsis+                         , clauseWhereModule = Nothing+                         }+           reportSDoc "trans.rec.face" 17 $ text $ show c+           return c+  cs <- forM (zip3 fns clause_types bodies) $ \ (fname, clause_ty, body) -> do+          let+              pats = teleNamedArgs gamma ++ [defaultNamedArg $ ProjP ProjSystem $ unArg fname]+              c = Clause { clauseFullRange = noRange+                         , clauseLHSRange  = noRange+                         , clauseTel       = gamma+                         , namedClausePats = pats+                         , clauseBody      = Just body+                         , clauseType      = Just $ argN (unDom clause_ty)+                         , clauseCatchall    = empty+                         , clauseRecursive   = Nothing+                             -- Andreas 2020-02-06 TODO+                             -- Or: Just False;  is it known to be non-recursive?+                         , clauseUnreachable = Just False+                         , clauseEllipsis    = NoEllipsis+                         , clauseWhereModule = Nothing+                         }+          reportSDoc "trans.rec" 17 $ text $ show c+          reportSDoc "trans.rec" 16 $ text "type =" <+> text (show (clauseType c))+          reportSDoc "trans.rec" 15 $ prettyTCM $ abstract gamma (unDom clause_ty)+          reportSDoc "trans.rec" 10 $ text "body =" <+> prettyTCM (abstract gamma body)+          return c+  addClauses theName $ c' : cs+  reportSDoc "trans.rec" 15 $ text $ "compiling clauses for " ++ show theName+  (mst, _, cc) <- inTopContext (compileClauses Nothing cs)+  whenJust mst $ setSplitTree theName+  setCompiledClauses theName cc+  reportSDoc "trans.rec" 15 $ text $ "compiled"+  return $ Just theName++ {-| @checkRecordProjections m r q tel ftel fs@.      [@m@    ]  name of the generated module@@ -289,7 +562,7 @@      [@con@  ]  name of the record constructor -    [@tel@  ]  parameters and record variable r ("self")+    [@tel@  ]  parameters (perhaps erased) and record variable r ("self")      [@ftel@ ]  telescope of fields @@ -299,35 +572,71 @@   ModuleName -> QName -> Bool -> ConHead -> Telescope -> Telescope ->   [A.Declaration] -> TCM () checkRecordProjections m r hasNamedCon con tel ftel fs = do-    checkProjs EmptyTel ftel fs+    checkProjs EmptyTel ftel [] fs   where -    checkProjs :: Telescope -> Telescope -> [A.Declaration] -> TCM ()+    checkProjs :: Telescope -> Telescope -> [Term] -> [A.Declaration] -> TCM () -    checkProjs _ _ [] = return ()+    checkProjs _ _ _ [] = return () -    checkProjs ftel1 ftel2 (A.ScopedDecl scope fs' : fs) =-      setScope scope >> checkProjs ftel1 ftel2 (fs' ++ fs)+    checkProjs ftel1 ftel2 vs (A.ScopedDecl scope fs' : fs) =+      setScope scope >> checkProjs ftel1 ftel2 vs (fs' ++ fs) -    checkProjs ftel1 (ExtendTel (Dom ai t) ftel2) (A.Field info x _ : fs) =+    -- Case: projection.+    checkProjs ftel1 (ExtendTel (dom@Dom{domInfo = ai,unDom = t}) ftel2) vs (A.Field info x _ : fs) =       traceCall (CheckProjection (getRange info) x t) $ do       -- Andreas, 2012-06-07:       -- Issue 387: It is wrong to just type check field types again       -- because then meta variables are created again.       -- Instead, we take the field type t from the field telescope.       reportSDoc "tc.rec.proj" 5 $ sep-        [ text "checking projection" <+> text (show x)+        [ "checking projection" <+> prettyTCM x         , nest 2 $ vcat-          [ text "top   =" <+> (inTopContext . prettyTCM =<< getContextTelescope)-          , text "tel   =" <+> (inTopContext . prettyTCM $ tel)-          , text "ftel1 =" <+> prettyTCM ftel1-          , text "t     =" <+> prettyTCM t-          , text "ftel2 =" <+> addContext ftel1 (underAbstraction_ ftel2 prettyTCM)+          [ "top   =" <+> (inTopContext . prettyTCM =<< getContextTelescope)+          , "tel   =" <+> (inTopContext . prettyTCM $ tel)           ]         ]+      -- Andreas, 2021-05-11, issue #5378+      -- The impossible is sometimes possible, so splitting out this part...+      reportSDoc "tc.rec.proj" 5 $ nest 2 $ vcat+          [ "ftel1 =" <+> escapeContext impossible 1 (prettyTCM ftel1)+          , "t     =" <+> escapeContext impossible 1 (addContext ftel1 $ prettyTCM t)+          , "ftel2 =" <+> escapeContext impossible 1 (addContext ftel1 $ underAbstraction dom ftel2 prettyTCM)+          ]+      reportSDoc "tc.rec.proj" 55 $ nest 2 $ vcat+          [ "ftel1 (raw) =" <+> pretty ftel1+          , "t     (raw) =" <+> pretty t+          , "ftel2 (raw) =" <+> pretty ftel2+          ]+      reportSDoc "tc.rec.proj" 5 $ nest 2 $ vcat+          [ "vs    =" <+> prettyList_ (map prettyTCM vs)+          , "abstr =" <+> (text . show) (Info.defAbstract info)+          , "quant =" <+> (text . show) (getQuantity ai)+          , "coh   =" <+> (text . show) (getCohesion ai)+          ] -      -- Andreas, 2010-09-09 The following comments are misleading, TODO: update-      -- in fact, tel includes the variable of record type as last one+      unless (getCohesion ai == Continuous) __IMPOSSIBLE__+      -- Andreas, 2025-05-03, moved check to ConcreteToAbstract.checkFieldArgInfo.+      -- -- Cohesion check:+      -- -- For a field `@c π : A` we would create a projection `π : .., (@(c^-1) r : R as) -> A`+      -- -- So we want to check that `@.., (c^-1 . c) x : A |- x : A` is allowed by the modalities.+      -- --+      -- -- Alternatively we could create a projection `.. |- π r :c A`+      -- -- but that would require support for a `t :c A` judgment.+      -- if hasLeftAdjoint (UnderComposition (getCohesion ai))+      --   then unless (getCohesion ai == Continuous)+      --               -- Atm, only Continuous has a left adjoint.+      --               -- Andrea TODO: properly update the context/type of the projection when we add Sharp+      --               __IMPOSSIBLE__+      --   else typeError $ InvalidFieldModality (getCohesion ai)++      -- For now, we forbid any polarity annotations on record fields (we would need to do as above,+      -- and eta-equality or projection existence would be in danger).+      unless (getModalPolarity ai `samePolarity` (withStandardLock MixedPolarity)) $+        -- Andreas, 2025-05-03, already checked in ConcreteToAbstract.checkFieldArgInfo+        __IMPOSSIBLE__++      -- The telescope tel includes the variable of record type as last one       -- e.g. for cartesion product it is       --       --   tel = {A' : Set} {B' : Set} (r : Prod A' B')@@ -335,35 +644,42 @@       -- create the projection functions (instantiate the type with the values       -- of the previous fields) +      -- The type of the projection function should be+      --  {Δ} -> (r : R Δ) -> t+      -- where Δ are the parameters of R+       {- what are the contexts? -          Γ, tel            ⊢ t-          Γ, tel, r         ⊢ vs-          Γ, tel, r, ftel₁  ⊢ raiseFrom (size ftel₁) 1 t+          Δ , ftel₁              ⊢ t+          Δ , (r : R Δ)          ⊢ parallelS vs : ftel₁+          Δ , (r : R Δ) , ftel₁  ⊢ t' = raiseFrom (size ftel₁) 1 t+          Δ , (r : R Δ)          ⊢ t'' = applySubst (parallelS vs) t'+                                 ⊢ finalt = telePi tel t''       -}--      -- The type of the projection function should be-      --  {tel} -> (r : R Δ) -> t-      -- where Δ = Γ, tel is the current context-      let finalt   = telePi (replaceEmptyName "r" tel) t+      let t'       = raiseFrom (size ftel1) 1 t+          t''      = applySubst (parallelS vs) t'+          finalt   = telePi (replaceEmptyName "r" tel) t''           projname = qualify m $ qnameName x           projcall o = Var 0 [Proj o projname]           rel      = getRelevance ai           -- the recursive call-          recurse  = checkProjs (abstract ftel1 $ ExtendTel (Dom ai t)+          recurse  = checkProjs (abstract ftel1 $ ExtendTel dom                                  $ Abs (nameToArgName $ qnameName projname) EmptyTel)-                                (ftel2 `absApp` projcall ProjSystem) fs+                                (absBody ftel2) (projcall ProjSystem : vs) fs -      reportSDoc "tc.rec.proj" 25 $ nest 2 $ text "finalt=" <+> do+      reportSDoc "tc.rec.proj" 25 $ nest 2 $ "finalt=" <+> do         inTopContext $ prettyTCM finalt -      -- Andreas, 2012-02-20 do not add irrelevant projections if-      -- disabled by --no-irrelevant-projections-      ifM (return (rel == Irrelevant) `and2M` do not . optIrrelevantProjections <$> pragmaOptions) recurse $ do-+      -- -- Andreas, 2012-02-20 do not add irrelevant projections if+      -- -- disabled by --no-irrelevant-projections+      -- ifM (return (rel == Irrelevant) `and2M` do not . optIrrelevantProjections <$> pragmaOptions) recurse $ do+      -- Andreas, 2018-06-09 issue #2170+      -- Always create irrelevant projections (because the scope checker accepts irrelevant fields).+      -- If --no-irrelevant-projections, then their use should be disallowed by the type checker for expressions.+      do         reportSDoc "tc.rec.proj" 10 $ sep-          [ text "adding projection"-          , nest 2 $ prettyTCM projname <+> text ":" <+> inTopContext (prettyTCM finalt)+          [ "adding projection"+          , nest 2 $ prettyTCM projname <+> ":" <+> inTopContext (prettyTCM finalt)           ]          -- The body should be@@ -377,53 +693,54 @@         -- 2012-04-02: DontCare instead of irrAxiom          -- compute body modification for irrelevant projections-        let bodyMod = case rel of-              Relevant   -> id-              NonStrict  -> id-              Irrelevant -> DontCare-              _          -> __IMPOSSIBLE__+        let bodyMod = applyWhen (isIrrelevant rel) dontCare          let -- Andreas, 2010-09-09: comment for existing code             -- split the telescope into parameters (ptel) and the type or the record             -- (rt) which should be  R ptel             telList = telToList tel-            (_ptel,[rt]) = splitAt (size tel - 1) telList-            cpo    = if hasNamedCon then ConOCon else ConORec-            cpi    = ConPatternInfo (Just cpo) (Just $ argFromDom $ fmap snd rt)-            conp   = defaultArg $ ConP con cpi $-                     [ Arg info $ unnamed $ varP "x" | Dom info _ <- telToList ftel ]+            (ptelList,[rt]) = splitAt (size tel - 1) telList+            ptel   = telFromList ptelList+            cpo    = if hasNamedCon then PatOCon else PatORec+            cpi    = ConPatternInfo { conPInfo   = PatternInfo cpo []+                                    , conPRecord = True+                                    , conPFallThrough = False+                                    , conPType   = Just $ argFromDom $ fmap snd rt+                                    , conPLazy   = True }+            conp   = defaultNamedArg $ ConP con cpi $ teleNamedArgs ftel             body   = Just $ bodyMod $ var (size ftel2)-            cltel  = ftel-            clause = Clause { clauseRange = getRange info+            cltel  = ptel `abstract` ftel+            cltype = Just $ Arg ai $ raise (1 + size ftel2) t+            clause = Clause { clauseLHSRange  = getRange info+                            , clauseFullRange = getRange info                             , clauseTel       = killRange cltel-                            , namedClausePats = [Named Nothing <$> numberPatVars __IMPOSSIBLE__ (idP $ size ftel) conp]+                            , namedClausePats = [conp]                             , clauseBody      = body-                            , clauseType      = Just $ Arg ai t-                            , clauseCatchall  = False+                            , clauseType      = cltype+                            , clauseCatchall  = empty+                            , clauseRecursive   = Just False+                            , clauseUnreachable = Just False+                            , clauseEllipsis    = NoEllipsis+                            , clauseWhereModule = Nothing                             }          let projection = Projection-              { projProper   = True+              { projProper   = Just r               , projOrig     = projname               -- name of the record type:               , projFromType = defaultArg r               -- index of the record argument (in the type),               -- start counting with 1:               , projIndex    = size tel -- which is @size ptel + 1@-              , projLams     = ProjLams $ map (\ (Dom ai (x,_)) -> Arg ai x) telList+              , projLams     = ProjLams $ map (argFromDom . fmap fst) telList               } -        reportSDoc "tc.rec.proj" 80 $ sep-          [ text "adding projection"-          , nest 2 $ prettyTCM projname <+> text (show clause)-          ]         reportSDoc "tc.rec.proj" 70 $ sep-          [ text "adding projection"-          , nest 2 $ prettyTCM projname <+> text (show (clausePats clause)) <+> text "=" <+>-                       inTopContext (addContext ftel (maybe (text "_|_") prettyTCM (clauseBody clause)))+          [ "adding projection"+          , nest 2 $ prettyTCM projname <+> pretty clause           ]         reportSDoc "tc.rec.proj" 10 $ sep-          [ text "adding projection"+          [ "adding projection"           , nest 2 $ prettyTCM (QNamed projname clause)           ] @@ -431,30 +748,51 @@               -- projection functions are defined. Record pattern               -- translation is defined in terms of projection               -- functions.-        cc <- compileClauses Nothing [clause]+        (mst, _, cc) <- compileClauses Nothing [clause] -        reportSDoc "tc.cc" 10 $ do-          sep [ text "compiled clauses of " <+> prettyTCM projname+        reportSDoc "tc.cc" 60 $ do+          sep [ "compiled clauses of " <+> prettyTCM projname               , nest 2 $ text (show cc)               ] -        escapeContext (size tel) $ do+        escapeContext impossible (size tel) $ do+          lang <- getLanguage+          fun  <- emptyFunctionData+          let -- It should be fine to mark a field with @ω in an+              -- erased record type: the field will be non-erased, but+              -- the projection will be erased. The following code+              -- ensures that the use of addConstant does not trigger+              -- a PlentyInHardCompileTimeMode warning.+              ai' = flip mapQuantity ai $ \case+                      Quantityω _ -> Quantityω QωInferred+                      q           -> q           addConstant projname $-            (defaultDefn ai projname (killRange finalt)-              emptyFunction-                { funClauses        = [clause]-                , funCompiled       = Just cc-                , funProjection     = Just projection-                , funTerminates     = Just True-                , funCopatternLHS   = isCopatternLHS [clause]+            (defaultDefn ai' projname (killRange finalt) lang $ FunctionDefn $+             set funProj_ True $+              fun+                { _funClauses        = [clause]+                , _funCompiled       = Just cc+                , _funSplitTree      = mst+                , _funProjection     = Right projection+                , _funMutual         = Just []  -- Projections are not mutually recursive with anything+                , _funTerminates     = Just True                 })-              { defArgOccurrences = [StrictPos] }-          computePolarity projname-          when (Info.defInstance info == InstanceDef) $-            addTypedInstance projname finalt+              { defArgOccurrences = [StrictPos]+              , defCopatternLHS   = hasProjectionPatterns cc+              }+          computePolarity [projname] +        addContext ftel1 case Info.defInstance info of+          -- Instance projections have to be added with their types "qua+          -- local variable" (i.e. the type you'd get were you to open+          -- the record module), but this type has to be treated in the+          -- context ftel1 otherwise it's nonsense+          InstanceDef _r -> addTypedInstance projname t+          NotInstanceDef -> pure ()+         recurse -    checkProjs ftel1 ftel2 (d : fs) = do+    -- Case: definition.+    checkProjs ftel1 ftel2 vs (d : fs) = do       checkDecl d-      checkProjs ftel1 ftel2 fs+      checkProjs ftel1 ftel2 vs fs
src/full/Agda/TypeChecking/Rules/Term.hs view
@@ -1,2191 +1,1783 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables      #-}--module Agda.TypeChecking.Rules.Term where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import Control.Arrow ((&&&), (***), first, second)-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Control.Monad.State (get, put)-import Control.Monad.Reader--import Data.Maybe-import Data.Either (partitionEithers)-import Data.Monoid (mappend)-import Data.List hiding (sort, null)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Traversable (sequenceA)-import Data.Void--import Agda.Interaction.Options-import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName)--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.Concrete (FieldAssignment'(..), nameFieldA, exprFieldA)-import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Common-import Agda.Syntax.Fixity-import Agda.Syntax.Internal as I-import Agda.Syntax.Position-import Agda.Syntax.Literal-import qualified Agda.Syntax.Reflected as R-import Agda.Syntax.Scope.Base ( ThingsInScope, AbstractName-                              , emptyScopeInfo-                              , exportedNamesInScope)-import Agda.Syntax.Scope.Monad (getNamedScope)-import Agda.Syntax.Translation.InternalToAbstract (reify)-import Agda.Syntax.Translation.ReflectedToAbstract (toAbstract_)--import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.EtaContract-import Agda.TypeChecking.Free (isBinderUsed)-import Agda.TypeChecking.Implicit-import Agda.TypeChecking.InstanceArguments-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Level-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Patterns.Abstract-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Quote-import Agda.TypeChecking.Unquote-import Agda.TypeChecking.RecordPatterns-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.SizedTypes-import Agda.TypeChecking.SizedTypes.Solve-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Rules.LHS--import {-# SOURCE #-} Agda.TypeChecking.Empty (isEmptyType)-import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkSectionApplication)-import {-# SOURCE #-} Agda.TypeChecking.Rules.Def (checkFunDef, checkFunDef', useTerPragma)--import Agda.Utils.Except-  ( Error(noMsg, strMsg)-  , ExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  )--import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List (groupOn)-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Size-import Agda.Utils.Tuple--#include "undefined.h"-import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Types-------------------------------------------------------------------------------- | Check that an expression is a type.-isType :: A.Expr -> Sort -> TCM Type-isType e s =-    traceCall (IsTypeCall e s) $ do-    v <- checkExpr e (sort s)-    return $ El s v---- | Check that an expression is a type without knowing the sort.-isType_ :: A.Expr -> TCM Type-isType_ e =-  traceCall (IsType_ e) $ sharedType =<< do-  let fallback = isType e =<< do workOnTypes $ newSortMeta-  case unScope e of-    A.Fun i (Arg info t) b -> do-      a <- Dom info <$> isType_ t-      b <- isType_ b-      s <- ptsRule a b-      let t' = El s $ Pi a $ NoAbs underscore b-      noFunctionsIntoSize b t'-      return t'-    A.Pi _ tel e | null tel -> isType_ e-    A.Pi _ tel e -> do-      (t0, t') <- checkPiTelescope tel $ \ tel -> do-        t0  <- instantiateFull =<< isType_ e-        tel <- instantiateFull tel-        return (t0, telePi tel t0)-      noFunctionsIntoSize t0 t'-      return t'-    A.Set _ n    -> do-      return $ sort (mkType n)-    A.App i s arg-      | getHiding arg == NotHidden,-        A.Set _ 0 <- unScope s ->-      ifNotM hasUniversePolymorphism-          (typeError $ GenericError "Use --universe-polymorphism to enable level arguments to Set")-      $ {- else -} do-        lvl <- levelType-        -- allow NonStrict variables when checking level-        --   Set : (NonStrict) Level -> Set\omega-        n   <- levelView =<< do-          applyRelevanceToContext NonStrict $-            checkNamedArg arg lvl-        return $ sort (Type n)--    -- Issue #707: Check an existing interaction point-    A.QuestionMark minfo ii -> caseMaybeM (lookupInteractionMeta ii) fallback $ \ x -> do-      -- -- | Just x <- A.metaNumber minfo -> do-      reportSDoc "tc.ip" 20 $ fsep-        [ text "Rechecking meta "-        , prettyTCM x-        , text $ " for interaction point " ++ show ii-        ]-      mv <- lookupMeta x-      let s0 = jMetaType . mvJudgement $ mv-      -- Andreas, 2016-10-14, issue #2257-      -- The meta was created in a context of length @n@.-      let n  = length . envContext . clEnv . miClosRange . mvInfo $ mv-      (vs, rest) <- splitAt n <$> getContextArgs-      reportSDoc "tc.ip" 20 $ vcat-        [ text "  s0   = " <+> prettyTCM s0-        , text "  vs   = " <+> prettyTCM vs-        , text "  rest = " <+> prettyTCM rest-        ]-      -- We assume the meta variable use here is in an extension of the original context.-      -- If not we revert to the old buggy behavior of #707 (see test/Succeed/Issue2257b).-      if (length vs /= n) then fallback else do-      s1  <- piApplyM s0 vs-      case ignoreSharing $ unEl s1 of-        Sort s -> return $ El s $ MetaV x $ map Apply vs-        _ -> __IMPOSSIBLE__--    _ -> fallback--ptsRule :: (LensSort a, LensSort b) => a -> b -> TCM Sort-ptsRule a b = pts <$> reduce (getSort a) <*> reduce (getSort b)---- | Ensure that a (freshly created) function type does not inhabit 'SizeUniv'.---   Precondition:  When @noFunctionsIntoSize t tBlame@ is called,---   we are in the context of @tBlame@ in order to print it correctly.---   Not being in context of @t@ should not matter, as we are only---   checking whether its sort reduces to 'SizeUniv'.-noFunctionsIntoSize :: Type -> Type -> TCM ()-noFunctionsIntoSize t tBlame = do-  reportSDoc "tc.fun" 20 $ do-    let El s (Pi dom b) = ignoreSharing <$> tBlame-    sep [ text "created function type " <+> prettyTCM tBlame-        , text "with pts rule" <+> prettyTCM (getSort dom, getSort b, s)-        ]-  s <- reduce $ getSort t-  when (s == SizeUniv) $ do-    -- Andreas, 2015-02-14-    -- We have constructed a function type in SizeUniv-    -- which is illegal to prevent issue 1428.-    typeError $ FunctionTypeInSizeUniv $ unEl tBlame---- | Check that an expression is a type which is equal to a given type.-isTypeEqualTo :: A.Expr -> Type -> TCM Type-isTypeEqualTo e0 t = scopedExpr e0 >>= \case-  A.ScopedExpr{} -> __IMPOSSIBLE__-  A.Underscore i | A.metaNumber i == Nothing -> return t-  e -> workOnTypes $ do-    t' <- isType e (getSort t)-    t' <$ leqType t t'--leqType_ :: Type -> Type -> TCM ()-leqType_ t t' = workOnTypes $ leqType t t'--{- UNUSED--- | Force a type to be a Pi. Instantiates if necessary. The 'Hiding' is only---   used when instantiating a meta variable.--forcePi :: Hiding -> String -> Type -> TCM Type-forcePi h name (El s t) =-    do  t' <- reduce t-        case t' of-            Pi _ _      -> return $ El s t'-            _           -> do-                sa <- newSortMeta-                sb <- newSortMeta-                let s' = sLub sa sb--                a <- newTypeMeta sa-                x <- freshName_ name-                let arg = setHiding h $ defaultDom a-                b <- addContext (x, arg) $ newTypeMeta sb-                let ty = El s' $ Pi arg (Abs (show x) b)-                equalType (El s t') ty-                ty' <- reduce ty-                return ty'--}-------------------------------------------------------------------------------- * Telescopes-------------------------------------------------------------------------------- | Type check a (module) telescope.---   Binds the variables defined by the telescope.-checkTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a-checkTelescope = checkTelescope' LamNotPi---- | Type check the telescope of a dependent function type.---   Binds the resurrected variables defined by the telescope.---   The returned telescope is unmodified (not resurrected).-checkPiTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a-checkPiTelescope = checkTelescope' PiNotLam---- | Flag to control resurrection on domains.-data LamOrPi-  = LamNotPi -- ^ We are checking a module telescope.-             --   We pass into the type world to check the domain type.-             --   This resurrects the whole context.-  | PiNotLam -- ^ We are checking a telescope in a Pi-type.-             --   We stay in the term world, but add resurrected-             --   domains to the context to check the remaining-             --   domains and codomain of the Pi-type.-  deriving (Eq, Show)---- | Type check a telescope. Binds the variables defined by the telescope.-checkTelescope' :: LamOrPi -> A.Telescope -> (Telescope -> TCM a) -> TCM a-checkTelescope' lamOrPi []        ret = ret EmptyTel-checkTelescope' lamOrPi (b : tel) ret =-    checkTypedBindings lamOrPi b $ \tel1 ->-    checkTelescope' lamOrPi tel  $ \tel2 ->-        ret $ abstract tel1 tel2---- | Check a typed binding and extends the context with the bound variables.---   The telescope passed to the continuation is valid in the original context.------   Parametrized by a flag wether we check a typed lambda or a Pi. This flag---   is needed for irrelevance.-checkTypedBindings :: LamOrPi -> A.TypedBindings -> (Telescope -> TCM a) -> TCM a-checkTypedBindings lamOrPi (A.TypedBindings i (Arg info b)) ret =-    checkTypedBinding lamOrPi info b $ \ bs ->-    ret $ telFromList bs--checkTypedBinding :: LamOrPi -> ArgInfo -> A.TypedBinding -> (ListTel -> TCM a) -> TCM a-checkTypedBinding lamOrPi info (A.TBind i xs e) ret = do-    -- Andreas, 2011-04-26 irrelevant function arguments may appear-    -- non-strictly in the codomain type-    -- 2011-10-04 if flag --experimental-irrelevance is set-    experimental <- optExperimentalIrrelevance <$> pragmaOptions-    t <- modEnv lamOrPi $ isType_ e-    let info' = mapRelevance (modRel lamOrPi experimental) info-    addContext' (xs, Dom info' t) $-      ret $ bindsWithHidingToTel xs (Dom info t)-    where-        -- if we are checking a typed lambda, we resurrect before we check the-        -- types, but do not modify the new context entries-        -- otherwise, if we are checking a pi, we do not resurrect, but-        -- modify the new context entries-        modEnv LamNotPi = workOnTypes-        modEnv _        = id-        modRel PiNotLam xp = if xp then irrToNonStrict else nonStrictToRel-        modRel _        _  = id-checkTypedBinding lamOrPi info (A.TLet _ lbs) ret = do-    checkLetBindings lbs (ret [])-------------------------------------------------------------------------------- * Lambda abstractions-------------------------------------------------------------------------------- | Type check a lambda expression.-checkLambda :: Arg A.TypedBinding -> A.Expr -> Type -> TCM Term-checkLambda (Arg _ (A.TLet _ lbs)) body target =-  checkLetBindings lbs (checkExpr body target)-checkLambda (Arg info (A.TBind _ xs typ)) body target = do-  reportSLn "tc.term.lambda" 60 $ "checkLambda   xs = " ++ show xs--  let numbinds = length xs-  TelV tel btyp <- telViewUpTo numbinds target-  if size tel < numbinds || numbinds /= 1-    then dontUseTargetType-    else useTargetType tel btyp-  where-    dontUseTargetType = do-      -- Checking λ (xs : argsT) → body : target-      verboseS "tc.term.lambda" 5 $ tick "lambda-no-target-type"--      -- First check that argsT is a valid type-      argsT <- workOnTypes $ Dom info <$> isType_ typ-      -- Andreas, 2015-05-28 Issue 1523-      -- If argsT is a SizeLt, it must be non-empty to avoid non-termination.-      -- TODO: do we need to block checkExpr?-      checkSizeLtSat $ unEl $ unDom argsT--      -- In order to have as much type information as possible when checking-      -- body, we first unify (xs : argsT) → ?t₁ with the target type. If this-      -- is inconclusive we need to block the resulting term so we create a-      -- fresh problem for the check.-      let tel = telFromList $ bindsWithHidingToTel xs argsT-      reportSLn "tc.term.lambda" 60 $ "dontUseTargetType tel = " ++ show tel-      -- DONT USE tel for addContext, as it loses NameIds.-      -- WRONG: t1 <- addContext tel $ workOnTypes newTypeMeta_-      t1 <- addContext (xs, argsT) $ workOnTypes newTypeMeta_-      -- Do not coerce hidden lambdas-      if notVisible info || any notVisible xs then do-        pid <- newProblem_ $ leqType (telePi tel t1) target-        -- Now check body : ?t₁-        -- WRONG: v <- addContext tel $ checkExpr body t1-        v <- addContext' (xs, argsT) $ checkExpr body t1-        -- Block on the type comparison-        blockTermOnProblem target (teleLam tel v) pid-       else do-        -- Now check body : ?t₁-        -- WRONG: v <- addContext tel $ checkExpr body t1-        v <- addContext' (xs, argsT) $ checkExpr body t1-        -- Block on the type comparison-        coerce (teleLam tel v) (telePi tel t1) target--    useTargetType tel@(ExtendTel arg (Abs y EmptyTel)) btyp = do-        verboseS "tc.term.lambda" 5 $ tick "lambda-with-target-type"-        reportSLn "tc.term.lambda" 60 $ "useTargetType y  = " ++ show y--        -- merge in the hiding info of the TBind-        info <- return $ mapHiding (mappend h) info-        unless (getHiding arg == getHiding info) $ typeError $ WrongHidingInLambda target-        -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given-        let r  = getRelevance info-            r' = getRelevance arg -- relevance of function type-        when (r == Irrelevant && r' /= r) $ typeError $ WrongIrrelevanceInLambda target-        -- Andreas, 2015-05-28 Issue 1523-        -- Ensure we are not stepping under a possibly non-existing size.-        -- TODO: do we need to block checkExpr?-        let a = unDom arg-        checkSizeLtSat $ unEl a-        -- We only need to block the final term on the argument type-        -- comparison. The body will be blocked if necessary. We still want to-        -- compare the argument types first, so we spawn a new problem for that-        -- check.-        (pid, argT) <- newProblem $ isTypeEqualTo typ a-        v <- add (notInScopeName y) (Dom (setRelevance r' info) argT) $ checkExpr body btyp-        blockTermOnProblem target (Lam info $ Abs (nameToArgName x) v) pid-      where-        [WithHiding h x] = xs-        -- Andreas, Issue 630: take name from function type if lambda name is "_"-        add y dom | isNoName x = addContext' (y, dom)-                  | otherwise  = addContext' (x, dom)-    useTargetType _ _ = __IMPOSSIBLE__---- | Checking a lambda whose domain type has already been checked.-checkPostponedLambda :: Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term-checkPostponedLambda args@(Arg _    ([]    , _ )) body target = do-  checkExpr body target-checkPostponedLambda args@(Arg info (WithHiding h x : xs, mt)) body target = do-  let postpone _ t = postponeTypeCheckingProblem_ $ CheckLambda args body t-      lamHiding = mappend h $ getHiding info-  insertHiddenLambdas lamHiding target postpone $ \ t@(El _ (Pi dom b)) -> do-    -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given-    let r     = getRelevance info -- relevance of lambda-        r'    = getRelevance dom  -- relevance of function type-        info' = setHiding lamHiding $ setRelevance r' info-    when (r == Irrelevant && r' /= r) $-      typeError $ WrongIrrelevanceInLambda target-    -- We only need to block the final term on the argument type-    -- comparison. The body will be blocked if necessary. We still want to-    -- compare the argument types first, so we spawn a new problem for that-    -- check.-    mpid <- caseMaybe mt (return Nothing) $ \ ascribedType -> Just <$> do-      newProblem_ $ leqType (unDom dom) ascribedType-    -- We type-check the body with the ascribedType given by the user-    -- to get better error messages.-    -- Using the type dom from the usage context would be more precise,-    -- though.-    let add dom | isNoName x = addContext (absName b, dom)-                | otherwise  = addContext (x, dom)-    v <- add (maybe dom (dom $>) mt) $-      checkPostponedLambda (Arg info (xs, mt)) body $ absBody b-    let v' = Lam info' $ Abs (nameToArgName x) v-    maybe (return v') (blockTermOnProblem t v') mpid----- | Insert hidden lambda until the hiding info of the domain type---   matches the expected hiding info.---   Throws 'WrongHidingInLambda'-insertHiddenLambdas-  :: Hiding                       -- ^ Expected hiding.-  -> Type                         -- ^ Expected to be a function type.-  -> (MetaId -> Type -> TCM Term) -- ^ Continuation on blocked type.-  -> (Type -> TCM Term)           -- ^ Continuation when expected hiding found.-                                  --   The continuation may assume that the @Type@-                                  --   is of the form @(El _ (Pi _ _))@.-  -> TCM Term                     -- ^ Term with hidden lambda inserted.-insertHiddenLambdas h target postpone ret = do-  -- If the target type is blocked, we postpone,-  -- because we do not know if a hidden lambda needs to be inserted.-  ifBlockedType target postpone $ \ t0 -> do-    let t = ignoreSharing <$> t0-    case unEl t of--      Pi dom b -> do-        let h' = getHiding dom-        -- Found expected hiding: return function type.-        if h == h' then ret t else do-          -- Found a visible argument but expected a hidden one:-          -- That's an error, as we cannot insert a visible lambda.-          if visible h' then typeError $ WrongHidingInLambda target else do-            -- Otherwise, we found a hidden argument that we can insert.-            let x = absName b-            Lam (domInfo dom) . Abs x <$> do-              addContext' (x, dom) $ insertHiddenLambdas h (absBody b) postpone ret--      _ -> typeError . GenericDocError =<< do-        text "Expected " <+> prettyTCM target <+> text " to be a function type"---- | @checkAbsurdLambda i h e t@ checks absurd lambda against type @t@.---   Precondition: @e = AbsurdLam i h@-checkAbsurdLambda :: A.ExprInfo -> Hiding -> A.Expr -> Type -> TCM Term-checkAbsurdLambda i h e t = do-  t <- instantiateFull t-  ifBlockedType t (\ m t' -> postponeTypeCheckingProblem_ $ CheckExpr e t') $ \ t' -> do-    case ignoreSharing $ unEl t' of-      Pi dom@(Dom info' a) b-        | h /= getHiding info' -> typeError $ WrongHidingInLambda t'-        | not (null $ allMetas a) ->-            postponeTypeCheckingProblem (CheckExpr e t') $-              null . allMetas <$> instantiateFull a-        | otherwise -> blockTerm t' $ do-          isEmptyType (getRange i) a-          -- Add helper function-          top <- currentModule-          aux <- qualify top <$> freshName_ (getRange i, absurdLambdaName)-          -- if we are in irrelevant position, the helper function-          -- is added as irrelevant-          rel <- asks envRelevance-          reportSDoc "tc.term.absurd" 10 $ vcat-            [ text "Adding absurd function" <+> prettyTCM rel <> prettyTCM aux-            , nest 2 $ text "of type" <+> prettyTCM t'-            ]-          addConstant aux $-            (\ d -> (defaultDefn (setRelevance rel info') aux t' d)-                    { defPolarity       = [Nonvariant]-                    , defArgOccurrences = [Unused] })-            $ emptyFunction-              { funClauses        =-                  [Clause-                    { clauseRange     = getRange e-                    , clauseTel       = telFromList [fmap ("()",) dom]-                    , namedClausePats = [Arg info' $ Named (Just $ unranged $ absName b) $ debruijnNamedVar "()" 0]-                    , clauseBody      = Nothing-                    , clauseType      = Just $ setRelevance rel $ defaultArg $ absBody b-                    , clauseCatchall  = False-                    }-                  ]-              , funCompiled       = Just Fail-              , funTerminates     = Just True-              }-          -- Andreas 2012-01-30: since aux is lifted to toplevel-          -- it needs to be applied to the current telescope (issue 557)-          tel <- getContextTelescope-          return $ Def aux $ map Apply $ teleArgs tel-      _ -> typeError $ ShouldBePi t'---- | @checkExtendedLambda i di qname cs e t@ check pattern matching lambda.--- Precondition: @e = ExtendedLam i di qname cs@-checkExtendedLambda :: A.ExprInfo -> A.DefInfo -> QName -> [A.Clause] ->-                       A.Expr -> Type -> TCM Term-checkExtendedLambda i di qname cs e t = do-   -- Andreas, 2016-06-16 issue #2045-   -- Try to get rid of unsolved size metas before we-   -- fix the type of the extended lambda auxiliary function-   solveSizeConstraints DontDefaultToInfty-   t <- instantiateFull t-   ifBlockedType t (\ m t' -> postponeTypeCheckingProblem_ $ CheckExpr e t') $ \ t -> do-     j   <- currentOrFreshMutualBlock-     rel <- asks envRelevance-     let info = setRelevance rel defaultArgInfo-     -- Andreas, 2016-07-13, issue 2028.-     -- Save the state to rollback the changes to the signature.-     st <- get-     -- Andreas, 2013-12-28: add extendedlambda as @Function@, not as @Axiom@;-     -- otherwise, @addClause@ in @checkFunDef'@ fails (see issue 1009).-     addConstant qname =<< do-       useTerPragma $-         (defaultDefn info qname t emptyFunction) { defMutual = j }-     reportSDoc "tc.term.exlam" 20 $-       text (show $ A.defAbstract di) <+>-       text "extended lambda's implementation \"" <> prettyTCM qname <>-       text "\" has type: " $$ prettyTCM t -- <+> text " where clauses: " <+> text (show cs)-     args     <- getContextArgs-     freevars <- getCurrentModuleFreeVars-     let argsNoParam = genericDrop freevars args -- don't count module parameters-     let (hid, notHid) = partition notVisible argsNoParam-     reportSDoc "tc.term.exlam" 30 $ vcat $-       [ text "dropped args: " <+> prettyTCM (take freevars args)-       , text "hidden  args: " <+> prettyTCM hid-       , text "visible args: " <+> prettyTCM notHid-       ]-     -- Andreas, Ulf, 2016-02-02: We want to postpone type checking an extended lambda-     -- in case the lhs checker failed due to insufficient type info for the patterns.-     -- Issues 480, 1159, 1811.-     mx <- catchIlltypedPatternBlockedOnMeta $ abstract (A.defAbstract di) $-       checkFunDef' t info NotDelayed (Just $ ExtLamInfo (length hid) (length notHid)) Nothing di qname cs-     case mx of-       -- Case: type checking succeeded, so we go ahead.-       Nothing -> return $ Def qname $ map Apply args-       -- Case: we could not check the extended lambda because we are blocked on a meta.-       -- In this case, we want to postpone.-       Just (err, x) -> do-         -- Note that we messed up the state a bit.  We might want to unroll these state changes.-         -- However, they are mostly harmless:-         -- 1. We created a new mutual block id.-         -- 2. We added a constant without definition.--         -- In fact, they are not so harmless, see issue 2028!-         -- Thus, reset the state!-         put st--         -- The meta might not be known in the reset state, as it could have been created-         -- somewhere on the way to the type error.-         mm <- Map.lookup x <$> getMetaStore-         case mvInstantiation <$> mm of-           -- Case: we do not know the meta-           Nothing -> do-             -- TODO: mine for a meta in t-             -- For now, we fail.-             throwError err-           -- Case: we know the meta here.-           Just InstV{} -> __IMPOSSIBLE__  -- It cannot be instantiated yet.-           Just{} -> do-             -- It has to be blocked on some meta, so we can postpone,-             -- being sure it will be retired when a meta is solved-             -- (which might be the blocking meta in which case we actually make progress).-             postponeTypeCheckingProblem (CheckExpr e t) $ isInstantiatedMeta x-  where-    -- Concrete definitions cannot use information about abstract things.-    abstract ConcreteDef = inConcreteMode-    abstract AbstractDef = inAbstractMode---- | Run a computation.------   * If successful, return Nothing.------   * If @IlltypedPattern p a@ is thrown and type @a@ is blocked on some meta @x@---     return @Just x@.  Note that the returned meta might only exists in the state---     where the error was thrown, thus, be an invalid 'MetaId' in the current state.------   * If another error was thrown or the type @a@ is not blocked, reraise the error.----catchIlltypedPatternBlockedOnMeta :: TCM () -> TCM (Maybe (TCErr, MetaId))-catchIlltypedPatternBlockedOnMeta m = (Nothing <$ do disableDestructiveUpdate m)-  `catchError` \ err -> do-  let reraise = throwError err-  case err of-    TypeError s cl@Closure{ clValue = IlltypedPattern p a } -> do-      mx <- localState $ do-        put s-        enterClosure cl $ \ _ -> do-          ifBlockedType a (\ x _ -> return $ Just x) $ {- else -} \ _ -> return Nothing-      caseMaybe mx reraise $ \ x -> return $ Just (err, x)-    _ -> reraise-------------------------------------------------------------------------------- * Records------------------------------------------------------------------------------expandModuleAssigns :: [Either A.Assign A.ModuleName] -> [C.Name] -> TCM A.Assigns-expandModuleAssigns mfs exs = do-  let (fs , ms) = partitionEithers mfs-      exs' = exs \\ map (view nameFieldA) fs-  fs' <- forM exs' $ \ f -> do-    pms <- forM ms $ \ m -> do-       modScope <- getNamedScope m-       let names :: ThingsInScope AbstractName-           names = exportedNamesInScope modScope-       return $-        case Map.lookup f names of-          Just [n] -> Just (m, FieldAssignment f (A.nameExpr n))-          _        -> Nothing--    case catMaybes pms of-      []        -> return Nothing-      [(_, fa)] -> return (Just fa)-      mfas      -> typeError $ GenericError $ "Ambiguity: the field " ++ show f ++ " appears in the following modules " ++ show (map fst mfas)-  return (fs ++ catMaybes fs')---- | @checkRecordExpression fs e t@ checks record construction against type @t@.--- Precondition @e = Rec _ fs@.-checkRecordExpression :: A.RecordAssigns  -> A.Expr -> Type -> TCM Term-checkRecordExpression mfs e t = do-  reportSDoc "tc.term.rec" 10 $ sep-    [ text "checking record expression"-    , prettyA e-    ]-  ifBlockedType t (\ _ t -> guessRecordType t) {-else-} $ \ t -> do-  case ignoreSharing $ unEl t of-    -- Case: We know the type of the record already.-    Def r es  -> do-      let ~(Just vs) = allApplyElims es-      reportSDoc "tc.term.rec" 20 $ text $ "  r   = " ++ show r--      reportSDoc "tc.term.rec" 30 $ text "  xs  = " <> do-        text =<< show . map unArg <$> getRecordFieldNames r-      reportSDoc "tc.term.rec" 30 $ text "  ftel= " <> do-        prettyTCM =<< getRecordFieldTypes r-      reportSDoc "tc.term.rec" 30 $ text "  con = " <> do-        text =<< show <$> getRecordConstructor r--      def <- getRecordDef r-      let -- Field names with ArgInfo.-          axs  = recordFieldNames def-          exs  = filter notHidden axs-          -- Just field names.-          xs   = map unArg axs-          -- Record constructor.-          con  = killRange $ recConHead def-      reportSDoc "tc.term.rec" 20 $ vcat-        [ text $ "  xs  = " ++ show xs-        , text   "  ftel= " <> prettyTCM (recTel def)-        , text $ "  con = " ++ show con-        ]--      -- Compute the list of given fields, decorated with the ArgInfo from the record def.-      fs <- expandModuleAssigns mfs (map unArg exs)--      -- Compute a list of metas for the missing visible fields.-      scope <- getScope-      let re = getRange e-          meta x = A.Underscore $ A.MetaInfo re scope Nothing (show x)-      -- In @es@ omitted explicit fields are replaced by underscores.-      -- Omitted implicit or instance fields-      -- are still left out and inserted later by checkArguments_.-      es <- insertMissingFields r meta fs axs--      args <- checkArguments_ ExpandLast re es (recTel def `apply` vs) >>= \case-        (args, remainingTel) | null remainingTel -> return args-        _ -> __IMPOSSIBLE__-      -- Don't need to block here!-      reportSDoc "tc.term.rec" 20 $ text $ "finished record expression"-      return $ Con con ConORec args-    _         -> typeError $ ShouldBeRecordType t--  where-    guessRecordType t = do-      let fields = [ x | Left (FieldAssignment x _) <- mfs ]-      rs <- findPossibleRecords fields-      case rs of-          -- If there are no records with the right fields we might as well fail right away.-        [] -> case fields of-          []  -> typeError $ GenericError "There are no records in scope"-          [f] -> typeError $ GenericError $ "There is no known record with the field " ++ show f-          _   -> typeError $ GenericError $ "There is no known record with the fields " ++ unwords (map show fields)-          -- If there's only one record with the appropriate fields, go with that.-        [r] -> do-          def <- getConstInfo r-          let rt = defType def-          vs  <- newArgsMeta rt-          target <- reduce $ piApply rt vs-          s  <- case ignoreSharing $ unEl target of-                  Level l -> return $ Type l-                  Sort s  -> return s-                  v       -> do-                    reportSDoc "impossible" 10 $ vcat-                      [ text "The impossible happened when checking record expression against meta"-                      , text "Candidate record type r = " <+> prettyTCM r-                      , text "Type of r               = " <+> prettyTCM rt-                      , text "Ends in (should be sort)= " <+> prettyTCM v-                      , text $ "  Raw                   =  " ++ show v-                      ]-                    __IMPOSSIBLE__-          let inferred = El s $ Def r $ map Apply vs-          v <- checkExpr e inferred-          coerce v inferred t-          -- Andreas 2012-04-21: OLD CODE, WRONG DIRECTION, I GUESS:-          -- blockTerm t $ v <$ leqType_ t inferred--          -- If there are more than one possible record we postpone-        _:_:_ -> do-          reportSDoc "tc.term.expr.rec" 10 $ sep-            [ text "Postponing type checking of"-            , nest 2 $ prettyA e <+> text ":" <+> prettyTCM t-            ]-          postponeTypeCheckingProblem_ $ CheckExpr e t----- | @checkRecordUpdate ei recexpr fs e t@--- Precondition @e = RecUpdate ei recexpr fs@.-checkRecordUpdate :: A.ExprInfo -> A.Expr -> A.Assigns -> A.Expr -> Type -> TCM Term-checkRecordUpdate ei recexpr fs e t = do-  case ignoreSharing $ unEl t of-    Def r vs  -> do-      v <- checkExpr recexpr t-      name <- freshNoName (getRange recexpr)-      addLetBinding defaultArgInfo name v t $ do-        projs <- recFields <$> getRecordDef r-        axs <- getRecordFieldNames r-        scope <- getScope-        let xs = map unArg axs-        es <- orderFields r Nothing xs $ map (\ (FieldAssignment x e) -> (x, Just e)) fs-        let es' = zipWith (replaceFields name ei) projs es-        checkExpr (A.Rec ei [ Left (FieldAssignment x e) | (x, Just e) <- zip xs es' ]) t-    MetaV _ _ -> do-      inferred <- inferExpr recexpr >>= reduce . snd-      case ignoreSharing $ unEl inferred of-        MetaV _ _ -> postponeTypeCheckingProblem_ $ CheckExpr e t-        _         -> do-          v <- checkExpr e inferred-          coerce v inferred t-    _         -> typeError $ ShouldBeRecordType t-  where-    replaceFields :: Name -> A.ExprInfo -> Arg A.QName -> Maybe A.Expr -> Maybe A.Expr-    replaceFields n ei a@(Arg _ p) Nothing | notHidden a =-        Just $ A.App ei (A.Def p) $ defaultNamedArg $ A.Var n-    replaceFields _ _  (Arg _ _) Nothing  = Nothing-    replaceFields _ _  _         (Just e) = Just $ e-------------------------------------------------------------------------------- * Literal------------------------------------------------------------------------------checkLiteral :: Literal -> Type -> TCM Term-checkLiteral lit t = do-  t' <- litType lit-  coerce (Lit lit) t' t-------------------------------------------------------------------------------- * Terms-------------------------------------------------------------------------------- | @checkArguments' exph r args t0 t k@ tries @checkArguments 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' ::-  ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-  (Args -> Type -> TCM Term) -> TCM Term-checkArguments' exph r args t0 t k = do-  z <- runExceptT $ checkArguments exph r args t0 t-  case z of-    Right (vs, t1) -> k vs t1-      -- vs = evaluated args-      -- t1 = remaining type (needs to be subtype of t)-    Left (us, es, t0) -> do-      reportSDoc "tc.term.expr.args" 80 $-        sep [ text "postponed checking arguments"-            , nest 4 $ prettyList (map (prettyA . namedThing . unArg) args)-            , nest 2 $ text "against"-            , nest 4 $ prettyTCM t0 ] $$-        sep [ text "progress:"-            , nest 2 $ text "checked" <+> prettyList (map prettyTCM us)-            , nest 2 $ text "remaining" <+> sep [ prettyList (map (prettyA . namedThing . unArg) es)-                                                , nest 2 $ text ":" <+> prettyTCM t0 ] ]-      postponeTypeCheckingProblem_ (CheckArgs exph r es t0 t $ \vs t -> k (us ++ vs) t)-      -- if unsuccessful, postpone checking until t0 unblocks----- | Remove top layers of scope info of expression and set the scope accordingly---   in the 'TCState'.--scopedExpr :: A.Expr -> TCM A.Expr-scopedExpr (A.ScopedExpr scope e) = setScope scope >> scopedExpr e-scopedExpr e                      = return e---- | Type check an expression.-checkExpr :: A.Expr -> Type -> TCM Term-checkExpr e t0 =-  verboseBracket "tc.term.expr.top" 5 "checkExpr" $-  traceCall (CheckExprCall e t0) $ localScope $ doExpandLast $ shared =<< do-    reportSDoc "tc.term.expr.top" 15 $-        text "Checking" <+> sep-          [ fsep [ prettyTCM e, text ":", prettyTCM t0 ]-          , nest 2 $ text "at " <+> (text . show =<< getCurrentRange)-          ]-    reportSDoc "tc.term.expr.top.detailed" 80 $-      text "Checking" <+> fsep [ prettyTCM e, text ":", text (show t0) ]-    t <- reduce t0-    reportSDoc "tc.term.expr.top" 15 $-        text "    --> " <+> prettyTCM t--    e <- scopedExpr e--    case e of--        A.ScopedExpr scope e -> __IMPOSSIBLE__ -- setScope scope >> checkExpr e t--        -- Insert hidden lambda if all of the following conditions are met:-            -- type is a hidden function type, {x : A} -> B or {{x : A} -> B-        _   | Pi (Dom info _) b <- ignoreSharing $ unEl t-            , let h = getHiding info-            , notVisible h-            -- expression is not a matching hidden lambda or question mark-            , not (hiddenLambdaOrHole h e)-            -> do-                x <- unshadowName <=< freshName rx $ notInScopeName $ absName b-                reportSLn "tc.term.expr.impl" 15 $ "Inserting implicit lambda"-                checkExpr (A.Lam (A.ExprRange re) (domainFree info x) e) t-            where-                re = getRange e-                rx = caseMaybe (rStart re) noRange $ \ pos -> posToRange pos pos--                hiddenLambdaOrHole h e = case e of-                  A.AbsurdLam _ h'        -> h == h'-                  A.ExtendedLam _ _ _ cls -> any hiddenLHS cls-                  A.Lam _ bind _          -> h == getHiding bind-                  A.QuestionMark{}        -> True-                  _                       -> False--                hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _)) _) _ _ _ _) = notVisible a-                hiddenLHS _ = False--        -- a meta variable without arguments: type check directly for efficiency-        A.QuestionMark i ii -> checkQuestionMark (newValueMeta' DontRunMetaOccursCheck) t0 i ii-        A.Underscore i -> checkUnderscore t0 i--        A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application"--        -- check |- Set l : t  (requires universe polymorphism)-        A.App i s arg@(Arg ai l)-          | A.Set _ 0 <- unScope s, visible ai ->-          ifNotM hasUniversePolymorphism-              (typeError $ GenericError "Use --universe-polymorphism to enable level arguments to Set")-          $ {- else -} do-            lvl <- levelType-            -- allow NonStrict variables when checking level-            --   Set : (NonStrict) Level -> Set\omega-            n   <- levelView =<< do-              applyRelevanceToContext NonStrict $-                checkNamedArg arg lvl-            -- check that Set (l+1) <= t-            reportSDoc "tc.univ.poly" 10 $-              text "checking Set " <+> prettyTCM n <+>-              text "against" <+> prettyTCM t-            coerce (Sort $ Type n) (sort $ sSuc $ Type n) t--        e0@(A.App i q (Arg ai e))-          | A.Quote _ <- unScope q, visible ai -> do-          let quoted (A.Def x) = return x-              quoted (A.Macro x) = return x-              quoted (A.Proj o (AmbQ [x])) = return x-              quoted (A.Proj o (AmbQ xs))  = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs-              quoted (A.Con (AmbQ [x])) = return x-              quoted (A.Con (AmbQ xs))  = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs-              quoted (A.ScopedExpr _ e) = quoted e-              quoted _                  = typeError $ GenericError $ "quote: not a defined name"-          x <- quoted (namedThing e)-          ty <- qNameType-          coerce (quoteName x) ty t--          | A.QuoteTerm _ <- unScope q ->-             do (et, _)   <- inferExpr (namedThing e)-                et'       <- etaContract =<< instantiateFull et-                let metas = allMetas et'-                case metas of-                  _:_ -> postponeTypeCheckingProblem (CheckExpr e0 t) $ andM $ map isInstantiatedMeta metas-                  []  -> do-                    q  <- quoteTerm et'-                    ty <- el primAgdaTerm-                    coerce q ty t--        A.Quote _ -> typeError $ GenericError "quote must be applied to a defined name"-        A.QuoteTerm _ -> typeError $ GenericError "quoteTerm must be applied to a term"-        A.Unquote _ -> typeError $ GenericError "unquote must be applied to a term"--        A.AbsurdLam i h -> checkAbsurdLambda i h e t--        A.ExtendedLam i di qname cs -> checkExtendedLambda i di qname cs e t--        A.Lam i (A.DomainFull (A.TypedBindings _ b)) e -> checkLambda b e t--        A.Lam i (A.DomainFree info x) e0 -> checkExpr (A.Lam i (domainFree info x) e0) t--        A.Lit lit    -> checkLiteral lit t-        A.Let i ds e -> checkLetBindings ds $ checkExpr e t-        A.Pi _ tel e | null tel -> checkExpr e t-        A.Pi _ tel e -> do-            (t0, t') <- checkPiTelescope tel $ \ tel -> do-                    t0  <- instantiateFull =<< isType_ e-                    tel <- instantiateFull tel-                    return (t0, telePi tel t0)-            noFunctionsIntoSize t0 t'-            let s = getSort t'-                v = unEl t'-            when (s == Inf) $ reportSDoc "tc.term.sort" 20 $-              vcat [ text ("reduced to omega:")-                   , nest 2 $ text "t   =" <+> prettyTCM t'-                   , nest 2 $ text "cxt =" <+> (prettyTCM =<< getContextTelescope)-                   ]-            coerce v (sort s) t-        A.Fun _ (Arg info a) b -> do-            a' <- isType_ a-            b' <- isType_ b-            s <- ptsRule a' b'-            let v = Pi (Dom info a') (NoAbs underscore b')-            noFunctionsIntoSize b' $ El s v-            coerce v (sort s) t-        A.Set _ n    -> do-          coerce (Sort $ mkType n) (sort $ mkType $ n + 1) t-        A.Prop _     -> do-          typeError $ GenericError "Prop is no longer supported"--        A.Rec _ fs  -> checkRecordExpression fs e t--        A.RecUpdate ei recexpr fs -> checkRecordUpdate ei recexpr fs e t--        A.DontCare e -> -- resurrect vars-          ifM ((Irrelevant ==) <$> asks envRelevance)-            (dontCare <$> do applyRelevanceToContext Irrelevant $ checkExpr e t)-            (internalError "DontCare may only appear in irrelevant contexts")--        e0@(A.QuoteGoal _ x e) -> do-          qg <- quoteGoal t-          case qg of-            Left metas -> postponeTypeCheckingProblem (CheckExpr e0 t) $ andM $ map isInstantiatedMeta metas-            Right quoted -> do-              tmType <- agdaTermType-              (v, ty) <- addLetBinding defaultArgInfo x quoted tmType (inferExpr e)-              coerce v ty t-        e0@(A.QuoteContext _) -> do-          qc <- quoteContext-          case qc of-            Left metas -> postponeTypeCheckingProblem (CheckExpr e0 t) $ andM $ map isInstantiatedMeta metas-            Right quotedContext -> do-              ctxType <- el $ list $ primArg <@> (unEl <$> agdaTypeType)-              coerce quotedContext ctxType t-        e0@(A.Tactic i e xs ys) -> do-          qc <- quoteContext-          qg <- quoteGoal t-          let postpone metas = postponeTypeCheckingProblem (CheckExpr e0 t) $ andM $ map isInstantiatedMeta metas-          case (qc, qg) of-            (Left metas1, Left metas2) -> postpone $ metas1 ++ metas2-            (Left metas , Right _    ) -> postpone $ metas-            (Right _    , Left metas ) -> postpone $ metas-            (Right quotedCtx, Right quotedGoal) -> do-              quotedCtx  <- defaultNamedArg <$> reify quotedCtx-              quotedGoal <- defaultNamedArg <$> reify quotedGoal-              let tac    = foldl (A.App i) (A.App i (A.App i e quotedCtx) quotedGoal) xs-                  result = foldl (A.App i) (A.Unquote i) (defaultNamedArg tac : ys)-              checkExpr result t--        A.ETel _   -> __IMPOSSIBLE__--        A.Dot{} -> typeError $ GenericError $ "Invalid dotted expression"--        -- Application-        _   | Application hd args <- appView e -> checkApplication hd args e t-------------------------------------------------------------------------------- * Reflection-------------------------------------------------------------------------------- | DOCUMENT ME!-quoteGoal :: Type -> TCM (Either [MetaId] Term)-quoteGoal t = do-  t' <- etaContract =<< instantiateFull t-  let metas = allMetas t'-  case metas of-    _:_ -> return $ Left metas-    []  -> do-      quotedGoal <- quoteTerm (unEl t')-      return $ Right quotedGoal---- | DOCUMENT ME!-quoteContext :: TCM (Either [MetaId] Term)-quoteContext = do-  contextTypes  <- map (fmap snd) <$> getContext-  contextTypes  <- etaContract =<< instantiateFull contextTypes-  let metas = allMetas contextTypes-  case metas of-    _:_ -> return $ Left metas-    []  -> do-      quotedContext <- buildList <*> mapM quoteDom contextTypes-      return $ Right quotedContext---- | Unquote a TCM computation in a given hole.-unquoteM :: A.Expr -> Term -> Type -> TCM Term -> TCM Term-unquoteM tac hole holeType k = do-  tac <- checkExpr tac =<< (el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit))-  inFreshModuleIfFreeParams $ unquoteTactic tac hole holeType k---- | DOCUMENT ME!-unquoteTactic :: Term -> Term -> Type -> TCM Term -> TCM Term-unquoteTactic tac hole goal k = do-  ok  <- runUnquoteM $ unquoteTCM tac hole-  case ok of-    Left (BlockedOnMeta oldState x) -> do-      put oldState-      mi <- Map.lookup x <$> getMetaStore-      (r, unblock) <- case mi of-        Nothing -> do -- fresh meta: need to block on something else!-          otherMetas <- allMetas <$> instantiateFull goal-          case otherMetas of-            []  -> return (noRange,     return False) -- Nothing to block on, leave it yellow. Alternative: fail.-            x:_ -> return (noRange,     isInstantiatedMeta x)  -- range?-        Just mi -> return (getRange mi, isInstantiatedMeta x)-      setCurrentRange r $-        postponeTypeCheckingProblem (UnquoteTactic tac hole goal) unblock-    Left err -> typeError $ UnquoteFailed err-    Right _ -> k-------------------------------------------------------------------------------- * Projections-------------------------------------------------------------------------------- | Inferring the type of an overloaded projection application.---   See 'inferOrCheckProjApp'.--inferProjApp :: A.Expr -> ProjOrigin -> [QName] -> A.Args -> TCM (Term, Type)-inferProjApp e o ds args0 = inferOrCheckProjApp e o ds args0 Nothing---- | Checking the type of an overloaded projection application.---   See 'inferOrCheckProjApp'.--checkProjApp  :: A.Expr -> ProjOrigin -> [QName] -> A.Args -> Type -> TCM Term-checkProjApp e o ds args0 t = do-  (v, ti) <- inferOrCheckProjApp e o ds args0 (Just t)-  coerce 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.-  -> [QName]-     -- ^ The projection name (potentially ambiguous).  List must not be empty.-  -> A.Args-     -- ^ The arguments to the projection.-  -> Maybe Type-     -- ^ The expected type of the expression (if 'Nothing', infer it).-  -> TCM (Term, Type)-     -- ^ The type-checked expression and its type (if successful).-inferOrCheckProjApp e o ds args mt = do-  reportSDoc "tc.proj.amb" 20 $ vcat-    [ text "checking ambiguous projection"-    , text $ "  ds   = " ++ show ds-    , text   "  args = " <+> sep (map prettyTCM args)-    , text   "  t    = " <+> caseMaybe mt (text "Nothing") prettyTCM-    ]--  let refuse :: String -> TCM (Term, Type)-      refuse reason = typeError $ GenericError $-        "Cannot resolve overloaded projection "-        ++ show (A.nameConcrete $ A.qnameName $ head ds)-        ++ " because " ++ reason-      refuseNotApplied = refuse "it is not applied to a visible argument"-      refuseNoMatching = refuse "no matching candidate found"-      refuseNotRecordType = refuse "principal argument is not of record type"--      -- 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 m = do-        tc <- caseMaybe mt newTypeMeta_ return-        v <- postponeTypeCheckingProblem (CheckExpr e tc) $ isInstantiatedMeta m-        return (v, tc)--  -- 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 . getHiding . 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 refuseNotApplied $ \ 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-      ifBlockedType core (\ m _ -> postpone m) $ {-else-} \ core -> do-      ifNotPiType core (\ _ -> refuseNotApplied) $ {-else-} \ dom _b -> do-      ifBlockedType (unDom dom) (\ m _ -> postpone m) $ {-else-} \ ta -> do-      caseMaybeM (isRecordType ta) refuseNotRecordType $ \ (_q, _pars, defn) -> do-      case defn of-        Record { recFields = fs } -> do-          case catMaybes $ for fs $ \ (Arg _ f) -> find (f ==) ds of-            [] -> refuseNoMatching-            [d] -> do-              storeDisambiguatedName d-              (,t) <$> checkHeadApplication e t (A.Proj o $ AmbQ [d]) args-            _ -> __IMPOSSIBLE__-        _ -> __IMPOSSIBLE__--    -- Case: we have a visible argument-    ((k, arg) : _) -> do-      (v0, ta) <- inferExpr $ namedArg arg-      reportSDoc "tc.proj.amb" 25 $ vcat-        [ text "  principal arg " <+> prettyTCM arg-        , text "  has type "      <+> prettyTCM ta-        ]-      -- ta should be a record type (after introducing the hidden args in v0)-      (vargs, ta) <- implicitArgs (-1) (not . visible) ta-      let v = v0 `apply` vargs-      ifBlockedType ta (\ m _ -> postpone m) {-else-} $ \ ta -> do-      caseMaybeM (isRecordType ta) refuseNotRecordType $ \ (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 " ++ show d-                , text "  td  = " <+> caseMaybeM (getDefType d ta) (text "Nothing") prettyTCM-                ]-              -- get the original projection name-              Projection{ projProper = proper, projOrig = orig } <- MaybeT $ isProjection d-              guard proper-              -- try to eliminate-              (dom, u, tb) <- MaybeT (projectTyped v ta o d `catchError` \ _ -> return Nothing)-              reportSDoc "tc.proj.amb" 30 $ vcat-                [ text "  dom = " <+> prettyTCM dom-                , text "  u   = " <+> prettyTCM u-                , text "  tb  = " <+> prettyTCM tb-                ]-              (q', pars, _) <- MaybeT $ isRecordType $ unDom dom-              reportSDoc "tc.proj.amb" 30 $ vcat-                [ text "  q   = " <+> prettyTCM q-                , text "  q'  = " <+> prettyTCM q'-                ]-              guard (q == q')-              -- Get the type of the projection and check-              -- that the first visible argument is the record value.-              tfull <- lift $ defType <$> getConstInfo d-              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)-              return (orig, (d, (pars, (dom, u, tb))))--          cands <- groupOn fst . catMaybes <$> mapM (runMaybeT . try) ds-          case cands of-            [] -> refuseNoMatching-            [[]] -> refuseNoMatching-            (_:_:_) -> refuse $ "several matching candidates found: "-                 ++ show (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-              storeDisambiguatedName d--              -- Check parameters-              tfull <- typeOfConst d-              (_,_) <- checkKnownArguments (take k args) pars tfull--              -- Check remaining arguments-              let tc = fromMaybe typeDontCare mt-              let r  = getRange e-              z <- runExceptT $ checkArguments ExpandLast r (drop (k+1) args) tb tc-              case z of-                Right (us, trest) -> return (u `apply` us, trest)-                -- We managed to check a part of es and got us1, but es2 remain.-                Left (us1, es2, trest1) -> 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-                  v <- postponeTypeCheckingProblem_ $-                    CheckArgs ExpandLast r es2 trest1 tc $ \ us2 trest ->-                      coerce (u `apply` us1 `apply` us2) trest tc-                  return (v, tc)----- | @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 :: A.Expr -> A.Args -> A.Expr -> Type -> TCM Term-checkApplication hd args e t = do-  reportSDoc "tc.check.app" 20 $ vcat-    [ text "checkApplication"-    , nest 2 $ text "hd   = " <+> prettyA hd-    , nest 2 $ text "args = " <+> sep (map prettyA args)-    , nest 2 $ text "e    = " <+> prettyA e-    , nest 2 $ text "t    = " <+> prettyTCM t-    ]-  reportSDoc "tc.check.app" 70 $ vcat-    [ text "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-    A.Proj _ (AmbQ []) -> __IMPOSSIBLE__--    -- Subcase: unambiguous projection-    A.Proj _ (AmbQ [_]) -> checkHeadApplication e t hd args--    -- Subcase: ambiguous projection-    A.Proj o (AmbQ ds@(_:_:_)) -> checkProjApp e o ds args t--    -- Subcase: ambiguous constructor-    A.Con (AmbQ cs@(_:_:_)) -> do-      -- First we should figure out which constructor we want.-      reportSLn "tc.check.term" 40 $ "Ambiguous constructor: " ++ show cs--      -- Get the datatypes of the various constructors-      let getData Constructor{conData = d} = d-          getData _                        = __IMPOSSIBLE__-      reportSLn "tc.check.term" 40 $ "  ranges before: " ++ show (getRange cs)-      -- 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.-      cons  <- mapM getConForm cs-      reportSLn "tc.check.term" 40 $ "  reduced: " ++ show cons-      dcs <- zipWithM (\ c con -> (, setConName c con) . getData . theDef <$> getConInfo con) cs cons-      -- Type error-      let badCon t = typeError $ DoesNotConstructAnElementOf (head cs) t-      -- Lets look at the target type at this point-      let getCon :: TCM (Maybe ConHead)-          getCon = do-            TelV tel t1 <- telView t-            addContext tel $ do-             reportSDoc "tc.check.term.con" 40 $ nest 2 $-               text "target type: " <+> prettyTCM t1-             ifBlockedType t1 (\ m t -> return Nothing) $ \ t' ->-               caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ d ->-                 case [ c | (d', c) <- dcs, d == d' ] of-                   [c] -> do-                     reportSLn "tc.check.term" 40 $ "  decided on: " ++ show c-                     storeDisambiguatedName $ conName c-                     return $ Just c-                   []  -> badCon $ t' $> Def d []-                   cs  -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $ map conName cs-      let unblock = isJust <$> getCon -- to unblock, call getCon later again-      mc <- getCon-      case mc of-        Just c  -> checkConstructorApplication e t c args-        Nothing -> postponeTypeCheckingProblem (CheckExpr e t) unblock--    -- Subcase: non-ambiguous constructor-    A.Con (AmbQ [c]) -> do-      -- augment c with record fields, but do not revert to original name-      con <- getOrigConHead c-      checkConstructorApplication e t con args--    -- Subcase: pattern synonym-    A.PatternSyn n -> do-      (ns, p) <- lookupPatternSyn n-      p <- setRange (getRange n) . killRange <$> expandPatternSynonyms (vacuous p)  -- expand recursive pattern synonyms-      -- 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 e' t--    -- Subcase: macro-    A.Macro x -> do-      -- First go: no parameters-      TelV tel _ <- telView =<< normalise . defType =<< instantiateDef =<< getConstInfo x--      tTerm <- primAgdaTerm-      tName <- primQName--      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.ExprRange (getRange a)) (A.QuoteTerm A.exprNoRange) . defaultNamedArg) a-          mkArg t a | unEl t == tName =-            (fmap . fmap)-              (A.App (A.ExprRange (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 : _) (arg : args) =-            case insertImplicit arg (map (fmap fst . argFromDom) tel) of-              ImpInsert is   -> makeArgs (drop (length is) tel) (arg : args)-              BadImplicits   -> (arg : args, [])  -- fail later in checkHeadApplication-              NoSuchName{}   -> (arg : args, [])  -- ditto-              NoInsertNeeded -> first (mkArg (snd $ unDom d) arg :) $ makeArgs (tail tel) args--          (macroArgs, otherArgs) = makeArgs argTel args-          unq = A.App (A.ExprRange $ fuseRange x args) (A.Unquote A.exprNoRange) . defaultNamedArg--          desugared = A.app (unq $ unAppView $ Application (A.Def x) $ macroArgs) otherArgs--      checkExpr desugared t--    -- Subcase: unquote-    A.Unquote _-      | [arg] <- args -> do-          (_, hole) <- newValueMeta RunMetaOccursCheck 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-          (vs, EmptyTel) <- checkArguments_ 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 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", dom) (metaTel args)--    -- Subcase: defined symbol or variable.-    _ -> checkHeadApplication e t hd args-------------------------------------------------------------------------------- * Meta variables-------------------------------------------------------------------------------- | Check an interaction point without arguments.-checkQuestionMark :: (Type -> TCM (MetaId, Term)) -> Type -> A.MetaInfo -> InteractionId -> TCM Term-checkQuestionMark new t0 i ii = do-  reportSDoc "tc.interaction" 20 $ sep-    [ text "Found interaction point"-    , text (show ii)-    , text ":"-    , prettyTCM t0-    ]-  reportSDoc "tc.interaction" 60 $ sep-    [ text "Raw:"-    , text (show t0)-    ]-  checkMeta (newQuestionMark' new ii) t0 i -- Andreas, 2013-05-22 use unreduced type t0!---- | Check an underscore without arguments.-checkUnderscore :: Type -> A.MetaInfo -> TCM Term-checkUnderscore = checkMeta (newValueMeta RunMetaOccursCheck)---- | Type check a meta variable.-checkMeta :: (Type -> TCM (MetaId, Term)) -> Type -> A.MetaInfo -> TCM Term-checkMeta newMeta t i = fst <$> checkOrInferMeta newMeta (Just t) i---- | Infer the type of a meta variable.---   If it is a new one, we create a new meta for its type.-inferMeta :: (Type -> TCM (MetaId, Term)) -> A.MetaInfo -> TCM (Args -> Term, Type)-inferMeta newMeta i = mapFst apply <$> checkOrInferMeta newMeta Nothing i---- | Type check a meta variable.---   If its type is not given, we return its type, or a fresh one, if it is a new meta.---   If its type is given, we check that the meta has this type, and we return the same---   type.-checkOrInferMeta :: (Type -> TCM (MetaId, Term)) -> Maybe Type -> A.MetaInfo -> TCM (Term, Type)-checkOrInferMeta newMeta mt i = do-  case A.metaNumber i of-    Nothing -> do-      setScope (A.metaScope i)-      t <- maybe (workOnTypes $ newTypeMeta_) return mt-      (x, v) <- newMeta t-      setMetaNameSuggestion x (A.metaNameSuggestion i)-      return (v, t)-    -- Rechecking an existing metavariable-    Just x -> do-      let v = MetaV x []-      t' <- jMetaType . mvJudgement <$> lookupMeta x-      case mt of-        Nothing -> return (v, t')-        Just t  -> (,t) <$> coerce v t' t---- | Turn a domain-free binding (e.g. lambda) into a domain-full one,---   by inserting an underscore for the missing type.-domainFree :: ArgInfo -> A.Name -> A.LamBinding-domainFree info x =-  A.DomainFull $ A.TypedBindings r $ Arg info $ A.TBind r [pure x] $ A.Underscore underscoreInfo-  where-    r = getRange x-    underscoreInfo = A.MetaInfo-      { A.metaRange          = r-      , A.metaScope          = emptyScopeInfo-      , A.metaNumber         = Nothing-      , A.metaNameSuggestion = show $ A.nameConcrete x-      }-------------------------------------------------------------------------------- * Applications------------------------------------------------------------------------------inferHeadDef :: ProjOrigin -> QName -> TCM (Args -> Term, Type)-inferHeadDef o x = do-  proj <- isProjection x-  let app =-        case proj of-          Nothing -> \ args -> Def x $ map Apply args-          Just p  -> \ args -> projDropParsApply p o args-  mapFst apply <$> 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 (Args -> 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-        [ text "variable" , text (show x)-        , text "(" , text (show u) , text ")"-        , text "has type:" , text (show a)-        ]-      when (unusableRelevance $ getRelevance a) $-        typeError $ VariableIsIrrelevant x-      return (apply u, unDom a)-    (A.Def x) -> inferHeadDef ProjPrefix x-    (A.Proj o (AmbQ [d])) -> inferHeadDef o d-    (A.Proj{}) -> __IMPOSSIBLE__ -- inferHead will only be called on unambiguous projections-    (A.Con (AmbQ [c])) -> 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 <- 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 [show c, "has", show n, "parameters."]--      -- So when applying the constructor throw away the parameters.-      return (apply u . genericDrop 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 (apply 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-    d  <- instantiateDef =<< getConstInfo x-    -- irrelevant defs are only allowed in irrelevant position-    let drel = defRelevance d-    when (drel /= Relevant) $ do-      rel <- asks envRelevance-      reportSDoc "tc.irr" 50 $ vcat-        [ text "declaration relevance =" <+> text (show drel)-        , text "context     relevance =" <+> text (show rel)-        ]-      unless (drel `moreRelevant` rel) $ typeError $ DefinitionIsIrrelevant x-    -- 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" 10 $ do-      text "inferred def " <+> prettyTCM x <+> hsep (map prettyTCM vs)-    let t = defType d-    reportSDoc "tc.term.def" 10 $ nest 2 $ text " : " <+> prettyTCM t-    let v = mkTerm vs -- applies x to vs, dropping parameters-    reportSDoc "tc.term.def" 10 $ nest 2 $ text " --> " <+> prettyTCM v-    return (v, t)---- | 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 :: A.Expr -> Type -> ConHead -> [NamedArg A.Expr] -> TCM Term-checkConstructorApplication org t c args = do-  reportSDoc "tc.term.con" 50 $ vcat-    [ text "entering checkConstructorApplication"-    , nest 2 $ vcat-      [ text "org  =" <+> prettyTCM org-      , text "t    =" <+> prettyTCM t-      , text "c    =" <+> prettyTCM c-      , text "args =" <+> prettyTCM args-    ] ]-  let paramsGiven = checkForParams args-  if paramsGiven then fallback else do-    reportSDoc "tc.term.con" 50 $ text "checkConstructorApplication: no parameters explicitly supplied, continuing..."-    cdef  <- getConInfo c-    let Constructor{conData = d, conPars = npars} = theDef cdef-    reportSDoc "tc.term.con" 50 $ nest 2 $ text "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 [])-    case (ignoreSharing t0, ignoreSharing $ unEl t) 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 $ text "d0   =" <+> prettyTCM d0-        reportSDoc "tc.term.con" 50 $ nest 2 $ text "d'   =" <+> prettyTCM d'-        reportSDoc "tc.term.con" 50 $ nest 2 $ text "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 $ List2 (Just npars, npars')) fallback $ \ (List2 (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    = genericTake n $ genericDrop (n' - n) vs-               ctype = defType cdef-           reportSDoc "tc.term.con" 20 $ vcat-             [ text "special checking of constructor application of" <+> prettyTCM c-             , nest 2 $ vcat [ text "ps     =" <+> prettyTCM ps-                             , text "ctype  =" <+> prettyTCM ctype ] ]-           let ctype' = ctype `piApply` ps-           reportSDoc "tc.term.con" 20 $ nest 2 $ text "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 <- asks envExpandLast-           checkArguments' expandLast (getRange c) args' ctype' t $ \us t' -> do-             reportSDoc "tc.term.con" 20 $ nest 2 $ vcat-               [ text "us     =" <+> prettyTCM us-               , text "t'     =" <+> prettyTCM t' ]-             coerce (Con c ConOCon us) t' t-      _ -> do-        reportSDoc "tc.term.con" 50 $ nest 2 $ text "we are not at a datatype, falling back"-        fallback-  where-    fallback = checkHeadApplication org t (A.Con (AmbQ [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) = span (not . visible) args-          notUnderscore A.Underscore{} = False-          notUnderscore _              = True-      in  any notUnderscore $ map (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 = fmap rangedThing . nameOf $ unArg arg-        h    = getHiding arg--        namedPar   x = dropPar ((x ==) . unDom)-        unnamedPar h = dropPar ((h ==) . getHiding)--        dropPar this (p : ps) | this p    = Just ps-                              | otherwise = dropPar this ps-        dropPar _ [] = Nothing---{- UNUSED CODE, BUT DON'T REMOVE (2012-04-18)--    -- Split the arguments to a constructor into those corresponding-    -- to parameters and those that don't. Dummy underscores are inserted-    -- for parameters that are not given explicitly.-    splitArgs [] args = ([], args)-    splitArgs ps []   =-          (map (const dummyUnderscore) ps, args)-    splitArgs ps args@(Arg NotHidden _ _ : _) =-          (map (const dummyUnderscore) ps, args)-    splitArgs (p:ps) (arg : args)-      | elem mname [Nothing, Just p] =-          mapFst (arg :) $ splitArgs ps args-      | otherwise =-          mapFst (dummyUnderscore :) $ splitArgs ps (arg:args)-      where-        mname = nameOf (unArg arg)--    dummyUnderscore = Arg Hidden Relevant (unnamed $ A.Underscore $ A.MetaInfo noRange emptyScopeInfo Nothing)--}---- | @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 :: A.Expr -> Type -> A.Expr -> [NamedArg A.Expr] -> TCM Term-checkHeadApplication e t hd args = do-  kit       <- coinductionKit-  case hd of-    A.Con (AmbQ [c]) | Just c == (nameOfSharp <$> kit) -> do-      -- Type checking # generated #-wrapper. The # that the user can write will be a Def,-      -- but the sharp we generate in the body of the wrapper is a Con.-      defaultResult-    A.Con (AmbQ [c]) -> do-      (f, t0) <- inferHead hd-      reportSDoc "tc.term.con" 5 $ vcat-        [ text "checkHeadApplication inferred" <+>-          prettyTCM c <+> text ":" <+> prettyTCM t0-        ]-      expandLast <- asks envExpandLast-      checkArguments' expandLast (getRange hd) args t0 t $ \vs t1 -> do-        TelV eTel eType <- telView t-        -- If the expected type @eType@ is a metavariable we have to make-        -- sure it's instantiated to the proper pi type-        TelV fTel fType <- telViewUpTo (size eTel) t1-        -- We know that the target type of the constructor (fType)-        -- does not depend on fTel so we can compare fType and eType-        -- first.--        when (size eTel > size fTel) $-          typeError $ UnequalTypes CmpLeq t1 t -- switch because of contravariance-          -- Andreas, 2011-05-10 report error about types rather  telescopes-          -- compareTel CmpLeq eTel fTel >> return () -- This will fail!--        reportSDoc "tc.term.con" 10 $ addContext eTel $ vcat-          [ text "checking" <+>-            prettyTCM fType <+> text "?<=" <+> prettyTCM eType-          ]-        blockTerm t $ f vs <$ workOnTypes (do-          addContext eTel $ leqType fType eType-          compareTel t t1 CmpLeq eTel fTel)--    (A.Def c) | Just c == (nameOfSharp <$> kit) -> do-      arg <- case args of-               [a] | getHiding a == NotHidden -> return $ namedArg a-               _ -> typeError $ GenericError $ show c ++ " must be applied to exactly one argument."--      -- The name of the fresh function.-      i <- fresh :: TCM Int-      let name = filter (/= '_') (show $ 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 lvl-        lv  <- levelView l-        (_, a) <- newValueMeta RunMetaOccursCheck (sort $ Type lv)-        return $ El (Type lv) $ Def inf [Apply $ setHiding Hidden $ defaultArg l, Apply $ defaultArg a]--      wrapper <- inFreshModuleIfFreeParams $ do-        c' <- setRange (getRange c) <$>-                liftM2 qualify (killRange <$> currentModule)-                               (freshName_ name)--        -- Define and type check the fresh function.-        rel <- asks envRelevance-        abs <- aModeToDef <$> asks envAbstractMode-        let info   = A.mkDefInfo (A.nameConcrete $ A.qnameName c') noFixity'-                                 PublicAccess abs noRange-            core   = A.LHSProj { A.lhsDestructor = AmbQ [flat]-                               , A.lhsFocus      = defaultNamedArg $ A.LHSHead c' []-                               , A.lhsPatsRight  = [] }-            clause = A.Clause (A.LHS (A.LHSRange noRange) core []) []-                              (A.RHS arg Nothing)-                              [] False--        i <- currentOrFreshMutualBlock--        -- If we are in irrelevant position, add definition irrelevantly.-        -- TODO: is this sufficient?-        addConstant c' =<< do-          let ai = setRelevance rel defaultArgInfo-          useTerPragma $-            (defaultDefn ai c' forcedType emptyFunction)-            { defMutual = i }--        checkFunDef NotDelayed info c' [clause]--        reportSDoc "tc.term.expr.coind" 15 $ do-          def <- theDef <$> getConstInfo c'-          vcat $-            [ text "The coinductive wrapper"-            , nest 2 $ prettyTCM rel <> prettyTCM c' <+> text ":"-            , nest 4 $ prettyTCM t-            , nest 2 $ prettyA clause-            , text "The definition is" <+> text (show $ funDelayed def) <>-              text "."-            ]-        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 $-          [ text "The coinductive constructor application"-          , nest 2 $ prettyTCM e-          , text "was translated into the application"-          , nest 2 $ prettyTCM e'-          ]--      blockTerm t $ e' <$ workOnTypes (leqType forcedType t)-    A.Con _  -> __IMPOSSIBLE__-    _ -> defaultResult-  where-  defaultResult = do-    (f, t0) <- inferHead hd-    expandLast <- asks envExpandLast-    checkArguments' expandLast (getRange hd) args t0 t $ \vs t1 -> do-      coerce (f vs) t1 t--traceCallE ::-#if !MIN_VERSION_transformers(0,4,1)-  Error e =>-#endif-  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---- | Check arguments whose value we already know.------   This function can be used to check user-supplied parameters---   we have already computed by inference.------   Precondition: The type @t@ of the head has enough domains.--checkKnownArguments-  :: [NamedArg A.Expr]  -- ^ User-supplied arguments (hidden ones may be missing).-  -> Args               -- ^ Inferred arguments (including hidden ones).-  -> Type               -- ^ Type of the head (must be Pi-type with enough domains).-  -> TCM (Args, Type)   -- ^ Remaining inferred arguments, remaining type.-checkKnownArguments []           vs t = return (vs, t)-checkKnownArguments (arg : args) vs t = do-  (vs', t') <- traceCall (SetRange $ getRange arg) $ checkKnownArgument arg vs t-  checkKnownArguments args vs' t'---- | Check an argument whose value we already know.--checkKnownArgument-  :: NamedArg A.Expr    -- ^ User-supplied argument.-  -> Args               -- ^ Inferred arguments (including hidden ones).-  -> Type               -- ^ Type of the head (must be Pi-type with enough domains).-  -> TCM (Args, Type)   -- ^ Remaining inferred arguments, remaining type.-checkKnownArgument arg [] _ = genericDocError =<< do-  text "Invalid projection parameter " <+> prettyA arg-checkKnownArgument arg@(Arg info e) (Arg _infov v : vs) t = do-  (Dom info' a, b) <- mustBePi t-  -- Skip the arguments from vs that do not correspond to e-  if not (getHiding info == getHiding info'-          && (notHidden info || maybe True ((absName b ==) . rangedThing) (nameOf e)))-    -- Continue with the next one-    then checkKnownArgument arg vs (b `absApp` v)-    -- Found the right argument-    else do-      u <- checkNamedArg arg a-      equalTerm a u v-      return (vs, b `absApp` v)---- | Check a single argument.--checkNamedArg :: NamedArg A.Expr -> Type -> TCM Term-checkNamedArg arg@(Arg info e0) t0 = do-  let e = namedThing e0-  let x = maybe "" rangedThing $ nameOf e0-  traceCall (CheckExprCall e t0) $ do-    reportSDoc "tc.term.args.named" 15 $ do-        text "Checking named arg" <+> sep-          [ fsep [ prettyTCM arg, text ":", prettyTCM t0 ]-          ]-    reportSLn "tc.term.args.named" 75 $ "  arg = " ++ show (deepUnscope arg)-    let checkU = checkMeta (newMetaArg info x) t0-    let checkQ = checkQuestionMark (newInteractionMetaArg info x) t0-    if not $ isHole e then checkExpr e t0 else localScope $ do-      -- Note: we need localScope here,-      -- as scopedExpr manipulates the scope in the state.-      -- However, we may not pull localScope over checkExpr!-      -- This is why we first test for isHole, and only do-      -- scope manipulations if we actually handle the checking-      -- of e here (and not pass it to checkExpr).-      scopedExpr e >>= \case-        A.Underscore i ->  checkU i-        A.QuestionMark i ii -> checkQ i ii-        _ -> __IMPOSSIBLE__-  where-  isHole A.Underscore{} = True-  isHole A.QuestionMark{} = True-  isHole (A.ScopedExpr _ e) = isHole e-  isHole _ = False---- | 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.--checkArguments :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-                  ExceptT (Args, [NamedArg A.Expr], Type) TCM (Args, Type)---- Case: no arguments, do not insert trailing hidden arguments: We are done.-checkArguments DontExpandLast _ [] t0 t1 = return ([], t0)---- Case: no arguments, but need to insert trailing hiddens.-checkArguments exh r [] t0 t1 =-    traceCallE (CheckArguments r [] t0 t1) $ lift $ do-      t1' <- unEl <$> reduce t1-      implicitArgs (-1) (expand t1') t0-    where-      expand (Pi (Dom info _) _)   Hidden = getHiding info /= Hidden &&-                                            exh == ExpandLast-      expand _                     Hidden = exh == ExpandLast-      expand (Pi (Dom info _) _) Instance = getHiding info /= Instance-      expand _                   Instance = True-      expand _                  NotHidden = False---- Case: argument given.-checkArguments exh r args0@(arg@(Arg info e) : args) t0 t1 =-    traceCallE (CheckArguments r args0 t0 t1) $ do-      lift $ reportSDoc "tc.term.args" 30 $ sep-        [ text "checkArguments"---        , text "  args0 =" <+> prettyA args0-        , nest 2 $ vcat-          [ text "e     =" <+> prettyA e-          , text "t0    =" <+> prettyTCM t0-          , text "t1    =" <+> prettyTCM t1-          ]-        ]-      -- First, insert implicit arguments, depending on current argument @arg@.-      let hx = getHiding info  -- hiding of current argument-          mx = fmap rangedThing $ nameOf 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 = hy /= hx || maybe False (y /=) mx-      (nargs, t) <- lift $ implicitNamedArgs (-1) expand t0-      -- Separate names from args.-      let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Arg ai u)) nargs-          xs        = catMaybes mxs-      -- We are done inserting implicit args.  Now, try to check @arg@.-      ifBlockedType t (\ m t -> throwError (us, args0, t)) $ \ 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.-              | notHidden 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--        -- 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--        -- t0' <- lift $ forcePi (getHiding info) (maybe "_" rangedThing $ nameOf e) t0'-        case ignoreSharing $ unEl t0' of-          Pi (Dom info' a) b-            | getHiding info == getHiding info'-              && (notHidden info || maybe True ((absName b ==) . rangedThing) (nameOf e)) -> do-                u <- lift $ applyRelevanceToContext (getRelevance 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 = maybe (Just $ unranged $ absName b) Just (nameOf e) }-                  checkNamedArg (Arg info' e') a-                -- save relevance info' from domain in argument-                addCheckedArgs us (Arg info' u) $-                  checkArguments exh (fuseRange r e) args (absApp b u) t1-            | otherwise -> do-                reportSDoc "error" 10 $ nest 2 $ vcat-                  [ text $ "info      = " ++ show info-                  , text $ "info'     = " ++ show info'-                  , text $ "absName b = " ++ show (absName b)-                  , text $ "nameOf e  = " ++ show (nameOf e)-                  ]-                wrongPi-          _ -> shouldBePi-  where-    addCheckedArgs us u rec =-      (mapFst ((us ++) . (u :)) <$> rec)-        `catchError` \(vs, es, t) ->-          throwError (us ++ u : vs, es, t)---- | Check that a list of arguments fits a telescope.---   Inserts hidden arguments as necessary.---   Returns the type-checked arguments and the remaining telescope.-checkArguments_-  :: ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?-  -> Range                -- ^ Range of application.-  -> [NamedArg A.Expr]    -- ^ Arguments to check.-  -> Telescope            -- ^ Telescope to check arguments against.-  -> TCM (Args, Telescope)-     -- ^ Checked arguments and remaining telescope if successful.-checkArguments_ exh r args tel = do-    z <- runExceptT $-      checkArguments exh r args (telePi tel typeDontCare) typeDontCare-    case z of-      Right (args, t) -> do-        let TelV tel' _ = telView' t-        return (args, tel')-      Left _ -> __IMPOSSIBLE__  -- type cannot be blocked as it is generated by telePi----- | Infer the type of an expression. Implemented by checking against a meta---   variable.  Except for neutrals, for them a polymorphic type is inferred.-inferExpr :: A.Expr -> TCM (Term, Type)--- inferExpr e = inferOrCheck e Nothing-inferExpr = inferExpr' DontExpandLast--inferExpr' :: ExpandHidden -> A.Expr -> TCM (Term, Type)-inferExpr' exh e = case e of-  _ | Application hd args <- appView e, defOrVar hd -> traceCall (InferExpr e) $ do-    case hd of-      A.Proj o (AmbQ ds@(_:_:_)) -> inferProjApp e o ds args-      _ -> do-        (f, t0) <- inferHead hd-        res <- runExceptT $ checkArguments exh (getRange hd) args t0 (sort Prop)-        case res of-          Right (vs, t1) -> return (f vs, t1)-          Left t1 -> fallback -- blocked on type t1-  _ -> fallback-  where-    fallback = do-      t <- workOnTypes $ newTypeMeta_-      v <- checkExpr e t-      return (v,t)--defOrVar :: A.Expr -> Bool-defOrVar A.Var{} = True-defOrVar A.Def{} = True-defOrVar A.Proj{} = True-defOrVar (A.ScopedExpr _ e) = defOrVar e-defOrVar _     = False---- | Used to check aliases @f = e@.---   Switches off 'ExpandLast' for the checking of top-level application.-checkDontExpandLast :: A.Expr -> Type -> TCM Term-checkDontExpandLast e t = case e of-  _ | Application hd args <- appView e,  defOrVar hd ->-    traceCall (CheckExprCall e t) $ localScope $ dontExpandLast $ shared =<< do-      checkApplication hd args e t-  _ -> checkExpr e t -- note that checkExpr always sets ExpandLast--{- Andreas, 2013-03-15 UNUSED, but don't remove-inferOrCheck :: A.Expr -> Maybe Type -> TCM (Term, Type)-inferOrCheck e mt = case e of-  _ | Application hd args <- appView e, defOrVar hd -> traceCall (InferExpr e) $ do-    (f, t0) <- inferHead hd-    res <- runErrorT $ checkArguments DontExpandLast-                                      (getRange hd) args t0 $-                                      maybe (sort Prop) id mt-    case res of-      Right (vs, t1) -> maybe (return (f vs, t1))-                              (\ t -> (,t) <$> coerce (f vs) t1 t)-                              mt-      Left t1        -> fallback -- blocked on type t1-  _ -> fallback-  where-    fallback = do-      t <- maybe (workOnTypes $ newTypeMeta_) return mt-      v <- checkExpr e t-      return (v,t)--}---- | Check whether a de Bruijn index is bound by a module telescope.-isModuleFreeVar :: Int -> TCM Bool-isModuleFreeVar i = do-  params <- moduleParamsToApply =<< currentModule-  return $ any ((== Var i []) . unArg) params---- | Infer the type of an expression, and if it is of the form---   @{tel} -> D vs@ for some datatype @D@ then insert the hidden---   arguments.  Otherwise, leave the type polymorphic.-inferExprForWith :: A.Expr -> TCM (Term, Type)-inferExprForWith e = do-  reportSDoc "tc.with.infer" 20 $ text "inferExprforWith " <+> prettyTCM e-  reportSLn  "tc.with.infer" 80 $ "inferExprforWith " ++ show (deepUnscope e)-  traceCall (InferExpr e) $ do-    -- With wants type and term fully instantiated!-    (v, t) <- instantiateFull =<< inferExpr e-    v0 <- reduce v-    -- Andreas 2014-11-06, issue 1342.-    -- Check that we do not `with` on a module parameter!-    case ignoreSharing v0 of-      Var i [] -> whenM (isModuleFreeVar i) $ do-        reportSDoc "tc.with.infer" 80 $ vcat-          [ text $ "with expression is variable " ++ show i-          , text "current modules = " <+> do text . show =<< currentModule-          , text "current module free vars = " <+> do text . show =<< getCurrentModuleFreeVars-          , text "context size = " <+> do text . show =<< getContextSize-          , text "current context = " <+> do prettyTCM =<< getContextTelescope-          ]-        typeError $ WithOnFreeVariable e v0-      _        -> return ()-    -- Possibly insert hidden arguments.-    TelV tel t0 <- telViewUpTo' (-1) ((NotHidden /=) . getHiding) t-    case ignoreSharing $ unEl t0 of-      Def d vs -> do-        res <- isDataOrRecordType d-        case res of-          Nothing -> return (v, t)-          Just{}  -> do-            (args, t1) <- implicitArgs (-1) (NotHidden /=) t-            return (v `apply` args, t1)-      _ -> return (v, t)-------------------------------------------------------------------------------- * Let bindings------------------------------------------------------------------------------checkLetBindings :: [A.LetBinding] -> TCM a -> TCM a-checkLetBindings = foldr (.) id . map checkLetBinding--checkLetBinding :: A.LetBinding -> TCM a -> TCM a--checkLetBinding b@(A.LetBind i info x t e) ret =-  traceCallCPS_ (CheckLetBinding b) ret $ \ret -> do-    t <- isType_ t-    v <- applyRelevanceToContext (getRelevance info) $ checkDontExpandLast e t-    addLetBinding info x v t ret--checkLetBinding b@(A.LetPatBind i p e) ret =-  traceCallCPS_ (CheckLetBinding b) ret $ \ret -> do-    p <- expandPatternSynonyms p-    (v, t) <- inferExpr' ExpandLast e-    let -- construct a type  t -> dummy  for use in checkLeftHandSide-        t0 = El (getSort t) $ Pi (Dom defaultArgInfo t) (NoAbs underscore typeDontCare)-        p0 = Arg defaultArgInfo (Named Nothing p)-    reportSDoc "tc.term.let.pattern" 10 $ vcat-      [ text "let-binding pattern p at type t"-      , nest 2 $ vcat-        [ text "p (A) =" <+> text (show p) -- prettyTCM p-        , text "t     =" <+> prettyTCM t-        ]-      ]-    fvs <- getContextSize-    checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 Nothing $ \ (LHSResult _ delta0 ps _t _ asb) -> bindAsPatterns asb $ do-          -- After dropping the free variable patterns there should be a single pattern left.-      let p = case drop fvs ps of [p] -> namedArg p; _ -> __IMPOSSIBLE__-          -- Also strip the context variables from the telescope-          delta = telFromList $ drop fvs $ telToList delta0-      reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat-        [ text "p (I) =" <+> text (show p)-        , text "delta =" <+> text (show delta)-        ]-      -- We translate it into a list of projections.-      fs <- recordPatternToProjections p-      -- We remove the bindings for the pattern variables from the context.-      cxt0 <- getContext-      let (binds, cxt) = splitAt (size delta) cxt0-          toDrop       = length binds--          -- We create a substitution for the let-bound variables-          -- (unfortunately, we cannot refer to x in internal syntax-          -- so we have to copy v).-          sigma = zipWith ($) fs (repeat v)-          -- We apply the types of the let bound-variables to this substitution.-          -- The 0th variable in a context is the last one, so we reverse.-          -- Further, we need to lower all other de Bruijn indices by-          -- the size of delta, so we append the identity substitution.-          sub    = parallelS (reverse sigma)--          -- Outer let-bindings will have been rebound by checkLeftHandSide, so-          -- we need to strenghten those as well. Don't use a strengthening-          -- subsititution since @-patterns in the pattern binding will reference-          -- the pattern variables.-          subLetBind (OpenThing cxt va) = OpenThing (drop toDrop cxt) (applySubst sub va)-      escapeContext toDrop $ updateModuleParameters sub-                           $ locally eLetBindings (fmap subLetBind) $ do-        reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat-          [ text "delta =" <+> prettyTCM delta-          , text "binds =" <+> text (show binds) -- prettyTCM binds-          ]-{- WE CANNOT USE THIS BINDING-       -- We add a first let-binding for the value of e.-       x <- freshNoName (getRange e)-       addLetBinding Relevant x v t $ do- -}-        let fdelta = flattenTel delta-        reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat-          [ text "fdelta =" <+> text (show fdelta)-          ]-        let tsl  = applySubst sub fdelta-        -- We get a list of types-        let ts   = map unDom tsl-        -- and relevances.-        let infos = map domInfo tsl-        -- We get list of names of the let-bound vars from the context.-        let xs   = map (fst . unDom) (reverse binds)-        -- We add all the bindings to the context.-        foldr (uncurry4 addLetBinding) ret $ zip4 infos xs sigma ts--checkLetBinding (A.LetApply i x modapp copyInfo _adir) ret = do-  -- Any variables in the context that doesn't belong to the current-  -- module should go with the new module.-  -- Example: @f x y = let open M t in u@.-  -- There are 2 @new@ variables, @x@ and @y@, going into the anonynous module-  -- @module _ (x : _) (y : _) = M t@.-  fv   <- getCurrentModuleFreeVars-  n    <- getContextSize-  let new = n - fv-  reportSLn "tc.term.let.apply" 10 $ "Applying " ++ show modapp ++ " with " ++ show new ++ " free variables"-  reportSDoc "tc.term.let.apply" 20 $ vcat-    [ text "context =" <+> (prettyTCM =<< getContextTelescope)-    , text "module  =" <+> (prettyTCM =<< currentModule)-    , text "fv      =" <+> (text $ show fv)-    ]-  checkSectionApplication i x modapp copyInfo-  withAnonymousModule x new ret--- LetOpen and LetDeclaredVariable are only used for highlighting.-checkLetBinding A.LetOpen{} ret = ret-checkLetBinding (A.LetDeclaredVariable _) ret = ret+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Rules.Term where++import Prelude hiding ( null )++import Control.Monad.Except ( MonadError(..) )++import Data.Maybe+import Data.Either (partitionEithers, lefts)+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set++import Agda.Interaction.Options+import Agda.Interaction.Highlighting.Generate (disambiguateRecordFields)++import Agda.Syntax.Abstract (Binder, TypedBindingInfo (tbTacticAttr))+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.Concrete (FieldAssignment'(..), nameFieldA, TacticAttribute'(..))+import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( prettyShow )+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Position+import Agda.Syntax.Literal+import Agda.Syntax.Scope.Base ( ThingsInScope, AbstractName+                              , emptyScopeInfo+                              , exportedNamesInScope)+import Agda.Syntax.Scope.Monad (getNamedScope)++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.EtaContract+import Agda.TypeChecking.Generalize+import Agda.TypeChecking.Implicit+import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.IApplyConfluence+import Agda.TypeChecking.Level+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Patterns.Abstract+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Quote+import Agda.TypeChecking.RecordPatterns+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rules.LHS+import Agda.TypeChecking.SizedTypes+import Agda.TypeChecking.SizedTypes.Solve+import Agda.TypeChecking.Sort+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Unquote+import Agda.TypeChecking.Warnings++import {-# SOURCE #-} Agda.TypeChecking.Empty ( ensureEmptyType )+import {-# SOURCE #-} Agda.TypeChecking.Rules.Def (checkFunDef', useTerPragma)+import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkSectionApplication)+import {-# SOURCE #-} Agda.TypeChecking.Rules.Application++import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List1  ( List1, pattern (:|) )+import Agda.Utils.List2  ( pattern List2 )+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.Singleton+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Types+---------------------------------------------------------------------------++-- | Check that an expression is a type.+isType :: A.Expr -> Sort -> TCM Type+isType = isType' CmpLeq++-- | Check that an expression is a type.+--   * If @c == CmpEq@, the given sort must be the minimal sort.+--   * If @c == CmpLeq@, the given sort may be any bigger sort.+isType' :: Comparison -> A.Expr -> Sort -> TCM Type+isType' c e s =+    traceCall (IsTypeCall c e s) $ do+    v <- checkExpr' c e (sort s)+    return $ El s v++-- | Check that an expression is a type and infer its (minimal) sort.+isType_ :: A.Expr -> TCM Type+isType_ e = traceCall (IsType_ e) $ do+  reportResult "tc.term.istype" 15 (\a -> vcat+    [ "isType_" <?> prettyTCM e+    , nest 2 $ "returns" <?> prettyTCM a+    ]) $ do+  let fallback = isType' CmpEq e =<< do workOnTypes $ newSortMeta+  SortKit{..} <- sortKit+  case unScope e of+    A.Fun i (Arg info t) b -> do+      a <- setArgInfo info . defaultDom <$> checkPiDomain (info :| []) t+      b <- isType_ b+      s <- inferFunSort a (getSort b)+      let t' = El s $ Pi a $ NoAbs underscore b+      checkTelePiSort t'+      --noFunctionsIntoSize t'+      return t'+    A.Pi _ tel e -> do+      (t0, t') <- checkPiTelescope (List1.toList tel) $ \ tel -> do+        t0  <- instantiateFull =<< isType_ e+        tel <- instantiateFull tel+        return (t0, telePi tel t0)+      checkTelePiSort t'+      --noFunctionsIntoSize t'+      return t'++    A.Generalized s e -> do+      (_, t') <- generalizeType (Set1.toSet s) $ isType_ e+      --noFunctionsIntoSize t'+      return t'++    -- Prop/(S)Set(ω)ᵢ+    A.Def' x suffix+      | Just (sz, u) <- isNameOfUniv x+      , let n = suffixToLevel suffix+      -> do+        univChecks u+        return . sort $ case sz of+          USmall -> Univ u $ ClosedLevel n+          ULarge -> Inf u n++    -- Prop/(S)et ℓ+    A.App i s arg+      | visible arg,+        A.Def x <- unScope s,+        Just (USmall, u) <- isNameOfUniv x -> do+      univChecks u+      unlessM hasUniversePolymorphism $ typeError NeedOptionUniversePolymorphism+      -- allow ShapeIrrelevant variables when checking level+      --   Set : (ShapeIrrelevant) Level -> Set\omega+      applyRelevanceToContext shapeIrrelevant $+        sort . Univ u <$> checkLevel arg++    -- Issue #707: Check an existing interaction point+    A.QuestionMark minfo ii -> caseMaybeM (lookupInteractionMeta ii) fallback $ \ x -> do+      -- -- | Just x <- A.metaNumber minfo -> do+      reportSDoc "tc.ip" 20 $ fsep+        [ "Rechecking meta "+        , prettyTCM x+        , text $ " for interaction point " ++ show ii+        ]+      mv <- lookupLocalMeta x+      let s0 = jMetaType . mvJudgement $ mv+      -- Andreas, 2016-10-14, issue #2257+      -- The meta was created in a context of length @n@.+      let n  = length . envContext . clEnv . miClosRange . mvInfo $ mv+      (vs, rest) <- splitAt n <$> getContextArgs++      let oldCxtNames = map nameCanonical $ contextNames' $ envContext+                      $ clEnv $ miClosRange $ mvInfo $ mv++      newCxtNames <- map nameCanonical <$> getContextNames'++      reportSDoc "tc.ip" 20 $ vcat+        [ "  s0   = " <+> prettyTCM s0+        , "  vs   = " <+> prettyTCM vs+        , "  rest = " <+> prettyTCM rest+        , "  oldCxtNames = " <+> prettyTCM oldCxtNames+        , "  newCxtNames = " <+> prettyTCM newCxtNames+        ]+      -- We assume the meta variable use here is in an extension of the original context.+      -- If not we revert to the old buggy behavior of #707 (see test/Succeed/Issue2257b).+      if (not $ List.isPrefixOf oldCxtNames newCxtNames) then fallback else do+      s1  <- reduce =<< piApplyM s0 vs+      reportSDoc "tc.ip" 20 $ vcat+        [ "  s1   = " <+> prettyTCM s1+        ]+      reportSDoc "tc.ip" 70 $ vcat+        [ "  s1   = " <+> text (show s1)+        ]+      case unEl s1 of+        Sort s -> return $ El s $ MetaV x $ map Apply vs+        _ -> __IMPOSSIBLE__++    _ -> fallback++checkLevel :: NamedArg A.Expr -> TCM Level+checkLevel arg = do+  lvl <- levelType+  levelView =<< checkNamedArg arg lvl++-- | Ensure that a (freshly created) function type does not inhabit 'SizeUniv'.+--   Precondition:  When @noFunctionsIntoSize t tBlame@ is called,+--   we are in the context of @tBlame@ in order to print it correctly.+--   Not being in context of @t@ should not matter, as we are only+--   checking whether its sort reduces to 'SizeUniv'.+--+--   Currently UNUSED since SizeUniv is turned off (as of 2016).+{-+noFunctionsIntoSize :: Type -> Type -> TCM ()+noFunctionsIntoSize t tBlame = do+  reportSDoc "tc.fun" 20 $ do+    let El s (Pi dom b) = tBlame+    sep [ "created function type " <+> prettyTCM tBlame+        , "with pts rule (" <+> prettyTCM (getSort dom) <+>+                        "," <+> underAbstraction_ b (prettyTCM . getSort) <+>+                        "," <+> prettyTCM s <+> ")"+        ]+  s <- reduce $ getSort t+  when (s == SizeUniv) $ do+    -- Andreas, 2015-02-14+    -- We have constructed a function type in SizeUniv+    -- which is illegal to prevent issue 1428.+    typeError $ FunctionTypeInSizeUniv $ unEl tBlame+-}++-- | Check that an expression is a type which is equal to a given type.+isTypeEqualTo :: A.Expr -> Type -> TCM Type+isTypeEqualTo e0 t = scopedExpr e0 >>= \case+  A.ScopedExpr{} -> __IMPOSSIBLE__+  A.Underscore i | isNothing (A.metaNumber i) -> return t+  e -> workOnTypes $ do+    t' <- isType e (getSort t)+    t' <$ leqType t t'++leqType_ :: Type -> Type -> TCM ()+leqType_ t t' = workOnTypes $ leqType t t'++---------------------------------------------------------------------------+-- * Telescopes+---------------------------------------------------------------------------++checkGeneralizeTelescope ::+     Maybe ModuleName+       -- ^ The module the telescope belongs to (if any).+  -> A.GeneralizeTelescope+       -- ^ Telescope to check and add to the context for the continuation.+  -> ([Maybe Name] -> Telescope -> TCM a)+       -- ^ Continuation living in the extended context.+  -> TCM a+checkGeneralizeTelescope mm (A.GeneralizeTel vars tel) =+    tr (generalizeTelescope vars (checkTelescope tel) . curry) . uncurry+  where+    tr = applyUnless (null tel) $ applyWhenJust mm $ \ m ->+      traceCallCPS $ CheckModuleParameters m tel++-- | Type check a (module) telescope.+--   Binds the variables defined by the telescope.+checkTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a+checkTelescope = checkTelescope' LamNotPi++-- | Type check the telescope of a dependent function type.+--   Binds the resurrected variables defined by the telescope.+--   The returned telescope is unmodified (not resurrected).+checkPiTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a+checkPiTelescope = checkTelescope' PiNotLam++-- | Flag to control resurrection on domains.+data LamOrPi+  = LamNotPi -- ^ We are checking a module telescope.+             --   We pass into the type world to check the domain type.+             --   This resurrects the whole context.+  | PiNotLam -- ^ We are checking a telescope in a Pi-type.+             --   We stay in the term world, but add resurrected+             --   domains to the context to check the remaining+             --   domains and codomain of the Pi-type.+  deriving (Eq, Show)++-- | Type check a telescope. Binds the variables defined by the telescope.+checkTelescope' :: LamOrPi -> A.Telescope -> (Telescope -> TCM a) -> TCM a+checkTelescope' lamOrPi []        ret = ret EmptyTel+checkTelescope' lamOrPi (b : tel) ret =+    checkTypedBindings lamOrPi b $ \tel1 ->+    checkTelescope' lamOrPi tel  $ \tel2 ->+        ret $ abstract tel1 tel2++-- | Check the domain of a function type.+--   Used in @checkTypedBindings@ and to typecheck @A.Fun@ cases.+checkDomain :: (LensLock a, LensModality a) => LamOrPi -> List1 a -> A.Expr -> TCM Type+checkDomain lamOrPi xs e = do+    -- Get cohesion and quantity of arguments, which should all be equal because+    -- they come from the same annotated Π-type.+    let (c :| cs) = fmap (getCohesion . getModality) xs+    unless (all (c ==) cs) $ __IMPOSSIBLE__++    let (q :| qs) = fmap (getQuantity . getModality) xs+    unless (all (q ==) qs) $ __IMPOSSIBLE__++    t <- applyQuantityToJudgement q $+         applyCohesionToContext c $+         applyWhenM (optPolarity <$> pragmaOptions) (applyPolarityToContext negativePolarity) $+         modEnv lamOrPi $ isType_ e+    -- Andrea TODO: also make sure that LockUniv implies IsLock+    when (any (\x -> case getLock x of { IsLock{} -> True ; _ -> False }) xs) $ do+         -- Solves issue #5033+        unlessM (isJust <$> getName' builtinLockUniv) $ do+          typeError $ NoBindingForPrimitive builtinLockUniv++        equalSort (getSort t) LockUniv++    return t+  where+        -- if we are checking a typed lambda, we resurrect before we check the+        -- types, but do not modify the new context entries+        -- otherwise, if we are checking a pi, we do not resurrect, but+        -- modify the new context entries+        modEnv LamNotPi = workOnTypes+        modEnv _        = id++checkPiDomain :: (LensLock a, LensModality a) => List1 a -> A.Expr -> TCM Type+checkPiDomain = checkDomain PiNotLam++-- | Check a typed binding and extends the context with the bound variables.+--   The telescope passed to the continuation is valid in the original context.+--+--   Parametrized by a flag whether we check a typed lambda or a Pi. This flag+--   is needed for irrelevance.++checkTypedBindings :: LamOrPi -> A.TypedBinding -> (Telescope -> TCM a) -> TCM a+checkTypedBindings lamOrPi (A.TBind r tac xps e) ret = do+    let xs = fmap (updateNamedArg $ A.unBind . A.binderName) xps+    tac <- traverse (checkTacticAttribute lamOrPi) $ theTacticAttribute $ tbTacticAttr tac+    whenJust tac $ \ t -> reportSDoc "tc.term.tactic" 30 $ "Checked tactic attribute:" <?> prettyTCM t+    -- Andreas, 2011-04-26 irrelevant function arguments may appear+    -- non-strictly in the codomain type+    -- 2011-10-04 if flag --experimental-irrelevance is set+    experimental <- optExperimentalIrrelevance <$> pragmaOptions++    t <- checkDomain lamOrPi xps e++    -- Jesper, 2019-02-12, Issue #3534: warn if the type of an+    -- instance argument does not have the right shape+    List1.unlessNull (List1.filter isInstance xps) $ \ ixs -> do+      (tel, _, target) <- getOutputTypeName t+      case target of+        OutputTypeName{} -> return ()+        OutputTypeVar{}  -> return ()+        OutputTypeNameNotYetKnown{} -> return ()+        OutputTypeVisiblePi{} -> setCurrentRange e $+          warning . InstanceArgWithExplicitArg =<< prettyTCM (A.mkTBind r ixs e)+        NoOutputTypeName -> setCurrentRange e $+          warning . InstanceNoOutputTypeName =<< prettyTCM (A.mkTBind r ixs e)++    let setTac tac EmptyTel            = EmptyTel+        setTac tac (ExtendTel dom tel) = ExtendTel dom{ domTactic = tac } $ setTac (raise 1 tac) <$> tel+        xs' = fmap (modMod lamOrPi experimental) xs+    let tel = setTac tac $ namedBindsToTel1 xs t++    addContext (xs', t) $ addTypedPatterns xps (ret tel)++    where+        -- if we are checking a typed lambda, we resurrect before we check the+        -- types, but do not modify the new context entries+        -- otherwise, if we are checking a pi, we do not resurrect, but+        -- modify the new context entries+        modEnv LamNotPi = workOnTypes+        modEnv _        = id+        modMod PiNotLam xp = inverseApplyPolarity (withStandardLock UnusedPolarity)+                             . applyWhen xp (mapRelevance irrelevantToShapeIrrelevant)+        modMod _        _  = id++checkTypedBindings lamOrPi (A.TLet _ lbs) ret = do+  checkLetBindings lbs (ret EmptyTel)++-- | After a typed binding has been checked, add the patterns it binds+addTypedPatterns :: List1 (NamedArg A.Binder) -> TCM a -> TCM a+addTypedPatterns xps ret = do+  let+    ps  = List1.mapMaybe (A.extractPattern . namedArg) xps+    lbs = map letBinding ps++    letBinding :: (A.Pattern, A.BindName) -> A.LetBinding+    letBinding (p, n) = A.LetPatBind (A.LetRange r) p (A.Var $ A.unBind n)+      where r = fuseRange p n++  checkLetBindings' lbs ret++-- | Check a tactic attribute. Should have type Term → TC ⊤.+checkTacticAttribute :: LamOrPi -> Ranged A.Expr -> TCM Term+checkTacticAttribute LamNotPi (Ranged r e) = setCurrentRange r $+  typeError $ TacticAttributeNotAllowed+checkTacticAttribute PiNotLam (Ranged r e) = do+  expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)+  checkExpr e expectedType++checkPath :: NamedArg Binder -> A.Type -> A.Expr -> Type -> TCM Term+checkPath xp typ body ty = do+ reportSDoc "tc.term.lambda" 30 $ hsep [ "checking path lambda", prettyA xp ]+ case (A.extractPattern $ namedArg xp) of+  Just{}  -> setCurrentRange xp $ typeError PatternInPathLambda+  Nothing -> do+    let x    = updateNamedArg (A.unBind . A.binderName) xp+        info = getArgInfo x+    PathType s path level typ lhs rhs <- pathView ty+    interval <- primIntervalType+    v <- addContext ([x], interval) $+           checkExpr body (El (raise 1 s) (raise 1 (unArg typ) `apply` [argN $ var 0]))+    iZero <- primIZero+    iOne  <- primIOne+    let lhs' = subst 0 iZero v+        rhs' = subst 0 iOne  v+    let t = Lam info $ Abs (namedArgName x) v+    let btyp i = El s (unArg typ `apply` [argN i])+    locallyTC eRange (const noRange) $ blockTerm ty $ setCurrentRange body $ do+      equalTerm (btyp iZero) lhs' (unArg lhs)+      equalTerm (btyp iOne) rhs' (unArg rhs)+      return t++---------------------------------------------------------------------------+-- * Lambda abstractions+---------------------------------------------------------------------------++-- | Type check a lambda expression.+--   "checkLambda bs e ty"  means  (\ bs -> e) : ty+checkLambda :: Comparison -> A.TypedBinding -> A.Expr -> Type -> TCM Term+checkLambda cmp (A.TLet _ lbs) body target =+  checkLetBindings lbs (checkExpr body target)+checkLambda cmp b@(A.TBind r tac xps0 typ) body target = do+  (tel, tgt0) <- splitImplicitBinderT (List1.head xps0) target++  -- Andreas, 2020-03-25, issue #4481: since we have named lambdas now,+  -- we need to insert skipped hidden arguments.++  -- Amy, 2024-10-17: we can't simply insert the new binders into this+  -- same TBind, since those are all assumed to be of the same type.+  -- This matters when we're skipping binders to reach something of a+  -- different type, e.g. in+  --+  --    (λ {C = C} → C) : {A B : Set} {C : Nat} → Nat+  --+  -- The previous implementation would add two binders and check them+  -- with the same type as that of {C}, i.e. something like+  --+  --    (λ {A B C : _} → C)+  --+  -- which fails. The new strategy is to lob domains off the type until+  -- we reach the right argument, then just add them to the context, and+  -- bind them after returning.++  teleLam tel <$> addContext tel do+    checkLambda' cmp r tac xps0 typ body tgt0++checkLambda' ::+     Comparison                -- ^ @cmp@+  -> Range                     -- ^ Range @r@ of the typed binding+  -> A.TypedBindingInfo        -- ^ @tac@ tactic/finiteness attribute of the typed binding+  -> List1 (NamedArg Binder)   -- ^ @xps@ variables/patterns of the typed binding+  -> A.Type                    -- ^ @typ@ Type of the typed binding+  -> A.Expr                    -- ^ @body@+  -> Type                      -- ^ @target@+  -> TCM Term+checkLambda' cmp r tac xps typ body target = do+  reportSDoc "tc.term.lambda" 30 $ vcat+    [ "checkLambda xs =" <+> prettyA xps+    , "possiblePath   =" <+> prettyTCM possiblePath+    , "numbinds       =" <+> prettyTCM numbinds+    , "typ            =" <+> prettyA   (unScope typ)+    , "tactic         =" <+> prettyA (tbTacticAttr tac)+    ]+  reportSDoc "tc.term.lambda" 60 $ vcat+    [ "info           =" <+> (text . show) info+    ]++  -- Consume @tac@:+  case tac of+    _ | null tac -> pure ()+    A.TypedBindingInfo{ tbTacticAttr = TacticAttribute (Just tactic) } -> do+      -- Andreas, 2024-02-22, issue #6783+      -- Error out if user supplied a tactic (rather than dropping it silently).+      _tactic <- checkTacticAttribute LamNotPi tactic+      -- We should not survive this check...+      __IMPOSSIBLE__+    _ -> __IMPOSSIBLE__++  TelV tel btyp <- telViewUpTo numbinds target+  if numbinds == 1 && not (null tel) then useTargetType tel btyp+  else if possiblePath then trySeeingIfPath+  else dontUseTargetType++  where+    b = A.TBind r tac xps typ+    xs = fmap (updateNamedArg (A.unBind . A.binderName)) xps+    numbinds = length xps+    possiblePath = numbinds == 1 && isUnderscore (unScope typ)+                   && isRelevant info && visible info+    info = getArgInfo $ List1.head xs++    trySeeingIfPath = do+      reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++ show xps+      let postpone' blocker tgt =+            ifM (isNothing <$> cubicalOption) {-then-} dontUseTargetType {-else-} $ postpone blocker tgt+      ifBlocked target postpone' $ \ _ t -> do+        ifNotM (isPathType <$> pathView t) dontUseTargetType {-else-} do+          -- Note that --cubical is on here since we returned from 'pathView'.+          checkPath (List1.head xps) typ body t++    postpone blocker tgt = flip postponeTypeCheckingProblem blocker $+      CheckExpr cmp (A.Lam A.exprNoRange (A.DomainFull b) body) tgt++    dontUseTargetType = do+      -- Checking λ (xs : argsT) → body : target+      verboseS "tc.term.lambda" 5 $ tick "lambda-no-target-type"++      -- First check that argsT is a valid type+      argsT <- workOnTypes $ isType_ typ+      let tel = namedBindsToTel1 xs argsT+      reportSDoc "tc.term.lambda" 30 $ "dontUseTargetType tel =" <+> pretty tel++      -- Andreas, 2015-05-28 Issue 1523+      -- If argsT is a SizeLt, it must be non-empty to avoid non-termination.+      -- TODO: do we need to block checkExpr?+      checkSizeLtSat $ unEl argsT++      -- Jesper 2019-12-17, #4261: we need to postpone here if+      -- checking of the record pattern fails; if we try to catch+      -- higher up the metas created during checking of @argsT@ are+      -- not available.+      let postponeOnBlockedPattern m = m `catchIlltypedPatternBlockedOnMeta` \(err , x) -> do+            reportSDoc "tc.term" 50 $ vcat $+              [ "checking record pattern stuck on meta: " <+> text (show x) ]+            t1 <- addContext (xs, argsT) $ workOnTypes newTypeMeta_+            let e    = A.Lam A.exprNoRange (A.DomainFull b) body+                tgt' = telePi tel t1+            w <- postponeTypeCheckingProblem (CheckExpr cmp e tgt') x+            return (tgt' , w)++      -- Now check body : ?t₁+      -- DONT USE tel for addContext, as it loses NameIds.+      -- WRONG: v <- addContext tel $ checkExpr body t1+      (target0 , w) <- postponeOnBlockedPattern $+         addContext (xs, argsT) $ addTypedPatterns xps $ do+           t1 <- workOnTypes newTypeMeta_+           v  <- checkExpr' cmp body t1+           return (telePi tel t1 , teleLam tel v)++      -- Do not coerce hidden lambdas+      if notVisible info || any notVisible xs then do+        pid <- newProblem_ $ leqType target0 target+        blockTermOnProblem target w pid+      else do+        coerce cmp w target0 target+++    useTargetType tel@(ExtendTel dom (Abs y EmptyTel)) btyp = do+        verboseS "tc.term.lambda" 5 $ tick "lambda-with-target-type"+        reportSLn "tc.term.lambda" 30 $ "useTargetType y  = " ++ y++        let (x :| []) = xs+        unless (sameHiding dom info) $ typeError $ WrongHidingInLambda target+        when (isJust $ getNameOf x) $+          -- Andreas, 2020-03-25, issue #4481: check for correct name+          unless (namedSame dom x) $+            setCurrentRange x $ typeError $ WrongHidingInLHS+        -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given+        info <- lambdaModalityCheck dom info+        -- Andreas, 2015-05-28 Issue 1523+        -- Ensure we are not stepping under a possibly non-existing size.+        -- TODO: do we need to block checkExpr?+        let a = unDom dom+        checkSizeLtSat $ unEl a+        -- We only need to block the final term on the argument type+        -- comparison. The body will be blocked if necessary. We still want to+        -- compare the argument types first, so we spawn a new problem for that+        -- check.+        (pid, argT) <- newProblem $ isTypeEqualTo typ a+        -- Andreas, Issue 630: take name from function type if lambda name is "_"+        v <- lambdaAddContext (namedArg x) y (defaultArgDom info argT) $+               addTypedPatterns xps $ checkExpr' cmp body btyp+        blockTermOnProblem target (Lam info $ Abs (namedArgName x) v) pid++    useTargetType _ _ = __IMPOSSIBLE__++-- | Check that modality info in lambda is compatible with modality+--   coming from the function type.+--   If lambda has no user-given modality, copy that of function type.+lambdaModalityCheck :: (LensAnnotation dom, LensModality dom) => dom -> ArgInfo -> TCM ArgInfo+lambdaModalityCheck dom = lambdaAnnotationCheck (getAnnotation dom) <=< lambdaPolarityCheck m <=< lambdaCohesionCheck m <=< lambdaQuantityCheck m <=< lambdaIrrelevanceCheck m+  where m = getModality dom++-- | Check that irrelevance info in lambda is compatible with irrelevance+--   coming from the function type.+--   If lambda has no user-given relevance, copy that of function type.+lambdaIrrelevanceCheck :: LensRelevance dom => dom -> ArgInfo -> TCM ArgInfo+lambdaIrrelevanceCheck dom info+    -- Case: no specific user annotation: use relevance of function type+  | getRelevance info == defaultRelevance = return $ setRelevance (getRelevance dom) info+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let rPi  = getRelevance dom  -- relevance of function type+      let rLam = getRelevance info -- relevance of lambda+      unless (sameRelevance rPi rLam) $+        typeError WrongIrrelevanceInLambda+      return info++-- | Check that quantity info in lambda is compatible with quantity+--   coming from the function type.+--   If lambda has no user-given quantity, copy that of function type.+lambdaQuantityCheck :: LensQuantity dom => dom -> ArgInfo -> TCM ArgInfo+lambdaQuantityCheck dom info+    -- Case: no specific user annotation: use quantity of function type+  | noUserQuantity info = return $ setQuantity (getQuantity dom) info+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let qPi  = getQuantity dom  -- quantity of function type+      let qLam = getQuantity info -- quantity of lambda+      unless (qPi `sameQuantity` qLam) $ do+        typeError WrongQuantityInLambda+      return info++lambdaAnnotationCheck :: LensAnnotation dom => dom -> ArgInfo -> TCM ArgInfo+lambdaAnnotationCheck dom info+    -- Case: no specific user annotation: use annotation of function type+  | getAnnotation info == defaultAnnotation = return $ setAnnotation (getAnnotation dom) info+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let aPi  = getAnnotation dom  -- annotation of function type+      let aLam = getAnnotation info -- annotation of lambda+      unless (aPi == aLam) $ do+        typeError WrongAnnotationInLambda+      return info++-- | Check that cohesion info in lambda is compatible with cohesion+--   coming from the function type.+--   If lambda has no user-given cohesion, copy that of function type.+lambdaCohesionCheck :: LensCohesion dom => dom -> ArgInfo -> TCM ArgInfo+lambdaCohesionCheck dom info+    -- Case: no specific user annotation: use cohesion of function type+  | getCohesion info == defaultCohesion = return $ setCohesion (getCohesion dom) info+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let cPi  = getCohesion dom  -- cohesion of function type+      let cLam = getCohesion info -- cohesion of lambda+      unless (cPi `sameCohesion` cLam) $ do+        -- if there is a cohesion annotation then+        -- it better match the domain.+        typeError WrongCohesionInLambda+      return info++-- | Check that polarity info in lambda is compatible with polarity+--   coming from the function type.+--   If lambda has no user-given polarity, copy that of function type.+lambdaPolarityCheck :: LensModalPolarity dom => dom -> ArgInfo -> TCM ArgInfo+lambdaPolarityCheck dom info+    -- Case: no specific user annotation: use polarity of function type+  | getModalPolarity info == defaultPolarity = return $ setModalPolarity (getModalPolarity dom) info+    -- Case: explicit user annotation is taken seriously+  | otherwise = do+      let cPi  = getModalPolarity dom  -- polarity of function type+      let cLam = getModalPolarity info -- polarity of lambda+      unless (cPi `samePolarity` cLam) $ do+        -- if there is a polarity annotation then+        -- it better match the domain.+        typeError WrongPolarityInLambda+      return info++-- Andreas, issue #630: take name from function type if lambda name is "_".+lambdaAddContext :: MonadAddContext m => Name -> ArgName -> Dom Type -> m a -> m a+lambdaAddContext x y dom+  | isNoName x = addContext (y, dom)                 -- Note: String instance+  | otherwise  = addContext (x, dom)                 -- Name instance of addContext++-- | Checking a lambda whose domain type has already been checked.+checkPostponedLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> A.Expr -> Type -> TCM Term+-- checkPostponedLambda cmp args@(Arg _    ([]    , _ )) body target = do+--   checkExpr' cmp body target+checkPostponedLambda cmp args@(Arg info (WithHiding h x :| xs, mt)) body target = do+  let postpone _ t = postponeTypeCheckingProblem_ $ CheckLambda cmp args body t+      lamHiding = mappend h $ getHiding info+  insertHiddenLambdas lamHiding target postpone $ \ t@(El _ (Pi dom b)) -> do+    -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given+    info' <- setHiding lamHiding <$> lambdaModalityCheck dom info+    -- We only need to block the final term on the argument type+    -- comparison. The body will be blocked if necessary. We still want to+    -- compare the argument types first, so we spawn a new problem for that+    -- check.+    mpid <- caseMaybe mt (return Nothing) $ \ ascribedType -> Just <$> do+      newProblem_ $ leqType (unDom dom) ascribedType+    -- We type-check the body with the ascribedType given by the user+    -- to get better error messages.+    -- Using the type dom from the usage context would be more precise,+    -- though.+    -- TODO: quantity+    let dom' = setRelevance (getRelevance info') . setHiding lamHiding $+          maybe dom (dom $>) mt+    v <- lambdaAddContext x (absName b) dom'  $+      checkPostponedLambda0 cmp (Arg info (xs, mt)) body $ absBody b+    let v' = Lam info' $ Abs (nameToArgName x) v+    maybe (return v') (blockTermOnProblem t v') mpid++checkPostponedLambda0 :: Comparison -> Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term+checkPostponedLambda0 cmp (Arg _    ([]    , _ )) body target =+  checkExpr' cmp body target+checkPostponedLambda0 cmp (Arg info (x : xs, mt)) body target =+  checkPostponedLambda cmp (Arg info (x :| xs, mt)) body target+++-- | Insert hidden lambda until the hiding info of the domain type+--   matches the expected hiding info.+--   Throws 'WrongHidingInLambda'+insertHiddenLambdas+  :: Hiding                       -- ^ Expected hiding.+  -> Type                         -- ^ Expected to be a function type.+  -> (Blocker -> Type -> TCM Term) -- ^ Continuation on blocked type.+  -> (Type -> TCM Term)           -- ^ Continuation when expected hiding found.+                                  --   The continuation may assume that the @Type@+                                  --   is of the form @(El _ (Pi _ _))@.+  -> TCM Term                     -- ^ Term with hidden lambda inserted.+insertHiddenLambdas h target postpone ret = do+  -- If the target type is blocked, we postpone,+  -- because we do not know if a hidden lambda needs to be inserted.+  ifBlocked target postpone $ \ _ t -> do+    case unEl t of++      Pi dom b -> do+        let h' = getHiding dom+        -- Found expected hiding: return function type.+        if sameHiding h h' then ret t else do+          -- Found a visible argument but expected a hidden one:+          -- That's an error, as we cannot insert a visible lambda.+          if visible h' then typeError $ WrongHidingInLambda target else do+            -- Otherwise, we found a hidden argument that we can insert.+            let x    = absName b+            Lam (setOrigin Inserted $ domInfo dom) . Abs x <$> do+              addContext (x, dom) $ insertHiddenLambdas h (absBody b) postpone ret++      _ -> typeError $ ShouldBePi target++-- | @checkAbsurdLambda i h e t@ checks absurd lambda against type @t@.+--   Precondition: @e = AbsurdLam i h@+checkAbsurdLambda :: Comparison -> A.ExprInfo -> Hiding -> A.Expr -> Type -> TCM Term+checkAbsurdLambda cmp i h e t =+  setRunTimeModeUnlessInHardCompileTimeMode $ do+      -- Andreas, 2019-10-01: check absurd lambdas in non-erased mode.+      -- Otherwise, they are not usable in meta-solutions in the term world.+      -- See test/Succeed/Issue3176.agda for an absurd lambda+      -- created in types.+      -- #4743: Except if hard compile-time mode is enabled.+  t <- instantiateFull t+  ifBlocked t (\ blocker t' -> postponeTypeCheckingProblem (CheckExpr cmp e t') blocker) $ \ _ t' -> do+    case unEl t' of+      Pi dom@(Dom{domInfo = info', unDom = a}) b+        | not (sameHiding h info') -> typeError $ WrongHidingInLambda t'+        | otherwise -> blockTerm t' $ do+          ensureEmptyType (getRange i) a+          -- Add helper function+          aux <- makeAbsurdLambda (getRange i) dom b+          -- Andreas 2012-01-30: since aux is lifted to toplevel+          -- it needs to be applied to the current telescope (issue 557)+          Def aux . map Apply . teleArgs <$> getContextTelescope+      _ -> typeError $ ShouldBePi t'++-- Create an absurd lambda with the given type.+-- Precondition: the given type is a pi type with an empty domain.+makeAbsurdLambda :: Range -> Dom Type -> Abs Type -> TCM QName+makeAbsurdLambda r a b = do+  let t = Pi a b+      s = mkPiSort a b+      info = domInfo a+  top <- currentModule+  aux <- qualify top <$> freshName_ (r, absurdLambdaName)+  -- if we are in irrelevant / erased position, the helper function+  -- is added as irrelevant / erased+  mod <- currentModality+  reportSDoc "tc.term.absurd" 10 $ vcat+    [ ("Adding absurd function" <+> prettyTCM mod) <> prettyTCM aux+    , nest 2 $ "of type" <+> prettyTCM t+    ]+  lang <- getLanguage+  fun  <- emptyFunctionData+  addConstant aux $+    (\ d -> (defaultDefn (setModality mod info) aux (El s t) lang d)+            { defPolarity       = [Nonvariant]+            , defArgOccurrences = [Unused] })+    $ FunctionDefn fun+      { _funClauses        =+          [ Clause+            { clauseLHSRange  = r+            , clauseFullRange = r+            , clauseTel       = telFromList [fmap (absurdPatternName,) a]+            , namedClausePats = [Arg info $ Named (Just $ WithOrigin Inserted $ unranged $ absName b) $ absurdP 0]+            , clauseBody      = Nothing+            , clauseType      = Just $ setModality mod $ defaultArg $ absBody b+            , clauseCatchall    = YesCatchall empty      -- absurd clauses are safe as catch-alls+            , clauseRecursive   = Just False+            , clauseUnreachable = Just True -- absurd clauses are unreachable+            , clauseEllipsis    = NoEllipsis+            , clauseWhereModule = Nothing+            }+          ]+      , _funCompiled       = Just $ Fail [Arg info "()"]+      , _funSplitTree      = Just $ SplittingDone 0+      , _funMutual         = Just []+      , _funTerminates     = Just True+      , _funExtLam         = Just $ ExtLamInfo top True empty+      }+  return aux++-- | @checkExtendedLambda i di erased qname cs e t@ check pattern matching lambda.+-- Precondition: @e = ExtendedLam i di erased qname cs@+checkExtendedLambda ::+  Comparison -> A.ExprInfo -> A.DefInfo -> Erased -> QName ->+  List1 A.Clause -> A.Expr -> Type -> TCM Term+checkExtendedLambda cmp i di erased qname cs e t = do+  mod <- currentModality+  when (isErased erased && not (hasQuantity0 mod)) $ typeError LambdaIsErased+  setModeUnlessInHardCompileTimeMode erased do+         -- Erased pattern-matching lambdas are checked in hard+         -- compile-time mode. For non-erased pattern-matching lambdas+         -- run-time mode is used, unless the current mode is hard+         -- compile-time mode.+    -- Andreas, 2016-06-16 issue #2045+    -- Try to get rid of unsolved size metas before we+    -- fix the type of the extended lambda auxiliary function+    solveSizeConstraints DontDefaultToInfty+    lamMod <- inFreshModuleIfFreeParams currentModule  -- #2883: need a fresh module if refined params+    t <- instantiateFull t+    ifBlocked t (\ m t' -> postponeTypeCheckingProblem_ $ CheckExpr cmp e t') \ _ t -> do+      j   <- currentOrFreshMutualBlock+      mod <- currentModality+      let info = setModality mod defaultArgInfo++      reportSDoc "tc.term.exlam" 20 $ vcat+        [ hsep+          [ text $ show $ A.defAbstract di+          , "extended lambda's implementation"+          , doubleQuotes $ prettyTCM qname+          , "has type:"+          ]+        , prettyTCM t -- <+> " where clauses: " <+> text (show cs)+        ]+      args     <- getContextArgs++      -- Andreas, Ulf, 2016-02-02: We want to postpone type checking an extended lambda+      -- in case the lhs checker failed due to insufficient type info for the patterns.+      -- Issues 480, 1159, 1811.+      abstract (A.defAbstract di) do+        -- Andreas, 2013-12-28: add extendedlambda as @Function@, not as @Axiom@;+        -- otherwise, @addClause@ in @checkFunDef'@ fails (see issue 1009).+        addConstant qname =<< do+          lang <- getLanguage+          fun  <- emptyFunction+          useTerPragma $+            (defaultDefn info qname t lang fun)+              { defMutual = j }+        checkFunDef' t info (Just $ ExtLamInfo lamMod False empty) Nothing di qname $+          List1.toList cs+        whenNothingM (asksTC envMutualBlock) $+          -- Andrea 10-03-2018: Should other checks be performed here too? e.g. termination/positivity/..+          checkIApplyConfluence_ qname+        return $ Def qname $ map Apply args+  where+    -- Concrete definitions cannot use information about abstract things.+    abstract ConcreteDef = inConcreteMode+    abstract AbstractDef = inAbstractMode++-- | Run a computation.+--+--   * If successful, that's it, we are done.+--+--   * If @NotADatatype a@ or @CannotEliminateWithPattern p a@+--     is thrown and type @a@ is blocked on some meta @x@,+--     reset any changes to the state and pass (the error and) @x@ to the handler.+--+--   * If @SplitError (UnificationStuck c tel us vs _)@ is thrown and the unification+--     problem @us =?= vs : tel@ is blocked on some meta @x@ pass @x@ to the handler.+--+--   * If another error was thrown or the type @a@ is not blocked, reraise the error.+--+--   Note that the returned meta might only exists in the state where the error was+--   thrown, thus, be an invalid 'MetaId' in the current state.+--+catchIlltypedPatternBlockedOnMeta :: TCM a -> ((TCErr, Blocker) -> TCM a) -> TCM a+catchIlltypedPatternBlockedOnMeta m handle = do++  -- Andreas, 2016-07-13, issue 2028.+  -- Save the state to rollback the changes to the signature.+  st <- getTC++  m `catchError` \ err -> do++    let reraise :: MonadError TCErr m => m a+        reraise = throwError err++    -- Get the blocker responsible for the type error.+    -- If we do not find a blocker or the error should not be handled,+    -- we reraise the error.+    blocker <- maybe reraise return $ case err of+      TypeError _ s cl -> case clValue cl of+        SortOfSplitVarError b _                       -> b+        SplitError (UnificationStuck b c tel us vs _) -> b+        SplitError (BlockedType b aClosure)           -> Just b+        CannotEliminateWithPattern b p a              -> b+        -- Andrea: TODO look for blocking meta in tClosure and its Sort.+        -- SplitError (CannotCreateMissingClause _ _ _ tClosure) ->+        _                                             -> Nothing+      _ -> Nothing++    reportSDoc "tc.postpone" 20 $ vcat $+      [ "checking definition blocked on: " <+> prettyTCM blocker ]++    -- Note that we messed up the state a bit.  We might want to unroll these state changes.+    -- However, they are mostly harmless:+    -- 1. We created a new mutual block id.+    -- 2. We added a constant without definition.+    -- In fact, they are not so harmless, see issue 2028!+    -- Thus, reset the state!+    putTC st++    -- There might be metas in the blocker not known in the reset state, as they could have been+    -- created somewhere on the way to the type error.+    blocker <- (`onBlockingMetasM` blocker) $ \ x ->+                lookupMeta x >>= \ case+      -- Case: we do not know the meta, so cannot unblock.+      Nothing -> return neverUnblock+      -- Case: we know the meta here.+      -- Just m | InstV{} <- mvInstantiation m -> __IMPOSSIBLE__  -- It cannot be instantiated yet.+      -- Andreas, 2018-11-23: I do not understand why @InstV@ is necessarily impossible.+      -- The reasoning is probably that the state @st@ is more advanced that @s@+      -- in which @x@ was blocking, thus metas in @st@ should be more instantiated than+      -- in @s@.  But issue #3403 presents a counterexample, so let's play save and reraise.+      -- Ulf, 2020-08-13: But treat this case as not blocked and reraise on both always and never.+      -- Ulf, 2020-08-13: Previously we returned neverUnblock for frozen metas here, but this is in+      -- fact not very helpful. Yes there is no hope of solving the problem, but throwing a hard+      -- error means we rob the user of the tools needed to figure out why the meta has not been+      -- solved. Better to leave the constraint.+      Just Left{} -> return alwaysUnblock+      Just (Right m)+        | InstV{} <- mvInstantiation m -> return alwaysUnblock+        | otherwise                    -> return $ unblockOnMeta x++    -- If it's not blocked or we can't ever unblock reraise the error.+    if blocker `elem` [neverUnblock, alwaysUnblock] then reraise else handle (err, blocker)++---------------------------------------------------------------------------+-- * Records+---------------------------------------------------------------------------++-- | Picks up record field assignments from modules that export a definition+--   that has the same name as the missing field.++expandModuleAssigns+  :: [Either A.Assign A.ModuleName]  -- ^ Modules and field assignments.+  -> [C.Name]                        -- ^ Names of fields of the record type.+  -> TCM A.Assigns                   -- ^ Completed field assignments from modules.+expandModuleAssigns mfs xs = do+  let (fs , ms) = partitionEithers mfs++  -- The fields of the record that have not been given by field assignments @fs@+  -- are looked up in the given modules @ms@.+  fs' <- forM (xs List.\\ map (view nameFieldA) fs) $ \ f -> do++    -- Get the possible assignments for field f from the modules.+    pms <- forM ms $ \ m -> do+      modScope <- getNamedScope m+      let names :: ThingsInScope AbstractName+          names = exportedNamesInScope modScope+      return $+        case Map.lookup f names of+          Just (n :| []) -> Just (m, FieldAssignment f $ killRange $ A.nameToExpr n)+          _ -> Nothing++    -- If we have several matching assignments, that's an error.+    case catMaybes pms of+      []        -> return Nothing+      [(_, fa)] -> return (Just fa)+      x:y:zs    -> typeError $ AmbiguousField f $ fmap fst $ List2 x y zs+  return (fs ++ catMaybes fs')++-- | @checkRecordExpression fs e t@ checks record construction against type @t@.+-- Precondition @e = Rec _ fs@.+checkRecordExpression+  :: Comparison       -- ^ How do we related the inferred type of the record expression+                      --   to the expected type?  Subtype or equal type?+  -> A.RecordAssigns  -- ^ @mfs@: modules and field assignments.+  -> A.Expr           -- ^ Must be @A.Rec _ mfs@.+  -> Type             -- ^ Expected type of record expression.+  -> TCM Term         -- ^ Record value in internal syntax.+checkRecordExpression cmp mfs e@(A.Rec kwr _r _) t = do+  reportSDoc "tc.term.rec" 10 $ sep+    [ "checking record expression"+    , prettyA e+    ]+  ifBlocked t (\ _ t -> guessRecordType t) {-else-} $ \ _ t -> do+  case unEl t of+    -- Case: We know the type of the record already.+    Def r es  -> do+      let ~(Just vs) = allApplyElims es+      reportSDoc "tc.term.rec" 20 $ "  r   = " <> pure (P.pretty r)++      def <- getRecordDef r+      let -- Field names (C.Name) with ArgInfo from record type definition.+          cxs  = map argFromDom $ recordFieldNames def+          -- Just field names.+          xs   = map unArg cxs+          -- Record constructor.+          con  = killRange $ _recConHead def+      reportSDoc "tc.term.rec" 20 $ vcat+        [ "  xs  = " <> pure (P.pretty xs)+        , "  ftel= " <> prettyTCM (_recTel def)+        , "  con = " <> pure (P.pretty con)+        ]++      -- Record expressions corresponding to erased record+      -- constructors can only be used in compile-time mode.+      constructorQ <- getQuantity <$> getConstInfo (conName con)+      currentQ     <- viewTC eQuantity+      unless (constructorQ `moreQuantity` currentQ) $ typeError RecordIsErased++      -- Andreas, 2018-09-06, issue #3122.+      -- Associate the concrete record field names used in the record expression+      -- to their counterpart in the record type definition.+      disambiguateRecordFields (map _nameFieldA $ lefts mfs) (map unDom $ _recFields def)++      -- Compute the list of given fields, decorated with the ArgInfo from the record def.+      -- Andreas, 2019-03-18, issue #3122, also pick up non-visible fields from the modules.+      fs <- expandModuleAssigns mfs xs++      -- Compute a list of metas for the missing visible fields.+      scope <- getScope+      let meta x = A.Underscore $ A.MetaInfo (getRange kwr) scope Nothing (prettyShow x) A.UnificationMeta+      -- In @es@ omitted explicit fields are replaced by underscores.+      -- Omitted implicit or instance fields+      -- are still left out and inserted later by checkArguments_.+      es <- insertMissingFieldsWarn r meta fs cxs++      args <- checkArguments_ cmp ExpandLast e es (_recTel def `apply` vs) >>= \case+        (elims, remainingTel) | null remainingTel+                              , Just args <- allApplyElims elims -> return args+        _ -> __IMPOSSIBLE__+      -- Don't need to block here!+      reportSDoc "tc.term.rec" 20 $ text $ "finished record expression"+      return $ Con con ConORec (map Apply args)+    _ -> typeError $ ShouldBeRecordType t++  where+    -- Case: We don't know the type of the record.+    guessRecordType t = do+      let fields = [ x | Left (FieldAssignment x _) <- mfs ]+      rs <- findPossibleRecords fields+      reportSDoc "tc.term.rec" 30 $ "Possible records for" <+> prettyTCM t <+> "are" <?> pretty rs+      case rs of+          -- If there are no records with the right fields we might as well fail right away.+        [] -> typeError $ NoKnownRecordWithSuchFields fields+          -- If there's only one record with the appropriate fields, go with that.+        [r] -> do+          -- #5198: Don't generate metas for parameters of the current module. In most cases they+          -- get solved, but not always.+          def <- instantiateDef =<< getConstInfo r+          ps  <- freeVarsToApply r+          let rt = defType def+          reportSDoc "tc.term.rec" 30 $ "Type of unique record" <+> prettyTCM rt+          vs  <- newArgsMeta rt+          target <- reduce $ piApply rt vs+          s  <- case unEl target of+                  Sort s  -> return s+                  v       -> do+                    reportSDoc "impossible" 10 $ vcat+                      [ "The impossible happened when checking record expression against meta"+                      , "Candidate record type r = " <+> prettyTCM r+                      , "Type of r               = " <+> prettyTCM rt+                      , "Ends in (should be sort)= " <+> prettyTCM v+                      , text $ "  Raw                   =  " ++ show v+                      ]+                    __IMPOSSIBLE__+          let inferred = El s $ Def r $ map Apply (ps ++ vs)+          v <- checkExpr e inferred+          coerce cmp v inferred t++          -- If there are more than one possible record we postpone+        _:_:_ -> do+          reportSDoc "tc.term.expr.rec" 10 $ sep+            [ "Postponing type checking of"+            , nest 2 $ prettyA e <+> ":" <+> prettyTCM t+            ]+          postponeTypeCheckingProblem_ $ CheckExpr cmp e t++checkRecordExpression _ _ _ _ = __IMPOSSIBLE__++-- | @checkRecordUpdate cmp ei recexpr fs e t@+--+-- Preconditions: @e = RecUpdate ei recexpr fs@ and @t@ is reduced.+--+checkRecordUpdate+  :: Comparison   -- ^ @cmp@+  -> KwRange      -- ^ Range of the @record@ keyword.+  -> A.ExprInfo   -- ^ @ei@+  -> A.Expr       -- ^ @recexpr@+  -> A.Assigns    -- ^ @fs@+  -> A.Expr       -- ^ @e = RecUpdate ei recexpr fs@+  -> Type         -- ^ Need not be reduced.+  -> TCM Term+checkRecordUpdate cmp kwr ei recexpr fs eupd t = do+  ifBlocked t (\ _ _ -> tryInfer) $ {-else-} \ _ t' -> do+    caseMaybeM (isRecordType t') should $ \ (r, _pars, defn) -> do+      -- Bind the record value (before update) to a fresh @name@.+      v <- checkExpr' cmp recexpr t'+      name <- freshNoName $ getRange recexpr+      addLetBinding defaultArgInfo Inserted name v t' $ do++        let projs = map argFromDom $ _recFields defn++        -- Andreas, 2018-09-06, issue #3122.+        -- Associate the concrete record field names used in the record expression+        -- to their counterpart in the record type definition.+        disambiguateRecordFields (map _nameFieldA fs) (map unArg projs)++        -- Desugar record update expression into record expression.+        let fs' = map (\ (FieldAssignment x e) -> (x, Just e)) fs+        let axs = map argFromDom $ recordFieldNames defn+        es  <- orderFieldsWarn r (const Nothing) axs fs'+        let es'  = zipWith (replaceFields name ei) projs es+        let erec = A.Rec kwr ei [ Left (FieldAssignment x e) | (Arg _ x, Just e) <- zip axs es' ]+        -- Call the type checker on the desugared syntax.+        checkExpr' cmp erec t+  where+    replaceFields :: Name -> A.ExprInfo -> Arg A.QName -> Maybe A.Expr -> Maybe A.Expr+    replaceFields name ei (Arg ai p) Nothing | visible ai = Just $+      -- omitted visible fields remain unchanged: @{ ...; p = p name; ...}@+      -- (hidden fields are supposed to be inferred)+      A.App+        (A.defaultAppInfo $ getRange ei)+        (A.Proj ProjSystem $ unambiguous p)+        (defaultNamedArg $ A.Var name)+    replaceFields _ _ _ me = me  -- other fields get the user-written updates++    tryInfer = do+      (_, trec) <- inferExpr recexpr+      ifBlocked trec (\ _ _ -> postpone) $ {-else-} \ _ _ -> do+        v <- checkExpr' cmp eupd trec+        coerce cmp v trec t++    postpone = postponeTypeCheckingProblem_ $ CheckExpr cmp eupd t+    should   = typeError $ ShouldBeRecordType t++---------------------------------------------------------------------------+-- * Literal+---------------------------------------------------------------------------++checkLiteral :: Literal -> Type -> TCM Term+checkLiteral lit t = do+  t' <- litType lit+  coerce CmpEq (Lit lit) t' t++---------------------------------------------------------------------------+-- * Terms+---------------------------------------------------------------------------++-- | Remove top layers of scope info of expression and set the scope accordingly+--   in the 'TCState'.++scopedExpr :: A.Expr -> TCM A.Expr+scopedExpr (A.ScopedExpr scope e) = setScope scope >> scopedExpr e+scopedExpr e                      = return e++-- | Type check an expression.+checkExpr :: A.Expr -> Type -> TCM Term+checkExpr = checkExpr' CmpLeq++-- Andreas, 2019-10-13, issue #4125:+-- For the sake of readable types in interactive program construction,+-- avoid unnecessary unfoldings via 'reduce' in the type checker!+checkExpr'+  :: Comparison+  -> A.Expr+  -> Type        -- ^ Unreduced!+  -> TCM Term+checkExpr' cmp e t =+  verboseBracket "tc.term.expr.top" 5 "checkExpr" $+  reportResult "tc.term.expr.top" 15 (\ v -> vcat+                                              [ "checkExpr" <?> fsep [ prettyTCM e, ":", prettyTCM t ]+                                              , "  returns" <?> prettyTCM v ]) $+  traceCall (CheckExprCall cmp e t) $ localScope $ doExpandLast $ unfoldInlined =<< do+    reportSDoc "tc.term.expr.top" 15 $+        "Checking" <+> sep+          [ fsep [ prettyTCM e, ":", prettyTCM t ]+          , nest 2 $ "at " <+> (text . prettyShow =<< getCurrentRange)+          ]+    reportSDoc "tc.term.expr.top.detailed" 80 $+      "Checking" <+> fsep [ prettyTCM e, ":", text (show t) ]+    tReduced <- reduce t+    reportSDoc "tc.term.expr.top" 15 $+        "    --> " <+> prettyTCM tReduced++    e <- scopedExpr e++    irrelevantIfProp <- runBlocked (isPropM t) >>= \case+      Right True  -> do+        let mod = unitModality { modRelevance = irrelevant }+        return $ fmap dontCare . applyModalityToContext mod+      _ -> return id++    irrelevantIfProp $ tryInsertHiddenLambda e tReduced $ case e of++        A.ScopedExpr scope e -> __IMPOSSIBLE__ -- setScope scope >> checkExpr e t++        -- a meta variable without arguments: type check directly for efficiency+        A.QuestionMark i ii -> checkQuestionMark (newValueMeta' RunMetaOccursCheck) cmp t i ii+        A.Underscore i -> checkUnderscore i cmp t++        A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application"++        e0@(A.App i q (Arg ai e))+          | A.Quote _ <- unScope q -> do+             if visible ai then do+               x  <- quotedName $ namedThing e+               ty <- qNameType+               coerce cmp (quoteName x) ty t+             else typeError $ CannotQuote CannotQuoteHidden++          | A.QuoteTerm _ <- unScope q -> do+             if visible ai then do+               (et, _) <- inferExpr (namedThing e)+               doQuoteTerm cmp et t+             else typeError $ CannotQuoteTerm CannotQuoteTermHidden++        A.Quote{}     -> typeError $ CannotQuote CannotQuoteNothing+        A.QuoteTerm{} -> typeError $ CannotQuoteTerm CannotQuoteTermNothing+        A.Unquote{}   -> unquoteError NakedUnquote++        A.AbsurdLam i h -> checkAbsurdLambda cmp i h e t++        A.ExtendedLam i di erased qname cs ->+          checkExtendedLambda cmp i di erased qname cs e t++        A.Lam i (A.DomainFull b) e -> checkLambda cmp b e t++        A.Lam i (A.DomainFree _ x) e0+          | isNothing (nameOf $ unArg x) && isNothing (A.binderPattern $ namedArg x) ->+              checkExpr' cmp (A.Lam i (domainFree (getArgInfo x) $ A.unBind <$> namedArg x) e0) t+          | otherwise -> __IMPOSSIBLE__++        A.Lit _ lit  -> checkLiteral lit t+        A.Let i ds e -> checkLetBindings ds $ checkExpr' cmp e t+        e@A.Pi{} -> do+            t' <- isType_ e+            let s = getSort t'+                v = unEl t'+            coerce cmp v (sort s) t++        A.Generalized s e -> do+            (_, t') <- generalizeType (Set1.toSet s) $ isType_ e+            --noFunctionsIntoSize t' t'+            let s = getSort t'+                v = unEl t'+            coerce cmp v (sort s) t++        e@A.Fun{} -> do+            t' <- isType_ e+            let s = getSort t'+                v = unEl t'+            coerce cmp v (sort s) t++        A.Rec _ _ fs  -> checkRecordExpression cmp fs e t++        A.RecUpdate kwr ei recexpr fs -> checkRecordUpdate cmp kwr ei recexpr fs e t++        A.DontCare e -> do+          rel <- viewTC eRelevance+          if isIrrelevant rel then dontCare <$> do+            -- resurrect variables+            applyRelevanceToContext rel $ checkExpr' cmp e t+          else+            internalError "DontCare may only appear in irrelevant contexts"++        A.Dot{} -> typeError InvalidDottedExpression++        -- Application+        _   | Application hd args <- appView e -> checkApplication cmp hd args e t++      `catchIlltypedPatternBlockedOnMeta` \ (err, x) -> do+        -- We could not check the term because the type of some pattern is blocked.+        -- It has to be blocked on some meta, so we can postpone,+        -- being sure it will be retried when a meta is solved+        -- (which might be the blocking meta in which case we actually make progress).+        reportSDoc "tc.term" 50 $ vcat $+          [ "checking pattern got stuck on meta: " <+> pretty x ]+        postponeTypeCheckingProblem (CheckExpr cmp e t) x++  where+  -- Call checkExpr with an hidden lambda inserted if appropriate,+  -- else fallback.+  tryInsertHiddenLambda+    :: A.Expr+    -> Type      -- Reduced.+    -> TCM Term+    -> TCM Term+  tryInsertHiddenLambda e tReduced fallback+    -- Insert hidden lambda if all of the following conditions are met:+    -- type is a hidden function type, {x : A} -> B or {{x : A}} -> B+    -- expression is not a lambda with the appropriate hiding yet+    | Pi (Dom{domInfo = info, unDom = a}) b <- unEl tReduced+        , let h = getHiding info+        , notVisible h+        -- expression is not a matching hidden lambda or question mark+        , not (hiddenLambdaOrHole h e)+        = do+      let proceed = doInsert (setOrigin Inserted info) $ absName b+      expandHidden <- asksTC envExpandLast+      -- If we skip the lambda insertion for an introduction,+      -- we will hit a dead end, so proceed no matter what.+      if definitelyIntroduction then proceed else+        -- #3019 and #4170: don't insert implicit lambdas in arguments to existing metas+        if expandHidden == ReallyDontExpandLast then fallback else do+        -- Andreas, 2017-01-19, issue #2412:+        -- We do not want to insert a hidden lambda if A is+        -- possibly empty type of sizes, as this will produce an error.+        reduce a >>= isSizeType >>= \case+          Just (BoundedLt u) -> ifBlocked u (\ _ _ -> fallback) $ \ _ v -> do+            ifM (checkSizeNeverZero v) proceed fallback+            `catchError` \_ -> fallback+          _ -> proceed++    | otherwise = fallback++    where+    re = getRange e+    rx = caseMaybe (rStart re) noRange $ \ pos -> posToRange pos pos++    doInsert info y = do+      x <- C.setNotInScope <$> freshName rx y+      reportSLn "tc.term.expr.impl" 15 $ "Inserting implicit lambda"+      checkExpr' cmp (A.Lam (A.ExprRange re) (domainFree info $ A.mkBinder x) e) tReduced++    hiddenLambdaOrHole h = \case+      A.AbsurdLam _ h'          -> sameHiding h h'+      A.ExtendedLam _ _ _ _ cls -> any hiddenLHS cls+      A.Lam _ bind _            -> sameHiding h bind+      A.QuestionMark{}          -> True+      _                         -> False++    hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _))) _ _ _ _) = notVisible a+    hiddenLHS _ = False++    -- Things with are definitely introductions,+    -- thus, cannot be of hidden Pi-type, unless they are hidden lambdas.+    definitelyIntroduction = case e of+      A.Lam{}        -> True+      A.AbsurdLam{}  -> True+      A.Lit{}        -> True+      A.Pi{}         -> True+      A.Fun{}        -> True+      A.Rec{}        -> True+      A.RecUpdate{}  -> True+      A.ScopedExpr{} -> __IMPOSSIBLE__+      _ -> False++---------------------------------------------------------------------------+-- * Reflection+---------------------------------------------------------------------------++doQuoteTerm :: Comparison -> Term -> Type -> TCM Term+doQuoteTerm cmp et t = do+  et'       <- etaContract =<< instantiateFull et+  case allMetasList et' of+    []  -> do+      q  <- quoteTerm et'+      ty <- el primAgdaTerm+      coerce cmp q ty t+    metas -> postponeTypeCheckingProblem (DoQuoteTerm cmp et t) $ unblockOnAllMetas $ Set.fromList metas++-- | Unquote a TCM computation in a given hole.+unquoteM :: A.Expr -> Term -> Type -> TCM ()+unquoteM tacA hole holeType = do+  tac <- applyQuantityToJudgement zeroQuantity $+    checkExpr tacA =<< (el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit))+  inFreshModuleIfFreeParams $ unquoteTactic tac hole holeType++-- | Run a tactic `tac : Term → TC ⊤` in a hole (second argument) of the type+--   given by the third argument. Runs the continuation if successful.+unquoteTactic :: Term -> Term -> Type -> TCM ()+unquoteTactic tac hole goal = do+  ifM (useTC stConsideringInstance) (addConstraint neverUnblock (UnquoteTactic tac hole goal)) do+  reportSDoc "tc.term.tactic" 40 $ sep+    [ "Running tactic" <+> prettyTCM tac+    , nest 2 $ "on" <+> prettyTCM hole <+> ":" <+> prettyTCM goal ]+  ok  <- runUnquoteM $ unquoteTCM tac hole+  case ok of+    Left (BlockedOnMeta oldState blocker) -> do+      putTC oldState+      let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupLocalMeta' x+      blocker' <- onBlockingMetasM stripFreshMeta blocker+      r <- case Set.toList $ allBlockingMetas blocker' of+            x : _ -> getRange <$> lookupLocalMeta' x+            []    -> return noRange+      setCurrentRange r $+        addConstraint blocker' (UnquoteTactic tac hole goal)+    Left err -> typeError $ UnquoteFailed err+    Right _ -> return ()++---------------------------------------------------------------------------+-- * Meta variables+---------------------------------------------------------------------------++-- | Check an interaction point without arguments.+checkQuestionMark+  :: (Comparison -> Type -> TCM (MetaId, Term))+  -> Comparison+  -> Type            -- ^ Not reduced!+  -> A.MetaInfo+  -> InteractionId+  -> TCM Term+checkQuestionMark new cmp t0 i ii = do+  reportSDoc "tc.interaction" 20 $ sep+    [ "Found interaction point"+    , text . show =<< asksTC (^. lensIsAbstract)+    , pretty ii+    , ":"+    , prettyTCM t0+    ]+  reportSDoc "tc.interaction" 60 $ sep+    [ "Raw:"+    , text (show t0)+    ]+  checkMeta i (newQuestionMark' new ii) cmp t0 -- Andreas, 2013-05-22 use unreduced type t0!++-- | Check an underscore without arguments.+checkUnderscore :: A.MetaInfo -> Comparison -> Type -> TCM Term+checkUnderscore i = checkMeta i (newValueMetaOfKind i RunMetaOccursCheck)++-- | Type check a meta variable.+checkMeta :: A.MetaInfo -> (Comparison -> Type -> TCM (MetaId, Term)) -> Comparison -> Type -> TCM Term+checkMeta i newMeta cmp t = fst <$> checkOrInferMeta i newMeta (Just (cmp , t))++-- | Infer the type of a meta variable.+--   If it is a new one, we create a new meta for its type.+inferMeta :: A.MetaInfo -> (Comparison -> Type -> TCM (MetaId, Term)) -> TCM (Elims -> Term, Type)+inferMeta i newMeta = mapFst applyE <$> checkOrInferMeta i newMeta Nothing++-- | Type check a meta variable.+--   If its type is not given, we return its type, or a fresh one, if it is a new meta.+--   If its type is given, we check that the meta has this type, and we return the same+--   type.+checkOrInferMeta+  :: A.MetaInfo+  -> (Comparison -> Type -> TCM (MetaId, Term))+  -> Maybe (Comparison , Type)+  -> TCM (Term, Type)+checkOrInferMeta i newMeta mt = do+  case A.metaNumber i of+    Nothing -> do+      unlessNull (A.metaScope i) setScope+      (cmp , t) <- maybe ((CmpEq,) <$> workOnTypes newTypeMeta_) return mt+      (x, v) <- newMeta cmp t+      setMetaNameSuggestion x (A.metaNameSuggestion i)+      return (v, t)+    -- Rechecking an existing metavariable+    Just x -> do+      let v = MetaV x []+      reportSDoc "tc.meta.check" 20 $+        "checking existing meta " <+> prettyTCM v+      t' <- metaType x+      reportSDoc "tc.meta.check" 20 $+        nest 2 $ "of type " <+> prettyTCM t'+      case mt of+        Nothing -> return (v, t')+        Just (cmp , t) -> (,t) <$> coerce cmp v t' t++-- | Turn a domain-free binding (e.g. lambda) into a domain-full one,+--   by inserting an underscore for the missing type.+domainFree :: ArgInfo -> A.Binder' A.Name -> A.LamBinding+domainFree info x =+  A.DomainFull $ A.mkTBind r (singleton $ unnamedArg info $ fmap A.mkBindName x)+               $ A.Underscore underscoreInfo+  where+    r = getRange x+    underscoreInfo = A.MetaInfo+      { A.metaRange          = r+      , A.metaScope          = emptyScopeInfo+      , A.metaNumber         = Nothing+      , A.metaNameSuggestion = prettyShow $ A.nameConcrete $ A.binderName x+      , A.metaKind           = A.UnificationMeta+      }+++-- | Check arguments whose value we already know.+--+--   This function can be used to check user-supplied parameters+--   we have already computed by inference.+--+--   Precondition: The type @t@ of the head has enough domains.++checkKnownArguments+  :: [NamedArg A.Expr]  -- ^ User-supplied arguments (hidden ones may be missing).+  -> Args               -- ^ Inferred arguments (including hidden ones).+  -> Type               -- ^ Type of the head (must be Pi-type with enough domains).+  -> TCM (Args, Type)   -- ^ Remaining inferred arguments, remaining type.+checkKnownArguments []           vs t = return (vs, t)+checkKnownArguments (arg : args) vs t = do+  (vs', t') <- setCurrentRange arg $ checkKnownArgument arg vs t+  checkKnownArguments args vs' t'++-- | Check an argument whose value we already know.++checkKnownArgument+  :: NamedArg A.Expr    -- ^ User-supplied argument.+  -> Args               -- ^ Inferred arguments (including hidden ones).+  -> Type               -- ^ Type of the head (must be Pi-type with enough domains).+  -> TCM (Args, Type)   -- ^ Remaining inferred arguments, remaining type.+checkKnownArgument arg [] _ = typeError $ InvalidProjectionParameter arg+-- Andreas, 2019-07-22, while #3353: we should use domName, not absName !!+-- WAS:+-- checkKnownArgument arg@(Arg info e) (Arg _infov v : vs) t = do+--   (dom@Dom{domInfo = info',unDom = a}, b) <- mustBePi t+--   -- Skip the arguments from vs that do not correspond to e+--   if not (sameHiding info info'+--           && (visible info || maybe True (absName b ==) (bareNameOf e)))+checkKnownArgument arg (Arg _ v : vs) t = do+  -- Skip the arguments from vs that do not correspond to e+  (dom@Dom{ unDom = a }, b) <- mustBePi t+  if not $ fromMaybe __IMPOSSIBLE__ $ fittingNamedArg arg dom+    -- Continue with the next one+    then checkKnownArgument arg vs (b `absApp` v)+    -- Found the right argument+    else do+      u <- checkNamedArg arg a+      equalTerm a u v+      return (vs, b `absApp` v)++-- | Check a single argument.++checkNamedArg :: NamedArg A.Expr -> Type -> TCM Term+checkNamedArg arg@(Arg info e0) t0 = do+  let e = namedThing e0+  let x = bareNameWithDefault "" e0+  traceCall (CheckExprCall CmpLeq e t0) $ do+    reportSDoc "tc.term.args.named" 15 $ do+        "Checking named arg" <+> sep+          [ fsep [ prettyTCM arg, ":", prettyTCM t0 ]+          ]+    reportSLn "tc.term.args.named" 75 $ "  arg = " ++ show (deepUnscope arg)+    -- Ulf, 2017-03-24: (#2172) Always treat explicit _ and ? as implicit+    -- argument (i.e. solve with unification).+    -- Andreas, 2024-03-07, issue #2829: Except when we don't.+    -- E.g. when 'insertImplicitPatSynArgs' inserted an instance underscore.+    let checkU i = checkMeta i (newMetaArg (A.metaKind i) info x) CmpLeq t0+    let checkQ = checkQuestionMark (newInteractionMetaArg info x) CmpLeq t0+    if not $ isHole e then checkExpr e t0 else localScope $ do+      -- Note: we need localScope here,+      -- as scopedExpr manipulates the scope in the state.+      -- However, we may not pull localScope over checkExpr!+      -- This is why we first test for isHole, and only do+      -- scope manipulations if we actually handle the checking+      -- of e here (and not pass it to checkExpr).+      scopedExpr e >>= \case+        A.Underscore i ->  checkU i+        A.QuestionMark i ii -> checkQ i ii+        _ -> __IMPOSSIBLE__+  where+  isHole A.Underscore{} = True+  isHole A.QuestionMark{} = True+  isHole (A.ScopedExpr _ e) = isHole e+  isHole _ = False++-- | Infer the type of an expression. Implemented by checking against a meta+--   variable.  Except for neutrals, for them a polymorphic type is inferred.+inferExpr :: A.Expr -> TCM (Term, Type)+-- inferExpr e = inferOrCheck e Nothing+inferExpr = inferExpr' DontExpandLast++inferExpr' :: ExpandHidden -> A.Expr -> TCM (Term, Type)+inferExpr' exh e = traceCall (InferExpr e) $ do+  let Application hd args = appView e+  reportSDoc "tc.infer" 30 $ vcat+    [ "inferExpr': appView of " <+> prettyA e+    , "  hd   = " <+> prettyA hd+    , "  args = " <+> prettyAs args+    ]+  reportSDoc "tc.infer" 60 $ vcat+    [ text $ "  hd (raw) = " ++ show hd+    ]+  inferApplication exh hd args e++defOrVar :: A.Expr -> Bool+defOrVar A.Var{} = True+defOrVar A.Def'{} = True+defOrVar A.Proj{} = True+defOrVar (A.ScopedExpr _ e) = defOrVar e+defOrVar _     = False++-- | Used to check aliases @f = e@.+--   Switches off 'ExpandLast' for the checking of top-level application.+checkDontExpandLast :: Comparison -> A.Expr -> Type -> TCM Term+checkDontExpandLast cmp e t = case e of+  _ | Application hd args <- appView e,  defOrVar hd ->+    traceCall (CheckExprCall cmp e t) $ localScope $ dontExpandLast $ do+      checkApplication cmp hd args e t+  _ -> checkExpr' cmp e t -- note that checkExpr always sets ExpandLast++-- | Check whether a de Bruijn index is bound by a module telescope.+isModuleFreeVar :: Int -> TCM Bool+isModuleFreeVar i = do+  params <- moduleParamsToApply =<< currentModule+  return $ any ((== Var i []) . unArg) params++-- | Infer the type of an expression, and if it is of the form+--   @{tel} -> D vs@ for some datatype @D@ then insert the hidden+--   arguments.  Otherwise, leave the type polymorphic.+inferExprForWith :: Arg A.Expr -> TCM (Term, Type)+inferExprForWith (Arg info e) = verboseBracket "tc.with.infer" 20 "inferExprForWith" $+  applyRelevanceToContext (getRelevance info) $ do+    reportSDoc "tc.with.infer" 20 $ "inferExprForWith " <+> prettyTCM e+    reportSLn  "tc.with.infer" 80 $ "inferExprForWith " ++ show (deepUnscope e)+    traceCall (InferExpr e) $ do+      -- Andreas, 2024-02-26, issue #7148:+      -- The 'instantiateFull' here performs necessary eta-contraction,+      -- both for future with-abstraction,+      -- and for testing whether v is a variable modulo eta.+      (v, t) <- instantiateFull =<< inferExpr e+      v <- reduce v+      -- Andreas 2014-11-06, issue 1342.+      -- Check that we do not `with` on a module parameter!+      case v of+        Var i [] -> whenM (isModuleFreeVar i) $ do+          reportSDoc "tc.with.infer" 80 $ vcat+            [ text $ "with expression is variable " ++ show i+            , "current modules = " <+> do text . show =<< currentModule+            , "current module free vars = " <+> do text . show =<< getCurrentModuleFreeVars+            , "context size = " <+> do text . show =<< getContextSize+            , "current context = " <+> do prettyTCM =<< getContextTelescope+            ]+          typeError $ WithOnFreeVariable e v+        _        -> return ()+      -- Possibly insert hidden arguments.+      TelV tel t0 <- telViewUpTo' (-1) (not . visible) t+      (v, t) <- case unEl t0 of+        Def d vs -> do+          isDataOrRecordType d >>= \case+            Nothing -> return (v, t)+            Just{}  -> do+              (args, t1) <- implicitArgs (-1) notVisible t+              return (v `apply` args, t1)+        _ -> return (v, t)+      -- #6868, #7113: trigger instance search to resolve instances in with-expression+      solveAwakeConstraints+      return (v, t)++---------------------------------------------------------------------------+-- * Let bindings+---------------------------------------------------------------------------++checkLetBindings' :: Foldable t => t A.LetBinding -> TCM a -> TCM a+checkLetBindings' = foldr ((.) . checkLetBinding') id++checkLetBinding' :: A.LetBinding -> TCM a -> TCM a++checkLetBinding' b@(A.LetBind i info x t e) ret = do+  -- #4131: Only DontExpandLast if no user written type signature+  let+    check+      | getOrigin info == Inserted = checkDontExpandLast+      | otherwise                  = checkExpr'++  t <- workOnTypes $ isType_ t+  v <- applyModalityToContext info $ check CmpLeq e t++  addLetBinding info UserWritten (A.unBind x) v t ret++checkLetBinding' b@(A.LetAxiom i info x t) ret = do+  t <- workOnTypes $ isType_ t+  current <- currentModule++  -- Note: if addConstant is called under a nontrivial context then+  -- it'll automatically quantify the type we give it over the context+  axn <- qualify current <$> freshName_ (A.unBind x)+  addConstant' axn info t defaultAxiom++  val <- Def axn . fmap Apply <$> getContextArgs+  addLetBinding info UserWritten (A.unBind x) val t ret++checkLetBinding' b@(A.LetPatBind i p e) ret = do+    p <- expandPatternSynonyms p+    (v, t) <- inferExpr' ExpandLast e+    let -- construct a type  t -> dummy  for use in checkLeftHandSide+        t0 = El (getSort t) $ Pi (defaultDom t) (NoAbs underscore __DUMMY_TYPE__)+        p0 = Arg defaultArgInfo (Named Nothing p)+    reportSDoc "tc.term.let.pattern" 10 $ vcat+      [ "let-binding pattern p at type t"+      , nest 2 $ vcat+        [ "p (A) =" <+> prettyA p+        , "t     =" <+> prettyTCM t+        , "cxtRel=" <+> do pretty =<< viewTC eRelevance+        , "cxtQnt=" <+> do pretty =<< viewTC eQuantity+        ]+      ]+    fvs <- getContextSize+    checkLeftHandSide (CheckPattern p EmptyTel t) noRange Nothing [p0] t0 Nothing [] $ \ (LHSResult _ delta0 ps _ _t _ asb _ _) -> bindAsPatterns asb $ do+          -- After dropping the free variable patterns there should be a single pattern left.+      let p = case drop fvs ps of [p] -> namedArg p; _ -> __IMPOSSIBLE__+          -- Also strip the context variables from the telescope+          delta = telFromList $ drop fvs $ telToList delta0+      reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat+        [ "p (I) =" <+> prettyTCM p+        , "delta =" <+> prettyTCM delta+        , "cxtRel=" <+> do pretty =<< viewTC eRelevance+        , "cxtQnt=" <+> do pretty =<< viewTC eQuantity+        ]+      reportSDoc "tc.term.let.pattern" 80 $ nest 2 $ vcat+        [ "p (I) =" <+> (text . show) p+        ]+      -- We translate it into a list of projections.+      fs <- recordPatternToProjections p+      -- We remove the bindings for the pattern variables from the context.+      cxt0 <- getContext+      let (binds, cxt) = splitAt (size delta) cxt0+          toDrop       = length binds++          -- We create a substitution for the let-bound variables+          -- (unfortunately, we cannot refer to x in internal syntax+          -- so we have to copy v).+          sigma = map ($ v) fs+          -- We apply the types of the let bound-variables to this substitution.+          -- The 0th variable in a context is the last one, so we reverse.+          -- Further, we need to lower all other de Bruijn indices by+          -- the size of delta, so we append the identity substitution.+          sub    = parallelS (reverse sigma)++      updateContext sub (drop toDrop) $ do+        reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat+          [ "delta =" <+> prettyTCM delta+          , "binds =" <+> prettyTCM binds+          ]+        let fdelta = flattenTel delta+        reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat+          [ "fdelta =" <+> addContext delta (prettyTCM fdelta)+          ]+        let tsl  = applySubst sub fdelta+        -- We get a list of types+        let ts   = map unDom tsl+        -- and relevances.+        let infos = map domInfo tsl+        -- We get list of names of the let-bound vars from the context.+        let xs   = map ctxEntryName $ reverse binds+        -- We add all the bindings to the context.+        foldr (uncurry4 $ flip addLetBinding UserWritten) ret $ List.zip4 infos xs sigma ts++checkLetBinding' (A.LetApply i erased x modapp copyInfo dir) ret = do+  -- Any variables in the context that doesn't belong to the current+  -- module should go with the new module.+  -- Example: @f x y = let open M t in u@.+  -- There are 2 @new@ variables, @x@ and @y@, going into the anonynous module+  -- @module _ (x : _) (y : _) = M t@.+  fv   <- getCurrentModuleFreeVars+  n    <- getContextSize+  let new = n - fv+  reportSDoc "tc.term.let.apply" 10 $ "Applying" <+> pretty x <+> prettyA modapp <?> ("with" <+> pshow new <+> "free variables")+  reportSDoc "tc.term.let.apply" 20 $ vcat+    [ "context =" <+> (prettyTCM =<< getContextTelescope)+    , "module  =" <+> (prettyTCM =<< currentModule)+    , "fv      =" <+> text (show fv)+    ]+  checkSectionApplication i erased x modapp copyInfo+    -- Some other part of the code ensures that "open public" is+    -- ignored in let expressions. Thus there is no need for+    -- checkSectionApplication to throw an error if the import+    -- directive does contain "open public".+    dir{ publicOpen = Nothing }+  withAnonymousModule x new ret+-- LetOpen and (WAS:) LetDeclaredVariable are only used for highlighting.+checkLetBinding' A.LetOpen{} ret = ret++-- | Version of checkLetBinding which traces the fact that we're+-- checking each binding in the Call.+checkLetBinding :: A.LetBinding -> TCM a -> TCM a+checkLetBinding b = traceCallCPS' (CheckLetBinding b) (checkLetBinding' b)++checkLetBindings :: Foldable t => t A.LetBinding -> TCM a -> TCM a+checkLetBindings = foldr ((.) . checkLetBinding) id
src/full/Agda/TypeChecking/Rules/Term.hs-boot view
@@ -1,24 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.Term where -import Agda.Syntax.Common (WithHiding, NamedArg, Arg)+import Agda.Syntax.Common (WithHiding, Arg) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal-import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base-import Agda.Utils.Except ( ExceptT )+import Agda.Utils.List1 (List1)  isType_ :: A.Expr -> TCM Type  checkExpr :: A.Expr -> Type -> TCM Term+checkExpr' :: Comparison -> A.Expr -> Type -> TCM Term inferExpr :: A.Expr -> TCM (Term, Type) -checkArguments :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-                  ExceptT (Args, [NamedArg A.Expr], Type) TCM (Args, Type)--checkArguments' :: ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-                   (Args -> Type -> TCM Term) -> TCM Term--checkPostponedLambda :: Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term+checkPostponedLambda :: Comparison -> Arg (List1 (WithHiding Name), Maybe Type) -> A.Expr -> Type -> TCM Term -unquoteTactic :: Term -> Term -> Type -> TCM Term -> TCM Term+doQuoteTerm :: Comparison -> Term -> Type -> TCM Term+unquoteTactic :: Term -> Term -> Type -> TCM ()
src/full/Agda/TypeChecking/Serialise.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}  -- Andreas, Makoto, Francesco 2014-10-15 AIM XX: -- -O2 does not have any noticable effect on runtime@@ -22,106 +24,136 @@   )   where -import Control.Applicative+import Prelude hiding ( null )++import System.Directory ( createDirectoryIfMissing )+import System.FilePath ( takeDirectory )+ import Control.Arrow (second) import Control.DeepSeq import qualified Control.Exception as E import Control.Monad+import Control.Monad.Except+import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader import Control.Monad.State.Strict+import Control.Monad.ST.Trans  import Data.Array.IArray+import Data.Array.IO import Data.Word+import Data.Word (Word32)+import Data.ByteString.Lazy    ( ByteString )+import Data.ByteString.Builder ( byteString, toLazyByteString ) import qualified Data.ByteString.Lazy as L-import qualified Data.HashTable.IO as H import qualified Data.Map as Map import qualified Data.Binary as B import qualified Data.Binary.Get as B import qualified Data.Binary.Put as B import qualified Data.List as List-import Data.Function+import Data.Function (on)  import qualified Codec.Compression.GZip as G+import qualified Codec.Compression.Zlib.Internal as Z +import GHC.Compact as C+ import qualified Agda.TypeChecking.Monad.Benchmark as Bench  import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances ()+import Agda.TypeChecking.Serialise.Instances () --instance only  import Agda.TypeChecking.Monad  import Agda.Utils.Hash+import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef-import Agda.Utils.Lens+import Agda.Utils.Null+import qualified Agda.Utils.ProfileOptions as Profile -import Agda.Utils.Except+import Agda.Utils.Impossible  -- Note that the Binary instance for Int writes 64 bits, but throws -- away the 32 high bits when reading (at the time of writing, on -- 32-bit machines). Word64 does not have these problems.  currentInterfaceVersion :: Word64-currentInterfaceVersion = 20161119 * 10 + 0+currentInterfaceVersion = 20250703 * 10 + 0 +-- | The result of 'encode' and 'encodeInterface'.++data Encoded = Encoded+  { uncompressed :: ByteString+    -- ^ The uncompressed bytestring, without hashes and the interface+    -- version.+  , compressed :: ByteString+    -- ^ The compressed bytestring.+  }+ -- | Encodes something. To ensure relocatability file paths in -- positions are replaced with module names. -encode :: EmbPrj a => a -> TCM L.ByteString+encode :: EmbPrj a => a -> TCM Encoded encode a = do-    collectStats <- hasVerbosity "profile.serialize" 20-    fileMod <- sourceToModule-    newD@(Dict nD sD bD iD dD _tD+    collectStats <- hasProfileOption Profile.Serialize+    newD@(Dict nD ltD stD bD iD dD       _nameD       _qnameD-      nC sC bC iC dC tC+      nC ltC stC bC iC dC tC       nameC       qnameC-      stats _ _) <- liftIO $ emptyDict collectStats-    root <- liftIO $ (`runReaderT` newD) $ do-       icodeFileMod fileMod-       icode a-    nL <- benchSort $ l nD-    sL <- benchSort $ l sD-    bL <- benchSort $ l bD-    iL <- benchSort $ l iD-    dL <- benchSort $ l dD+      stats _) <- liftIO $ emptyDict collectStats+    root <- liftIO $ (`runReaderT` newD) $ icode a+    nL  <- benchSort $ l nD+    stL <- benchSort $ l stD+    ltL <- benchSort $ l ltD+    bL  <- benchSort $ l bD+    iL  <- benchSort $ l iD+    dL  <- benchSort $ l dD     -- Record reuse statistics.-    verboseS "profile.sharing" 10 $ do+    whenProfile Profile.Sharing $ do       statistics "pointers" tC-    verboseS "profile.serialize" 10 $ do-      statistics "Integer"  iC-      statistics "String"   sC-      statistics "ByteString" bC-      statistics "Double"   dC-      statistics "Node"     nC+    whenProfile Profile.Serialize $ do+      statistics "Integer"     iC+      statistics "Lazy Text"   ltC+      statistics "Strict Text" stC+      statistics "Text"        bC+      statistics "Double"      dC+      statistics "Node"        nC       statistics "Shared Term" tC-      statistics "A.QName"  qnameC-      statistics "A.Name"  nameC+      statistics "A.QName"     qnameC+      statistics "A.Name"      nameC     when collectStats $ do-      stats <- Map.fromList . map (second toInteger) <$> do-        liftIO $ H.toList stats-      modifyStatistics $ Map.union stats+      stats <- Map.fromListWith __IMPOSSIBLE__ . map (second toInteger) <$> do+        liftIO $ List.sort <$> H.toList stats+      modifyStatistics $ Map.unionWith (+) stats     -- Encode hashmaps and root, and compress.     bits1 <- Bench.billTo [ Bench.Serialization, Bench.BinaryEncode ] $-      return $!! B.encode (root, nL, sL, bL, iL, dL)+      return $!! B.encode (root, nL, ltL, stL, bL, iL, dL)     let compressParams = G.defaultCompressParams           { G.compressLevel    = G.bestSpeed           , G.compressStrategy = G.huffmanOnlyStrategy           }     cbits <- Bench.billTo [ Bench.Serialization, Bench.Compress ] $       return $!! G.compressWith compressParams bits1-    let x = B.encode currentInterfaceVersion `L.append` cbits-    return x+    let x = B.encode currentInterfaceVersion <> cbits+    return (Encoded { uncompressed = bits1, compressed = x })   where     l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h     benchSort = Bench.billTo [Bench.Serialization, Bench.Sort] . liftIO     statistics :: String -> IORef FreshAndReuse -> TCM ()     statistics kind ioref = do-      FreshAndReuse fresh reused <- liftIO $ readIORef ioref+      FreshAndReuse fresh+#ifdef DEBUG_SERIALISATION+                          reused+#endif+                                 <- liftIO $ readIORef ioref       tickN (kind ++ "  (fresh)") $ fromIntegral fresh+#ifdef DEBUG_SERIALISATION       tickN (kind ++ " (reused)") $ fromIntegral reused+#endif --- encode :: EmbPrj a => a -> TCM L.ByteString+-- encode :: EmbPrj a => a -> TCM ByteString -- encode a = do --     fileMod <- sourceToModule --     (x, shared, total) <- liftIO $ do@@ -129,94 +161,137 @@ --       root <- runReaderT (icode a) newD --       nL <- l nD; sL <- l sD; iL <- l iD; dL <- l dD --       (shared, total) <- readIORef stats---       return (B.encode currentInterfaceVersion `L.append`+--       return (B.encode currentInterfaceVersion <> --               G.compress (B.encode (root, nL, sL, iL, dL)), shared, total)---     verboseS "profile.sharing" 10 $ do+--     whenProfile Profile.Sharing $ do --       tickN "pointers (reused)" $ fromIntegral shared --       tickN "pointers" $ fromIntegral total --     return x --   where --   l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h --- | Decodes something. The result depends on the include path.------ Returns 'Nothing' if the input does not start with the right magic--- number or some other decoding error is encountered.+newtype ListLike a = ListLike { unListLike :: Array Word32 a } -decode :: EmbPrj a => L.ByteString -> TCM (Maybe a)-decode s = do-  mf   <- use stModuleToSource-  incs <- getIncludeDirs+instance B.Binary a => B.Binary (ListLike a) where+  put = __IMPOSSIBLE__ -- Will never serialise this+  get = fmap ListLike $ runSTArray $ do+    n <- lift (B.get :: B.Get Int)+    -- Andreas, 2024-10-15: If n is zero, create an empty array.+    -- Since our indices are Word32, we need to represent it as [1..0] instead of the usual [0..-1].+    if n <= 0 then (newArray_ (1,0) :: STT s B.Get (STArray s Word32 a)) else do -  -- Note that B.runGetState and G.decompress can raise errors if the-  -- input is malformed. The decoder is (intended to be) strict enough-  -- to ensure that all such errors can be caught by the handler here.+    arr <- newArray_ (0, fromIntegral n - 1) :: STT s B.Get (STArray s Word32 a) -  shared <- sharedFun+    -- We'd like to use 'for_ [0..n-1]' here, but unfortunately GHC doesn't unfold+    -- the list construction and so performs worse than the hand-written version.+    let+      getMany i = if i == n then return () else do+        x <- lift B.get+        unsafeWriteSTArray arr i x+        getMany (i + 1)+    () <- getMany 0 -  (mf, r) <- liftIO $ E.handle (\(E.ErrorCall s) -> noResult s) $ do+    return arr -    (ver, s, _) <- return $ runGetState B.get s 0-    if ver /= currentInterfaceVersion-     then noResult "Wrong interface version."-     else do+-- | Decodes an uncompressed bytestring (without extra hashes or magic+-- numbers). The result depends on the include path.+--+-- Returns 'Nothing' if a decoding error is encountered. -      ((r, nL, sL, bL, iL, dL), s, _) <--        return $ runGetState B.get (G.decompress s) 0-      if s /= L.empty-         -- G.decompress seems to throw away garbage at the end, so-         -- the then branch is possibly dead code.-       then noResult "Garbage at end."-       else do+decode :: EmbPrj a => ByteString -> TCM (Maybe a)+decode s = do+  mf   <- useTC stModuleToSource+  incs <- getIncludeDirs -        st <- St (ar nL) (ar sL) (ar bL) (ar iL) (ar dL)-                <$> liftIO H.new-                <*> return mf <*> return incs-                <*> return shared-        (r, st) <- runStateT (runExceptT (value r)) st-        return (Just (modFile st), r)+  -- Note that runGetState can raise errors if the input is malformed.+  -- The decoder is (intended to be) strict enough to ensure that all+  -- such errors can be caught by the handler here. -  case mf of-    Nothing -> return ()-    Just mf -> stModuleToSource .= mf+  res <- liftIO $ E.handle (\(E.ErrorCall s) -> pure $ Left s) $ do+    ((r, nL, ltL, stL, bL, iL, dL), s, _) <- return $ runGetState B.get s 0+    let ar = unListLike+    when (not (null s)) $ E.throwIO $ E.ErrorCall "Garbage at end."+    let nL' = ar nL+    st <- St nL' (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL)+            <$> liftIO (newArray (bounds nL') MEEmpty)+            <*> return mf <*> return incs+    (r, st) <- runStateT (value r) st+    let !mf = modFile st+    return $ Right (mf, r) -  case r of-    Right x   -> return (Just x)-    Left  err -> do-      reportSLn "import.iface" 5 $ "Error when decoding interface file"-      -- Andreas, 2014-06-11 deactivated debug printing-      -- in order to get rid of dependency of Serialize on TCM.Pretty-      -- reportSDoc "import.iface" 5 $-      --   text "Error when decoding interface file:"-      --   $+$ nest 2 (prettyTCM err)-      return Nothing+  case res of+    Left s -> do+      reportSLn "import.iface" 5 $ "Error when decoding interface file: " ++ s+      pure Nothing -  where-  ar l = listArray (0, List.genericLength l - 1) l+    Right (mf, x) -> do+      setTCLens stModuleToSource mf+      -- "Compact" the interfaces (without breaking sharing) to+      -- reduce the amount of memory that is traversed by the+      -- garbage collector.+      Bench.billTo [Bench.Deserialization, Bench.Compaction] $+        liftIO (Just . C.getCompact <$> C.compactWithSharing x) -  noResult s = return (Nothing, Left $ GenericError s) -encodeInterface :: Interface -> TCM L.ByteString-encodeInterface i = L.append hashes <$> encode i+encodeInterface :: Interface -> TCM Encoded+encodeInterface i = do+  r <- encode i+  return r{ compressed = hashes <> compressed r }   where-    hashes :: L.ByteString+    hashes :: ByteString     hashes = B.runPut $ B.put (iSourceHash i) >> B.put (iFullHash i) --- | Encodes something. To ensure relocatability file paths in+-- | Encodes an interface. To ensure relocatability file paths in -- positions are replaced with module names.+--+-- An uncompressed bytestring corresponding to the encoded interface+-- is returned. -encodeFile :: FilePath -> Interface -> TCM ()-encodeFile f i = liftIO . L.writeFile f =<< encodeInterface i+encodeFile :: FilePath -> Interface -> TCM ByteString+encodeFile f i = do+  r <- encodeInterface i+  liftIO $ createDirectoryIfMissing True (takeDirectory f)+  liftIO $ L.writeFile f (compressed r)+  return (uncompressed r) --- | Decodes something. The result depends on the include path.+-- | Decodes an interface. The result depends on the include path. -- -- Returns 'Nothing' if the file does not start with the right magic -- number or some other decoding error is encountered. -decodeInterface :: L.ByteString -> TCM (Maybe Interface)-decodeInterface s = decode $ L.drop 16 s+decodeInterface :: ByteString -> TCM (Maybe Interface)+decodeInterface s = do -decodeHashes :: L.ByteString -> Maybe (Hash, Hash)+  -- Note that runGetState and the decompression code below can raise+  -- errors if the input is malformed. The decoder is (intended to be)+  -- strict enough to ensure that all such errors can be caught by the+  -- handler here or the one in decode.++  s <- liftIO $+       E.handle (\(E.ErrorCall s) -> return (Left s)) $+       E.evaluate $+       let (ver, s', _) = runGetState B.get (L.drop 16 s) 0 in+       if ver /= currentInterfaceVersion+       then Left "Wrong interface version."+       else Right $+            toLazyByteString $+            Z.foldDecompressStreamWithInput+              (\s -> (byteString s <>))+              (\s -> if null s+                     then mempty+                     else error "Garbage at end.")+              (\err -> error (show err))+              (Z.decompressST Z.gzipFormat Z.defaultDecompressParams)+              s'++  case s of+    Right s  -> decode s+    Left err -> do+      reportSLn "import.iface" 5 $+        "Error when decoding interface file: " ++ err+      return Nothing++decodeHashes :: ByteString -> Maybe (Hash, Hash) decodeHashes s   | L.length s < 16 = Nothing   | otherwise       = Just $ B.runGet getH $ L.take 16 s@@ -224,17 +299,3 @@  decodeFile :: FilePath -> TCM (Maybe Interface) decodeFile f = decodeInterface =<< liftIO (L.readFile f)---- | Store a 'SourceToModule' (map from 'AbsolutePath' to 'TopLevelModuleName')---   as map from 'AbsolutePath' to 'Int32', in order to directly get the identifiers---   from absolute pathes rather than going through top level module names.-icodeFileMod-  :: SourceToModule-     -- ^ Maps file names to the corresponding module names.-     --   Must contain a mapping for every file name that is later encountered.-  -> S ()-icodeFileMod fileMod = do-  hmap <- asks absPathD-  forM_ (Map.toList fileMod) $ \ (absolutePath, topLevelModuleName) -> do-    i <- icod_ topLevelModuleName-    liftIO $ H.insert hmap absolutePath i
src/full/Agda/TypeChecking/Serialise/Base.hs view
@@ -1,66 +1,167 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE UnboxedTuples        #-}+{-# LANGUAGE UndecidableInstances #-} -- Due to ICODE vararg typeclass +{-+András, 2023-10-2:++All code in Agda/TypeChecking/Serialise should be strict, since serialization necessarily+forces all data, eventually.+  - (<$!>) should be used instead of lazy fmap.+  - Any redex that's passed to `return`, a lazy constructor, or a function, should+    be forced beforehand with strict `let`, strict binding or ($!).+-}+ module Agda.TypeChecking.Serialise.Base where -import Control.Applicative-import Control.Monad+import qualified Control.Exception as E+import Control.Monad ((<$!>))+import Control.Monad.Except+import Control.Monad.IO.Class     ( MonadIO(..) ) import Control.Monad.Reader import Control.Monad.State.Strict (StateT, gets) +import Data.Proxy+ import Data.Array.IArray+import Data.Array.IO+import qualified Data.HashMap.Strict as Hm import qualified Data.ByteString.Lazy as L import Data.Hashable-import qualified Data.HashTable.IO as H-import Data.Int (Int32)+import Data.Word (Word32) import Data.Maybe import qualified Data.Binary as B import qualified Data.Binary.Get as B-import Data.Typeable ( cast, Typeable, typeOf, TypeRep )+import qualified Data.Text      as T+import qualified Data.Text.Lazy as TL+import Data.Typeable ( cast, Typeable, TypeRep, typeRep, typeRepFingerprint )+import GHC.Exts (Word(..), timesWord2#, xor#, Any)+import GHC.Fingerprint.Type+import Unsafe.Coerce  import Agda.Syntax.Common (NameId) import Agda.Syntax.Internal (Term, QName(..), ModuleName(..), nameId)-import Agda.TypeChecking.Monad.Base (TypeError(GenericError), ModuleToSource)+import Agda.TypeChecking.Monad.Base.Types (ModuleToSource)  import Agda.Utils.FileName+import Agda.Utils.HashTable (HashTable)+import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef import Agda.Utils.Lens+import Agda.Utils.List1 (List1) import Agda.Utils.Monad-import Agda.Utils.Pointer-import Agda.Utils.Except (ExceptT, throwError)+import Agda.Utils.TypeLevel +#include <MachDeps.h>+ -- | Constructor tag (maybe omitted) and argument indices.+data Node = Empty | Cons !Word32 !Node deriving Eq -type Node = [Int32]+instance Hashable Node where+  -- Adapted from https://github.com/tkaitchuck/aHash/wiki/AHash-fallback-algorithm+  hashWithSalt h n = fromIntegral (go (fromIntegral h) n) where+    xor (W# x) (W# y) = W# (xor# x y) --- | The type of hashtables used in this module.------ A very limited amount of testing indicates that 'H.CuckooHashTable'--- is somewhat slower than 'H.BasicHashTable', and that--- 'H.LinearHashTable' and the hashtables from "Data.Hashtable" are--- much slower.+    foldedMul :: Word -> Word -> Word+    foldedMul (W# x) (W# y) = case timesWord2# x y of (# hi, lo #) -> W# (xor# hi lo) -#if defined(mingw32_HOST_OS) && defined(x86_64_HOST_ARCH)-type HashTable k v = H.CuckooHashTable k v+    combine :: Word -> Word -> Word+    combine x y = foldedMul (xor x y) factor where+      -- We use a version of fibonacci hashing, where our multiplier is the+      -- nearest prime to 2^64/phi or 2^32/phi. See https://stackoverflow.com/q/4113278.+#if WORD_SIZE_IN_BITS == 64+      factor = 11400714819323198549 #else-type HashTable k v = H.BasicHashTable k v+      factor = 2654435741 #endif +    go :: Word -> Node -> Word+    go !h Empty       = h+    go  h (Cons n ns) = go (combine h (fromIntegral n)) ns++  hash = hashWithSalt seed where+#if WORD_SIZE_IN_BITS == 64+      seed = 3032525626373534813+#else+      seed = 1103515245+#endif++instance B.Binary Node where++  get = go =<< B.get where++    go :: Int -> B.Get Node+    go n | n <= 0 =+      pure Empty+    go n = do+      !x    <- B.get+      !node <- go (n - 1)+      pure $ Cons x node++  put n = B.put (len n) <> go n where++    len :: Node -> Int+    len = go 0 where+      go !acc Empty     = acc+      go acc (Cons _ n) = go (acc + 1) n++    go :: Node -> B.Put+    go Empty       = mempty+    go (Cons n ns) = B.put n <> go ns++-- | Association lists mapping TypeRep fingerprints to values. In some cases+--   values with different types have the same serialized representation. This+--   structure disambiguates them.+data MemoEntry = MEEmpty | MECons {-# unpack #-} !Fingerprint !Any !MemoEntry++-- 2023-10-2 András: `typeRepFingerprint` usually inlines a 4-way case, which+-- yields significant code size increase as GHC often inlines the same code into+-- the branches. This wouldn't matter in "normal" code but the serialization+-- instances use very heavy inlining. The NOINLINE cuts down on the code size.+fingerprintNoinline :: TypeRep -> Fingerprint+fingerprintNoinline rep = typeRepFingerprint rep+{-# NOINLINE fingerprintNoinline #-}++lookupME :: forall a b. Proxy a -> Fingerprint -> MemoEntry -> (a -> b) -> b -> b+lookupME proxy fprint me found notfound = go fprint me where+  go :: Fingerprint -> MemoEntry -> b+  go fp MEEmpty =+    notfound+  go fp (MECons fp' x me)+    | fp == fp' = found (unsafeCoerce x)+    | True      = go fp me+{-# NOINLINE lookupME #-}+ -- | Structure providing fresh identifiers for hash map --   and counting hash map hits (i.e. when no fresh identifier required).+#ifdef DEBUG_SERIALISATION data FreshAndReuse = FreshAndReuse-  { farFresh :: !Int32 -- ^ Number of hash map misses.-  , farReuse :: !Int32 -- ^ Number of hash map hits.+  { farFresh :: !Word32 -- ^ Number of hash map misses.+  , farReuse :: !Word32 -- ^ Number of hash map hits.   }+#else+newtype FreshAndReuse = FreshAndReuse+  { farFresh :: Word32 -- ^ Number of hash map misses.+  }+#endif  farEmpty :: FreshAndReuse-farEmpty = FreshAndReuse 0 0+farEmpty = FreshAndReuse 0+#ifdef DEBUG_SERIALISATION+                           0+#endif -lensFresh :: Lens' Int32 FreshAndReuse+lensFresh :: Lens' FreshAndReuse Word32 lensFresh f r = f (farFresh r) <&> \ i -> r { farFresh = i }+{-# INLINE lensFresh #-} -lensReuse :: Lens' Int32 FreshAndReuse+#ifdef DEBUG_SERIALISATION+lensReuse :: Lens' FreshAndReuse Word32 lensReuse f r = f (farReuse r) <&> \ i -> r { farReuse = i }+{-# INLINE lensReuse #-}+#endif  -- | Two 'QName's are equal if their @QNameId@ is equal. type QNameId = [NameId]@@ -72,32 +173,32 @@ -- | State of the the encoder. data Dict = Dict   -- Dictionaries which are serialized:-  { nodeD        :: !(HashTable Node    Int32)    -- ^ Written to interface file.-  , stringD      :: !(HashTable String  Int32)    -- ^ Written to interface file.-  , bstringD     :: !(HashTable L.ByteString Int32) -- ^ Written to interface file.-  , integerD     :: !(HashTable Integer Int32)    -- ^ Written to interface file.-  , doubleD      :: !(HashTable Double  Int32)    -- ^ Written to interface file.+  { nodeD        :: !(HashTable Node    Word32)    -- ^ Written to interface file.+  , stringD      :: !(HashTable String  Word32)    -- ^ Written to interface file.+  , lTextD       :: !(HashTable TL.Text Word32)    -- ^ Written to interface file.+  , sTextD       :: !(HashTable T.Text  Word32)    -- ^ Written to interface file.+  , integerD     :: !(HashTable Integer Word32)    -- ^ Written to interface file.+  , doubleD      :: !(HashTable Double  Word32)    -- ^ Written to interface file.   -- Dicitionaries which are not serialized, but provide   -- short cuts to speed up serialization:-  , termD        :: !(HashTable (Ptr Term) Int32) -- ^ Not written to interface file.   -- Andreas, Makoto, AIM XXI   -- Memoizing A.Name does not buy us much if we already memoize A.QName.-  , nameD        :: !(HashTable NameId  Int32)    -- ^ Not written to interface file.-  , qnameD       :: !(HashTable QNameId Int32)    -- ^ Not written to interface file.+  , nameD        :: !(HashTable NameId  Word32)    -- ^ Not written to interface file.+  , qnameD       :: !(HashTable QNameId Word32)    -- ^ Not written to interface file.   -- Fresh UIDs and reuse statistics:   , nodeC        :: !(IORef FreshAndReuse)  -- counters for fresh indexes   , stringC      :: !(IORef FreshAndReuse)-  , bstringC     :: !(IORef FreshAndReuse)+  , lTextC       :: !(IORef FreshAndReuse)+  , sTextC       :: !(IORef FreshAndReuse)   , integerC     :: !(IORef FreshAndReuse)   , doubleC      :: !(IORef FreshAndReuse)   , termC        :: !(IORef FreshAndReuse)   , nameC        :: !(IORef FreshAndReuse)   , qnameC       :: !(IORef FreshAndReuse)   , stats        :: !(HashTable String Int)-  , collectStats :: Bool+  , collectStats :: !Bool     -- ^ If @True@ collect in @stats@ the quantities of     --   calls to @icode@ for each @Typeable a@.-  , absPathD     :: !(HashTable AbsolutePath Int32) -- ^ Not written to interface file.   }  -- | Creates an empty dictionary.@@ -106,14 +207,14 @@      -- ^ Collect statistics for @icode@ calls?   -> IO Dict emptyDict collectStats = Dict-  <$> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new+  <$> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty@@ -122,31 +223,28 @@   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty-  <*> H.new+  <*> newIORef farEmpty+  <*> H.empty   <*> pure collectStats-  <*> H.new --- | Universal type, wraps everything.-data U = forall a . Typeable a => U !a- -- | Univeral memo structure, to introduce sharing during decoding-type Memo = HashTable (Int32, TypeRep) U    -- (node index, type rep)+type Memo = IOArray Word32 MemoEntry  -- | State of the decoder. data St = St-  { nodeE     :: !(Array Int32 Node)     -- ^ Obtained from interface file.-  , stringE   :: !(Array Int32 String)   -- ^ Obtained from interface file.-  , bstringE  :: !(Array Int32 L.ByteString) -- ^ Obtained from interface file.-  , integerE  :: !(Array Int32 Integer)  -- ^ Obtained from interface file.-  , doubleE   :: !(Array Int32 Double)   -- ^ Obtained from interface file.+  { nodeE     :: !(Array Word32 [Word32])  -- ^ Obtained from interface file.+  , stringE   :: !(Array Word32 String)   -- ^ Obtained from interface file.+  , lTextE    :: !(Array Word32 TL.Text)  -- ^ Obtained from interface file.+  , sTextE    :: !(Array Word32 T.Text)   -- ^ Obtained from interface file.+  , integerE  :: !(Array Word32 Integer)  -- ^ Obtained from interface file.+  , doubleE   :: !(Array Word32 Double)   -- ^ Obtained from interface file.   , nodeMemo  :: !Memo     -- ^ Created and modified by decoder.     --   Used to introduce sharing while deserializing objects.   , modFile   :: !ModuleToSource     -- ^ Maps module names to file names. Constructed by the decoder.-  , includes  :: [AbsolutePath]+  , includes  :: !(List1 AbsolutePath)     -- ^ The include directories.-  , mkShared  :: Term -> Term   }  -- | Monad used by the encoder.@@ -158,31 +256,52 @@ -- 'TCM' is not used because the associated overheads would make -- decoding slower. -type R a = ExceptT TypeError (StateT St IO) a+type R = StateT St IO  -- | Throws an error which is suitable when the data stream is -- malformed.  malformed :: R a-malformed = throwError $ GenericError "Malformed input."+malformed = liftIO $ E.throwIO $ E.ErrorCall "Malformed input."+{-# NOINLINE malformed #-} -- 2023-10-2 András: cold code, so should be out-of-line.  class Typeable a => EmbPrj a where-  icode :: a -> S Int32  -- ^ Serialization (wrapper).-  icod_ :: a -> S Int32  -- ^ Serialization (worker).-  value :: Int32 -> R a  -- ^ Deserialization.+  icode :: a -> S Word32  -- ^ Serialization (wrapper).+  icod_ :: a -> S Word32  -- ^ Serialization (worker).+  value :: Word32 -> R a  -- ^ Deserialization.    icode a = do+    !r <- icod_ a     tickICode a-    icod_ a+    pure r+  {-# INLINE icode #-} +  -- Simple enumeration types can be (de)serialized using (from/to)Enum.+  default value :: (Enum a, Bounded a) => Word32 -> R a+  value i =+    let i' = fromIntegral i in+    if i' >= fromEnum (minBound :: a) && i' <= fromEnum (maxBound :: a)+    then pure $! toEnum i'+    else malformed++  default icod_ :: (Enum a, Bounded a) => a -> S Word32+  icod_ x = return $! fromIntegral $! fromEnum x++-- | The actual logic of `tickICode` is cold code, so it's out-of-line,+--   to decrease code size and avoid cache pollution.+goTickIcode :: forall a. Typeable a => Proxy a -> S ()+goTickIcode p = do+  let key = "icode " ++ show (typeRep p)+  hmap <- asks stats+  liftIO $ do+    n <- fromMaybe 0 <$> H.lookup hmap key+    H.insert hmap key $! n + 1+{-# NOINLINE goTickIcode #-}+ -- | Increase entry for @a@ in 'stats'. tickICode :: forall a. Typeable a => a -> S ()-tickICode _ = whenM (asks collectStats) $ do-    let key = "icode " ++ show (typeOf (undefined :: a))-    hmap <- asks stats-    liftIO $ do-      n <- fromMaybe 0 <$> H.lookup hmap key-      H.insert hmap key $! n + 1+tickICode _ = whenM (asks collectStats) $ goTickIcode (Proxy :: Proxy a)+{-# INLINE tickICode #-}  -- | Data.Binary.runGetState is deprecated in favour of runGetIncremental. --   Reimplementing it in terms of the new function. The new Decoder type contains@@ -204,9 +323,9 @@ --       } -- -- type ICodeX k---   =  (Dict -> HashTable k Int32)---   -> (Dict -> IORef Int32)---   -> k -> S Int32+--   =  (Dict -> HashTable k Word32)+--   -> (Dict -> IORef Word32)+--   -> k -> S Word32 -- {-# SPECIALIZE icodeX :: ICodeX String  #-} -- {-# SPECIALIZE icodeX :: ICodeX Integer #-} -- {-# SPECIALIZE icodeX :: ICodeX Double  #-}@@ -218,9 +337,9 @@ -- instruction cache misses. -- {-# INLINE icodeX #-} icodeX :: (Eq k, Hashable k)-  =>  (Dict -> HashTable k Int32)+  =>  (Dict -> HashTable k Word32)   -> (Dict -> IORef FreshAndReuse)-  -> k -> S Int32+  -> k -> S Word32 icodeX dict counter key = do   d <- asks dict   c <- asks counter@@ -228,10 +347,12 @@     mi <- H.lookup d key     case mi of       Just i  -> do-        modifyIORef' c $ over lensReuse (+1)-        return i+#ifdef DEBUG_SERIALISATION+        modifyIORef' c $ over lensReuse (+ 1)+#endif+        return $! i       Nothing -> do-        fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)+        !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)         H.insert d key fresh         return fresh @@ -239,7 +360,7 @@ -- its four uses: Integer, String, Double, Node. -- Not a great gain (hardly noticeable), but not harmful. -icodeInteger :: Integer -> S Int32+icodeInteger :: Integer -> S Word32 icodeInteger key = do   d <- asks integerD   c <- asks integerC@@ -247,14 +368,16 @@     mi <- H.lookup d key     case mi of       Just i  -> do-        modifyIORef' c $ over lensReuse (+1)-        return i+#ifdef DEBUG_SERIALISATION+        modifyIORef' c $ over lensReuse (+ 1)+#endif+        return $! i       Nothing -> do-        fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)+        !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)         H.insert d key fresh         return fresh -icodeDouble :: Double -> S Int32+icodeDouble :: Double -> S Word32 icodeDouble key = do   d <- asks doubleD   c <- asks doubleC@@ -262,14 +385,16 @@     mi <- H.lookup d key     case mi of       Just i  -> do-        modifyIORef' c $ over lensReuse (+1)-        return i+#ifdef DEBUG_SERIALISATION+        modifyIORef' c $ over lensReuse (+ 1)+#endif+        return $! i       Nothing -> do-        fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)+        !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)         H.insert d key fresh         return fresh -icodeString :: String -> S Int32+icodeString :: String -> S Word32 icodeString key = do   d <- asks stringD   c <- asks stringC@@ -277,385 +402,171 @@     mi <- H.lookup d key     case mi of       Just i  -> do-        modifyIORef' c $ over lensReuse (+1)+#ifdef DEBUG_SERIALISATION+        modifyIORef' c $ over lensReuse (+ 1)+#endif         return i       Nothing -> do-        fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)+        !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)         H.insert d key fresh         return fresh -icodeN :: Node -> S Int32-icodeN key = do+icodeNode :: Node -> S Word32+icodeNode key = do   d <- asks nodeD   c <- asks nodeC   liftIO $ do     mi <- H.lookup d key     case mi of       Just i  -> do-        modifyIORef' c $ over lensReuse (+1)-        return i+#ifdef DEBUG_SERIALISATION+        modifyIORef' c $ over lensReuse (+ 1)+#endif+        return $! i       Nothing -> do-        fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)+        !fresh <- (^. lensFresh) <$> do readModifyIORef' c $ over lensFresh (+ 1)         H.insert d key fresh         return fresh --- icodeN :: [Int32] -> S Int32+-- icodeN :: [Word32] -> S Word32 -- icodeN = icodeX nodeD nodeC  -- | @icode@ only if thing has not seen before. icodeMemo   :: (Ord a, Hashable a)-  => (Dict -> HashTable a Int32)    -- ^ Memo structure for thing of key @a@.+  => (Dict -> HashTable a Word32)    -- ^ Memo structure for thing of key @a@.   -> (Dict -> IORef FreshAndReuse)  -- ^ Statistics.   -> a        -- ^ Key to the thing.-  -> S Int32  -- ^ Fallback computation to encode the thing.-  -> S Int32  -- ^ Encoded thing.+  -> S Word32  -- ^ Fallback computation to encode the thing.+  -> S Word32  -- ^ Encoded thing. icodeMemo getDict getCounter a icodeP = do     h  <- asks getDict     mi <- liftIO $ H.lookup h a     st <- asks getCounter     case mi of       Just i  -> liftIO $ do+#ifdef DEBUG_SERIALISATION         modifyIORef' st $ over lensReuse (+ 1)-        return i+#endif+        return $! i       Nothing -> do-        liftIO $ modifyIORef' st $ over lensFresh (+1)-        i <- icodeP+        liftIO $ modifyIORef' st $ over lensFresh (+ 1)+        !i <- icodeP         liftIO $ H.insert h a i         return i  {-# INLINE vcase #-}--- | @vcase value ix@ decodes thing represented by @ix :: Int32@+-- | @vcase value ix@ decodes thing represented by @ix :: Word32@ --   via the @valu@ function and stores it in 'nodeMemo'. --   If @ix@ is present in 'nodeMemo', @valu@ is not used, but --   the thing is read from 'nodeMemo' instead.-vcase :: forall a . EmbPrj a => (Node -> R a) -> Int32 -> R a+vcase :: forall a . EmbPrj a => ([Word32] -> R a) -> Word32 -> R a vcase valu = \ix -> do     memo <- gets nodeMemo-    -- compute run-time representation of type a-    let aTyp = typeOf (undefined :: a)+    let fp = fingerprintNoinline (typeRep (Proxy :: Proxy a))     -- to introduce sharing, see if we have seen a thing     -- represented by ix before-    maybeU <- liftIO $ H.lookup memo (ix, aTyp)-    case maybeU of-      -- yes, we have seen it before, use the version from memo-      Just (U u) -> maybe malformed return (cast u)-      -- no, it's new, so generate it via valu and insert it into memo-      Nothing    -> do-          v <- valu . (! ix) =<< gets nodeE-          liftIO $ H.insert memo (ix, aTyp) (U v)-          return v---- Andreas, Makoto, AIM XX (2014-10-15):--- No performance gain for INLINE here (neutral / slighly negative).------ {-# INLINE icode0 #-}--- {-# INLINE icode1 #-}--- {-# INLINE icode2 #-}--- {-# INLINE icode3 #-}--- {-# INLINE icode4 #-}--- {-# INLINE icode5 #-}--- {-# INLINE icode6 #-}--- {-# INLINE icode7 #-}--- {-# INLINE icode8 #-}--- {-# INLINE icode9 #-}--- {-# INLINE icode10 #-}--- {-# INLINE icode11 #-}--- {-# INLINE icode12 #-}--- {-# INLINE icode13 #-}--- {-# INLINE icode14 #-}--icode0 :: Int32 -> S Int32--icode1 :: EmbPrj a => Int32 -> a -> S Int32--icode2 :: (EmbPrj a, EmbPrj b) =>-          Int32 -> a -> b ->-          S Int32--icode3 :: (EmbPrj a, EmbPrj b, EmbPrj c) =>-          Int32 -> a -> b -> c ->-          S Int32+    slot <- liftIO $ readArray memo ix+    lookupME (Proxy :: Proxy a) fp slot+      -- use the stored value+      pure+      -- read new value and save it+      do !v <- valu . (! ix) =<< gets nodeE+         liftIO $ writeArray memo ix $! MECons fp (unsafeCoerce v) slot+         return v -icode4 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>-          Int32 -> a -> b -> c -> d ->-          S Int32+-- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@+--   and returns the corresponding list of @Word32@. -icode5 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>-          Int32 -> a -> b -> c -> d -> e ->-          S Int32+class ICODE t b where+  icodeArgs :: IsBase t ~ b => All EmbPrj (Domains t) =>+               Proxy t -> StrictProducts (Domains t) -> S Node -icode6 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>-          Int32 -> a -> b -> c -> d -> e -> f ->-          S Int32+instance IsBase t ~ 'True => ICODE t 'True where+  icodeArgs _ _  = return Empty+  {-# INLINE icodeArgs #-} -icode7 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g ) =>-          Int32 -> a -> b -> c -> d -> e -> f -> g ->-          S Int32+instance ICODE t (IsBase t) => ICODE (a -> t) 'False where+  icodeArgs _ (Pair a as) = do+    !hd   <- icode a+    !node <- icodeArgs (Proxy :: Proxy t) as+    pure $ Cons hd node+  {-# INLINE icodeArgs #-} -icode8 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h ) =>-          Int32 -> a -> b -> c -> d -> e -> f -> g -> h ->-          S Int32+-- | @icodeN tag t a1 ... an@ serialises the arguments @a1@, ..., @an@ of the+--   constructor @t@ together with a tag @tag@ picked to disambiguate between+--   different constructors.+--   It corresponds to @icodeNode . (tag :) =<< mapM icode [a1, ..., an]@ -icode9 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i ) =>-          Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i ->-          S Int32+{-# INLINE icodeN #-}+icodeN :: forall t. ICODE t (IsBase t) => StrictCurrying (Domains t) (S Word32) =>+          All EmbPrj (Domains t) =>+          Word32 -> t -> Arrows (Domains t) (S Word32)+icodeN tag _ =+  strictCurrys (Proxy :: Proxy (Domains t)) (Proxy :: Proxy (S Word32)) $ \ !args -> do+    !node <- icodeArgs (Proxy :: Proxy t) args+    icodeNode $ Cons tag node -icode10 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j ->-           S Int32+-- | @icodeN'@ is the same as @icodeN@ except that there is no tag+{-# INLINE icodeN' #-}+icodeN' :: forall t. ICODE t (IsBase t) => StrictCurrying (Domains t) (S Word32) =>+           All EmbPrj (Domains t) =>+           t -> Arrows (Domains t) (S Word32)+icodeN' _ =+  strictCurrys (Proxy :: Proxy (Domains t)) (Proxy :: Proxy (S Word32)) $ \ !args -> do+    !node <- icodeArgs (Proxy :: Proxy t) args+    icodeNode node -icode11 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k ->-           S Int32+-- Instead of having up to 25 versions of @valu N@, we define+-- the class VALU which generates them by typeclass resolution.+-- All of these should get inlined at compile time. -icode12 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l ->-           S Int32+class VALU t b where -icode13 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-           , EmbPrj m ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m ->-           S Int32+  valuN' :: b ~ IsBase t =>+            All EmbPrj (Domains t) =>+            t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t) -icode14 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-           , EmbPrj m, EmbPrj n ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n ->-           S Int32+  valueArgs :: b ~ IsBase t =>+               All EmbPrj (CoDomain t ': Domains t) =>+               Proxy t -> [Word32] -> Maybe (StrictProducts (Constant Word32 (Domains t))) -icode15 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-           , EmbPrj m, EmbPrj n, EmbPrj o ) =>-           Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o ->-           S Int32+instance VALU t 'True where+  {-# INLINE valuN' #-}+  valuN' c () = return c -icode0 tag = icodeN [tag]-icode1 tag a = icodeN . (tag :) =<< sequence [icode a]-icode2 tag a b = icodeN . (tag :) =<< sequence [icode a, icode b]-icode3 tag a b c = icodeN . (tag :) =<< sequence [icode a, icode b, icode c]-icode4 tag a b c d = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d]-icode5 tag a b c d e = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e]-icode6 tag a b c d e f = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f]-icode7 tag a b c d e f g = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g]-icode8 tag a b c d e f g h = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h]-icode9 tag a b c d e f g h i = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i]-icode10 tag a b c d e f g h i j = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j]-icode11 tag a b c d e f g h i j k = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k]-icode12 tag a b c d e f g h i j k l = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l]-icode13 tag a b c d e f g h i j k l m = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m]-icode14 tag a b c d e f g h i j k l m n = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m, icode n]-icode15 tag a b c d e f g h i j k l m n o = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m, icode n, icode o]+  {-# INLINE valueArgs #-}+  valueArgs _ xs = case xs of+    [] -> Just ()+    _  -> Nothing  --- Andreas, Makoto, AIM XX (2014-10-15):--- No performance gain for INLINE here (neutral / slighly negative).------ {-# INLINE icode0' #-}--- {-# INLINE icode1' #-}--- {-# INLINE icode2' #-}--- {-# INLINE icode3' #-}--- {-# INLINE icode4' #-}--- {-# INLINE icode5' #-}--- {-# INLINE icode6' #-}--- {-# INLINE icode7' #-}--- {-# INLINE icode8' #-}--- {-# INLINE icode9' #-}--- {-# INLINE icode10' #-}--- {-# INLINE icode11' #-}--- {-# INLINE icode12' #-}--- {-# INLINE icode13' #-}--- {-# INLINE icode14' #-}--icode0' :: S Int32--icode1' :: EmbPrj a => a -> S Int32--icode2' :: (EmbPrj a, EmbPrj b) =>-           a -> b ->-           S Int32--icode3' :: (EmbPrj a, EmbPrj b, EmbPrj c) =>-           a -> b -> c ->-           S Int32--icode4' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>-           a -> b -> c -> d ->-           S Int32--icode5' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>-           a -> b -> c -> d -> e ->-           S Int32--icode6' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>-           a -> b -> c -> d -> e -> f ->-           S Int32--icode7' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g ) =>-           a -> b -> c -> d -> e -> f -> g ->-           S Int32--icode8' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h ) =>-           a -> b -> c -> d -> e -> f -> g -> h ->-           S Int32--icode9' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-           , EmbPrj g, EmbPrj h, EmbPrj i ) =>-           a -> b -> c -> d -> e -> f -> g -> h -> i ->-           S Int32--icode10' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-            , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>-            a -> b -> c -> d -> e -> f -> g -> h -> i -> j ->-            S Int32--icode11' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-            , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>-            a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k ->-            S Int32--icode12' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-            , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>-            a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l ->-            S Int32--icode13' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-            , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-            , EmbPrj m ) =>-            a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m ->-            S Int32--icode14' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-            , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-            , EmbPrj m, EmbPrj n ) =>-            a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n ->-            S Int32--icode0' = icodeN []-icode1' a = icodeN =<< sequence [icode a]-icode2' a b = icodeN =<< sequence [icode a, icode b]-icode3' a b c = icodeN =<< sequence [icode a, icode b, icode c]-icode4' a b c d = icodeN =<< sequence [icode a, icode b, icode c, icode d]-icode5' a b c d e = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e]-icode6' a b c d e f = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f]-icode7' a b c d e f g = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g]-icode8' a b c d e f g h = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h]-icode9' a b c d e f g h i = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i]-icode10' a b c d e f g h i j = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j]-icode11' a b c d e f g h i j k = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k]-icode12' a b c d e f g h i j k l = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l]-icode13' a b c d e f g h i j k l m = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m]-icode14' a b c d e f g h i j k l m n = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m, icode n]--valu0 :: a -> R a--valu1 :: EmbPrj a => (a -> b) -> Int32 -> R b--valu2 :: (EmbPrj a, EmbPrj b) =>-         (a -> b -> c) ->-         Int32 -> Int32 ->-         R c--valu3 :: (EmbPrj a, EmbPrj b, EmbPrj c) =>-         (a -> b -> c -> d) ->-         Int32 -> Int32 -> Int32 ->-         R d--valu4 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>-         (a -> b -> c -> d -> e) ->-         Int32 -> Int32 -> Int32 -> Int32 ->-         R e--valu5 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>-         (a -> b -> c -> d -> e -> f) ->-         Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R f--valu6 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>-         (a -> b -> c -> d -> e -> f -> g) ->-         Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R g--valu7 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-         , EmbPrj g ) =>-         (a -> b -> c -> d -> e -> f -> g -> h) ->-         Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R h--valu8 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-         , EmbPrj g, EmbPrj h ) =>-         (a -> b -> c -> d -> e -> f -> g -> h -> i) ->-         Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R i--valu9 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-         , EmbPrj g, EmbPrj h, EmbPrj i ) =>-         (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) ->-         Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R j--valu10 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-          R k--valu11 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-         R l--valu12 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-          R m--valu13 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-          , EmbPrj m ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-          R n--valu14 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-          , EmbPrj m, EmbPrj n ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-          R o+instance VALU t (IsBase t) => VALU (a -> t) 'False where+  {-# INLINE valuN' #-}+  valuN' c (Pair a as) = do+    !v <- value a+    let !cv = c v+    valuN' cv as +  {-# INLINE valueArgs #-}+  valueArgs _ xs = case xs of+    x : xs' -> Pair x <$!> valueArgs (Proxy :: Proxy t) xs'+    _       -> Nothing -valu15 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f-          , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l-          , EmbPrj m, EmbPrj n, EmbPrj o ) =>-          (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p) ->-          Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->-          R p+{-# INLINE valuN #-}+valuN :: forall t. VALU t (IsBase t) =>+         StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)) =>+         All EmbPrj (Domains t) =>+         t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))+valuN f = strictCurrys (Proxy :: Proxy (Constant Word32 (Domains t)))+                 (Proxy :: Proxy (R (CoDomain t)))+                 (valuN' f) -valu0 z = return z-valu1 z a = valu0 z `ap` value a-valu2 z a b = valu1 z a `ap` value b-valu3 z a b c = valu2 z a b `ap` value c-valu4 z a b c d = valu3 z a b c `ap` value d-valu5 z a b c d e = valu4 z a b c d `ap` value e-valu6 z a b c d e f = valu5 z a b c d e `ap` value f-valu7 z a b c d e f g = valu6 z a b c d e f `ap` value g-valu8 z a b c d e f g h = valu7 z a b c d e f g `ap` value h-valu9 z a b c d e f g h i = valu8 z a b c d e f g h `ap` value i-valu10 z a b c d e f g h i j = valu9 z a b c d e f g h i `ap` value j-valu11 z a b c d e f g h i j k = valu10 z a b c d e f g h i j `ap` value k-valu12 z a b c d e f g h i j k l = valu11 z a b c d e f g h i j k `ap` value l-valu13 z a b c d e f g h i j k l m = valu12 z a b c d e f g h i j k l `ap` value m-valu14 z a b c d e f g h i j k l m n = valu13 z a b c d e f g h i j k l m `ap` value n-valu15 z a b c d e f g h i j k l m n o = valu14 z a b c d e f g h i j k l m n `ap` value o+{-# INLINE valueN #-}+valueN :: forall t. VALU t (IsBase t) =>+          All EmbPrj (CoDomain t ': Domains t) =>+          t -> Word32 -> R (CoDomain t)+valueN t = vcase valu where+  valu int32s = case valueArgs (Proxy :: Proxy t) int32s of+                  Nothing -> malformed+                  Just vs -> valuN' t vs
src/full/Agda/TypeChecking/Serialise/Instances.hs view
@@ -1,19 +1,34 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- Only instances exported module Agda.TypeChecking.Serialise.Instances () where +import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Abstract ()-import Agda.TypeChecking.Serialise.Instances.Common ()-import Agda.TypeChecking.Serialise.Instances.Compilers ()+import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) import Agda.TypeChecking.Serialise.Instances.Highlighting ()-import Agda.TypeChecking.Serialise.Instances.Internal ()+import Agda.TypeChecking.Serialise.Instances.Errors ()+import Agda.Utils.Hash +type RangedImportedModules =+  [(SerialisedRange, TopLevelModuleName, Hash)]++fromImportedModules ::+  [(TopLevelModuleName, Hash)] -> RangedImportedModules+fromImportedModules ms = [(SerialisedRange $ getRange x, x, hash) | (x, hash) <- ms]++toImportedModules ::+  RangedImportedModules -> [(TopLevelModuleName, Hash)]+toImportedModules ms = [(setRange (underlyingRange r) x, hash) | (r, x, hash) <- ms]+ instance EmbPrj Interface where-  icod_ (Interface a b c d e f g h i j k l m n) = icode14' a b c d e f g h i j k l m n+  icod_ (Interface a b c d e f g h i j k l m n o p q r s t u v w x) =+      icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t u v w x+    where interface a b c = Interface a b c . toImportedModules -  value = vcase valu where-    valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n] = valu14 Interface a b c d e f g h i j k l m n-    valu _                                          = malformed+  value = valueN interface+    where interface a b c = Interface a b c . toImportedModules
src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs view
@@ -1,183 +1,257 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Serialise.Instances.Abstract where -import Control.Applicative+import Control.Monad+import Data.Void (Void) import qualified Data.Map as Map import qualified Data.Set as Set  import Agda.Syntax.Common import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pattern ( noDotOrEqPattern ) import Agda.Syntax.Info import Agda.Syntax.Scope.Base-import Agda.Syntax.Position as P import Agda.Syntax.Fixity  import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Common ()--import Agda.TypeChecking.Monad--import Agda.Utils.Except+import Agda.TypeChecking.Serialise.Instances.Common () --instance only -#include "undefined.h"+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.Null import Agda.Utils.Impossible +-- Don't serialize the tactic.+instance EmbPrj A.BindName where+  icod_ (A.BindName a) = icodeN' A.BindName a+  value = valueN A.BindName+ instance EmbPrj Scope where-  icod_ (Scope a b c d e) = icode5' a b c d e+  icod_ (Scope a b c d e) = icodeN' Scope a b c d e -  value = vcase valu where-    valu [a, b, c, d, e] = valu5 Scope a b c d e-    valu _               = malformed+  value = valueN Scope +instance EmbPrj DataOrRecordModule where+  icod_ IsDataModule   = pure 0+  icod_ IsRecordModule = pure 1++  value = \case+    0 -> pure IsDataModule+    1 -> pure IsRecordModule+    _ -> malformed+ instance EmbPrj NameSpaceId where-  icod_ PublicNS        = icode0'-  icod_ PrivateNS       = icode0 1-  icod_ ImportedNS      = icode0 2-  icod_ OnlyQualifiedNS = icode0 3+  icod_ PublicNS        = pure 0+  icod_ PrivateNS       = pure 1+  icod_ ImportedNS      = pure 2 -  value = vcase valu where-    valu []  = valu0 PublicNS-    valu [1] = valu0 PrivateNS-    valu [2] = valu0 ImportedNS-    valu [3] = valu0 OnlyQualifiedNS-    valu _   = malformed+  value = \case+    0 -> pure PublicNS+    1 -> pure PrivateNS+    2 -> pure ImportedNS+    _ -> malformed  instance EmbPrj Access where-  icod_ (PrivateAccess UserWritten) = icode0 0-  icod_ PrivateAccess{} = icode0 1-  icod_ PublicAccess  = icode0'-  icod_ OnlyQualified = icode0 2+  icod_ (PrivateAccess _ UserWritten) = pure 0+  icod_ PrivateAccess{}               = pure 1+  icod_ PublicAccess                  = pure 2 -  value = vcase valu where-    valu [0] = valu0 $ PrivateAccess UserWritten-    valu [1] = valu0 $ PrivateAccess Inserted-    valu []  = valu0 PublicAccess-    valu [2] = valu0 OnlyQualified-    valu _   = malformed+  value = \case+    0 -> pure $ PrivateAccess empty UserWritten+    1 -> pure $ privateAccessInserted+    2 -> pure PublicAccess+    _ -> malformed  instance EmbPrj NameSpace where-  icod_ (NameSpace a b c) = icode3' a b c+  icod_ (NameSpace a b c) = icodeN' NameSpace a b c -  value = vcase valu where-    valu [a, b, c] = valu3 NameSpace a b c-    valu _         = malformed+  value = valueN NameSpace  instance EmbPrj WhyInScope where-  icod_ Defined       = icode0'-  icod_ (Opened a b)  = icode2 0 a b-  icod_ (Applied a b) = icode2 1 a b+  icod_ Defined       = icodeN' Defined+  icod_ (Opened a b)  = icodeN 0 Opened a b+  icod_ (Applied a b) = icodeN 1 Applied a b    value = vcase valu where-    valu []        = valu0 Defined-    valu [0, a, b] = valu2 Opened a b-    valu [1, a, b] = valu2 Applied a b+    valu []        = valuN Defined+    valu [0, a, b] = valuN Opened a b+    valu [1, a, b] = valuN Applied a b     valu _         = malformed +-- Issue #1346: QNames are shared on their nameIds, so serializing will lose fixity information for+-- rebound fixities. We don't care about that in terms, but in the scope it's important to keep the+-- right fixity. Thus serialize the fixity separately.++data AbsNameWithFixity = AbsNameWithFixity Fixity A.QName KindOfName WhyInScope NameMetadata++toAbsName :: AbsNameWithFixity -> AbstractName+toAbsName (AbsNameWithFixity fx a b c d) = AbsName (set lensFixity fx a) b c d++fromAbsName :: AbstractName -> AbsNameWithFixity+fromAbsName (AbsName a b c d) = AbsNameWithFixity (a ^. lensFixity) a b c d++instance EmbPrj AbsNameWithFixity where+  icod_ (AbsNameWithFixity a b c d e) = icodeN' AbsNameWithFixity a b c d e+  value = valueN AbsNameWithFixity+ instance EmbPrj AbstractName where-  icod_ (AbsName a b c) = icode3' a b c+  icod_ a = icod_ (fromAbsName a)+  value = toAbsName <.> value +instance EmbPrj NameMetadata where+  icod_ NoMetadata                  = icodeN' NoMetadata+  icod_ (GeneralizedVarsMetadata a) = icodeN' GeneralizedVarsMetadata a+   value = vcase valu where-    valu [a, b, c] = valu3 AbsName a b c-    valu _         = malformed+    valu []  = valuN NoMetadata+    valu [a] = valuN GeneralizedVarsMetadata a+    valu _   = malformed -instance EmbPrj AbstractModule where-  icod_ (AbsModule a b) = icode2' a b+instance EmbPrj A.Suffix where+  icod_ A.NoSuffix   = icodeN' A.NoSuffix+  icod_ (A.Suffix a) = icodeN' A.Suffix a    value = vcase valu where-    valu [a, b] = valu2 AbsModule a b-    valu _      = malformed+    valu []  = valuN A.NoSuffix+    valu [a] = valuN A.Suffix a+    valu _   = malformed +instance EmbPrj AbstractModule where+  icod_ (AbsModule a b) = icodeN' AbsModule a b++  value = valueN AbsModule+ instance EmbPrj KindOfName where-  icod_ DefName        = icode0'-  icod_ ConName        = icode0 1-  icod_ FldName        = icode0 2-  icod_ PatternSynName = icode0 3-  icod_ QuotableName   = icode0 4-  icod_ MacroName      = icode0 5+  -- -- Enums have a generic EmbPrj+  --+  -- icod_ DefName        = icodeN' DefName+  -- icod_ ConName        = icodeN 1 ConName+  -- icod_ FldName        = icodeN 2 FldName+  -- icod_ PatternSynName = icodeN 3 PatternSynName+  -- icod_ QuotableName   = icodeN 4 QuotableName+  -- icod_ MacroName      = icodeN 5 MacroName+  -- icod_ GeneralizeName = icodeN 6 GeneralizeName+  -- icod_ DisallowedGeneralizeName = icodeN 7 DisallowedGeneralizeName -  value = vcase valu where-    valu []  = valu0 DefName-    valu [1] = valu0 ConName-    valu [2] = valu0 FldName-    valu [3] = valu0 PatternSynName-    valu [4] = valu0 QuotableName-    valu [5] = valu0 MacroName-    valu _   = malformed+  -- value = vcase valu where+  --   valu []  = valuN DefName+  --   valu [1] = valuN ConName+  --   valu [2] = valuN FldName+  --   valu [3] = valuN PatternSynName+  --   valu [4] = valuN QuotableName+  --   valu [5] = valuN MacroName+  --   valu [6] = valuN GeneralizeName+  --   valu [7] = valuN DisallowedGeneralizeName+  --   valu _   = malformed +instance EmbPrj BindingSource where+  icod_ = \case+    LambdaBound     -> pure 0+    PatternBound _  -> pure 1+    LetBound        -> pure 2+    WithBound       -> pure 3+    MacroBound      -> pure 4++  value = \case+    0 -> pure LambdaBound+    1 -> pure $ PatternBound empty+    2 -> pure LetBound+    3 -> pure WithBound+    4 -> pure MacroBound+    _ -> malformed+ instance EmbPrj LocalVar where-  icod_ (LocalVar a)      = icode1' a-  icod_ (ShadowedVar a b) = icode2' a b+  icod_ (LocalVar a b c)  = icodeN' LocalVar a b c -  value = vcase valu where-    valu [a]    = valu1 LocalVar a-    valu [a, b] = valu2 ShadowedVar a b-    valu _      = malformed+  value = valueN LocalVar  instance EmbPrj ConPatInfo where-  icod_ (ConPatInfo a _) = icod_ a-  value a                = flip ConPatInfo patNoRange <$> value a+  icod_ (ConPatInfo a _ b) = icodeN' (\a b -> ConPatInfo a patNoRange b) a b +  value = valueN $ \a b -> ConPatInfo a patNoRange b++instance EmbPrj ConPatLazy+ -- Only for pattern synonyms (where a is Void) instance EmbPrj a => EmbPrj (A.Pattern' a) where-  icod_ (A.VarP a)            = icode1 0 a-  icod_ (A.ConP a b c)        = icode3 1 a b c-  icod_ (A.DefP _ a b)        = icode2 2 a b-  icod_ (A.WildP _)           = icode0 3-  icod_ (A.AsP _ a b)         = icode2 4 a b-  icod_ (A.DotP _ a b)        = icode2 5 a b-  icod_ (A.AbsurdP _)         = icode0 6-  icod_ (A.LitP a)            = icode1 7 a-  icod_ (A.ProjP _ a b)       = icode2 8 a b-  icod_ (A.PatternSynP _ a b) = icode2 9 a b-  icod_ (A.RecP _ a)          = icode1 10 a+  icod_ (A.VarP a)            = icodeN 0 A.VarP a+  icod_ (A.ConP a b c)        = icodeN 1 A.ConP a b c+  icod_ (A.DefP p a b)        = icodeN 2 (A.DefP p) a b+  icod_ t@(A.WildP p)         = icodeN 3 t+  icod_ (A.AsP p a b)         = icodeN 4 (A.AsP p) a b+  icod_ (A.DotP r a)          = icodeN 5 (A.DotP r) a+  icod_ t@(A.AbsurdP _)       = icodeN 6 t+  icod_ (A.LitP i a)          = icodeN 7 (A.LitP i) a+  icod_ (A.ProjP p a b)       = icodeN 8 (A.ProjP p) a b+  icod_ (A.PatternSynP p a b) = icodeN 9 (A.PatternSynP p) a b+  icod_ (A.RecP r a b)        = icodeN 10 (A.RecP r) a b+  icod_ (A.EqualP _ a)        = __IMPOSSIBLE__+  icod_ (A.WithP i a)         = icodeN 11 (A.WithP i) a    value = vcase valu where-    valu [0, a]       = valu1 A.VarP a-    valu [1, a, b, c] = valu3 A.ConP a b c-    valu [2, a, b]    = valu2 (A.DefP i) a b-    valu [3]          = valu0 (A.WildP i)-    valu [4, a, b]    = valu2 (A.AsP i) a b-    valu [5, a, b]    = valu2 (A.DotP i) a b-    valu [6]          = valu0 (A.AbsurdP i)-    valu [7, a]       = valu1 (A.LitP) a-    valu [8, a, b]    = valu2 (A.ProjP i) a b-    valu [9, a, b]    = valu2 (A.PatternSynP i) a b-    valu [10, a]      = valu1 (A.RecP i) a+    valu [0, a]       = valuN A.VarP a+    valu [1, a, b, c] = valuN A.ConP a b c+    valu [2, a, b]    = valuN (A.DefP i) a b+    valu [3]          = valuN (A.WildP i)+    valu [4, a, b]    = valuN (A.AsP i) a b+    valu [5, a]       = valuN (A.DotP i) a+    valu [6]          = valuN (A.AbsurdP i)+    valu [7, a]       = valuN (A.LitP i) a+    valu [8, a, b]    = valuN (A.ProjP i) a b+    valu [9, a, b]    = valuN (A.PatternSynP i) a b+    valu [10, a, b]   = valuN (A.RecP empty) a b+    valu [11, a]      = valuN (A.WithP i) a     valu _            = malformed      i = patNoRange +-- | Hackish serialization for patterns that deletes dot patterns.+--   So that we can serialize the 'WithClauseProjectionFixityMismatch'+--   without having to define serialization of expressions.+--+instance {-# OVERLAPS #-} EmbPrj A.Pattern where+  icod_ = icod_ <=< noDotOrEqPattern (return $ A.WildP empty)+  value = fmap (__IMPOSSIBLE__ :: Void -> A.Expr) <.> value++instance EmbPrj ParenPreference where+  icod_ PreferParen     = icodeN' PreferParen+  icod_ PreferParenless = icodeN 1 PreferParenless+  value = vcase valu where+    valu []  = valuN PreferParen+    valu [1] = valuN PreferParenless+    valu _   = malformed+ instance EmbPrj Precedence where-  icod_ TopCtx                 = icode0'-  icod_ FunctionSpaceDomainCtx = icode0 1-  icod_ (LeftOperandCtx a)     = icode1 2 a-  icod_ (RightOperandCtx a)    = icode1 3 a-  icod_ FunctionCtx            = icode0 4-  icod_ ArgumentCtx            = icode0 5-  icod_ InsideOperandCtx       = icode0 6-  icod_ WithFunCtx             = icode0 7-  icod_ WithArgCtx             = icode0 8-  icod_ DotPatternCtx          = icode0 9+  icod_ TopCtx                 = icodeN' TopCtx+  icod_ FunctionSpaceDomainCtx = icodeN 1 FunctionSpaceDomainCtx+  icod_ (LeftOperandCtx a)     = icodeN 2 LeftOperandCtx a+  icod_ (RightOperandCtx a b)  = icodeN 3 RightOperandCtx a b+  icod_ FunctionCtx            = icodeN 4 FunctionCtx+  icod_ (ArgumentCtx a)        = icodeN 5 ArgumentCtx a+  icod_ InsideOperandCtx       = icodeN 6 InsideOperandCtx+  icod_ WithFunCtx             = icodeN 7 WithFunCtx+  icod_ WithArgCtx             = icodeN 8 WithArgCtx+  icod_ DotPatternCtx          = icodeN 9 DotPatternCtx    value = vcase valu where-    valu []     = valu0 TopCtx-    valu [1]    = valu0 FunctionSpaceDomainCtx-    valu [2, a] = valu1 LeftOperandCtx a-    valu [3, a] = valu1 RightOperandCtx a-    valu [4]    = valu0 FunctionCtx-    valu [5]    = valu0 ArgumentCtx-    valu [6]    = valu0 InsideOperandCtx-    valu [7]    = valu0 WithFunCtx-    valu [8]    = valu0 WithArgCtx-    valu [9]    = valu0 DotPatternCtx-    valu _      = malformed+    valu []        = valuN TopCtx+    valu [1]       = valuN FunctionSpaceDomainCtx+    valu [2, a]    = valuN LeftOperandCtx a+    valu [3, a, b] = valuN RightOperandCtx a b+    valu [4]       = valuN FunctionCtx+    valu [5, a]    = valuN ArgumentCtx a+    valu [6]       = valuN InsideOperandCtx+    valu [7]       = valuN WithFunCtx+    valu [8]       = valuN WithArgCtx+    valu [9]       = valuN DotPatternCtx+    valu _         = malformed  instance EmbPrj ScopeInfo where-  icod_ (ScopeInfo a b c d _ _ _) = icode4' a b c d+  icod_ (ScopeInfo a b c d e f g h i j k) = icodeN' (\ a b c d e -> ScopeInfo a b c d e f g h i j k) a b c d e -  value = vcase valu where      -- reverse maps will be recomputed-    valu [a, b, c, d] = valu4 (\ a b c d -> ScopeInfo a b c d Map.empty Map.empty Set.empty) a b c d-    valu _            = malformed+  value = valueN (\ a b c d e -> ScopeInfo a b c d e Map.empty Map.empty Set.empty Map.empty Map.empty Map.empty)++instance EmbPrj NameOrModule
src/full/Agda/TypeChecking/Serialise/Instances/Common.hs view
@@ -1,464 +1,759 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ScopedTypeVariables       #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverlappingInstances       #-}-#endif- {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-} -module Agda.TypeChecking.Serialise.Instances.Common () where+module Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) where -import Control.Applicative-import Control.Monad.Reader-import Control.Monad.State.Strict (gets, modify)+import qualified Control.Exception as E+import Control.Monad              ( (<=<), (<$!>) )+import Control.Monad.IO.Class     ( MonadIO(..) )+import Control.Monad.Except       ( MonadError(..) )+import Control.Monad.Reader       ( MonadReader(..), asks )+import Control.Monad.State        ( runStateT )+import Control.Monad.State.Strict ( gets, modify )  import Data.Array.IArray-import Data.Word-import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as Fold import Data.Hashable-import qualified Data.HashTable.IO as H+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap import Data.Int (Int32)-import Data.Maybe+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq-#if __GLASGOW_HASKELL__ <= 708-import Data.Typeable (Typeable)-#endif+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Strict.Tuple (Pair(..))+import qualified Data.Text      as T+import qualified Data.Text.Lazy as TL+import Data.Typeable import Data.Void+import Data.Word (Word32, Word64)  import Agda.Syntax.Common+import Agda.Syntax.Builtin import Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Concrete (RecordDirective(..)) import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Position as P-import Agda.Syntax.Fixity-import Agda.Syntax.Notation import Agda.Syntax.Literal+import Agda.Syntax.TopLevelModuleName import Agda.Interaction.FindFile+import Agda.Interaction.Library +import Agda.TypeChecking.Monad.Base.Types import Agda.TypeChecking.Serialise.Base  import Agda.Utils.BiMap (BiMap) import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.HashMap (HashMap)-import qualified Agda.Utils.HashMap as HMap-import Agda.Utils.FileName+import Agda.Utils.FileId (getIdFile)+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.List2 (List2(List2))+import qualified Agda.Utils.List2 as List2 import qualified Agda.Utils.Maybe.Strict as Strict--import Agda.Utils.Except+import Agda.Utils.Null+import Agda.Utils.SmallSet (SmallSet(..))+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Trie (Trie(..))+import Agda.Utils.WithDefault -#include "undefined.h" import Agda.Utils.Impossible+import Agda.Utils.CallStack -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPING #-} EmbPrj String where-#else-instance EmbPrj String where-#endif   icod_   = icodeString-  value i = (! i) `fmap` gets stringE+  value i = (! i) <$!> gets stringE -instance EmbPrj L.ByteString where-  icod_   = icodeX bstringD bstringC-  value i = (! i) `fmap` gets bstringE+instance EmbPrj TL.Text where+  icod_   = icodeX lTextD lTextC+  value i = (! i) <$!> gets lTextE +instance EmbPrj T.Text where+  icod_   = icodeX sTextD sTextC+  value i = (! i) <$!> gets sTextE+ instance EmbPrj Integer where   icod_   = icodeInteger-  value i = (! i) `fmap` gets integerE+  value i = (! i) <$!> gets integerE  instance EmbPrj Word64 where-  icod_ i = icode2' (int32 q) (int32 r)-    where (q, r) = quotRem i (2^32)-          int32 :: Word64 -> Int32-          int32 = fromIntegral+  icod_ i = icodeN' (undefined :: Word32 -> Word32 -> Word32) (word32 q) (word32 r)+    where (q, r) = quotRem i (2 ^ 32)+          word32 :: Word64 -> Word32+          word32 = fromIntegral    value = vcase valu where-    valu [a, b] = return $ n * mod (fromIntegral a) n + mod (fromIntegral b) n+    valu [a, b] = return $! n * fromIntegral a + fromIntegral b     valu _      = malformed-    n = 2^32+    n = 2 ^ 32 -instance EmbPrj Int32 where+instance EmbPrj Word32 where   icod_ i = return i   value i = return i +-- Andreas, Agda Hackathon 2024-10-15+-- Are we sure we never use an Int that does not fit into 32 bits? instance EmbPrj Int where-  icod_ i = return (fromIntegral i)-  value i = return (fromIntegral i)+  icod_ i = return $! fromIntegral i+  value i = return $! fromIntegral i +instance EmbPrj Int32 where+  icod_ i = return $! fromIntegral i+  value i = return $! fromIntegral i+ instance EmbPrj Char where-  icod_ c = return (fromIntegral $ fromEnum c)-  value i = return (toEnum $ fromInteger $ toInteger i)+  icod_ c = return $! fromIntegral $ fromEnum c+  value i = return $! toEnum $ fromInteger $ toInteger i  instance EmbPrj Double where   icod_   = icodeDouble-  value i = (! i) `fmap` gets doubleE+  value i = (! i) <$!> gets doubleE  instance EmbPrj Void where   icod_ = absurd   value = vcase valu where valu _ = malformed  instance EmbPrj () where-  icod_ () = icode0'+  icod_ () = pure 0 -  value = vcase valu where-    valu [] = valu0 ()-    valu _  = malformed+  value 0 = pure ()+  value _ = malformed  instance (EmbPrj a, EmbPrj b) => EmbPrj (a, b) where-  icod_ (a, b) = icode2' a b+  icod_ (a, b) = icodeN' (,) a b -  value = vcase valu where-    valu [a, b] = valu2 (,) a b-    valu _      = malformed+  value = valueN (,) +instance (EmbPrj a, EmbPrj b) => EmbPrj (Pair a b) where+  icod_ (a :!: b) = icodeN' (:!:) a b++  value = valueN (:!:)+ instance (EmbPrj a, EmbPrj b, EmbPrj c) => EmbPrj (a, b, c) where-  icod_ (a, b, c) = icode3' a b c+  icod_ (a, b, c) = icodeN' (,,) a b c -  value = vcase valu where-    valu [a, b, c] = valu3 (,,) a b c-    valu _         = malformed+  value = valueN (,,)  instance (EmbPrj a, EmbPrj b) => EmbPrj (Either a b) where-  icod_ (Left  x) = icode1 0 x-  icod_ (Right x) = icode1 1 x+  icod_ (Left  x) = icodeN 0 Left x+  icod_ (Right x) = icodeN 1 Right x    value = vcase valu where-    valu [0, x] = valu1 Left  x-    valu [1, x] = valu1 Right x+    valu [0, x] = valuN Left  x+    valu [1, x] = valuN Right x     valu _   = malformed  instance EmbPrj a => EmbPrj (Maybe a) where-  icod_ Nothing  = icode0'-  icod_ (Just x) = icode1' x+  icod_ Nothing  = icodeN' Nothing+  icod_ (Just x) = icodeN' Just x    value = vcase valu where-    valu []  = valu0 Nothing-    valu [x] = valu1 Just x+    valu []  = valuN Nothing+    valu [x] = valuN Just x     valu _   = malformed  instance EmbPrj a => EmbPrj (Strict.Maybe a) where   icod_ m = icode (Strict.toLazy m)-  value m = Strict.toStrict `fmap` value m+  value m = Strict.toStrict <$!> value m  instance EmbPrj Bool where-  icod_ True  = icode0'-  icod_ False = icode0 0+  icod_ False = pure 0+  icod_ True  = pure 1 -  value = vcase valu where-    valu []  = valu0 True-    valu [0] = valu0 False-    valu _   = malformed+  value 0 = pure False+  value 1 = pure True+  value _ = malformed -instance EmbPrj AbsolutePath where-  icod_ file = do-    d <-  asks absPathD-    liftIO $ fromMaybe __IMPOSSIBLE__ <$> H.lookup d file+instance EmbPrj ConstructorOrPatternSynonym -  value m = do-    m :: TopLevelModuleName-            <- value m-    mf      <- gets modFile-    incs    <- gets includes-    (r, mf) <- liftIO $ findFile'' incs m mf-    modify $ \s -> s { modFile = mf }-    case r of-      Left err -> throwError $ findErrorToTypeError m err-      Right f  -> return f+instance EmbPrj FileType where+  icod_ AgdaFileType  = pure 0+  icod_ MdFileType    = pure 1+  icod_ RstFileType   = pure 2+  icod_ TexFileType   = pure 3+  icod_ OrgFileType   = pure 4+  icod_ TypstFileType = pure 5+  icod_ TreeFileType  = pure 6 +  value = \case+    0 -> pure AgdaFileType+    1 -> pure MdFileType+    2 -> pure RstFileType+    3 -> pure TexFileType+    4 -> pure OrgFileType+    5 -> pure TypstFileType+    6 -> pure TreeFileType+    _ -> malformed++instance EmbPrj Cubical where+  icod_ CErased = icodeN'  CErased+  icod_ CFull   = icodeN 0 CFull++  value = vcase $ \case+    []  -> valuN CErased+    [0] -> valuN CFull+    _   -> malformed++instance EmbPrj Language where+  icod_ WithoutK    = icodeN'  WithoutK+  icod_ WithK       = icodeN 0 WithK+  icod_ (Cubical a) = icodeN 1 Cubical a++  value = vcase $ \case+    []     -> valuN WithoutK+    [0]    -> valuN WithK+    [1, a] -> valuN Cubical a+    _      -> malformed+ instance EmbPrj a => EmbPrj (Position' a) where-  icod_ (P.Pn file pos line col) = icode4' file pos line col+  icod_ (P.Pn file pos line col) = icodeN' P.Pn file pos line col -  value = vcase valu where-    valu [f, p, l, c] = valu4 P.Pn f p l c-    valu _            = malformed+  value = valueN P.Pn +instance (EmbPrj a, Typeable b) => EmbPrj (WithDefault' a b) where+  icod_ = \case+    Default -> icodeN' Default+    Value b -> icodeN' Value b++  value = vcase $ \case+    []  -> valuN Default+    [a] -> valuN Value a+    _ -> malformed+ instance EmbPrj TopLevelModuleName where-  icod_ (TopLevelModuleName a) = icode1' a+  icod_ (TopLevelModuleName a b c d) = icodeN' TopLevelModuleName a b c d -  value = vcase valu where-    valu [a] = valu1 TopLevelModuleName a-    valu _   = malformed+  value = valueN TopLevelModuleName -#if __GLASGOW_HASKELL__ >= 710 instance {-# OVERLAPPABLE #-} EmbPrj a => EmbPrj [a] where-#else-instance EmbPrj a => EmbPrj [a] where-#endif-  icod_ xs = icodeN =<< mapM icode xs-  value    = vcase (mapM value)---   icode []       = icode0'---   icode (x : xs) = icode2' x xs---   value = vcase valu where valu []      = valu0 []---                            valu [x, xs] = valu2 (:) x xs---                            valu _       = malformed+  icod_ xs = icodeNode =<< go xs where+    go :: [a] -> S Node+    go []     = pure Empty+    go (a:as) = do {n <- icode a; ns <- go as; pure $! Cons n ns} -instance (Ord a, Ord b, EmbPrj a, EmbPrj b) => EmbPrj (BiMap a b) where-  icod_ m = icode (BiMap.toList m)-  value m = BiMap.fromList <$> value m+  value = vcase (mapM value) +instance EmbPrj a => EmbPrj (List1 a) where+  icod_ = icod_ . List1.toList+  value = maybe malformed return . List1.nonEmpty <=< value++instance EmbPrj a => EmbPrj (List2 a) where+  icod_ = icod_ . List2.toList+  value = maybe malformed return . List2.fromListMaybe <=< value++instance (EmbPrj k, EmbPrj v, EmbPrj (BiMap.Tag v)) =>+         EmbPrj (BiMap k v) where+  icod_ m = icode (BiMap.toDistinctAscendingLists m)+  value m = BiMap.fromDistinctAscendingLists <$!> value m+++-- | Encode a list of key-value pairs as a flat list.+mapPairsIcode :: (EmbPrj k, EmbPrj v) => [(k, v)] -> S Word32+mapPairsIcode xs = icodeNode =<< convert Empty xs where+  -- As we need to call `convert' in the tail position, the resulting list is+  -- written (and read) in reverse order, with the highest pair first in the+  -- resulting list.+  convert !ys [] = return ys+  convert  ys ((start, entry):xs) = do+    start <- icode start+    entry <- icode entry+    convert (Cons start (Cons entry ys)) xs++mapPairsValue :: (EmbPrj k, EmbPrj v) => [Word32] -> R [(k, v)]+mapPairsValue = convert [] where+  convert ys [] = return ys+  convert ys (start:entry:xs) = do+    !start <- value start+    !entry <- value entry+    convert ((start, entry):ys) xs+  convert _ _ = malformed+ instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where-  icod_ m = icode (Map.toList m)-  value m = Map.fromList `fmap` value m+  icod_ m = mapPairsIcode (Map.toAscList m)+  value = vcase ((Map.fromDistinctAscList <$!>) . mapPairsValue)  instance (Ord a, EmbPrj a) => EmbPrj (Set a) where-  icod_ s = icode (Set.toList s)-  value s = Set.fromList `fmap` value s+  icod_ s = icode (Set.toAscList s)+  value s = Set.fromDistinctAscList <$!> value s +instance (Ord a, EmbPrj a) => EmbPrj (Set1 a) where+  icod_ s = icode (Set1.toAscList s)+  value s = Set1.fromDistinctAscList <$!> value s++instance EmbPrj IntSet where+  icod_ s = icode (IntSet.toAscList s)+  value s = IntSet.fromDistinctAscList <$!> value s++instance Typeable a => EmbPrj (SmallSet a) where+  icod_ (SmallSet a) = icodeN' SmallSet a+  value = valueN SmallSet++instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Trie a b) where+  icod_ (Trie a b)= icodeN' Trie a b++  value = valueN Trie+ instance EmbPrj a => EmbPrj (Seq a) where   icod_ s = icode (Fold.toList s)-  value s = Seq.fromList `fmap` value s+  value s = Seq.fromList <$!> value s  instance EmbPrj a => EmbPrj (P.Interval' a) where-  icod_ (P.Interval p q) = icode2' p q+  icod_ (P.Interval f p q) = icodeN' P.Interval f p q -  value = vcase valu where-    valu [p, q] = valu2 P.Interval p q-    valu _      = malformed+  value = valueN P.Interval +instance EmbPrj RangeFile where+  icod_ (RangeFile _ Nothing)  = __IMPOSSIBLE__+  icod_ (RangeFile _ (Just a)) = icode a++  value r = do+    m :: TopLevelModuleName+            <- value r+    mf      <- gets modFile+    incs    <- gets includes+    (r, mf) <- liftIO $ runStateT (findFile'' incs m) mf+    modify $ \s -> s { modFile = mf }+    case r of+      Left err -> liftIO $ E.throwIO $ E.ErrorCall $ "file not found: " ++ show err+      Right (SourceFile i)  -> do+        let fp = getIdFile (fileDict mf) i+        return $ RangeFile fp (Just m)+ -- | Ranges are always deserialised as 'noRange'.  instance EmbPrj Range where-  icod_ _ = icode0'+  icod_ _ = icodeN' ()   value _ = return noRange +instance EmbPrj KwRange where+  icod_ _ = icodeN' ()+  value _ = return empty+ -- | Ranges that should be serialised properly.  newtype SerialisedRange = SerialisedRange { underlyingRange :: Range }-#if __GLASGOW_HASKELL__ <= 708-  deriving (Typeable)-#endif  instance EmbPrj SerialisedRange where-  icod_ (SerialisedRange r) =-    icode2' (P.rangeFile r) (P.rangeIntervals r)+  icod_ (SerialisedRange r) = icodeN' P.intervalsToRange (P.rangeFile r) (P.rangeIntervals r) -  value = vcase valu where-    valu [a, b] = SerialisedRange <$> valu2 P.intervalsToRange a b-    valu _      = malformed+  value i = SerialisedRange <$!> valueN P.intervalsToRange i  instance EmbPrj C.Name where-  icod_ (C.NoName a b) = icode2 0 a b-  icod_ (C.Name r xs)  = icode2' r xs+  icod_ (C.NoName a b)     = icodeN 0 C.NoName a b+  icod_ (C.Name r nis xs)  = icodeN 1 C.Name r nis xs    value = vcase valu where-    valu [0, a, b] = valu2 C.NoName a b-    valu [r, xs]   = valu2 C.Name   r xs-    valu _         = malformed+    valu [0, a, b]       = valuN C.NoName a b+    valu [1, r, nis, xs] = valuN C.Name   r nis xs+    valu _               = malformed  instance EmbPrj NamePart where-  icod_ Hole   = icode0'-  icod_ (Id a) = icode1' a+  icod_ Hole   = icodeN' Hole+  icod_ (Id a) = icodeN' Id a    value = vcase valu where-    valu []  = valu0 Hole-    valu [a] = valu1 Id a+    valu []  = valuN Hole+    valu [a] = valuN Id a     valu _   = malformed +instance EmbPrj NameInScope where+  icod_ InScope    = icodeN' InScope+  icod_ NotInScope = icodeN 0 NotInScope++  value = vcase valu where+    valu []  = valuN InScope+    valu [0] = valuN NotInScope+    valu _   = malformed+ instance EmbPrj C.QName where-  icod_ (Qual    a b) = icode2' a b-  icod_ (C.QName a  ) = icode1' a+  icod_ (Qual    a b) = icodeN' Qual a b+  icod_ (C.QName a  ) = icodeN' C.QName a    value = vcase valu where-    valu [a, b] = valu2 Qual    a b-    valu [a]    = valu1 C.QName a+    valu [a, b] = valuN Qual    a b+    valu [a]    = valuN C.QName a     valu _      = malformed -instance EmbPrj Agda.Syntax.Fixity.Associativity where-  icod_ LeftAssoc  = icode0'-  icod_ RightAssoc = icode0 1-  icod_ NonAssoc   = icode0 2+instance (EmbPrj a, EmbPrj b) => EmbPrj (ImportedName' a b) where+  icod_ (ImportedModule a) = icodeN 1 ImportedModule a+  icod_ (ImportedName a)   = icodeN 2 ImportedName a    value = vcase valu where-    valu []  = valu0 LeftAssoc-    valu [1] = valu0 RightAssoc-    valu [2] = valu0 NonAssoc-    valu _   = malformed+    valu [1, a] = valuN ImportedModule a+    valu [2, a] = valuN ImportedName a+    valu _ = malformed -instance EmbPrj Agda.Syntax.Fixity.PrecedenceLevel where-  icod_ Unrelated   = icode0'-  icod_ (Related a) = icode1' a+instance EmbPrj Associativity where+  icod_ LeftAssoc  = pure 0+  icod_ RightAssoc = pure 1+  icod_ NonAssoc   = pure 2 +  value = \case+    0 -> pure LeftAssoc+    1 -> pure RightAssoc+    2 -> pure NonAssoc+    _ -> malformed++instance EmbPrj FixityLevel where+  icod_ Unrelated   = icodeN' Unrelated+  icod_ (Related a) = icodeN' Related a+   value = vcase valu where-    valu []  = valu0 Unrelated-    valu [a] = valu1 Related a+    valu []  = valuN Unrelated+    valu [a] = valuN Related a     valu _   = malformed -instance EmbPrj Agda.Syntax.Fixity.Fixity where-  icod_ (Fixity a b c) = icode3' a b c+instance EmbPrj Fixity where+  icod_ (Fixity a b c) = icodeN' Fixity a b c -  value = vcase valu where-    valu [a, b, c] = valu3 Fixity a b c-    valu _         = malformed+  value = valueN Fixity -instance EmbPrj Agda.Syntax.Fixity.Fixity' where-  icod_ (Fixity' a b _) = icode2' a b  -- discard theNameRange+instance EmbPrj Fixity' where+  icod_ (Fixity' a b r) = icodeN' (\ a b -> Fixity' a b r) a b  -- discard theNameRange -  value = vcase valu where-    valu [a, b] = valu2 (\ f n -> Fixity' f n noRange) a b-    valu _      = malformed+  value = valueN (\ f n -> Fixity' f n noRange) -instance EmbPrj GenPart where-  icod_ (BindHole a)   = icode1 0 a-  icod_ (NormalHole a) = icode1 1 a-  icod_ (WildHole a)   = icode1 2 a-  icod_ (IdPart a)     = icode1' a+instance EmbPrj BoundVariablePosition where+  icod_ (BoundVariablePosition a b) = icodeN' BoundVariablePosition a b +  value = valueN BoundVariablePosition++instance EmbPrj NotationPart where+  icod_ (VarPart a b)  = icodeN 0 VarPart a b+  icod_ (HolePart a b) = icodeN 1 HolePart a b+  icod_ (WildPart a)   = icodeN 2 WildPart a+  icod_ (IdPart a)     = icodeN' IdPart a+   value = vcase valu where-    valu [0, a] = valu1 BindHole a-    valu [1, a] = valu1 NormalHole a-    valu [2, a] = valu1 WildHole a-    valu [a]    = valu1 IdPart a-    valu _      = malformed+    valu [0, a, b] = valuN VarPart a b+    valu [1, a, b] = valuN HolePart a b+    valu [2, a]    = valuN WildPart a+    valu [a]       = valuN IdPart a+    valu _         = malformed  instance EmbPrj MetaId where-  icod_ (MetaId n) = icod_ n-  value i = MetaId <$> value i+  icod_ (MetaId a b) = icode (a, b) +  value m = uncurry MetaId <$!> value m++instance EmbPrj ProblemId where+  icod_ (ProblemId a) = icode a++  value m = ProblemId <$!> value m+ instance EmbPrj A.QName where-  icod_ n@(A.QName a b) = icodeMemo qnameD qnameC (qnameId n) $ icode2' a b+  icod_ n@(A.QName a b) = icodeMemo qnameD qnameC (qnameId n) $ icodeN' A.QName a b -  value = vcase valu where-    valu [a, b] = valu2 A.QName a b-    valu _      = malformed+  value = valueN A.QName  instance EmbPrj A.AmbiguousQName where   icod_ (A.AmbQ a) = icode a-  value n          = A.AmbQ `fmap` value n+  value n          = A.AmbQ <$!> value n  instance EmbPrj A.ModuleName where   icod_ (A.MName a) = icode a-  value n           = A.MName `fmap` value n+  value n           = A.MName <$!> value n  instance EmbPrj A.Name where-  icod_ (A.Name a b c d) = icodeMemo nameD nameC a $-    icode4' a b (SerialisedRange c) d+  icod_ (A.Name a b c d e f) = icodeMemo nameD nameC a $+    icodeN' (\ a b c -> A.Name a b c . underlyingRange) a b c (SerialisedRange d) e f -  value = vcase valu where-    valu [a, b, c, d] = valu4 (\a b c -> A.Name a b (underlyingRange c))-                              a b c d-    valu _            = malformed+  value = valueN (\a b c d -> A.Name a b c (underlyingRange d))  instance EmbPrj a => EmbPrj (C.FieldAssignment' a) where-  icod_ (C.FieldAssignment a b) = icode2' a b+  icod_ (C.FieldAssignment a b) = icodeN' C.FieldAssignment a b -  value = vcase valu where-    valu [a, b] = valu2 C.FieldAssignment a b-    valu _      = malformed+  value = valueN C.FieldAssignment  instance (EmbPrj s, EmbPrj t) => EmbPrj (Named s t) where-  icod_ (Named a b) = icode2' a b+  icod_ (Named a b) = icodeN' Named a b -  value = vcase valu where-    valu [a, b] = valu2 Named a b-    valu _      = malformed+  value = valueN Named  instance EmbPrj a => EmbPrj (Ranged a) where-  icod_ (Ranged r x) = icode2' r x+  icod_ (Ranged r x) = icodeN' Ranged r x -  value = vcase valu where-    valu [r, x] = valu2 Ranged r x-    valu _      = malformed+  value = valueN Ranged  instance EmbPrj ArgInfo where-  icod_ (ArgInfo h r o v) = icode4' h r o v+  icod_ (ArgInfo h r o fv ann) = icodeN' ArgInfo h r o fv ann -  value = vcase valu where-    valu [h, r, o, v] = valu4 ArgInfo h r o v-    valu _            = malformed+  value = valueN ArgInfo +instance EmbPrj ModuleNameHash where+  icod_ (ModuleNameHash a) = icodeN' ModuleNameHash a++  value = valueN ModuleNameHash+ instance EmbPrj NameId where-  icod_ (NameId a b) = icode2' a b+  icod_ (NameId a b) = icodeN' NameId a b -  value = vcase valu where-    valu [a, b] = valu2 NameId a b-    valu _      = malformed+  value = valueN NameId +instance EmbPrj OpaqueId where+  icod_ (OpaqueId a b) = icodeN' OpaqueId a b++  value = valueN OpaqueId+ instance (Eq k, Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where-  icod_ m = icode (HMap.toList m)-  value m = HMap.fromList `fmap` value m+  icod_ m = mapPairsIcode (HMap.toList m)+  value = vcase ((HMap.fromList <$!>) . mapPairsValue)  instance EmbPrj a => EmbPrj (WithHiding a) where-  icod_ (WithHiding a b) = icode2' a b+  icod_ (WithHiding a b) = icodeN' WithHiding a b -  value = vcase valu where-    valu [a, b] = valu2 WithHiding a b-    valu _      = malformed+  value = valueN WithHiding  instance EmbPrj a => EmbPrj (Arg a) where-  icod_ (Arg i e) = icode2' i e+  icod_ (Arg i e) = icodeN' Arg i e -  value = vcase valu where-    valu [i, e] = valu2 Arg i e-    valu _      = malformed+  value = valueN Arg -instance EmbPrj a => EmbPrj (Dom a) where-  icod_ (Dom i e) = icode2' i e+instance EmbPrj a => EmbPrj (HasEta' a) where+  icod_ YesEta    = icodeN' YesEta+  icod_ (NoEta a) = icodeN' NoEta a    value = vcase valu where-    valu [i, e] = valu2 Dom i e-    valu _      = malformed+    valu []  = valuN YesEta+    valu [a] = valuN NoEta a+    valu _   = malformed +instance EmbPrj PatternOrCopattern+instance EmbPrj OverlapMode+ instance EmbPrj Induction where-  icod_ Inductive   = icode0'-  icod_ CoInductive = icode0 1+  icod_ Inductive   = icodeN' Inductive+  icod_ CoInductive = icodeN 1 CoInductive    value = vcase valu where-    valu []  = valu0 Inductive-    valu [1] = valu0 CoInductive+    valu []  = valuN Inductive+    valu [1] = valuN CoInductive     valu _   = malformed  instance EmbPrj Hiding where-  icod_ Hidden    = return 0-  icod_ NotHidden = return 1-  icod_ Instance  = return 2+  icod_ Hidden                = return 0+  icod_ NotHidden             = return 1+  icod_ (Instance NoOverlap)  = return 2+  icod_ (Instance YesOverlap) = return 3    value 0 = return Hidden   value 1 = return NotHidden-  value 2 = return Instance+  value 2 = return (Instance NoOverlap)+  value 3 = return (Instance YesOverlap)   value _ = malformed +instance EmbPrj Q0Origin where+  icod_ = \case+    Q0Inferred -> return 0+    Q0 _       -> return 1+    Q0Erased _ -> return 2++  value = \case+    0 -> return $ Q0Inferred+    1 -> return $ Q0       noRange+    2 -> return $ Q0Erased noRange+    _ -> malformed++instance EmbPrj Q1Origin where+  icod_ = \case+    Q1Inferred -> return 0+    Q1 _       -> return 1+    Q1Linear _ -> return 2++  value = \case+    0 -> return $ Q1Inferred+    1 -> return $ Q1       noRange+    2 -> return $ Q1Linear noRange+    _ -> malformed++instance EmbPrj QωOrigin where+  icod_ = \case+    QωInferred -> return 0+    Qω _       -> return 1+    QωPlenty _ -> return 2++  value = \case+    0 -> return $ QωInferred+    1 -> return $ Qω       noRange+    2 -> return $ QωPlenty noRange+    _ -> malformed++instance EmbPrj Quantity where+  icod_ = \case+    Quantity0 a -> icodeN 0 Quantity0 a+    Quantity1 a -> icodeN 1 Quantity1 a+    Quantityω a -> icodeN'  Quantityω a  -- default quantity, shorter code++  value = vcase $ \case+    [0, a] -> valuN Quantity0 a+    [1, a] -> valuN Quantity1 a+    [a]    -> valuN Quantityω a+    _      -> malformed++-- -- ALT: forget quantity origin when serializing?+-- instance EmbPrj Quantity where+--   icod_ Quantity0 = return 0+--   icod_ Quantity1 = return 1+--   icod_ Quantityω = return 2++--   value 0 = return Quantity0+--   value 1 = return Quantity1+--   value 2 = return Quantityω+--   value _ = malformed++instance EmbPrj Cohesion where+  icod_ Flat       = return 0+  icod_ Continuous = return 1+  icod_ Squash     = return 2++  value 0 = return Flat+  value 1 = return Continuous+  value 2 = return Squash+  value _ = malformed++instance EmbPrj ModalPolarity where+  icod_ UnusedPolarity = return 0+  icod_ StrictlyPositive = return 1+  icod_ Positive = return 2+  icod_ Negative = return 3+  icod_ MixedPolarity = return 4++  value 0 = return UnusedPolarity+  value 1 = return StrictlyPositive+  value 2 = return Positive+  value 3 = return Negative+  value 4 = return MixedPolarity+  value _ = malformed++instance EmbPrj PolarityModality where+  icod_ (PolarityModality p o l) = icod_ (p, o, l)++  value n = do+    (p, o, l) <- polPair+    return $ PolarityModality p o l+    where+      polPair :: R (ModalPolarity, ModalPolarity, ModalPolarity)+      polPair = value n++instance EmbPrj Modality where+  icod_ (Modality a b c d) = icodeN' Modality a b c d++  value = vcase $ \case+    [a, b, c, d] -> valuN Modality a b c d+    _ -> malformed++instance EmbPrj OriginRelevant where+  icod_ = \case+    ORelInferred   -> return 0+    ORelRelevant _ -> return 1++  value = \case+    0 -> return $ ORelInferred+    1 -> return $ ORelRelevant noRange+    _ -> malformed++instance EmbPrj OriginIrrelevant where+  icod_ = \case+    OIrrInferred     -> return 0+    OIrrDot _        -> return 1+    OIrrIrr _        -> return 2+    OIrrIrrelevant _ -> return 3++  value = \case+    0 -> return $ OIrrInferred+    1 -> return $ OIrrDot        noRange+    2 -> return $ OIrrIrr        noRange+    3 -> return $ OIrrIrrelevant noRange+    _ -> malformed++instance EmbPrj OriginShapeIrrelevant where+  icod_ = \case+    OShIrrInferred          -> return 0+    OShIrrDotDot _          -> return 1+    OShIrrShIrr _           -> return 2+    OShIrrShapeIrrelevant _ -> return 3++  value = \case+    0 -> return $ OShIrrInferred+    1 -> return $ OShIrrDotDot          noRange+    2 -> return $ OShIrrShIrr           noRange+    3 -> return $ OShIrrShapeIrrelevant noRange+    _ -> malformed+ instance EmbPrj Relevance where-  icod_ Relevant       = return 0-  icod_ Irrelevant     = return 1-  icod_ (Forced Small) = return 2-  icod_ (Forced Big)   = return 3-  icod_ NonStrict      = return 4-  icod_ UnusedArg      = return 5+  icod_ = \case+    Relevant   a      -> icodeN' Relevant a+    Irrelevant a      -> icodeN 0 Irrelevant a+    ShapeIrrelevant a -> icodeN 1 ShapeIrrelevant a -  value 0 = return Relevant-  value 1 = return Irrelevant-  value 2 = return (Forced Small)-  value 3 = return (Forced Big)-  value 4 = return NonStrict-  value 5 = return UnusedArg+  value = vcase \case+    [a]    -> valuN Relevant a+    [0, a] -> valuN Irrelevant a+    [1, a] -> valuN ShapeIrrelevant a+    _      -> malformed++instance EmbPrj Annotation where+  icod_ (Annotation l) = icodeN' Annotation l++  value = valueN Annotation++instance EmbPrj Lock where+  icod_ IsNotLock          = pure 0+  icod_ (IsLock LockOTick) = pure 1+  icod_ (IsLock LockOLock) = pure 2++  value 0 = pure IsNotLock+  value 1 = pure (IsLock LockOTick)+  value 2 = pure (IsLock LockOLock)   value _ = malformed  instance EmbPrj Origin where   icod_ UserWritten = return 0   icod_ Inserted    = return 1   icod_ Reflected   = return 2+  icod_ CaseSplit   = return 3+  icod_ Substitution = return 4+  icod_ ExpandedPun = return 5+  icod_ Generalization = return 6    value 0 = return UserWritten   value 1 = return Inserted   value 2 = return Reflected+  value 3 = return CaseSplit+  value 4 = return Substitution+  value 5 = return ExpandedPun+  value 6 = return Generalization   value _ = malformed +instance EmbPrj a => EmbPrj (WithOrigin a) where+  icod_ (WithOrigin a b) = icodeN' WithOrigin a b++  value = valueN WithOrigin++instance EmbPrj FreeVariables where+  icod_ UnknownFVs   = icodeN' UnknownFVs+  icod_ (KnownFVs a) = icodeN' KnownFVs a++  value = vcase valu where+    valu []  = valuN UnknownFVs+    valu [a] = valuN KnownFVs a+    valu _   = malformed+ instance EmbPrj ConOrigin where   icod_ ConOSystem = return 0   icod_ ConOCon    = return 1   icod_ ConORec    = return 2+  icod_ ConOSplit  = return 3    value 0 = return ConOSystem   value 1 = return ConOCon   value 2 = return ConORec+  value 3 = return ConOSplit   value _ = malformed  instance EmbPrj ProjOrigin where@@ -472,36 +767,123 @@   value _ = malformed  instance EmbPrj Agda.Syntax.Literal.Literal where-  icod_ (LitNat    a b)   = icode2' a b-  icod_ (LitFloat  a b)   = icode2 1 a b-  icod_ (LitString a b)   = icode2 2 a b-  icod_ (LitChar   a b)   = icode2 3 a b-  icod_ (LitQName  a b)   = icode2 5 a b-  icod_ (LitMeta   a b c) = icode3 6 a b c+  icod_ (LitNat    a)   = icodeN' LitNat a+  icod_ (LitFloat  a)   = icodeN 1 LitFloat a+  icod_ (LitString a)   = icodeN 2 LitString a+  icod_ (LitChar   a)   = icodeN 3 LitChar a+  icod_ (LitQName  a)   = icodeN 5 LitQName a+  icod_ (LitMeta   a b) = icodeN 6 LitMeta a b+  icod_ (LitWord64 a)   = icodeN 7 LitWord64 a    value = vcase valu where-    valu [a, b]       = valu2 LitNat    a b-    valu [1, a, b]    = valu2 LitFloat  a b-    valu [2, a, b]    = valu2 LitString a b-    valu [3, a, b]    = valu2 LitChar   a b-    valu [5, a, b]    = valu2 LitQName  a b-    valu [6, a, b, c] = valu3 LitMeta   a b c+    valu [a]       = valuN LitNat    a+    valu [1, a]    = valuN LitFloat  a+    valu [2, a]    = valuN LitString a+    valu [3, a]    = valuN LitChar   a+    valu [5, a]    = valuN LitQName  a+    valu [6, a, b] = valuN LitMeta   a b+    valu [7, a]    = valuN LitWord64 a     valu _            = malformed  instance EmbPrj IsAbstract where-  icod_ AbstractDef = icode0 0-  icod_ ConcreteDef = icode0'+  icod_ AbstractDef = icodeN 0 AbstractDef+  icod_ ConcreteDef = icodeN' ConcreteDef    value = vcase valu where-    valu [0] = valu0 AbstractDef-    valu []  = valu0 ConcreteDef+    valu [0] = valuN AbstractDef+    valu []  = valuN ConcreteDef     valu _   = malformed -instance EmbPrj Delayed where-  icod_ Delayed    = icode0 0-  icod_ NotDelayed = icode0'+instance EmbPrj IsOpaque where+  icod_ (OpaqueDef a)  = icodeN' OpaqueDef a+  icod_ TransparentDef = icodeN' TransparentDef    value = vcase valu where-    valu [0] = valu0 Delayed-    valu []  = valu0 NotDelayed+    valu [a] = valuN OpaqueDef a+    valu []  = valuN TransparentDef+    valu _   = malformed++instance EmbPrj SrcLoc where+  icod_ (SrcLoc p m f sl sc el ec) = icodeN' SrcLoc p m f sl sc el ec+  value = valueN SrcLoc++instance EmbPrj CallStack where+  icod_ = icode . getCallStack+  value = (<$!>) fromCallSiteList . value++instance EmbPrj Impossible where+  icod_ (Impossible a)              = icodeN 0 Impossible a+  icod_ (Unreachable a)             = icodeN 1 Unreachable a+  icod_ (ImpMissingDefinitions a b) = icodeN 2 ImpMissingDefinitions a b++  value = vcase valu where+    valu [0, a]    = valuN Impossible  a+    valu [1, a]    = valuN Unreachable a+    valu [2, a, b] = valuN ImpMissingDefinitions a b+    valu _         = malformed++instance EmbPrj ExpandedEllipsis where+  icod_ NoEllipsis = icodeN' NoEllipsis+  icod_ (ExpandedEllipsis a b) = icodeN 1 ExpandedEllipsis a b++  value = vcase valu where+    valu []      = valuN NoEllipsis+    valu [1,a,b] = valuN ExpandedEllipsis a b+    valu _       = malformed++instance EmbPrj OptionsPragma where+  icod_ (OptionsPragma a b) = icod_ (a, b)++  value op = uncurry OptionsPragma <$!> value op++instance EmbPrj BuiltinId+instance EmbPrj PrimitiveId++instance EmbPrj SomeBuiltin where+  icod_ (BuiltinName x)   = icodeN 0 BuiltinName x+  icod_ (PrimitiveName x) = icodeN 1 PrimitiveName x++  value = vcase valu where+    valu [0, x] = valuN BuiltinName x+    valu [1, x] = valuN PrimitiveName x+    valu _      = malformed++instance EmbPrj IsInstance where+  icod_ = \case+    InstanceDef a  -> icodeN' InstanceDef a+    NotInstanceDef -> icodeN' NotInstanceDef++  value = vcase \case+    [a] -> valuN InstanceDef a+    []  -> valuN NotInstanceDef+    _ -> malformed++instance EmbPrj a => EmbPrj (RecordDirectives' a) where+  icod_ (RecordDirectives a b c d) = icodeN' RecordDirectives a b c d++  value = vcase \case+    [a, b, c, d] -> valuN RecordDirectives a b c d+    _ -> malformed++instance EmbPrj RecordDirective where+  icod_ = \case+    Constructor a b      -> icodeN 0 Constructor a b+    Eta a                -> icodeN 1 Eta a+    Induction a          -> icodeN 2 Induction a+    PatternOrCopattern a -> icodeN 3 PatternOrCopattern a++  value = vcase \case+    [0, a, b] -> valuN Constructor a b+    [1, a]    -> valuN Eta a+    [2, a]    -> valuN Induction a+    [3, a]    -> valuN PatternOrCopattern a+    _ -> malformed++instance EmbPrj Catchall where+  icod_ NoCatchall  = icodeN' NoCatchall+  icod_ (YesCatchall x) = icodeN' YesCatchall x++  value = vcase valu where+    valu []  = valuN NoCatchall+    valu [x] = valuN YesCatchall x     valu _   = malformed
src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs view
@@ -1,166 +1,27 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fno-warn-orphans     #-} {-# OPTIONS_GHC -fwarn-unused-imports #-}  module Agda.TypeChecking.Serialise.Instances.Compilers where -import qualified Data.Binary.Get as B-import qualified Data.Binary.Put as B--import qualified Agda.Compiler.Epic.Interface as Epic-import qualified Agda.Compiler.UHC.Pragmas.Base as CR-import qualified Agda.Compiler.UHC.Bridge as UHCB-import qualified Agda.Compiler.JS.Syntax as JS- import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Common ()+import Agda.TypeChecking.Serialise.Instances.Common  import Agda.TypeChecking.Monad -instance EmbPrj HaskellExport where-  icod_ (HsExport a b) = icode2' a b--  value = vcase valu where-    valu [a,b] = valu2 HsExport a b-    valu _     = malformed--instance EmbPrj HaskellRepresentation where-  icod_ (HsType a)   = icode1' a-  icod_ (HsDefn a b) = icode2' a b--  value = vcase valu where-    valu [a]    = valu1 HsType a-    valu [a, b] = valu2 HsDefn a b-    valu _      = malformed--instance EmbPrj CompiledRepresentation where-  icod_ (CompiledRep a b c d e) = icode5' a b c d e--  value = vcase valu where-    valu [a, b, c, d, e] = valu5 CompiledRep a b c d e-    valu _               = malformed--instance EmbPrj JS.Exp where-  icod_ (JS.Self)         = icode0 0-  icod_ (JS.Local i)      = icode1 1 i-  icod_ (JS.Global i)     = icode1 2 i-  icod_ (JS.Undefined)    = icode0 3-  icod_ (JS.String s)     = icode1 4 s-  icod_ (JS.Char c)       = icode1 5 c-  icod_ (JS.Integer n)    = icode1 6 n-  icod_ (JS.Double d)     = icode1 7 d-  icod_ (JS.Lambda n e)   = icode2 8 n e-  icod_ (JS.Object o)     = icode1 9 o-  icod_ (JS.Apply e es)   = icode2 10 e es-  icod_ (JS.Lookup e l)   = icode2 11 e l-  icod_ (JS.If e f g)     = icode3 12 e f g-  icod_ (JS.BinOp e op f) = icode3 13 e op f-  icod_ (JS.PreOp op e)   = icode2 14 op e-  icod_ (JS.Const i)      = icode1 15 i-  icod_ (JS.PlainJS a)    = icode1 16 a--  value = vcase valu where-    valu [0]           = valu0 JS.Self-    valu [1,  a]       = valu1 JS.Local a-    valu [2,  a]       = valu1 JS.Global a-    valu [3]           = valu0 JS.Undefined-    valu [4,  a]       = valu1 JS.String a-    valu [5,  a]       = valu1 JS.Char a-    valu [6,  a]       = valu1 JS.Integer a-    valu [7,  a]       = valu1 JS.Double a-    valu [8,  a, b]    = valu2 JS.Lambda a b-    valu [9,  a]       = valu1 JS.Object a-    valu [10, a, b]    = valu2 JS.Apply a b-    valu [11, a, b]    = valu2 JS.Lookup a b-    valu [12, a, b, c] = valu3 JS.If a b c-    valu [13, a, b, c] = valu3 JS.BinOp a b c-    valu [14, a, b]    = valu2 JS.PreOp a b-    valu [15, a]       = valu1 JS.Const a-    valu [16, a]       = valu1 JS.PlainJS a-    valu _             = malformed--instance EmbPrj JS.LocalId where-  icod_ (JS.LocalId l) = icode l-  value n              = JS.LocalId `fmap` value n--instance EmbPrj JS.GlobalId where-  icod_ (JS.GlobalId l) = icode l-  value n               = JS.GlobalId `fmap` value n--instance EmbPrj JS.MemberId where-  icod_ (JS.MemberId l) = icode l-  value n               = JS.MemberId `fmap` value n--instance EmbPrj CoreRepresentation where-  icod_ (CrDefn a)   = icode1 1 a-  icod_ (CrType a)   = icode1 2 a-  icod_ (CrConstr a) = icode1 3 a--  value = vcase valu where-    valu [1, a] = valu1 CrDefn a-    valu [2, a] = valu1 CrType a-    valu [3, a] = valu1 CrConstr a-    valu _      = malformed--instance EmbPrj CR.CoreType where-  icod_ (CR.CTMagic a) = icode1 1 a-  icod_ (CR.CTNormal a)  = icode1 2 a--  value = vcase valu where-    valu [1, a]    = valu1 CR.CTMagic a-    valu [2, a]    = valu1 CR.CTNormal a-    valu _         = malformed--instance EmbPrj CR.CoreConstr where-  icod_ (CR.CCMagic a b)    = icode2 1 a b-  icod_ (CR.CCNormal a b c) = icode3 2 a b c--  value = vcase valu where-    valu [1, a, b]    = valu2 CR.CCMagic a b-    valu [2, a, b, c] = valu3 CR.CCNormal a b c-    valu _            = malformed--instance EmbPrj CR.HsName where-  icod_   = icode . B.runPut . UHCB.serialize-  value n = value n >>= return . (B.runGet UHCB.unserialize)---- This is used for the Epic compiler backend-instance EmbPrj Epic.EInterface where-  icod_ (Epic.EInterface a b c d e f g h) = icode8' a b c d e f g h--  value = vcase valu where-    valu [a, b, c, d, e, f, g, h] = valu8 Epic.EInterface a b c d e f g h-    valu _                        = malformed--instance EmbPrj Epic.InjectiveFun where-  icod_ (Epic.InjectiveFun a b) = icode2' a b--  value = vcase valu where-    valu [a,b] = valu2 Epic.InjectiveFun a b-    valu _     = malformed--instance EmbPrj Epic.Relevance where-  icod_ Epic.Irr = icode0 0-  icod_ Epic.Rel = icode0 1--  value = vcase valu where-    valu [0] = valu0 Epic.Irr-    valu [1] = valu0 Epic.Rel-    valu _   = malformed+instance EmbPrj CompilerPragma where+  icod_ (CompilerPragma a b) =+    icodeN' (CompilerPragma . underlyingRange) (SerialisedRange a) b -instance EmbPrj Epic.Forced where-  icod_ Epic.Forced    = icode0 0-  icod_ Epic.NotForced = icode0 1+  value = valueN (CompilerPragma . underlyingRange) -  value = vcase valu where-    valu [0] = valu0 Epic.Forced-    valu [1] = valu0 Epic.NotForced-    valu _   = malformed+instance EmbPrj ForeignCode where+  icod_ (ForeignCode r a) =+    icodeN' (ForeignCode . underlyingRange) (SerialisedRange r) a -instance EmbPrj Epic.Tag where-  icod_ (Epic.Tag a)     = icode1 0 a-  icod_ (Epic.PrimTag a) = icode1 1 a+  value = valueN (ForeignCode . underlyingRange) -  value = vcase valu where-    valu [0, a] = valu1 Epic.Tag a-    valu [1, a] = valu1 Epic.PrimTag a-    valu _      = malformed+instance EmbPrj ForeignCodeStack where+  icod_ = icod_ . getForeignCodeStack+  value = fmap ForeignCodeStack . value
+ src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs view
@@ -0,0 +1,493 @@+{-# OPTIONS_GHC -fno-warn-orphans     #-}++module Agda.TypeChecking.Serialise.Instances.Errors where++import Control.Monad++import Agda.TypeChecking.Serialise.Base+import Agda.TypeChecking.Serialise.Instances.Common   ( SerialisedRange(..) )+import Agda.TypeChecking.Serialise.Instances.Internal () --instance only+import Agda.TypeChecking.Serialise.Instances.Abstract () --instance only++import Agda.Syntax.Concrete.Definitions.Errors+    ( DeclarationWarning(..), DeclarationWarning'(..), OpenOrImport(..) )+import Agda.Syntax.Parser.Monad+import Agda.TypeChecking.Monad.Base+import qualified Agda.TypeChecking.Monad.Base.Warning as W+import Agda.Interaction.Options+import Agda.Interaction.Options.Warnings+import Agda.Interaction.Library.Base+import Agda.Termination.CutOff+import Agda.Syntax.Common.Pretty+import Agda.Utils.ProfileOptions++import Agda.Utils.Impossible++instance EmbPrj IsAmbiguous where+  icod_ = \case+    YesAmbiguous a -> icodeN' YesAmbiguous a+    NotAmbiguous   -> icodeN' NotAmbiguous++  value = vcase \case+    [a] -> valuN YesAmbiguous a+    []  -> valuN NotAmbiguous+    _   -> malformed++instance EmbPrj TCWarning where+  icod_ (TCWarning fp r a b c d) = icodeN' (\ fp -> TCWarning fp . underlyingRange) fp (SerialisedRange r) a b c d+  value = valueN (\ fp -> TCWarning fp . underlyingRange)++-- We don't need to serialise warnings that turn into errors+instance EmbPrj Warning where+  icod_ = \case+    TerminationIssue a                    -> __IMPOSSIBLE__+    UnreachableClauses a b                -> icodeN 0 UnreachableClauses a b+    CoverageIssue a b                     -> __IMPOSSIBLE__+    NotStrictlyPositive a b               -> __IMPOSSIBLE__+    ConstructorDoesNotFitInData{}         -> __IMPOSSIBLE__+    UnsolvedMetaVariables a               -> __IMPOSSIBLE__+    UnsolvedInteractionMetas a            -> __IMPOSSIBLE__+    UnsolvedConstraints a                 -> __IMPOSSIBLE__+    InteractionMetaBoundaries a           -> __IMPOSSIBLE__+    OldBuiltin a b                        -> icodeN 1 OldBuiltin a b+    EmptyRewritePragma                    -> icodeN 2 EmptyRewritePragma+    UselessPublic a                       -> icodeN 3 UselessPublic a+    UselessInline a                       -> icodeN 4 UselessInline a+    InvalidCharacterLiteral a             -> __IMPOSSIBLE__+    SafeFlagPostulate a                   -> __IMPOSSIBLE__+    SafeFlagPragma a                      -> __IMPOSSIBLE__+    SafeFlagWithoutKFlagPrimEraseEquality -> __IMPOSSIBLE__+    DuplicateRecordDirective a            -> icodeN 5 DuplicateRecordDirective a+    DeprecationWarning a b c              -> icodeN 6 DeprecationWarning a b c+    NicifierIssue a                       -> icodeN 7 NicifierIssue a+    InversionDepthReached a               -> icodeN 8 InversionDepthReached a+    UserWarning a                         -> icodeN 9 UserWarning a+    AbsurdPatternRequiresAbsentRHS        -> icodeN 10 AbsurdPatternRequiresAbsentRHS+    ModuleDoesntExport a b c d            -> icodeN 11 ModuleDoesntExport a b c d+    LibraryWarning a                      -> icodeN 12 LibraryWarning a+    CoverageNoExactSplit a b              -> icodeN 13 CoverageNoExactSplit a b+    CantGeneralizeOverSorts a             -> icodeN 14 CantGeneralizeOverSorts a+    IllformedAsClause a                   -> icodeN 15 IllformedAsClause a+    WithoutKFlagPrimEraseEquality         -> icodeN 16 WithoutKFlagPrimEraseEquality+    InstanceWithExplicitArg a             -> icodeN 17 InstanceWithExplicitArg a+    InfectiveImport a                     -> icodeN 18 InfectiveImport a+    CoInfectiveImport a                   -> icodeN 19 CoInfectiveImport a+    InstanceNoOutputTypeName a            -> icodeN 20 InstanceNoOutputTypeName a+    InstanceArgWithExplicitArg a          -> icodeN 21 InstanceArgWithExplicitArg a+    WrongInstanceDeclaration              -> icodeN 22 WrongInstanceDeclaration+    RewriteNonConfluent a b c d           -> icodeN 23 RewriteNonConfluent a b c d+    RewriteMaybeNonConfluent a b c        -> icodeN 24 RewriteMaybeNonConfluent a b c+    PragmaCompileErased a b               -> icodeN 25 PragmaCompileErased a b+    FixityInRenamingModule a              -> icodeN 26 FixityInRenamingModule a+    NotInScopeW a                         -> icodeN 27 NotInScopeW a+    ClashesViaRenaming a b                -> icodeN 28 ClashesViaRenaming a b+    RecordFieldWarning a                  -> icodeN 29 RecordFieldWarning a+    UselessPatternDeclarationForRecord a  -> icodeN 30 UselessPatternDeclarationForRecord a+    EmptyWhere                            -> icodeN 31 EmptyWhere+    AsPatternShadowsConstructorOrPatternSynonym a -> icodeN 32 AsPatternShadowsConstructorOrPatternSynonym a+    DuplicateUsing a                      -> icodeN 33 DuplicateUsing a+    UselessHiding a                       -> icodeN 34 UselessHiding a+    UselessPragma a b                     -> icodeN 35 UselessPragma a b+    RewriteAmbiguousRules a b c           -> icodeN 36 RewriteAmbiguousRules a b c+    RewriteMissingRule a b c              -> icodeN 37 RewriteMissingRule a b c+    ParseWarning a                        -> icodeN 38 ParseWarning a+    UselessTactic                         -> icodeN 39 UselessTactic+    UnsupportedIndexedMatch f             -> icodeN 40 UnsupportedIndexedMatch f+    OptionWarning a                       -> icodeN 41 OptionWarning a+    PlentyInHardCompileTimeMode a         -> icodeN 42 PlentyInHardCompileTimeMode a+    NotAffectedByOpaque                   -> icodeN 43 NotAffectedByOpaque+    UnfoldTransparentName nm              -> icodeN 44 UnfoldTransparentName nm+    UselessOpaque                         -> icodeN 45 UselessOpaque+    InlineNoExactSplit a b                -> icodeN 46 InlineNoExactSplit a b+    FaceConstraintCannotBeHidden a        -> icodeN 47 FaceConstraintCannotBeHidden a+    FaceConstraintCannotBeNamed a         -> icodeN 48 FaceConstraintCannotBeNamed a+    PatternShadowsConstructor a b         -> icodeN 49 PatternShadowsConstructor a b+    ConfluenceCheckingIncompleteBecauseOfMeta a -> icodeN 50 ConfluenceCheckingIncompleteBecauseOfMeta a+    BuiltinDeclaresIdentifier a                 -> icodeN 51 BuiltinDeclaresIdentifier a+    ConfluenceForCubicalNotSupported            -> icodeN 52 ConfluenceForCubicalNotSupported+    -- We do not need to serialize compiler warnings:+    PragmaCompileList                           -> __IMPOSSIBLE__+    PragmaCompileMaybe                          -> __IMPOSSIBLE__+    NoMain _                                    -> __IMPOSSIBLE__+    IllegalRewriteRule a b                      -> icodeN 53 IllegalRewriteRule a b+    MissingTypeSignatureForOpaque a b           -> icodeN 54 MissingTypeSignatureForOpaque a b+    ConflictingPragmaOptions a b                -> icodeN 55 ConflictingPragmaOptions a b+    CustomBackendWarning a b                    -> icodeN 56 CustomBackendWarning a b+    CoinductiveEtaRecord a                      -> icodeN 57 CoinductiveEtaRecord a+    WithClauseProjectionFixityMismatch a b c d  -> icodeN 58 WithClauseProjectionFixityMismatch a b c d+    InvalidDisplayForm a b                      -> icodeN 59 InvalidDisplayForm a b+    TooManyArgumentsToSort a b                  -> __IMPOSSIBLE__+    NotARewriteRule a b                         -> icodeN 60 NotARewriteRule a b+    PragmaCompileWrongName a b                  -> icodeN 61 PragmaCompileWrongName a b+    PragmaCompileUnparsable a                   -> icodeN 62 PragmaCompileUnparsable a+    PragmaCompileWrong a b                      -> icodeN 63 PragmaCompileWrong a b+    PragmaExpectsUnambiguousConstructorOrFunction a b c ->+      icodeN 64 PragmaExpectsUnambiguousConstructorOrFunction a b c+    PragmaExpectsUnambiguousProjectionOrFunction a b c ->+      icodeN 65 PragmaExpectsUnambiguousProjectionOrFunction a b c+    PragmaExpectsDefinedSymbol a b              -> icodeN 66 PragmaExpectsDefinedSymbol a b+    UnfoldingWrongName a                        -> icodeN 67 UnfoldingWrongName a+    -- TODO: linearity+    -- FixingQuantity a b c                        -> icodeN 68 FixingQuantity a b c+    FixingRelevance a b c                       -> icodeN 69 FixingRelevance a b c+    UnusedVariablesInDisplayForm a              -> icodeN 70 UnusedVariablesInDisplayForm a+    HiddenNotInArgumentPosition a               -> __IMPOSSIBLE__+    InstanceNotInArgumentPosition a             -> __IMPOSSIBLE__+    MacroInLetBindings                          -> __IMPOSSIBLE__+    AbstractInLetBindings                       -> __IMPOSSIBLE__+    TopLevelPolarity a b                        -> __IMPOSSIBLE__+    TooManyPolarities a b                       -> icodeN 71 TooManyPolarities a b+    FixingCohesion a b c                        -> icodeN 72 FixingCohesion a b c+    FixingPolarity a b c                        -> icodeN 73 FixingPolarity a b c+    RewritesNothing                             -> icodeN 74 RewritesNothing++  value = vcase $ \ case+    [0, a, b]            -> valuN UnreachableClauses a b+    [1, a, b]            -> valuN OldBuiltin a b+    [2]                  -> valuN EmptyRewritePragma+    [3, a]               -> valuN UselessPublic a+    [4, a]               -> valuN UselessInline a+    [5, a]               -> valuN DuplicateRecordDirective a+    [6, a, b, c]         -> valuN DeprecationWarning a b c+    [7, a]               -> valuN NicifierIssue a+    [8, a]               -> valuN InversionDepthReached a+    [9, a]               -> valuN UserWarning a+    [10]                 -> valuN AbsurdPatternRequiresAbsentRHS+    [11, a, b, c, d]     -> valuN ModuleDoesntExport a b c d+    [12, a]              -> valuN LibraryWarning a+    [13, a, b]           -> valuN CoverageNoExactSplit a b+    [14, a]              -> valuN CantGeneralizeOverSorts a+    [15, a]              -> valuN IllformedAsClause a+    [16]                 -> valuN WithoutKFlagPrimEraseEquality+    [17, a]              -> valuN InstanceWithExplicitArg a+    [18, a]              -> valuN InfectiveImport a+    [19, a]              -> valuN CoInfectiveImport a+    [20, a]              -> valuN InstanceNoOutputTypeName a+    [21, a]              -> valuN InstanceArgWithExplicitArg a+    [22]                 -> valuN WrongInstanceDeclaration+    [23, a, b, c, d]     -> valuN RewriteNonConfluent a b c d+    [24, a, b, c]        -> valuN RewriteMaybeNonConfluent a b c+    [25, a, b]           -> valuN PragmaCompileErased a b+    [26, a]              -> valuN FixityInRenamingModule a+    [27, a]              -> valuN NotInScopeW a+    [28, a, b]           -> valuN ClashesViaRenaming a b+    [29, a]              -> valuN RecordFieldWarning a+    [30, a]              -> valuN UselessPatternDeclarationForRecord a+    [31]                 -> valuN EmptyWhere+    [32, a]              -> valuN AsPatternShadowsConstructorOrPatternSynonym a+    [33, a]              -> valuN DuplicateUsing a+    [34, a]              -> valuN UselessHiding a+    [35, a, b]           -> valuN UselessPragma a b+    [36, a, b, c]        -> valuN RewriteAmbiguousRules a b c+    [37, a, b, c]        -> valuN RewriteMissingRule a b c+    [38, a]              -> valuN ParseWarning a+    [39]                 -> valuN UselessTactic+    [40, a]              -> valuN UnsupportedIndexedMatch a+    [41, a]              -> valuN OptionWarning a+    [42, a]              -> valuN PlentyInHardCompileTimeMode a+    [43]                 -> valuN NotAffectedByOpaque+    [44, a]              -> valuN UnfoldTransparentName a+    [45]                 -> valuN UselessOpaque+    [46, a, b]           -> valuN InlineNoExactSplit a b+    [47, a]              -> valuN FaceConstraintCannotBeHidden a+    [48, a]              -> valuN FaceConstraintCannotBeNamed a+    [49, a, b]           -> valuN PatternShadowsConstructor a b+    [50, a]              -> valuN ConfluenceCheckingIncompleteBecauseOfMeta a+    [51, a]              -> valuN BuiltinDeclaresIdentifier a+    [52]                 -> valuN ConfluenceForCubicalNotSupported+    [53, a, b]           -> valuN IllegalRewriteRule a b+    [54, a, b]           -> valuN MissingTypeSignatureForOpaque a b+    [55, a, b]           -> valuN ConflictingPragmaOptions a b+    [56, a, b]           -> valuN CustomBackendWarning a b+    [57, a]              -> valuN CoinductiveEtaRecord a+    [58, a, b, c, d]     -> valuN WithClauseProjectionFixityMismatch a b c d+    [59, a, b]           -> valuN InvalidDisplayForm a b+    [60, a, b]           -> valuN NotARewriteRule a b+    [61, a, b]           -> valuN PragmaCompileWrongName a b+    [62, a]              -> valuN PragmaCompileUnparsable a+    [63, a, b]           -> valuN PragmaCompileWrong a b+    [64, a, b, c]        -> valuN PragmaExpectsUnambiguousConstructorOrFunction a b c+    [65, a, b, c]        -> valuN PragmaExpectsUnambiguousProjectionOrFunction a b c+    [66, a, b]           -> valuN PragmaExpectsDefinedSymbol a b+    [67, a]              -> valuN UnfoldingWrongName a+    -- TODO: linearity+    -- [68, a, b, c]        -> valuN FixingQuantity a b c+    [69, a, b, c]        -> valuN FixingRelevance a b c+    [70, a]              -> valuN UnusedVariablesInDisplayForm a+    [71, a, b]           -> valuN TooManyPolarities a b+    [72, a, b, c]        -> valuN FixingCohesion a b c+    [73, a, b, c]        -> valuN FixingPolarity a b c+    [74]                 -> valuN RewritesNothing+    _ -> malformed++instance EmbPrj UselessPublicReason++instance EmbPrj IllegalRewriteRuleReason where+  icod_ = \case+    LHSNotDefinitionOrConstructor               -> icodeN 0 LHSNotDefinitionOrConstructor+    VariablesNotBoundByLHS a                    -> icodeN 1 VariablesNotBoundByLHS a+    VariablesBoundMoreThanOnce a                -> icodeN 2 VariablesBoundMoreThanOnce a+    LHSReduces a b                              -> icodeN 3 LHSReduces a b+    -- 4 was HeadSymbolIsProjection+    HeadSymbolIsProjectionLikeFunction a        -> icodeN 5 HeadSymbolIsProjectionLikeFunction a+    HeadSymbolIsTypeConstructor a               -> icodeN 6 HeadSymbolIsTypeConstructor a+    HeadSymbolContainsMetas a                   -> icodeN 7 HeadSymbolContainsMetas a+    ConstructorParametersNotGeneral a b         -> icodeN 8 ConstructorParametersNotGeneral a b+    ContainsUnsolvedMetaVariables a             -> icodeN 9 ContainsUnsolvedMetaVariables a+    BlockedOnProblems a                         -> icodeN 10 BlockedOnProblems a+    RequiresDefinitions a                       -> icodeN 11 RequiresDefinitions a+    DoesNotTargetRewriteRelation                -> icodeN 12 DoesNotTargetRewriteRelation+    BeforeFunctionDefinition                    -> icodeN 13 BeforeFunctionDefinition+    BeforeMutualFunctionDefinition a            -> icodeN 14 BeforeMutualFunctionDefinition a+    DuplicateRewriteRule                        -> icodeN 15 DuplicateRewriteRule++  value = vcase $ \case+    [0]       -> valuN LHSNotDefinitionOrConstructor+    [1, a]    -> valuN VariablesNotBoundByLHS a+    [2, a]    -> valuN VariablesBoundMoreThanOnce a+    [3, a, b] -> valuN LHSReduces a b+    -- 4 was HeadSymbolIsProjection+    [5, a]    -> valuN HeadSymbolIsProjectionLikeFunction a+    [6, a]    -> valuN HeadSymbolIsTypeConstructor a+    [7, a]    -> valuN HeadSymbolContainsMetas a+    [8, a, b] -> valuN ConstructorParametersNotGeneral a b+    [9, a]    -> valuN ContainsUnsolvedMetaVariables a+    [10, a]   -> valuN BlockedOnProblems a+    [11, a]   -> valuN RequiresDefinitions a+    [12]      -> valuN DoesNotTargetRewriteRelation+    [13]      -> valuN BeforeFunctionDefinition+    [14, a]   -> valuN BeforeMutualFunctionDefinition a+    [15]      -> valuN DuplicateRewriteRule+    _ -> malformed++instance EmbPrj OptionWarning where+  icod_ = \case+    OptionRenamed a b -> icodeN 0 OptionRenamed a b+    WarningProblem a  -> icodeN 1 WarningProblem a++  value = vcase $ \case+    [0, a, b] -> valuN OptionRenamed a b+    [1, a]    -> valuN WarningProblem a+    _ -> malformed++instance EmbPrj WarningModeError where+  icod_ = \case+    Unknown a   -> icodeN 0 Unknown a+    NoNoError a -> icodeN 1 NoNoError a++  value = vcase $ \case+    [0, a] -> valuN Unknown a+    [1, a] -> valuN NoNoError a+    _ -> malformed++instance EmbPrj ParseWarning where+  icod_ = \case+    OverlappingTokensWarning a -> icodeN 0 OverlappingTokensWarning a+    UnsupportedAttribute a b   -> icodeN 1 UnsupportedAttribute a b+    MultipleAttributes a b     -> icodeN 2 MultipleAttributes a b+    UnknownAttribute a b       -> icodeN 3 UnknownAttribute a b+    UnknownPolarity a b        -> icodeN 4 UnknownPolarity a b+    MisplacedAttributes a b    -> icodeN 5 MisplacedAttributes a b++  value = vcase $ \case+    [0, a]    -> valuN OverlappingTokensWarning a+    [1, a, b] -> valuN UnsupportedAttribute a b+    [2, a, b] -> valuN MultipleAttributes a b+    [3, a, b] -> valuN UnknownAttribute a b+    [4, a, b] -> valuN UnknownPolarity a b+    [5, a, b] -> valuN MisplacedAttributes a b+    _ -> malformed++instance EmbPrj RecordFieldWarning where+  icod_ = \case+    W.DuplicateFields a   -> icodeN 0 W.DuplicateFields a+    W.TooManyFields a b c -> icodeN 1 W.TooManyFields a b c++  value = vcase $ \case+    [0, a]       -> valuN W.DuplicateFields a+    [1, a, b, c] -> valuN W.TooManyFields a b c+    _ -> malformed++instance EmbPrj DeclarationWarning where+  icod_ (DeclarationWarning a b) = icodeN' DeclarationWarning a b+  value = vcase $ \case+    [a, b] -> valuN DeclarationWarning a b+    _ -> malformed++instance EmbPrj DeclarationWarning' where+  icod_ = \case+    UnknownNamesInFixityDecl a        -> icodeN 0 UnknownNamesInFixityDecl a+    UnknownNamesInPolarityPragmas a   -> icodeN 1 UnknownNamesInPolarityPragmas a+    PolarityPragmasButNotPostulates a -> icodeN 2 PolarityPragmasButNotPostulates a+    UselessPrivate a                  -> icodeN 3 UselessPrivate a+    UselessAbstract a                 -> icodeN 4 UselessAbstract a+    UselessInstance a                 -> icodeN 5 UselessInstance a+    EmptyMutual a                     -> icodeN 6 EmptyMutual a+    EmptyAbstract a                   -> icodeN 7 EmptyAbstract a+    EmptyPrivate a                    -> icodeN 8 EmptyPrivate a+    EmptyInstance a                   -> icodeN 9 EmptyInstance a+    EmptyMacro a                      -> icodeN 10 EmptyMacro a+    EmptyPostulate a                  -> icodeN 11 EmptyPostulate a+    InvalidTerminationCheckPragma a   -> icodeN 12 InvalidTerminationCheckPragma a+    InvalidNoPositivityCheckPragma a  -> icodeN 13 InvalidNoPositivityCheckPragma a+    InvalidCatchallPragma a           -> icodeN 14 InvalidCatchallPragma a+    InvalidNoUniverseCheckPragma a    -> icodeN 15 InvalidNoUniverseCheckPragma a+    UnknownFixityInMixfixDecl a       -> icodeN 16 UnknownFixityInMixfixDecl a+    MissingDefinitions a              -> icodeN 17 MissingDefinitions a+    NotAllowedInMutual r a            -> icodeN 18 NotAllowedInMutual r a+    PragmaNoTerminationCheck r        -> icodeN 19 PragmaNoTerminationCheck r+    EmptyGeneralize a                 -> icodeN 20 EmptyGeneralize a+    PragmaCompiled r                  -> icodeN 21 PragmaCompiled r+    EmptyPrimitive a                  -> icodeN 22 EmptyPrimitive a+    EmptyField r                      -> icodeN 23 EmptyField r+    ShadowingInTelescope nrs          -> icodeN 24 ShadowingInTelescope nrs+    InvalidCoverageCheckPragma r      -> icodeN 25 InvalidCoverageCheckPragma r+    OpenImportAbstract r kwr a        -> icodeN 26 OpenImportAbstract r kwr a+    OpenImportPrivate r kwr kwr' a    -> icodeN 27 OpenImportPrivate r kwr kwr' a+    EmptyConstructor a                -> icodeN 28 EmptyConstructor a+    -- 29 removed+    -- 30 removed+    InvalidConstructorBlock a         -> icodeN 31 InvalidConstructorBlock a+    MissingDataDeclaration a          -> icodeN 32 MissingDataDeclaration a+    HiddenGeneralize r                -> icodeN 33 HiddenGeneralize r+    UselessMacro r                    -> icodeN 34 UselessMacro r+    SafeFlagEta                    {} -> __IMPOSSIBLE__+    SafeFlagInjective              {} -> __IMPOSSIBLE__+    SafeFlagNoCoverageCheck        {} -> __IMPOSSIBLE__+    SafeFlagNoPositivityCheck      {} -> __IMPOSSIBLE__+    SafeFlagNoUniverseCheck        {} -> __IMPOSSIBLE__+    SafeFlagNonTerminating         {} -> __IMPOSSIBLE__+    SafeFlagPolarity               {} -> __IMPOSSIBLE__+    SafeFlagTerminating            {} -> __IMPOSSIBLE__+    EmptyPolarityPragma r             -> icodeN 35 EmptyPolarityPragma r++  value = vcase $ \case+    [0, a]   -> valuN UnknownNamesInFixityDecl a+    [1, a]   -> valuN UnknownNamesInPolarityPragmas a+    [2, a]   -> valuN PolarityPragmasButNotPostulates a+    [3, a]   -> valuN UselessPrivate a+    [4, a]   -> valuN UselessAbstract a+    [5, a]   -> valuN UselessInstance a+    [6, a]   -> valuN EmptyMutual a+    [7, a]   -> valuN EmptyAbstract a+    [8, a]   -> valuN EmptyPrivate a+    [9, a]   -> valuN EmptyInstance a+    [10,a]   -> valuN EmptyMacro a+    [11,a]   -> valuN EmptyPostulate a+    [12,a]   -> valuN InvalidTerminationCheckPragma a+    [13,a]   -> valuN InvalidNoPositivityCheckPragma a+    [14,a]   -> valuN InvalidCatchallPragma a+    [15,a]   -> valuN InvalidNoUniverseCheckPragma a+    [16,a]   -> valuN UnknownFixityInMixfixDecl a+    [17,a]   -> valuN MissingDefinitions a+    [18,r,a] -> valuN NotAllowedInMutual r a+    [19,r]   -> valuN PragmaNoTerminationCheck r+    [20,a]   -> valuN EmptyGeneralize a+    [21,a]   -> valuN PragmaCompiled a+    [22,a]   -> valuN EmptyPrimitive a+    [23,r]   -> valuN EmptyField r+    [24,nrs] -> valuN ShadowingInTelescope nrs+    [25,r]   -> valuN InvalidCoverageCheckPragma r+    [26,r,kwr,a] -> valuN OpenImportAbstract r kwr a+    [27,r,kwr,kwr',a] -> valuN OpenImportPrivate r kwr kwr' a+    [28,r]   -> valuN EmptyConstructor r+    -- 29 removed+    -- 30 removed+    [31,r]   -> valuN InvalidConstructorBlock r+    [32,r]   -> valuN MissingDataDeclaration r+    [33,r]   -> valuN HiddenGeneralize r+    [34,r]   -> valuN UselessMacro r+    [35,r]   -> valuN EmptyPolarityPragma r+    _ -> malformed++instance EmbPrj OpenOrImport++instance EmbPrj LibWarning where+  icod_ = \case+    LibWarning a b -> icodeN 0 LibWarning a b++  value = vcase $ \case+    [0, a, b]   -> valuN LibWarning a b+    _ -> malformed++instance EmbPrj LibWarning' where+  icod_ = \case+    UnknownField     a   -> icodeN 0 UnknownField a++  value = vcase $ \case+    [0, a]    -> valuN UnknownField a+    _ -> malformed++instance EmbPrj ExecutablesFile where+  icod_ = \case+    ExecutablesFile a b -> icodeN 0 ExecutablesFile a b++  value = vcase $ \case+    [0, a, b] -> valuN ExecutablesFile a b+    _ -> malformed++instance EmbPrj LibPositionInfo where+  icod_ = \case+    LibPositionInfo a b c -> icodeN 0 LibPositionInfo a b c++  value = vcase $ \case+    [0, a, b, c] -> valuN LibPositionInfo a b c+    _ -> malformed++instance EmbPrj Doc where+  icod_ d = icodeN' (undefined :: String -> Doc) (render d)++  value = valueN text++instance EmbPrj InfectiveCoinfective where+  icod_ Infective   = icodeN' Infective+  icod_ Coinfective = icodeN 0 Coinfective++  value = vcase valu where+    valu []  = valuN Infective+    valu [0] = valuN Coinfective+    valu _   = malformed++instance EmbPrj PragmaOptions where+  icod_    (PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ddd eee fff ggg hhh iii jjj kkk lll mmm nnn ooo ppp qqq rrr sss) =+    icodeN' PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ddd eee fff ggg hhh iii jjj kkk lll mmm nnn ooo ppp qqq rrr sss++  value = valueN PragmaOptions++instance EmbPrj ProfileOptions where+  icod_ opts = icode (profileOptionsToList opts)+  value = fmap profileOptionsFromList . value++instance EmbPrj ProfileOption++instance EmbPrj LHSOrPatSyn++instance EmbPrj UnicodeOrAscii++instance EmbPrj ConfluenceCheck where+  icod_ LocalConfluenceCheck  = icodeN' LocalConfluenceCheck+  icod_ GlobalConfluenceCheck = icodeN 0 GlobalConfluenceCheck++  value = vcase valu where+    valu []  = valuN LocalConfluenceCheck+    valu [0] = valuN GlobalConfluenceCheck+    valu _   = malformed++instance EmbPrj WarningMode where+  icod_ (WarningMode a b) = icodeN' WarningMode a b++  value = valueN WarningMode++-- Andreas, 2024-08-18+-- Removed manual implementation of EmbPrj for this Enum type.+instance EmbPrj WarningName++instance EmbPrj CutOff where+  icod_ = \case+    DontCutOff -> icodeN' DontCutOff+    CutOff a -> icodeN 0 CutOff a++  value = vcase valu where+    valu [] = valuN DontCutOff+    valu [0,a] = valuN CutOff a+    valu _ = malformed
src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs view
@@ -1,97 +1,158 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Serialise.Instances.Highlighting where +import qualified Data.Map.Strict as Map+import Data.Strict.Tuple (Pair(..))+import Data.Word (Word32)+ import qualified Agda.Interaction.Highlighting.Range   as HR import qualified Agda.Interaction.Highlighting.Precise as HP+import qualified Agda.Utils.RangeMap                   as RM  import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Common ()+import Agda.TypeChecking.Serialise.Instances.Common () --instance only  instance EmbPrj HR.Range where-  icod_ (HR.Range a b) = icode2' a b+  icod_ (HR.Range a b) = icodeN' HR.Range a b -  value = vcase valu where-    valu [a, b] = valu2 HR.Range a b-    valu _      = malformed+  value = valueN HR.Range  instance EmbPrj HP.NameKind where-  icod_ HP.Bound           = icode0'-  icod_ (HP.Constructor a) = icode1 1 a-  icod_ HP.Datatype        = icode0 2-  icod_ HP.Field           = icode0 3-  icod_ HP.Function        = icode0 4-  icod_ HP.Module          = icode0 5-  icod_ HP.Postulate       = icode0 6-  icod_ HP.Primitive       = icode0 7-  icod_ HP.Record          = icode0 8-  icod_ HP.Argument        = icode0 9-  icod_ HP.Macro           = icode0 10+  icod_ HP.Bound           = icodeN' HP.Bound+  icod_ (HP.Constructor a) = icodeN 1 HP.Constructor a+  icod_ HP.Datatype        = icodeN 2 ()+  icod_ HP.Field           = icodeN 3 ()+  icod_ HP.Function        = icodeN 4 ()+  icod_ HP.Module          = icodeN 5 ()+  icod_ HP.Postulate       = icodeN 6 ()+  icod_ HP.Primitive       = icodeN 7 ()+  icod_ HP.Record          = icodeN 8 ()+  icod_ HP.Argument        = icodeN 9 ()+  icod_ HP.Macro           = icodeN 10 ()+  icod_ HP.Generalizable   = icodeN 11 ()    value = vcase valu where-    valu []      = valu0 HP.Bound-    valu [1 , a] = valu1 HP.Constructor a-    valu [2]     = valu0 HP.Datatype-    valu [3]     = valu0 HP.Field-    valu [4]     = valu0 HP.Function-    valu [5]     = valu0 HP.Module-    valu [6]     = valu0 HP.Postulate-    valu [7]     = valu0 HP.Primitive-    valu [8]     = valu0 HP.Record-    valu [9]     = valu0 HP.Argument-    valu [10]    = valu0 HP.Macro+    valu []      = valuN HP.Bound+    valu [1 , a] = valuN HP.Constructor a+    valu [2]     = valuN HP.Datatype+    valu [3]     = valuN HP.Field+    valu [4]     = valuN HP.Function+    valu [5]     = valuN HP.Module+    valu [6]     = valuN HP.Postulate+    valu [7]     = valuN HP.Primitive+    valu [8]     = valuN HP.Record+    valu [9]     = valuN HP.Argument+    valu [10]    = valuN HP.Macro+    valu [11]    = valuN HP.Generalizable     valu _       = malformed  instance EmbPrj HP.Aspect where-  icod_ HP.Comment       = icode0 0-  icod_ HP.Keyword       = icode0 1-  icod_ HP.String        = icode0 2-  icod_ HP.Number        = icode0 3-  icod_ HP.Symbol        = icode0'-  icod_ HP.PrimitiveType = icode0 5-  icod_ (HP.Name mk b)   = icode2 6 mk b+  icod_ HP.Comment        = icodeN 0 ()+  icod_ HP.Keyword       = icodeN 1 ()+  icod_ HP.String        = icodeN 2 ()+  icod_ HP.Number        = icodeN 3 ()+  icod_ HP.Symbol        = icodeN' HP.Symbol+  icod_ HP.PrimitiveType = icodeN 4 ()+  icod_ (HP.Name mk b)   = icodeN 5 HP.Name mk b+  icod_ HP.Pragma        = icodeN 6 ()+  icod_ HP.Background    = icodeN 7 ()+  icod_ HP.Markup        = icodeN 8 ()+  icod_ HP.Hole          = icodeN 9 ()    value = vcase valu where-    valu [0]        = valu0 HP.Comment-    valu [1]        = valu0 HP.Keyword-    valu [2]        = valu0 HP.String-    valu [3]        = valu0 HP.Number-    valu []         = valu0 HP.Symbol-    valu [5]        = valu0 HP.PrimitiveType-    valu [6, mk, b] = valu2 HP.Name mk b+    valu [0]        = valuN HP.Comment+    valu [1]        = valuN HP.Keyword+    valu [2]        = valuN HP.String+    valu [3]        = valuN HP.Number+    valu []         = valuN HP.Symbol+    valu [4]        = valuN HP.PrimitiveType+    valu [5, mk, b] = valuN HP.Name mk b+    valu [6]        = valuN HP.Pragma+    valu [7]        = valuN HP.Background+    valu [8]        = valuN HP.Markup+    valu [9]        = valuN HP.Hole     valu _          = malformed  instance EmbPrj HP.OtherAspect where-  icod_ HP.Error              = icode0 0-  icod_ HP.DottedPattern      = icode0'-  icod_ HP.UnsolvedMeta       = icode0 2-  icod_ HP.TerminationProblem = icode0 3-  icod_ HP.IncompletePattern  = icode0 4-  icod_ HP.TypeChecks         = icode0 5-  icod_ HP.UnsolvedConstraint = icode0 6-  icod_ HP.PositivityProblem  = icode0 7+  icod_ HP.Error                = pure 0+  icod_ HP.ErrorWarning         = pure 1+  icod_ HP.DottedPattern        = pure 2+  icod_ HP.UnsolvedMeta         = pure 3+  icod_ HP.TerminationProblem   = pure 4+  icod_ HP.IncompletePattern    = pure 5+  icod_ HP.TypeChecks           = pure 6+  icod_ HP.UnsolvedConstraint   = pure 7+  icod_ HP.PositivityProblem    = pure 8+  icod_ HP.Deadcode             = pure 9+  icod_ HP.CoverageProblem      = pure 10+  icod_ HP.CatchallClause       = pure 11+  icod_ HP.ConfluenceProblem    = pure 12+  icod_ HP.MissingDefinition    = pure 13+  icod_ HP.ShadowingInTelescope = pure 14+  icod_ HP.CosmeticProblem      = pure 15+  icod_ HP.InstanceProblem      = pure 16 -  value = vcase valu where-    valu [0] = valu0 HP.Error-    valu []  = valu0 HP.DottedPattern-    valu [2] = valu0 HP.UnsolvedMeta-    valu [3] = valu0 HP.TerminationProblem-    valu [4] = valu0 HP.IncompletePattern-    valu [5] = valu0 HP.TypeChecks-    valu [6] = valu0 HP.UnsolvedConstraint-    valu [7] = valu0 HP.PositivityProblem-    valu _   = malformed+  value = \case+    0  -> pure HP.Error+    1  -> pure HP.ErrorWarning+    2  -> pure HP.DottedPattern+    3  -> pure HP.UnsolvedMeta+    4  -> pure HP.TerminationProblem+    5  -> pure HP.IncompletePattern+    6  -> pure HP.TypeChecks+    7  -> pure HP.UnsolvedConstraint+    8  -> pure HP.PositivityProblem+    9  -> pure HP.Deadcode+    10 -> pure HP.CoverageProblem+    11 -> pure HP.CatchallClause+    12 -> pure HP.ConfluenceProblem+    13 -> pure HP.MissingDefinition+    14 -> pure HP.ShadowingInTelescope+    15 -> pure HP.CosmeticProblem+    16 -> pure HP.InstanceProblem+    _  -> malformed  instance EmbPrj HP.Aspects where-  icod_ (HP.Aspects a b c d) = icode4' a b c d+  icod_ (HP.Aspects a b c d e) = icodeN' HP.Aspects a b c d e -  value = vcase valu where-    valu [a, b, c, d] = valu4 HP.Aspects a b c d-    valu _            = malformed+  value = valueN HP.Aspects -instance EmbPrj HP.CompressedFile where-  icod_ (HP.CompressedFile f) = icode1' f+instance EmbPrj HP.DefinitionSite where+  icod_ (HP.DefinitionSite a b c d) = icodeN' HP.DefinitionSite a b c d -  value = vcase valu where-    valu [f] = valu1 HP.CompressedFile f-    valu _   = malformed+  value = valueN HP.DefinitionSite++instance EmbPrj a => EmbPrj (RM.RangeMap a) where+  -- Write the RangeMap as flat list rather than a list of (Int, (Int, x)). Much+  -- like Map, we need to call `convert' in the tail position and so the output+  -- list is written (and read) in reverse order.+  icod_ (RM.RangeMap f) = icodeNode =<< convert Empty (Map.toAscList f) where+    convert :: Node -> [(Int, RM.PairInt a)] -> S Node+    convert !ys [] = return ys+    convert  ys ((start, RM.PairInt (end :!: entry)):xs) = do+      !start <- icode start+      !end <- icode end+      !entry <- icode entry+      convert (Cons start (Cons end (Cons entry ys))) xs++  value = vcase (fmap (RM.RangeMap . Map.fromDistinctAscList) . convert []) where+    convert :: [(Int, RM.PairInt a)] -> [Word32] -> R [(Int, RM.PairInt a)]+    convert !ys [] = return ys+    convert  ys (start:end:entry:xs) = do+      !start <- value start+      !end <- value end+      !entry <- value entry+      convert ((start, RM.PairInt (end :!: entry)):ys) xs+    convert _ _ = malformed++instance EmbPrj HP.TokenBased where+  icod_ HP.TokenBased        = pure 0+  icod_ HP.NotOnlyTokenBased = pure 1++  value = \case+    0 -> pure HP.TokenBased+    1 -> pure HP.NotOnlyTokenBased+    _ -> malformed
src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs view
@@ -1,274 +1,343 @@-{-# LANGUAGE CPP #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Serialise.Instances.Internal where -import Control.Applicative-import Control.Monad.State.Strict+import qualified Data.HashSet as HashSet+import Control.Monad+import Control.Monad.IO.Class  import Agda.Syntax.Internal as I import Agda.Syntax.Position as P  import Agda.TypeChecking.Serialise.Base-import Agda.TypeChecking.Serialise.Instances.Common ()-import Agda.TypeChecking.Serialise.Instances.Compilers ()+import Agda.TypeChecking.Serialise.Instances.Compilers () --instance only  import Agda.TypeChecking.Monad import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.DiscrimTree.Types +import Agda.Utils.Functor import Agda.Utils.Permutation -#include "undefined.h" import Agda.Utils.Impossible +instance EmbPrj a => EmbPrj (Dom a) where+  icod_ (Dom a c d e f) = icodeN' Dom a c d e f++  value = valueN Dom+ instance EmbPrj Signature where-  icod_ (Sig a b c) = icode3' a b c+  icod_ (Sig a b c d) = icodeN' Sig a b c d -  value = vcase valu where-    valu [a, b, c] = valu3 Sig a b c-    valu _         = malformed+  value = valueN Sig +instance EmbPrj InstanceTable where+  icod_ (InstanceTable a b) = icodeN' InstanceTable a b++  value = valueN InstanceTable+ instance EmbPrj Section where-  icod_ (Section a) = icode1' a+  icod_ (Section a) = icodeN' Section a -  value = vcase valu where-    valu [a] = valu1 Section a-    valu _   = malformed+  value = valueN Section  instance EmbPrj a => EmbPrj (Tele a) where-  icod_ EmptyTel        = icode0'-  icod_ (ExtendTel a b) = icode2' a b+  icod_ EmptyTel        = icodeN' EmptyTel+  icod_ (ExtendTel a b) = icodeN' ExtendTel a b    value = vcase valu where-    valu []     = valu0 EmptyTel-    valu [a, b] = valu2 ExtendTel a b+    valu []     = valuN EmptyTel+    valu [a, b] = valuN ExtendTel a b     valu _      = malformed  instance EmbPrj Permutation where-  icod_ (Perm a b) = icode2' a b+  icod_ (Perm a b) = icodeN' Perm a b -  value = vcase valu where-    valu [a, b] = valu2 Perm a b-    valu _      = malformed+  value = valueN Perm  instance EmbPrj a => EmbPrj (Drop a) where-  icod_ (Drop a b) = icode2' a b+  icod_ (Drop a b) = icodeN' Drop a b -  value = vcase valu where-    valu [a, b] = valu2 Drop a b-    valu _      = malformed+  value = valueN Drop  instance EmbPrj a => EmbPrj (Elim' a) where-  icod_ (Apply a)  = icode1' a-  icod_ (Proj a b) = icode2 0 a b+  icod_ (Apply a)      = icodeN' Apply a+  icod_ (IApply x y a) = icodeN 0 IApply x y a+  icod_ (Proj a b)     = icodeN 0 Proj a b    value = vcase valu where-    valu [a]       = valu1 Apply a-    valu [0, a, b] = valu2 Proj a b+    valu [a]       = valuN Apply a+    valu [0,x,y,a] = valuN IApply x y a+    valu [0, a, b] = valuN Proj a b     valu _         = malformed +instance EmbPrj I.DataOrRecord where+  icod_ = \case+    IsData      -> icodeN' IsData+    IsRecord pm -> icodeN' IsRecord pm++  value = vcase $ \case+    []   -> valuN IsData+    [pm] -> valuN IsRecord pm+    _    -> malformed+ instance EmbPrj I.ConHead where-  icod_ (ConHead a b c) = icode3' a b c+  icod_ (ConHead a b c d) = icodeN' ConHead a b c d -  value = vcase valu where-    valu [a, b, c] = valu3 ConHead a b c-    valu _         = malformed+  value = valueN ConHead  instance (EmbPrj a) => EmbPrj (I.Type' a) where-  icod_ (El a b) = icode2' a b+  icod_ (El a b) = icodeN' El a b -  value = vcase valu where-    valu [a, b] = valu2 El a b-    valu _      = malformed+  value = valueN El -instance (EmbPrj a) => EmbPrj (I.Abs a) where-  icod_ (NoAbs a b) = icode2 0 a b-  icod_ (Abs a b)   = icode2' a b+instance EmbPrj a => EmbPrj (I.Abs a) where+  icod_ (NoAbs a b) = icodeN 0 NoAbs a b+  icod_ (Abs a b)   = icodeN' Abs a b    value = vcase valu where-    valu [a, b]    = valu2 Abs a b-    valu [0, a, b] = valu2 NoAbs a b+    valu [a, b]    = valuN Abs a b+    valu [0, a, b] = valuN NoAbs a b     valu _         = malformed  instance EmbPrj I.Term where-  icod_ (Var     a []) = icode1' a-  icod_ (Var      a b) = icode2 0 a b-  icod_ (Lam      a b) = icode2 1 a b-  icod_ (Lit      a  ) = icode1 2 a-  icod_ (Def      a b) = icode2 3 a b-  icod_ (Con    a b c) = icode3 4 a b c-  icod_ (Pi       a b) = icode2 5 a b-  icod_ (Sort     a  ) = icode1 7 a-  icod_ (MetaV    a b) = __IMPOSSIBLE__-  icod_ (DontCare a  ) = icode1 8 a-  icod_ (Level    a  ) = icode1 9 a-  icod_ (Shared p)     = icodeMemo termD termC p $ icode (derefPtr p)+  icod_ (Var     a []) = icodeN' (\ a -> Var a []) a+  icod_ (Var      a b) = icodeN 0 Var a b+  icod_ (Lam      a b) = icodeN 1 Lam a b+  icod_ (Lit      a  ) = icodeN 2 Lit a+  icod_ (Def      a b) = icodeN 3 Def a b+  icod_ (Con    a b c) = icodeN 4 Con a b c+  icod_ (Pi       a b) = icodeN 5 Pi a b+  icod_ (MetaV    a b) = icodeN 6 MetaV a b+  icod_ (Sort     a  ) = icodeN 7 Sort a+  icod_ (DontCare a  ) = icodeN 8 DontCare a+  icod_ (Level    a  ) = icodeN 9 Level a+  icod_ (Dummy    a b) = icodeN 10 Dummy a b -  value r = vcase valu' r where-    valu' xs       = gets mkShared <*> valu xs-    valu [a]       = valu1 var   a-    valu [0, a, b] = valu2 Var   a b-    valu [1, a, b] = valu2 Lam   a b-    valu [2, a]    = valu1 Lit   a-    valu [3, a, b] = valu2 Def   a b-    valu [4, a, b, c] = valu3 Con a b c-    valu [5, a, b] = valu2 Pi    a b-    valu [7, a]    = valu1 Sort  a-    valu [8, a]    = valu1 DontCare a-    valu [9, a]    = valu1 Level a+  value = vcase valu where+    valu [a]       = valuN var   a+    valu [0, a, b] = valuN Var   a b+    valu [1, a, b] = valuN Lam   a b+    valu [2, a]    = valuN Lit   a+    valu [3, a, b] = valuN Def   a b+    valu [4, a, b, c] = valuN Con a b c+    valu [5, a, b] = valuN Pi    a b+    valu [6, a, b] = valuN MetaV a b+    valu [7, a]    = valuN Sort  a+    valu [8, a]    = valuN DontCare a+    valu [9, a]    = valuN Level a+    valu [10, a, b] = valuN Dummy a b     valu _         = malformed  instance EmbPrj Level where-  icod_ (Max a) = icode1' a+  icod_ (Max a b) = icodeN' Max a b -  value = vcase valu where-    valu [a] = valu1 Max a-    valu _   = malformed+  value = valueN Max  instance EmbPrj PlusLevel where-  icod_ (ClosedLevel a) = icode1' a-  icod_ (Plus a b)      = icode2' a b+  icod_ (Plus a b) = icodeN' Plus a b -  value = vcase valu where-    valu [a]    = valu1 ClosedLevel a-    valu [a, b] = valu2 Plus a b-    valu _      = malformed+  value = valueN Plus -instance EmbPrj LevelAtom where-  icod_ (NeutralLevel _ a) = icode1' a-  icod_ (UnreducedLevel a) = icode1 1 a-  icod_ MetaLevel{}        = __IMPOSSIBLE__-  icod_ BlockedLevel{}     = __IMPOSSIBLE__+instance EmbPrj IsFibrant where+  icod_ IsFibrant = return 0+  icod_ IsStrict  = return 1 -  value = vcase valu where-    valu [a]    = valu1 UnreducedLevel a -- we forget that we are a NeutralLevel,-                                         -- since we do not want do (de)serialize-                                         -- the reason for neutrality-    valu [1, a] = valu1 UnreducedLevel a-    valu _      = malformed+  value 0 = return IsFibrant+  value 1 = return IsStrict+  value _ = malformed +instance EmbPrj Univ where+ instance EmbPrj I.Sort where-  icod_ (Type  a  ) = icode1' a-  icod_ Prop        = icode1 1 ()-  icod_ SizeUniv    = icode1 3 ()-  icod_ Inf         = icode1 4 ()-  icod_ (DLub a b)  = __IMPOSSIBLE__+  icod_ = \case+    Univ a b     -> icodeN 0  Univ a b+    SizeUniv     -> icodeN 2  SizeUniv+    Inf a b      -> icodeN 3  Inf a b+    PiSort a b c -> icodeN 4  PiSort a b c+    FunSort a b  -> icodeN 5  FunSort a b+    UnivSort a   -> icodeN 6  UnivSort a+    DefS a b     -> icodeN 7  DefS a b+    LockUniv     -> icodeN 9  LockUniv+    IntervalUniv -> icodeN 10 IntervalUniv+    MetaS a b    -> icodeN 11 MetaS a b+    DummyS s     -> icodeN 12 DummyS s+    LevelUniv    -> icodeN 13 LevelUniv    value = vcase valu where-    valu [a]    = valu1 Type  a-    valu [1, _] = valu0 Prop-    valu [3, _] = valu0 SizeUniv-    valu [4, _] = valu0 Inf-    valu _      = malformed+    valu [0, a, b] = valuN Univ a b+    valu [2]       = valuN SizeUniv+    valu [3, a, b] = valuN Inf a b+    valu [4, a, b, c] = valuN PiSort a b c+    valu [5, a, b] = valuN FunSort a b+    valu [6, a]    = valuN UnivSort a+    valu [7, a, b] = valuN DefS a b+    valu [9]       = valuN LockUniv+    valu [10]      = valuN IntervalUniv+    valu [11, a, b] = valuN MetaS a b+    valu [12, s]   = valuN DummyS s+    valu [13]      = valuN LevelUniv+    valu _         = malformed  instance EmbPrj DisplayForm where-  icod_ (Display a b c) = icode3' a b c+  icod_ (Display a b c) = icodeN' Display a b c -  value = vcase valu where-    valu [a, b, c] = valu3 Display a b c-    valu _         = malformed+  value = valueN Display  instance EmbPrj a => EmbPrj (Open a) where-  icod_ (OpenThing a b) = icode2' a b--  value = vcase valu where-    valu [a, b] = valu2 OpenThing a b-    valu _      = malformed--instance EmbPrj a => EmbPrj (Local a) where-  icod_ (Local a b) = icode2' a b-  icod_ (Global a)  = icode1' a+  icod_ (OpenThing a b c d) = icodeN' OpenThing a b c d -  value = vcase valu where-    valu [a, b] = valu2 Local a b-    valu [a]    = valu1 Global a-    valu _      = malformed+  value = valueN OpenThing -instance EmbPrj CtxId where-  icod_ (CtxId a) = icode a-  value n         = CtxId `fmap` value n+instance EmbPrj CheckpointId where+  icod_ (CheckpointId a) = icode a+  value n                = CheckpointId <$!> value n  instance EmbPrj DisplayTerm where-  icod_ (DTerm    a  )   = icode1' a-  icod_ (DDot     a  )   = icode1 1 a-  icod_ (DCon     a b c) = icode3 2 a b c-  icod_ (DDef     a b)   = icode2 3 a b-  icod_ (DWithApp a b c) = icode3 4 a b c+  icod_ (DTerm'   a b)   = icodeN' DTerm' a b+  icod_ (DDot'    a b)   = icodeN 1 DDot' a b+  icod_ (DCon     a b c) = icodeN 2 DCon a b c+  icod_ (DDef     a b)   = icodeN 3 DDef a b+  icod_ (DWithApp a b c) = icodeN 4 DWithApp a b c    value = vcase valu where-    valu [a]          = valu1 DTerm a-    valu [1, a]       = valu1 DDot a-    valu [2, a, b, c] = valu3 DCon a b c-    valu [3, a, b]    = valu2 DDef a b-    valu [4, a, b, c] = valu3 DWithApp a b c+    valu [a, b]       = valuN DTerm' a b+    valu [1, a, b]    = valuN DDot' a b+    valu [2, a, b, c] = valuN DCon a b c+    valu [3, a, b]    = valuN DDef a b+    valu [4, a, b, c] = valuN DWithApp a b c     valu _            = malformed  instance EmbPrj MutualId where-  icod_ (MutId a) = icode a-  value n         = MutId `fmap` value n+  icod_ (MutualId a) = icode a+  value n            = MutualId <$!> value n +instance EmbPrj CompKit where+  icod_ (CompKit a b) = icodeN' CompKit a b+  value = valueN CompKit++instance EmbPrj InstanceInfo where+  icod_ (InstanceInfo a b) = icodeN' InstanceInfo a b+  value = valueN InstanceInfo+ instance EmbPrj Definition where-  icod_ (Defn a b c d e f g h i j k l) = icode12' a b (P.killRange c) d e f g h i j k l+  icod_ (Defn a b c d e f g h i j k l m n o blocked r s) =+    icodeN' Defn a b (P.killRange c) d e f g h i j k l m n o (ossify blocked) r s+    where+      -- Andreas, 2024-01-02, issue #7044:+      -- After serialization, a definition can never be unblocked,+      -- since all metas are ossified.+      -- Thus, we turn any blocker into 'neverUnblock'.+      ossify :: Blocked_ -> Blocked_+      ossify = \case+        b@NotBlocked{} -> b+        Blocked b () -> Blocked neverUnblock ()+  value = valueN Defn +instance EmbPrj NotBlocked where+  icod_ ReallyNotBlocked = icodeN' ReallyNotBlocked+  icod_ (StuckOn a)      = icodeN 0 StuckOn a+  icod_ Underapplied     = icodeN 1 Underapplied+  icod_ AbsurdMatch      = icodeN 2 AbsurdMatch+  icod_ (MissingClauses a) = icodeN 3 MissingClauses a+   value = vcase valu where-    valu [a, b, c, d, e, f, g, h, i, j, k, l] = valu12 Defn a b c d e f g h i j k l-    valu _                                    = malformed+    valu []     = valuN ReallyNotBlocked+    valu [0, a] = valuN StuckOn a+    valu [1]    = valuN Underapplied+    valu [2]    = valuN AbsurdMatch+    valu [3, a] = valuN MissingClauses a+    valu _      = malformed +-- Andreas, 2024-01-02, issue #7044.+-- We only serialize 'neverUnblock';+-- other than that, there should not be any blockers left at serialization time.+blockedToMaybe :: Blocked_ -> Maybe NotBlocked+blockedToMaybe = \case+  NotBlocked a ()       -> Just a+  Blocked a ()+    | a == neverUnblock -> Nothing+    | otherwise         -> __IMPOSSIBLE__++blockedFromMaybe :: Maybe NotBlocked -> Blocked_+blockedFromMaybe = maybe (Blocked neverUnblock ()) (`NotBlocked` ())++instance EmbPrj Blocked_ where+  icod_ = icod_ . blockedToMaybe+  value = blockedFromMaybe <.> value+ instance EmbPrj NLPat where-  icod_ (PVar a b c)    = icode3 0 a b c-  icod_ (PWild)         = icode0 1-  icod_ (PDef a b)      = icode2 2 a b-  icod_ (PLam a b)      = icode2 3 a b-  icod_ (PPi a b)       = icode2 4 a b-  icod_ (PBoundVar a b) = icode2 5 a b-  icod_ (PTerm a)       = icode1 6 a+  icod_ (PVar a b)      = icodeN 0 PVar a b+  icod_ (PDef a b)      = icodeN 1 PDef a b+  icod_ (PLam a b)      = icodeN 2 PLam a b+  icod_ (PPi a b)       = icodeN 3 PPi a b+  icod_ (PSort a)       = icodeN 4 PSort a+  icod_ (PBoundVar a b) = icodeN 5 PBoundVar a b+  icod_ (PTerm a)       = icodeN 6 PTerm a    value = vcase valu where-    valu [0, a, b, c] = valu3 PVar a b c-    valu [1]          = valu0 PWild-    valu [2, a, b]    = valu2 PDef a b-    valu [3, a, b]    = valu2 PLam a b-    valu [4, a, b]    = valu2 PPi a b-    valu [5, a, b]    = valu2 PBoundVar a b-    valu [6, a]       = valu1 PTerm a+    valu [0, a, b]    = valuN PVar a b+    valu [1, a, b]    = valuN PDef a b+    valu [2, a, b]    = valuN PLam a b+    valu [3, a, b]    = valuN PPi a b+    valu [4, a]       = valuN PSort a+    valu [5, a, b]    = valuN PBoundVar a b+    valu [6, a]       = valuN PTerm a     valu _            = malformed  instance EmbPrj NLPType where-  icod_ (NLPType a b) = icode2' a b+  icod_ (NLPType a b) = icodeN' NLPType a b +  value = valueN NLPType++instance EmbPrj NLPSort where+  icod_ (PType a)   = icodeN 0 PType a+  icod_ (PProp a)   = icodeN 1 PProp a+  icod_ (PInf f a)  = icodeN 2 PInf f a+  icod_ PSizeUniv   = icodeN 3 PSizeUniv+  icod_ PLockUniv   = icodeN 4 PLockUniv+  icod_ PIntervalUniv = icodeN 5 PIntervalUniv+  icod_ (PSSet a)   = icodeN 6 PSSet a+  icod_ PLevelUniv = icodeN 7 PLevelUniv+   value = vcase valu where-    valu [a, b] = valu2 NLPType a b+    valu [0, a] = valuN PType a+    valu [1, a] = valuN PProp a+    valu [2, f, a] = valuN PInf f a+    valu [3]    = valuN PSizeUniv+    valu [4]    = valuN PLockUniv+    valu [5]    = valuN PIntervalUniv+    valu [6, a] = valuN PSSet a+    valu [7]    = valuN PLevelUniv     valu _      = malformed  instance EmbPrj RewriteRule where-  icod_ (RewriteRule a b c d e f) = icode6' a b c d e f+  icod_ (RewriteRule a b c d e f g h) = icodeN' RewriteRule a b c d e f g h -  value = vcase valu where-    valu [a, b, c, d, e, f] = valu6 RewriteRule a b c d e f-    valu _                  = malformed+  value = valueN RewriteRule  instance EmbPrj Projection where-  icod_ (Projection a b c d e) = icode5' a b c d e+  icod_ (Projection a b c d e) = icodeN' Projection a b c d e -  value = vcase valu where-    valu [a, b, c, d, e] = valu5 Projection a b c d e-    valu _ = malformed+  value = valueN Projection  instance EmbPrj ProjLams where-  icod_ (ProjLams a) = icode1' a+  icod_ (ProjLams a) = icodeN' ProjLams a -  value = vcase valu where-    valu [a] = valu1 ProjLams a-    valu _   = malformed+  value = valueN ProjLams +instance EmbPrj System where+  icod_ (System a b) = icodeN' System a b++  value = valueN System+ instance EmbPrj ExtLamInfo where-  icod_ (ExtLamInfo a b) = icode2' a b+  icod_ (ExtLamInfo a b c) = icodeN' ExtLamInfo a b c -  value = vcase valu where-    valu [a, b] = valu2 ExtLamInfo a b-    valu _      = malformed+  value = valueN ExtLamInfo  instance EmbPrj Polarity where   icod_ Covariant     = return 0@@ -282,6 +351,33 @@   value 3 = return Nonvariant   value _ = malformed +instance EmbPrj IsForced where+  icod_ Forced    = return 0+  icod_ NotForced = return 1++  value 0 = return Forced+  value 1 = return NotForced+  value _ = malformed++instance EmbPrj NumGeneralizableArgs where+  icod_ NoGeneralizableArgs       = icodeN' NoGeneralizableArgs+  icod_ (SomeGeneralizableArgs a) = icodeN' SomeGeneralizableArgs a++  value = vcase valu where+    valu []  = valuN NoGeneralizableArgs+    valu [a] = valuN SomeGeneralizableArgs a+    valu _   = malformed++instance EmbPrj DoGeneralize where+  icod_ YesGeneralizeVar  = return 0+  icod_ YesGeneralizeMeta = return 1+  icod_ NoGeneralize      = return 2++  value 0 = return YesGeneralizeVar+  value 1 = return YesGeneralizeMeta+  value 2 = return NoGeneralize+  value _ = malformed+ instance EmbPrj Occurrence where   icod_ StrictPos = return 0   icod_ Mixed     = return 1@@ -299,129 +395,291 @@   value _ = malformed  instance EmbPrj EtaEquality where-  icod_ (Specified a) = icode1 0 a-  icod_ (Inferred a)  = icode1 1 a+  icod_ (Specified a) = icodeN 0 Specified a+  icod_ (Inferred a)  = icodeN 1 Inferred a    value = vcase valu where-    valu [0,a] = valu1 Specified a-    valu [1,a] = valu1 Inferred a+    valu [0,a] = valuN Specified a+    valu [1,a] = valuN Inferred a     valu _     = malformed +instance EmbPrj ProjectionLikenessMissing++instance EmbPrj BuiltinSort where+  icod_ = \case+    SortUniv  a      -> icodeN 0 SortUniv  a+    SortOmega a      -> icodeN 1 SortOmega a+    SortIntervalUniv -> icodeN 2 SortIntervalUniv+    SortLevelUniv    -> icodeN 3 SortLevelUniv++  value = vcase \case+    [0, a] -> valuN SortUniv  a+    [1, a] -> valuN SortOmega a+    [2]    -> valuN SortIntervalUniv+    [3]    -> valuN SortLevelUniv+    _ -> malformed+ instance EmbPrj Defn where-  icod_ Axiom                                   = icode0 0-  icod_ (Function    a b _ c d e f g h i j k m) = icode12 1 a b c d e f g h i j k m-  icod_ (Datatype    a b c d e f g h i j)       = icode10 2 a b c d e f g h i j-  icod_ (Record      a b c d e f g h i j k)     = icode11 3 a b c d e f g h i j k-  icod_ (Constructor a b c d e f)               = icode6 4 a b c d e f-  icod_ (Primitive   a b c d)                   = icode4 5 a b c d-  icod_ AbstractDefn                            = __IMPOSSIBLE__+  icod_ (Axiom       a)                                 = icodeN 0 Axiom a+  icod_ (Function    a b s t u c d e f g h i j k)       = icodeN 1 (\ a b s -> Function a b s t) a b s u c d e f g h i j k+  icod_ (Datatype    a b c d e f g h i j)               = icodeN 2 Datatype a b c d e f g h i j+  icod_ (Record      a b c d e f g h i j k l m)         = icodeN 3 Record a b c d e f g h i j k l m+  icod_ (Constructor a b c d e f g h i j k)             = icodeN 4 Constructor a b c d e f g h i j k+  icod_ (Primitive   a b c d e f)                       = icodeN 5 Primitive a b c d e f+  icod_ (PrimitiveSort a b)                             = icodeN 6 PrimitiveSort a b+  icod_ AbstractDefn{}                                  = __IMPOSSIBLE__+  icod_ (GeneralizableVar a)                            = icodeN 7 GeneralizableVar a+  icod_ (DataOrRecSig a)                                = icodeN 8 DataOrRecSig a+    -- Andreas, 2024-10-27+    -- DataOrRecSig is possible via unquoteDecl in meta-programming, see #7576    value = vcase valu where-    valu [0]                                     = valu0 Axiom-    valu [1, a, b, c, d, e, f, g, h, i, j, k, m] = valu12 (\ a b -> Function a b Nothing) a b c d e f g h i j k m-    valu [2, a, b, c, d, e, f, g, h, i, j]       = valu10 Datatype a b c d e f g h i j-    valu [3, a, b, c, d, e, f, g, h, i, j, k]    = valu11 Record  a b c d e f g h i j k-    valu [4, a, b, c, d, e, f]                   = valu6 Constructor a b c d e f-    valu [5, a, b, c, d]                         = valu4 Primitive   a b c d-    valu _                                       = malformed+    valu [0, a]                                        = valuN Axiom a+    valu [1, a, b, s, u, c, d, e, f, g, h, i, j, k]+                                                       = valuN (\ a b s -> Function a b s Nothing) a b s u c d e f g h i j k+    valu [2, a, b, c, d, e, f, g, h, i, j]             = valuN Datatype a b c d e f g h i j+    valu [3, a, b, c, d, e, f, g, h, i, j, k, l, m]    = valuN Record   a b c d e f g h i j k l m+    valu [4, a, b, c, d, e, f, g, h, i, j, k]          = valuN Constructor a b c d e f g h i j k+    valu [5, a, b, c, d, e, f]                         = valuN Primitive   a b c d e f+    valu [6, a, b]                                     = valuN PrimitiveSort a b+    valu [7, a]                                        = valuN GeneralizableVar a+    valu [8, a]                                        = valuN DataOrRecSig a+    valu _                                             = malformed -instance EmbPrj FunctionFlag where-  icod_ FunStatic       = icode0 0-  icod_ FunInline       = icode0 1-  icod_ FunMacro        = icode0 2+instance EmbPrj LazySplit where+  icod_ StrictSplit = icodeN' StrictSplit+  icod_ LazySplit   = icodeN 0 LazySplit    value = vcase valu where-    valu [0] = valu0 FunStatic-    valu [1] = valu0 FunInline-    valu [2] = valu0 FunMacro+    valu []  = valuN StrictSplit+    valu [0] = valuN LazySplit     valu _   = malformed -instance EmbPrj a => EmbPrj (WithArity a) where-  icod_ (WithArity a b) = icode2' a b+instance EmbPrj SplitTag where+  icod_ (SplitCon c)  = icodeN 0 SplitCon c+  icod_ (SplitLit l)  = icodeN 1 SplitLit l+  icod_ SplitCatchall = icodeN' SplitCatchall    value = vcase valu where-    valu [a, b] = valu2 WithArity a b+    valu []     = valuN SplitCatchall+    valu [0, c] = valuN SplitCon c+    valu [1, l] = valuN SplitLit l     valu _      = malformed -instance EmbPrj a => EmbPrj (Case a) where-  icod_ (Branches a b c d) = icode4' a b c d+instance EmbPrj a => EmbPrj (SplitTree' a) where+  icod_ (SplittingDone a) = icodeN' SplittingDone a+  icod_ (SplitAt a b c)   = icodeN 0 SplitAt a b c    value = vcase valu where-    valu [a, b, c, d] = valu4 Branches a b c d+    valu [a]          = valuN SplittingDone a+    valu [0, a, b, c] = valuN SplitAt a b c     valu _            = malformed +instance EmbPrj FunctionFlag++instance EmbPrj a => EmbPrj (WithArity a) where+  icod_ (WithArity a b) = icodeN' WithArity a b++  value = valueN WithArity++instance EmbPrj a => EmbPrj (Case a) where+  icod_ (Branches a b c d e f g) = icodeN' Branches a b c d e f g++  value = valueN Branches++-- Opaque blocks are serialised in an abbreviated manner: We only need+-- the enclosed definitions (3rd argument) and parent (4th argument) to+-- compute the transitive closure during scope checking, never+-- afterwards.+instance EmbPrj OpaqueBlock where+  icod_ (OpaqueBlock id uf _ _ r) =+    icodeN' (\id uf ->+      let !unfolding = HashSet.fromList uf+      in OpaqueBlock id unfolding mempty Nothing)+    id (HashSet.toList uf) r++  value = valueN (\id uf -> let !unfolding = HashSet.fromList uf+                            in OpaqueBlock id unfolding mempty Nothing)+ instance EmbPrj CompiledClauses where-  icod_ Fail       = icode0'-  icod_ (Done a b) = icode2' a (P.killRange b)-  icod_ (Case a b) = icode2 2 a b+  icod_ (Fail a)   = icodeN' Fail a+  icod_ (Done a b) = icodeN' Done a (P.killRange b)+  icod_ (Case a b) = icodeN 2 Case a b    value = vcase valu where-    valu []        = valu0 Fail-    valu [a, b]    = valu2 Done a b-    valu [2, a, b] = valu2 Case a b+    valu [a]       = valuN Fail a+    valu [a, b]    = valuN Done a b+    valu [2, a, b] = valuN Case a b     valu _         = malformed  instance EmbPrj a => EmbPrj (FunctionInverse' a) where-  icod_ NotInjective = icode0'-  icod_ (Inverse a)  = icode1' a+  icod_ NotInjective = icodeN' NotInjective+  icod_ (Inverse a)  = icodeN' Inverse a    value = vcase valu where-    valu []  = valu0 NotInjective-    valu [a] = valu1 Inverse a+    valu []  = valuN NotInjective+    valu [a] = valuN Inverse a     valu _   = malformed  instance EmbPrj TermHead where-  icod_ SortHead     = icode0'-  icod_ PiHead       = icode0 1-  icod_ (ConsHead a) = icode1 2 a+  icod_ SortHead     = icodeN' SortHead+  icod_ PiHead       = icodeN 1 PiHead+  icod_ (ConsHead a) = icodeN 2 ConsHead a+  icod_ (VarHead a)  = icodeN 3 VarHead a+  icod_ UnknownHead  = icodeN 4 UnknownHead    value = vcase valu where-    valu []     = valu0 SortHead-    valu [1]    = valu0 PiHead-    valu [2, a] = valu1 ConsHead a+    valu []     = valuN SortHead+    valu [1]    = valuN PiHead+    valu [2, a] = valuN ConsHead a+    valu [3, a] = valuN VarHead a+    valu [4]    = valuN UnknownHead     valu _      = malformed  instance EmbPrj I.Clause where-  icod_ (Clause a b c d e f) = icode6' a b c d e f+  icod_ (Clause a b c d e f g h i j k) = icodeN' Clause a b c d e f g h i j k -  value = vcase valu where-    valu [a, b, c, d, e, f] = valu6 Clause a b c d e f-    valu _                  = malformed+  value = valueN Clause  instance EmbPrj I.ConPatternInfo where-  icod_ (ConPatternInfo a b) = icode2' a b+  icod_ (ConPatternInfo a b c d e) = icodeN' ConPatternInfo a b c d e -  value = vcase valu where-    valu [a, b] = valu2 ConPatternInfo a b-    valu _      = malformed+  value = valueN ConPatternInfo  instance EmbPrj I.DBPatVar where-  icod_ (DBPatVar a b) = icode2' a b+  icod_ (DBPatVar a b) = icodeN' DBPatVar a b +  value = valueN DBPatVar++instance EmbPrj I.PatternInfo where+  icod_ (PatternInfo a b) = icodeN' PatternInfo a b++  value = valueN PatternInfo++instance EmbPrj I.PatOrigin where+  icod_ PatOSystem  = icodeN' PatOSystem+  icod_ PatOSplit   = icodeN 1 PatOSplit+  icod_ (PatOVar a) = icodeN 2 PatOVar a+  icod_ PatODot     = icodeN 3 PatODot+  icod_ PatOWild    = icodeN 4 PatOWild+  icod_ PatOCon     = icodeN 5 PatOCon+  icod_ PatORec     = icodeN 6 PatORec+  icod_ PatOLit     = icodeN 7 PatOLit+  icod_ PatOAbsurd  = icodeN 8 PatOAbsurd+  icod_ (PatOSplitArg a) = icodeN 9 PatOSplitArg a+   value = vcase valu where-    valu [a, b] = valu2 DBPatVar a b+    valu []     = valuN PatOSystem+    valu [1]    = valuN PatOSplit+    valu [2, a] = valuN PatOVar a+    valu [3]    = valuN PatODot+    valu [4]    = valuN PatOWild+    valu [5]    = valuN PatOCon+    valu [6]    = valuN PatORec+    valu [7]    = valuN PatOLit+    valu [8]    = valuN PatOAbsurd+    valu [9, a] = valuN PatOSplitArg a     valu _      = malformed  instance EmbPrj a => EmbPrj (I.Pattern' a) where-  icod_ (VarP a    ) = icode1' a-  icod_ (ConP a b c) = icode3 1 a b c-  icod_ (LitP a    ) = icode1 2 a-  icod_ (DotP a    ) = icode1 3 a-  icod_ (ProjP a b ) = icode2 4 a b+  icod_ (VarP a b  ) = icodeN 0 VarP a b+  icod_ (ConP a b c) = icodeN 1 ConP a b c+  icod_ (LitP a b  ) = icodeN 2 LitP a b+  icod_ (DotP a b  ) = icodeN 3 DotP a b+  icod_ (ProjP a b ) = icodeN 4 ProjP a b+  icod_ (IApplyP a b c d) = icodeN 5 IApplyP a b c d+  icod_ (DefP a b c) = icodeN 6 DefP a b c    value = vcase valu where-    valu [a]       = valu1 VarP a-    valu [1, a, b, c] = valu3 ConP a b c-    valu [2, a]    = valu1 LitP a-    valu [3, a]    = valu1 DotP a-    valu [4, a, b] = valu2 ProjP a b+    valu [0, a, b] = valuN VarP a b+    valu [1, a, b, c] = valuN ConP a b c+    valu [2, a, b] = valuN LitP a b+    valu [3, a, b] = valuN DotP a b+    valu [4, a, b] = valuN ProjP a b+    valu [5, a, b, c, d] = valuN IApplyP a b c d+    valu [6, a, b, c] = valuN DefP a b c     valu _         = malformed  instance EmbPrj a => EmbPrj (Builtin a) where-  icod_ (Prim    a) = icode1' a-  icod_ (Builtin a) = icode1 1 a+  icod_ (Prim    a) = icodeN' Prim a+  icod_ (Builtin a) = icodeN 1 Builtin a+  icod_ (BuiltinRewriteRelations a) = icodeN 2 BuiltinRewriteRelations a    value = vcase valu where-    valu [a]    = valu1 Prim    a-    valu [1, a] = valu1 Builtin a+    valu [a]    = valuN Prim    a+    valu [1, a] = valuN Builtin a+    valu [2, a] = valuN BuiltinRewriteRelations a     valu _      = malformed++instance EmbPrj a => EmbPrj (Substitution' a) where+  icod_ IdS                = icodeN' IdS+  icod_ (EmptyS a)         = icodeN' EmptyS a+  icod_ (a :# b)           = icodeN' (:#) a b+  icod_ (Strengthen a b c) = icodeN 0 Strengthen a b c+  icod_ (Wk a b)           = icodeN 1 Wk a b+  icod_ (Lift a b)         = icodeN 2 Lift a b++  value = vcase valu where+    valu []           = valuN IdS+    valu [a]          = valuN EmptyS a+    valu [a, b]       = valuN (:#) a b+    valu [0, a, b, c] = valuN Strengthen a b c+    valu [1, a, b]    = valuN Wk a b+    valu [2, a, b]    = valuN Lift a b+    valu _            = malformed++instance EmbPrj Instantiation where+  icod_ (Instantiation a b) = icodeN' Instantiation a b+  value = valueN Instantiation++instance EmbPrj Comparison where+  icod_ CmpEq  = icodeN' CmpEq+  icod_ CmpLeq = icodeN 0 CmpLeq++  value = vcase valu+    where+    valu []  = valuN CmpEq+    valu [0] = valuN CmpLeq+    valu _   = malformed++instance EmbPrj a => EmbPrj (Judgement a) where+  icod_ (HasType a b c) = icodeN' HasType a b c+  icod_ (IsSort a b)    = icodeN' IsSort a b++  value = vcase valu+    where+    valu [a, b, c] = valuN HasType a b c+    valu [a, b]    = valuN IsSort a b+    valu _         = malformed++instance EmbPrj RemoteMetaVariable where+  icod_ (RemoteMetaVariable a b c) = icodeN' RemoteMetaVariable a b c+  value = valueN RemoteMetaVariable++instance EmbPrj Key where+  icod_ (RigidK x y) = icodeN 0 RigidK x y+  icod_ (LocalK x y) = icodeN 1 LocalK x y+  icod_ (PiK h)      = icodeN 2 PiK h+  icod_ FlexK        = icodeN 3 FlexK+  icod_ ConstK       = icodeN 4 ConstK+  icod_ SortK        = icodeN 5 SortK++  value = vcase valu where+    valu [0, x, y] = valuN RigidK x y+    valu [1, x, y] = valuN LocalK x y+    valu [2, h]    = valuN PiK h+    valu [3]       = valuN FlexK+    valu [4]       = valuN ConstK+    valu [5]       = valuN SortK+    valu _         = malformed++instance (EmbPrj a, Ord a) => EmbPrj (DiscrimTree a) where+  icod_ EmptyDT        = icodeN' EmptyDT+  icod_ (DoneDT s)     = icodeN' DoneDT s+  icod_ (CaseDT i k s) = icodeN' CaseDT i k s++  value = vcase valu where+    valu []        = valuN EmptyDT+    valu [a]       = valuN DoneDT a+    valu [i, k, s] = valuN CaseDT i k s+    valu _         = malformed
src/full/Agda/TypeChecking/SizedTypes.hs view
@@ -1,39 +1,47 @@-{-# LANGUAGE CPP                      #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.SizedTypes where  import Prelude hiding (null) -import Control.Monad.Writer+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT )+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Writer ( MonadWriter(..), WriterT(..), runWriterT ) -import Data.List hiding (null)-import qualified Data.Map as Map+import qualified Data.Foldable as Fold+import qualified Data.List as List+import qualified Data.Set as Set+import Data.Set (Set)  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Common.Pretty (Pretty)+import qualified Agda.Syntax.Common.Pretty as P  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty.Constraint () -- instance PrettyTCM Constraint import Agda.TypeChecking.Reduce-import {-# SOURCE #-} Agda.TypeChecking.MetaVars import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (MonadCheckInternal, infer)+import {-# SOURCE #-} Agda.TypeChecking.Constraints () -- instance MonadConstraint TCM import {-# SOURCE #-} Agda.TypeChecking.Conversion-import {-# SOURCE #-} Agda.TypeChecking.Constraints -import Agda.Utils.Except ( MonadError(catchError, throwError) )+import Agda.Utils.Functor import Agda.Utils.List as List+import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple -import qualified Agda.Utils.Warshall as W--#include "undefined.h" import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -42,23 +50,35 @@  -- | Check whether a type is either not a SIZELT or a SIZELT that is non-empty. checkSizeLtSat :: Term -> TCM ()-checkSizeLtSat t = do-  reportSDoc "tc.size" 10 $ sep-    [ text "checking that " <+> prettyTCM t <+> text " is not an empty type of sizes"-    , text "in context " <+> do inTopContext . prettyTCM =<< getContextTelescope-    ]-  let postpone :: Term -> TCM ()-      postpone t = addConstraint $ CheckSizeLtSat t-  ifBlocked t (const postpone) $ \ t -> do-    caseMaybeM (isSizeType t) (return ()) $ \ b -> do+checkSizeLtSat t = whenM haveSizeLt $ do+  reportSDoc "tc.size" 10 $ do+    tel <- getContextTelescope+    sep+      [ "checking that " <+> prettyTCM t <+> " is not an empty type of sizes"+      , if null tel then empty else do+        "in context " <+> inTopContext (prettyTCM tel)+      ]+  reportSLn "tc.size" 60 $ "- raw type = " ++ show t+  let postpone :: Blocker -> Term -> TCM ()+      postpone b t = do+        reportSDoc "tc.size.lt" 20 $ sep+          [ "- postponing `not empty type of sizes' check for " <+> prettyTCM t ]+        addConstraint b $ CheckSizeLtSat t+  let ok :: TCM ()+      ok = reportSLn "tc.size.lt" 20 $ "- succeeded: not an empty type of sizes"+  ifBlocked t postpone $ \ _ t -> do+    reportSLn "tc.size.lt" 20 $ "- type is not blocked"+    caseMaybeM (isSizeType t) ok $ \ b -> do+      reportSLn "tc.size.lt" 20 $ " - type is a size type"       case b of-        BoundedNo -> return ()+        BoundedNo -> ok         BoundedLt b -> do-          ifBlocked b (\ _ _ -> postpone t) $ \ b -> do+          reportSDoc "tc.size.lt" 20 $ " - type is SIZELT" <+> prettyTCM b+          ifBlocked b (\ x _ -> postpone x t) $ \ _ b -> do+            reportSLn "tc.size.lt" 20 $ " - size bound is not blocked"             catchConstraint (CheckSizeLtSat t) $ do               unlessM (checkSizeNeverZero b) $ do-                typeError . GenericDocError =<< do-                  text "Possibly empty type of sizes " <+> prettyTCM t+                typeError $ EmptyTypeOfSizes t  -- | Precondition: Term is reduced and not blocked. --   Throws a 'patternViolation' if undecided@@ -69,7 +89,7 @@     SizeInf     -> return True  -- OK, infty is never 0.     SizeSuc{}   -> return True  -- OK, a + 1 is never 0.     OtherSize u ->-      case ignoreSharing u of+      case u of         Var i [] -> checkSizeVarNeverZero i         -- neutral sizes cannot be guaranteed > 0         _ -> return False@@ -86,8 +106,8 @@ --   -- We raise each type to make sense in the current context. --   let ts = zipWith raise [1..] $ map (snd . unDom) doms --   reportSDoc "tc.size" 15 $ sep---     [ text "checking that size " <+> prettyTCM (var i) <+> text " is never 0"---     , text "in context " <+> do sep $ map prettyTCM ts+--     [ "checking that size " <+> prettyTCM (var i) <+> " is never 0"+--     , "in context " <+> do sep $ map prettyTCM ts --     ] --   foldr f (return False) ts --   where@@ -97,12 +117,12 @@ --     let yes     = return True --         no      = cont --         perhaps = cont >>= \ res -> if res then return res else patternViolation---     ifBlockedType t (\ _ _ -> perhaps) $ \ t -> do+--     ifBlocked t (\ _ _ -> perhaps) $ \ t -> do --       caseMaybeM (isSizeType t) no $ \ b -> do --         case b of --           BoundedNo -> no --           BoundedLt u -> ifBlocked u (\ _ _ -> perhaps) $ \ u -> do---             case ignoreSharing u of+--             case u of --                Var i' [] | i == i' -> yes --                _ -> no @@ -113,20 +133,23 @@ --   Throws a 'patternViolation' if undecided. checkSizeVarNeverZero :: Int -> TCM Bool checkSizeVarNeverZero i = do-  reportSDoc "tc.size" 20 $ text "checkSizeVarNeverZero" <+> prettyTCM (var i)+  reportSDoc "tc.size" 20 $ "checkSizeVarNeverZero" <+> prettyTCM (var i)   -- Looking for the minimal value for size variable i,   -- we can restrict to the last i   -- entries, as only these can contain i in an upper bound.-  ts <- map (snd . unDom) . take i <$> getContext+  ts <- map ctxEntryType . take i <$> getContext   -- If we encountered a blocking meta in the context, we cannot   -- say ``no'' for sure.-  (n, Any meta) <- runWriterT $ minSizeValAux ts $ repeat 0+  (n, blockers) <- runWriterT $ minSizeValAux ts $ repeat 0+  let blocker = unblockOnAll blockers   if n > 0 then return True else-    if meta then patternViolation else return False+    if blocker == alwaysUnblock+      then return False+      else patternViolation blocker   where   -- Compute the least valuation for size context ts above the   -- given valuation and return its last value.-  minSizeValAux :: [Type] -> [Int] -> WriterT Any TCM Int+  minSizeValAux :: [Type] -> [Int] -> WriterT (Set Blocker) TCM Int   minSizeValAux _        []      = __IMPOSSIBLE__   minSizeValAux []       (n : _) = return n   minSizeValAux (t : ts) (n : ns) = do@@ -135,56 +158,71 @@              " t =") <+> (text . show) t  -- prettyTCM t  -- Wrong context!     -- n is the min. value for variable 0 which has type t.     let cont = minSizeValAux ts ns-        perhaps = tell (Any True) >> cont+        perhaps x = tell (Set.singleton x) >> cont     -- If we encounter a blocked type in the context, we cannot     -- give a definite answer.-    ifBlockedType t (\ _ _ -> perhaps) $ \ t -> do+    ifBlocked t (\ x _ -> perhaps x) $ \ _ t -> do       caseMaybeM (liftTCM $ isSizeType t) cont $ \ b -> do         case b of           BoundedNo -> cont-          BoundedLt u -> ifBlocked u (\ _ _ -> perhaps) $ \ u -> do+          BoundedLt u -> ifBlocked u (\ x _ -> perhaps x) $ \ _ u -> do             reportSLn "tc.size" 60 $ "minSizeVal upper bound u = " ++ show u             v <- liftTCM $ deepSizeView u             case v of               -- Variable 0 has bound @(< j + m)@               -- meaning that @minval(j) > n - m@, i.e., @minval(j) >= n+1-m@.               -- Thus, we update the min value for @j@ with function @(max (n+1-m))@.-              DSizeVar j m -> do+              DSizeVar (ProjectedVar j []) m -> do                 reportSLn "tc.size" 60 $ "minSizeVal upper bound v = " ++ show v-                let ns' = List.updateAt j (max $ n+1-m) ns+                let ns' = List.updateAt j (max $ n + 1 - m) ns                 reportSLn "tc.size" 60 $ "minSizeVal ns' = " ++ show (take (length ts + 1) ns')                 minSizeValAux ts ns'-              DSizeMeta{} -> perhaps+              DSizeMeta x _ _ -> perhaps (unblockOnMeta x)               _ -> cont  -- | Check whether a variable in the context is bounded by a size expression. --   If @x : Size< a@, then @a@ is returned.-isBounded :: MonadTCM tcm => Nat -> tcm BoundedSize-isBounded i = liftTCM $ do-  t <- reduce =<< typeOfBV i-  case ignoreSharing $ unEl t of+isBounded :: PureTCM m => Nat -> m BoundedSize+isBounded i = isBoundedSizeType =<< typeOfBV i++isBoundedProjVar+  :: (MonadCheckInternal m, PureTCM m)+  => ProjectedVar -> m BoundedSize+isBoundedProjVar pv = isBoundedSizeType =<< infer (unviewProjectedVar pv)++isBoundedSizeType :: PureTCM m => Type -> m BoundedSize+isBoundedSizeType t =+  reduce (unEl t) >>= \case     Def x [Apply u] -> do       sizelt <- getBuiltin' builtinSizeLt       return $ if (Just (Def x []) == sizelt) then BoundedLt $ unArg u else BoundedNo     _ -> return BoundedNo  -- | Whenever we create a bounded size meta, add a constraint---   expressing the bound.+--   expressing the bound. First argument is the new meta and must be a @MetaV{}@. --   In @boundedSizeMetaHook v tel a@, @tel@ includes the current context.-boundedSizeMetaHook :: Term -> Telescope -> Type -> TCM ()-boundedSizeMetaHook v tel0 a = do+boundedSizeMetaHook+  :: ( MonadConstraint m+     , MonadTCEnv m+     , ReadTCState m+     , MonadAddContext m+     , HasOptions m+     , HasBuiltins m+     )+  => Term -> Telescope -> Type -> m ()+boundedSizeMetaHook v@(MetaV x _) tel0 a = do   res <- isSizeType a   case res of     Just (BoundedLt u) -> do       n <- getContextSize-      let tel | n > 0     = telFromList $ genericDrop n $ telToList tel0+      let tel | n > 0     = telFromList $ drop n $ telToList tel0               | otherwise = tel0       addContext tel $ do         v <- sizeSuc 1 $ raise (size tel) v `apply` teleArgs tel         -- compareSizes CmpLeq v u-        size <- sizeType-        addConstraint $ ValueCmp CmpLeq size v u+        addConstraint (unblockOnMeta x) $ ValueCmp CmpLeq AsSizes v u     _ -> return ()+boundedSizeMetaHook _ _ _ = __IMPOSSIBLE__  -- | @trySizeUniv cmp t m n x els1 y els2@ --   is called as a last resort when conversion checking @m `cmp` n : t@@@ -195,16 +233,19 @@ --   like @Size< i =< Size@. -- --   If it does not succeed it reports failure of conversion check.-trySizeUniv :: Comparison -> Type -> Term -> Term-  -> QName -> Elims -> QName -> Elims -> TCM ()+trySizeUniv+  :: MonadConversion m+  => Comparison -> CompareAs -> Term -> Term+  -> QName -> Elims -> QName -> Elims -> m () trySizeUniv cmp t m n x els1 y els2 = do-  let failure = typeError $ UnequalTerms cmp m n t+  let failure :: forall m a. MonadTCError m => m a+      failure = typeError $ UnequalTerms cmp m n t       forceInfty u = compareSizes CmpEq (unArg u) =<< primSizeInf   -- Get the SIZE built-ins.-  (size, sizelt) <- flip catchError (const failure) $ do-     Def size   _ <- ignoreSharing <$> primSize-     Def sizelt _ <- ignoreSharing <$> primSizeLt-     return (size, sizelt)+  (size, sizelt) <- maybe failure pure =<< runMaybeT do+    size   <- MaybeT $ getBuiltinName' builtinSize+    sizelt <- MaybeT $ getBuiltinName' builtinSizeLt+    pure (size, sizelt)   case (cmp, els1, els2) of      -- Case @Size< _ <= Size@: true.      (CmpLeq, [_], [])  | x == sizelt && y == size -> return ()@@ -221,45 +262,48 @@  -- | Compute the deep size view of a term. --   Precondition: sized types are enabled.-deepSizeView :: Term -> TCM DeepSizeView+deepSizeView :: (PureTCM m, MonadTCError m) => Term -> m DeepSizeView deepSizeView v = do-  Def inf [] <- ignoreSharing <$> primSizeInf-  Def suc [] <- ignoreSharing <$> primSizeSuc-  let loop v = do-        v <- reduce v-        case ignoreSharing v of+  inf <- getBuiltinName_ builtinSizeInf+  suc <- getBuiltinName_ builtinSizeSuc+  let loop v =+        reduce v >>= \case           Def x []        | x == inf -> return $ DSizeInf           Def x [Apply u] | x == suc -> sizeViewSuc_ suc <$> loop (unArg u)-          Var i []                   -> return $ DSizeVar i 0++          Var i es | Just pv <- ProjectedVar i <$> mapM isProjElim es+                                     -> return $ DSizeVar pv 0           MetaV x us                 -> return $ DSizeMeta x us 0-          _                          -> return $ DOtherSize v+          v                          -> return $ DOtherSize v   loop v -sizeMaxView :: Term -> TCM SizeMaxView+sizeMaxView :: PureTCM m => Term -> m SizeMaxView sizeMaxView v = do-  inf <- getBuiltinDefName builtinSizeInf-  suc <- getBuiltinDefName builtinSizeSuc-  max <- getBuiltinDefName builtinSizeMax+  inf <- getBuiltinName' builtinSizeInf+  suc <- getBuiltinName' builtinSizeSuc+  max <- getBuiltinName' builtinSizeMax   let loop v = do         v <- reduce v-        case ignoreSharing v of-          Def x []                   | Just x == inf -> return $ [DSizeInf]+        case v of+          Def x []                   | Just x == inf -> return $ singleton $ DSizeInf           Def x [Apply u]            | Just x == suc -> maxViewSuc_ (fromJust suc) <$> loop (unArg u)           Def x [Apply u1, Apply u2] | Just x == max -> maxViewMax <$> loop (unArg u1) <*> loop (unArg u2)-          Var i []                      -> return $ [DSizeVar i 0]-          MetaV x us                    -> return $ [DSizeMeta x us 0]-          _                             -> return $ [DOtherSize v]+          Var i es | Just pv <- ProjectedVar i <$> mapM isProjElim es+                                        -> return $ singleton $ DSizeVar pv 0+          MetaV x us                    -> return $ singleton $ DSizeMeta x us 0+          _                             -> return $ singleton $ DOtherSize v   loop v  ------------------------------------------------------------------------ -- * Size comparison that might add constraints. ------------------------------------------------------------------------ +{-# SPECIALIZE compareSizes :: Comparison -> Term -> Term -> TCM () #-} -- | Compare two sizes.-compareSizes :: Comparison -> Term -> Term -> TCM ()-compareSizes cmp u v = do+compareSizes :: (MonadConversion m) => Comparison -> Term -> Term -> m ()+compareSizes cmp u v = verboseBracket "tc.conv.size" 10 "compareSizes" $ do   reportSDoc "tc.conv.size" 10 $ vcat-    [ text "Comparing sizes"+    [ "Comparing sizes"     , nest 2 $ sep [ prettyTCM u <+> prettyTCM cmp                    , prettyTCM v                    ]@@ -268,45 +312,63 @@     u <- reduce u     v <- reduce v     reportSDoc "tc.conv.size" 60 $-      nest 2 $ sep [ text (show u) <+> prettyTCM cmp-                   , text (show v)+      nest 2 $ sep [ pretty u <+> prettyTCM cmp+                   , pretty v                    ]+  whenProfile Profile.Conversion $ tick "compare sizes"   us <- sizeMaxView u   vs <- sizeMaxView v   compareMaxViews cmp us vs  -- | Compare two sizes in max view.-compareMaxViews :: Comparison -> SizeMaxView -> SizeMaxView -> TCM ()+compareMaxViews :: (MonadConversion m) => Comparison -> SizeMaxView -> SizeMaxView -> m () compareMaxViews cmp us vs = case (cmp, us, vs) of-  (CmpLeq, _, (DSizeInf : _)) -> return ()-  (cmp,   [u], [v]) -> compareSizeViews cmp u v-  (CmpLeq, us, [v]) -> forM_ us $ \ u -> compareSizeViews cmp u v-  (CmpLeq, us, vs)  -> forM_ us $ \ u -> compareBelowMax u vs-  (CmpEq,  us, vs)  -> compareMaxViews CmpLeq us vs >> compareMaxViews CmpLeq vs us+  (CmpLeq, _, (DSizeInf :| _)) -> return ()+  (cmp,    u :| [], v :| []) -> compareSizeViews cmp u v+  (CmpLeq, us,      v :| []) -> Fold.forM_ us $ \ u -> compareSizeViews cmp u v+  (CmpLeq, us,      vs)      -> Fold.forM_ us $ \ u -> compareBelowMax u vs+  (CmpEq,  us,      vs)      -> do+    compareMaxViews CmpLeq us vs+    compareMaxViews CmpLeq vs us  -- | @compareBelowMax u vs@ checks @u <= max vs@.  Precondition: @size vs >= 2@-compareBelowMax :: DeepSizeView -> SizeMaxView -> TCM ()-compareBelowMax u vs =-  alt (dontAssignMetas $ alts $ map (compareSizeViews CmpLeq u) vs) $ do+compareBelowMax :: (MonadConversion m) => DeepSizeView -> SizeMaxView -> m ()+compareBelowMax u vs = verboseBracket "tc.conv.size" 45 "compareBelowMax" $ do+  reportSDoc "tc.conv.size" 45 $ sep+    [ pretty u+    , pretty CmpLeq+    , pretty vs+    ]+  -- When trying several alternatives, we do not assign metas+  -- and also do not produce constraints (see 'giveUp' below).+  -- Andreas, 2019-03-28, issue #3600.+  alt (dontAssignMetas $ Fold.foldr1 alt $ fmap (compareSizeViews CmpLeq u) vs) $ do+    reportSDoc "tc.conv.size" 45 $ vcat+      [ "compareBelowMax: giving up"+      ]     u <- unDeepSizeView u     v <- unMaxView vs     size <- sizeType-    addConstraint $ ValueCmp CmpLeq size u v-  where alt  c1 c2 = c1 `catchError` const c2-        alts []     = __IMPOSSIBLE__-        alts [c]    = c-        alts (c:cs) = c `alt` alts cs+    giveUp CmpLeq size u v+  where+  alt c1 c2 = c1 `catchError` const c2 -compareSizeViews :: Comparison -> DeepSizeView -> DeepSizeView -> TCM ()+compareSizeViews :: (MonadConversion m) => Comparison -> DeepSizeView -> DeepSizeView -> m () compareSizeViews cmp s1' s2' = do+  reportSDoc "tc.conv.size" 45 $ hsep+    [ "compareSizeViews"+    , pretty s1'+    , pretty cmp+    , pretty s2'+    ]   size <- sizeType   let (s1, s2) = removeSucs (s1', s2')       withUnView cont = do         u <- unDeepSizeView s1         v <- unDeepSizeView s2         cont u v-      failure = withUnView $ \ u v -> typeError $ UnequalTerms cmp u v size-      continue cmp = withUnView $ compareAtom cmp size+      failure = withUnView $ \ u v -> typeError $ UnequalTerms cmp u v AsSizes+      continue cmp = withUnView $ compareAtom cmp AsSizes   case (cmp, s1, s2) of     (CmpLeq, _,            DSizeInf)   -> return ()     (CmpEq,  DSizeInf,     DSizeInf)   -> return ()@@ -315,7 +377,7 @@     (_    ,  DSizeInf,     _         ) -> continue CmpEq     (CmpLeq, DSizeVar i n, DSizeVar j m) | i == j -> unless (n <= m) failure     (CmpLeq, DSizeVar i n, DSizeVar j m) | i /= j -> do-       res <- isBounded i+       res <- isBoundedProjVar i        case res of          BoundedNo -> failure          BoundedLt u' -> do@@ -327,11 +389,22 @@               compareSizes cmp u'' v              else compareSizes cmp u' =<< sizeSuc 1 v     (CmpLeq, s1,        s2)         -> withUnView $ \ u v -> do-      unlessM (trivial u v) $ addConstraint $ ValueCmp CmpLeq size u v+      unlessM (trivial u v) $ giveUp CmpLeq size u v     (CmpEq, s1, s2) -> continue cmp +-- | If 'envAssignMetas' then postpone as constraint, otherwise, fail hard.+--   Failing is required if we speculatively test several alternatives.+giveUp :: (MonadConversion m) => Comparison -> Type -> Term -> Term -> m ()+giveUp cmp size u v =+  ifM (asksTC envAssignMetas)+    {-then-} (do+      -- TODO: compute proper blocker+      unblock <- unblockOnAnyMetaIn <$> instantiateFull [u, v]+      addConstraint unblock $ ValueCmp CmpLeq AsSizes u v)+    {-else-} (typeError $ UnequalTerms cmp u v AsSizes)+ -- | Checked whether a size constraint is trivial (like @X <= X+1@).-trivial :: Term -> Term -> TCM Bool+trivial :: (MonadConversion m) => Term -> Term -> m Bool trivial u v = do     a@(e , n ) <- oldSizeExpr u     b@(e', n') <- oldSizeExpr v@@ -339,9 +412,9 @@           -- Andreas, 2012-02-24  filtering out more trivial constraints fixes           -- test/lib-succeed/SizeInconsistentMeta4.agda     reportSDoc "tc.conv.size" 60 $-      nest 2 $ sep [ if triv then text "trivial constraint" else empty-                   , text (show a) <+> text "<="-                   , text (show b)+      nest 2 $ sep [ if triv then "trivial constraint" else empty+                   , pretty a <+> "<="+                   , pretty b                    ]     return triv   `catchError` \_ -> return False@@ -351,23 +424,39 @@ ------------------------------------------------------------------------  -- | Test whether a problem consists only of size constraints.-isSizeProblem :: ProblemId -> TCM Bool-isSizeProblem pid = andM . map (isSizeConstraint . theConstraint) =<< getConstraintsForProblem pid+isSizeProblem :: (ReadTCState m, HasOptions m, HasBuiltins m) => ProblemId -> m Bool+isSizeProblem pid = do+  test <- isSizeTypeTest+  all (mkIsSizeConstraint test (const True) . theConstraint) <$> getConstraintsForProblem pid --- | Test is a constraint speaks about sizes.-isSizeConstraint :: Closure Constraint -> TCM Bool-isSizeConstraint Closure{ clValue = ValueCmp _ s _ _ } = isJust <$> isSizeType s-isSizeConstraint _ = return False+-- | Test whether a constraint speaks about sizes.+isSizeConstraint :: (HasOptions m, HasBuiltins m) => (Comparison -> Bool) -> Closure Constraint -> m Bool+isSizeConstraint p c = isSizeTypeTest <&> \ test -> mkIsSizeConstraint test p c --- | Find the size constraints.-getSizeConstraints :: TCM [Closure Constraint]-getSizeConstraints = do+mkIsSizeConstraint :: (Term -> Maybe BoundedSize) -> (Comparison -> Bool) -> Closure Constraint -> Bool+mkIsSizeConstraint test = isSizeConstraint_ $ isJust . test . unEl++isSizeConstraint_+  :: (Type -> Bool)       -- ^ Test for being a sized type+  -> (Comparison -> Bool) -- ^ Restriction to these directions.+  -> Closure Constraint+  -> Bool+isSizeConstraint_ _isSizeType p Closure{ clValue = ValueCmp cmp AsSizes       _ _ } = p cmp+isSizeConstraint_  isSizeType p Closure{ clValue = ValueCmp cmp (AsTermsOf s) _ _ } = p cmp && isSizeType s+isSizeConstraint_ _isSizeType _ _ = False++-- | Take out all size constraints of the given direction (DANGER!).+takeSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint]+takeSizeConstraints p = do   test <- isSizeTypeTest-  let sizeConstraint cl@Closure{ clValue = ValueCmp CmpLeq s _ _ }-              | isJust (test $ unEl s) = Just cl-      sizeConstraint _ = Nothing-  mapMaybe (sizeConstraint . theConstraint) <$> getAllConstraints+  takeConstraints (mkIsSizeConstraint test p . theConstraint) +-- | Find the size constraints of the matching direction.+getSizeConstraints :: (Comparison -> Bool) -> TCM [ProblemConstraint]+getSizeConstraints p = do+  test <- isSizeTypeTest+  filter (mkIsSizeConstraint test p . theConstraint) <$> getAllConstraints+ -- | Return a list of size metas and their context. getSizeMetas :: Bool -> TCM [(MetaId, Type, Telescope)] getSizeMetas interactionMetas = do@@ -376,9 +465,10 @@     getOpenMetas >>= do       mapM $ \ m -> do         let no = return Nothing-        mi <- lookupMeta m+        mi <- lookupLocalMeta m         case mvJudgement mi of-          HasType _ a -> do+          _ | BlockedConst{} <- mvInstantiation mi -> no  -- Blocked terms should not be touched (#2637, #2881)+          HasType _ cmp a -> do             TelV tel b <- telView a             -- b is reduced             caseMaybe (test $ unEl b) no $ \ _ -> do@@ -425,36 +515,37 @@ data OldSizeExpr   = SizeMeta MetaId [Int] -- ^ A size meta applied to de Bruijn indices.   | Rigid Int             -- ^ A de Bruijn index.-  deriving (Eq)+  deriving (Eq, Show) -instance Show OldSizeExpr where-  show (SizeMeta m _) = "X" ++ show (fromIntegral m :: Int)-  show (Rigid i)      = "c" ++ show i+instance Pretty OldSizeExpr where+  pretty (SizeMeta m _) = P.text "X" <> P.pretty m+  pretty (Rigid i)      = P.text $ "c" ++ show i  -- | Size constraints we can solve. data OldSizeConstraint   = Leq OldSizeExpr Int OldSizeExpr     -- ^ @Leq a +n b@ represents @a =< b + n@.     --   @Leq a -n b@ represents @a + n =< b@.+  deriving (Show) -instance Show OldSizeConstraint where-  show (Leq a n b)-    | n == 0    = show a ++ " =< " ++ show b-    | n > 0     = show a ++ " =< " ++ show b ++ " + " ++ show n-    | otherwise = show a ++ " + " ++ show (-n) ++ " =< " ++ show b+instance Pretty OldSizeConstraint where+  pretty (Leq a n b)+    | n == 0    = P.pretty a P.<+> "=<" P.<+> P.pretty b+    | n > 0     = P.pretty a P.<+> "=<" P.<+> P.pretty b P.<+> "+" P.<+> P.text (show n)+    | otherwise = P.pretty a P.<+> "+" P.<+> P.text (show (-n)) P.<+> "=<" P.<+> P.pretty b  -- | Compute a set of size constraints that all live in the same context --   from constraints over terms of type size that may live in different --   contexts. -- --   cf. 'Agda.TypeChecking.LevelConstraints.simplifyLevelConstraint'-oldComputeSizeConstraints :: [Closure Constraint] -> TCM [OldSizeConstraint]+oldComputeSizeConstraints :: [ProblemConstraint] -> TCM [OldSizeConstraint] oldComputeSizeConstraints [] = return [] -- special case to avoid maximum [] oldComputeSizeConstraints cs = catMaybes <$> mapM oldComputeSizeConstraint leqs   where     -- get the constraints plus contexts they are defined in-    gammas       = map (envContext . clEnv) cs-    ls           = map clValue cs+    gammas       = map (envContext . clEnv . theConstraint) cs+    ls           = map (clValue . theConstraint) cs     -- compute the longest context (common water level)     ns           = map size gammas     waterLevel   = maximum ns@@ -469,7 +560,7 @@   case c of     ValueCmp CmpLeq _ u v -> do         reportSDoc "tc.size.solve" 50 $ sep-          [ text "converting size constraint"+          [ "converting size constraint"           , prettyTCM c           ]         (a, n) <- oldSizeExpr u@@ -483,23 +574,24 @@ -- | Turn a term with de Bruijn indices into a size expression with offset. -- --   Throws a 'patternViolation' if the term isn't a proper size expression.-oldSizeExpr :: Term -> TCM (OldSizeExpr, Int)+oldSizeExpr :: (PureTCM m, MonadBlock m) => Term -> m (OldSizeExpr, Int) oldSizeExpr u = do   u <- reduce u -- Andreas, 2009-02-09.                 -- This is necessary to surface the solutions of metavariables.-  reportSDoc "tc.conv.size" 60 $ text "oldSizeExpr:" <+> prettyTCM u+  reportSDoc "tc.conv.size" 60 $ "oldSizeExpr:" <+> prettyTCM u   s <- sizeView u   case s of-    SizeInf     -> patternViolation-    SizeSuc u   -> mapSnd (+1) <$> oldSizeExpr u-    OtherSize u -> case ignoreSharing u of+    SizeInf     -> patternViolation neverUnblock+    SizeSuc u   -> mapSnd (+ 1) <$> oldSizeExpr u+    OtherSize u -> case u of       Var i []  -> return (Rigid i, 0)       MetaV m es | Just xs <- mapM isVar es, fastDistinct xs                 -> return (SizeMeta m xs, 0)-      _ -> patternViolation+      _ -> patternViolation neverUnblock   where     isVar (Proj{})  = Nothing-    isVar (Apply v) = case ignoreSharing $ unArg v of+    isVar (IApply _ _ v) = isVar (Apply (defaultArg v))+    isVar (Apply v) = case unArg v of       Var i [] -> Just i       _        -> Nothing @@ -524,123 +616,17 @@   case (a,b) of     (Rigid{}, Rigid{})       -> return c     (SizeMeta m xs, Rigid i) -> do-      j <- findIndex (==i) xs+      j <- List.elemIndex i xs       return $ Leq (SizeMeta m [0..size xs-1]) n (Rigid j)     (Rigid i, SizeMeta m xs) -> do-      j <- findIndex (==i) xs+      j <- List.elemIndex i xs       return $ Leq (Rigid j) n (SizeMeta m [0..size xs-1])     (SizeMeta m xs, SizeMeta l ys)          -- try to invert xs on ys-       | Just ys' <- mapM (\ y -> findIndex (==y) xs) ys ->+       | Just ys' <- mapM (\ y -> List.elemIndex y xs) ys ->            return $ Leq (SizeMeta m [0..size xs-1]) n (SizeMeta l ys')          -- try to invert ys on xs-       | Just xs' <- mapM (\ x -> findIndex (==x) ys) xs ->+       | Just xs' <- mapM (\ x -> List.elemIndex x ys) xs ->            return $ Leq (SizeMeta m xs') n (SizeMeta l [0..size ys-1])          -- give up        | otherwise -> Nothing---- | Main function.---   Uses the old solver for size constraints using "Agda.Utils.Warshall".---   This solver does not smartly use size hypotheses @j : Size< i@.---   It only checks that its computed solution is compatible-oldSolveSizeConstraints :: TCM ()-oldSolveSizeConstraints = whenM haveSizedTypes $ do-  reportSLn "tc.size.solve" 70 $ "Considering to solve size constraints"-  cs0 <- getSizeConstraints-  cs <- oldComputeSizeConstraints cs0-  ms <- getSizeMetas True -- get all size metas, also interaction metas--  when (not (null cs) || not (null ms)) $ do-    reportSLn "tc.size.solve" 10 $ "Solving size constraints " ++ show cs--    cs <- return $ mapMaybe oldCanonicalizeSizeConstraint cs-    reportSLn "tc.size.solve" 10 $ "Canonicalized constraints: " ++ show cs--    let -- Error for giving up-        cannotSolve = typeError . GenericDocError =<<-          vcat (text "Cannot solve size constraints" : map prettyTCM cs0)--        -- Size metas in constraints.-        metas0 :: [(MetaId, Int)]  -- meta id + arity-        metas0 = nub $ map (mapSnd length) $ concatMap flexibleVariables cs--        -- Unconstrained size metas that do not occur in constraints.-        metas1 :: [(MetaId, Int)]-        metas1 = forMaybe ms $ \ (m, _, tel) ->-          maybe (Just (m, size tel)) (const Nothing) $-            lookup m metas0--        -- All size metas-        metas = metas0 ++ metas1--    reportSLn "tc.size.solve" 15 $ "Metas: " ++ show metas0 ++ ", " ++ show metas1--    verboseS "tc.size.solve" 20 $-        -- debug print the type of all size metas-        forM_ metas $ \ (m, _) ->-            reportSDoc "tc.size.solve" 20 $ prettyTCM =<< mvJudgement <$> lookupMeta m--    -- Run the solver.-    unlessM (oldSolver metas cs) cannotSolve--    -- Double-checking the solution.--    -- Andreas, 2012-09-19-    -- The returned solution might not be consistent with-    -- the hypotheses on rigid vars (j : Size< i).-    -- Thus, we double check that all size constraints-    -- have been solved correctly.-    flip catchError (const cannotSolve) $-      noConstraints $-        forM_ cs0 $ \ cl -> enterClosure cl solveConstraint----- | Old solver for size constraints using "Agda.Utils.Warshall".---   This solver does not smartly use size hypotheses @j : Size< i@.-oldSolver-  :: [(MetaId, Int)]      -- ^ Size metas and their arity.-  -> [OldSizeConstraint]  -- ^ Size constraints (in preprocessed form).-  -> TCM Bool             -- ^ Returns @False@ if solver fails.-oldSolver metas cs = do-  let cannotSolve    = return False-      mkFlex (m, ar) = W.NewFlex (fromIntegral m) $ \ i -> fromIntegral i < ar-      mkConstr (Leq a n b)  = W.Arc (mkNode a) n (mkNode b)-      mkNode (Rigid i)      = W.Rigid $ W.RVar i-      mkNode (SizeMeta m _) = W.Flex $ fromIntegral m--  -- run the Warshall solver-  case W.solve $ map mkFlex metas ++ map mkConstr cs of-    Nothing  -> cannotSolve-    Just sol -> do-      reportSLn "tc.size.solve" 10 $ "Solved constraints: " ++ show sol-      suc   <- primSizeSuc-      infty <- primSizeInf-      let plus v 0 = v-          plus v n = suc `apply1` plus v (n - 1)--          inst (i, e) = do--            let m  = fromIntegral i  -- meta variable identifier-                ar = fromMaybe __IMPOSSIBLE__ $ lookup m metas  -- meta var arity--                term (W.SizeConst W.Infinite) = infty-                term (W.SizeVar j n) | j < ar = plus (var $ ar - j - 1) n-                term _                        = __IMPOSSIBLE__--                tel = replicate ar $ defaultArg "s"-                -- convert size expression to term-                v = term e--            reportSDoc "tc.size.solve" 20 $ sep-              [ pretty m <+> text ":="-              , nest 2 $ prettyTCM v-              ]--            -- Andreas, 2012-09-25: do not assign interaction metas to \infty-            let isInf (W.SizeConst W.Infinite) = True-                isInf _                        = False-            unlessM (((isInf e &&) . isJust <$> isInteractionMeta m) `or2M` isFrozen m) $-              assignTerm m tel v--      mapM_ inst $ Map.toList sol-      return True
+ src/full/Agda/TypeChecking/SizedTypes/Pretty.hs view
@@ -0,0 +1,50 @@++module Agda.TypeChecking.SizedTypes.Pretty where++import Control.Monad+import Data.Maybe++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.TypeChecking.Monad.Base.Types+import Agda.TypeChecking.Monad.Builtin (HasBuiltins, builtinSizeInf, getBuiltin')+import Agda.TypeChecking.Monad.Context (unsafeModifyContext, contextNames)+import Agda.TypeChecking.Monad.SizedTypes+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.SizedTypes.Syntax++import Agda.Utils.Function+import Agda.Utils.Impossible++-- | Turn a size expression into a term.+unSizeExpr :: HasBuiltins m => DBSizeExpr -> m Term+unSizeExpr a =+  case a of+    Infty         -> fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeInf+    Rigid r (O n) -> do+      unless (n >= 0) __IMPOSSIBLE__+      sizeSuc n $ var $ rigidIndex r+    Flex (SizeMeta x es) (O n) -> do+      unless (n >= 0) __IMPOSSIBLE__+      sizeSuc n $ MetaV x $ map (Apply . defaultArg . var) es+    Const{} -> __IMPOSSIBLE__++instance PrettyTCM SizeMeta where+  prettyTCM (SizeMeta x es) = prettyTCM (MetaV x $ map (Apply . defaultArg . var) es)++-- | Assumes we are in the right context.+instance PrettyTCM (SizeConstraint) where+  prettyTCM (Constraint a cmp b) = do+    u <- unSizeExpr a+    v <- unSizeExpr b+    prettyTCM u <+> pretty cmp <+> prettyTCM v++instance PrettyTCM HypSizeConstraint where+  prettyTCM (HypSizeConstraint cxt _ hs c) =+    unsafeModifyContext (const cxt) $ do+      let cxtNames = contextNames cxt+      -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do+      prettyList (map prettyTCM cxtNames) <+> do+        applyUnless (null hs)+          ((hcat (punctuate ", " $ map prettyTCM hs) <+> "|-") <+>)+          (prettyTCM c)
src/full/Agda/TypeChecking/SizedTypes/Solve.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables   #-}  -- | Solving size constraints under hypotheses. --@@ -52,68 +50,58 @@  import Prelude hiding (null) -import Control.Monad hiding (forM, forM_)+import Control.Monad.Except ( catchError ) import Control.Monad.Trans.Maybe-import Control.Monad.Reader (asks) -import Data.Foldable (Foldable, foldMap, forM_)-import Data.Function+import Data.Either+import Data.Foldable (forM_)+import qualified Data.Foldable as Fold+import Data.Function (on)+import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Monoid import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import qualified Data.Traversable as Trav-import Data.Traversable (Traversable, forM)--import Agda.Interaction.Options+import Data.Traversable (forM)  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars  import Agda.TypeChecking.Monad as TCM hiding (Offset)-import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Free import Agda.TypeChecking.Reduce import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Conversion import Agda.TypeChecking.Constraints as C  import qualified Agda.TypeChecking.SizedTypes as S+import Agda.TypeChecking.SizedTypes.Pretty import Agda.TypeChecking.SizedTypes.Syntax as Size import Agda.TypeChecking.SizedTypes.Utils-import Agda.TypeChecking.SizedTypes.WarshallSolver as Size+import Agda.TypeChecking.SizedTypes.WarshallSolver as Size hiding (simplify1)  import Agda.Utils.Cluster-import Agda.Utils.Either-import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens--#if MIN_VERSION_base(4,8,0)-import qualified Agda.Utils.List as List hiding ( uncons )-#else+import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, (<|)) import qualified Agda.Utils.List as List-#endif-+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import Agda.Syntax.Common.Pretty (Pretty, prettyShow)+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Singleton import Agda.Utils.Size-import Agda.Utils.Tuple import qualified Agda.Utils.VarSet as VarSet -import qualified Agda.Utils.Either as Either--#include "undefined.h" import Agda.Utils.Impossible -type CC = Closure TCM.Constraint- -- | Flag to control the behavior of size solver. data DefaultToInfty   = DefaultToInfty      -- ^ Instantiate all unconstrained size variables to ∞.@@ -125,16 +113,16 @@ solveSizeConstraints :: DefaultToInfty -> TCM () solveSizeConstraints flag =  do -  -- 1. Get the constraints normalised.+  -- 1. Take out the size constraints normalised. -  cs0 <- mapM (mapClosure normalise) =<< S.getSizeConstraints+  -- NOTE: this deletes the size constraints from the constraint set!+  cs0 :: [ProblemConstraint]+    <- forMM (S.takeSizeConstraints (== CmpLeq)) $ \ (c :: ProblemConstraint) -> do+      mapClosure normalise (theConstraint c) <&> \ cl -> c { theConstraint = cl }+   unless (null cs0) $     reportSDoc "tc.size.solve" 40 $ vcat $-      [ text $ "Solving constraints (" ++ show flag ++ ")"-      ] ++ map prettyTCM cs0-  let -- Error for giving up-      cannotSolve = typeError . GenericDocError =<<-        vcat (text "Cannot solve size constraints" : map prettyTCM cs0)+      text ( "Solving constraints (" ++ show flag ++ ")" ) : map prettyTCM cs0    -- 2. Cluster the constraints by common size metas. @@ -142,18 +130,18 @@   sizeMetaSet <- Set.fromList . map (\ (x, _t, _tel) -> x) <$> S.getSizeMetas True    -- Pair each constraint with its list of size metas occurring in it.-  cms <- forM cs0 $ \ cl -> enterClosure cl $ \ c -> do+  cms <- forM cs0 $ \ cl -> enterClosure (theConstraint cl) $ \ c -> do      -- @allMetas@ does not reduce or instantiate;     -- this is why we require the size constraints to be normalised.-    return (cl, map metaId . Set.toList $-      sizeMetaSet `Set.intersection` Set.fromList (allMetas c))+    return (cl, Set.toList $+      sizeMetaSet `Set.intersection` allMetas singleton c)    -- Now, some constraints may have no metas (clcs), the others have at least one (othercs).-  let classify :: (a, [b]) -> Either a (a, (b,[b]))+  let classify :: (a, [b]) -> Either a (a, List1 b)       classify (cl, [])     = Left  cl-      classify (cl, (x:xs)) = Right (cl, (x,xs))-  let (clcs, othercs) = List.mapEither classify cms+      classify (cl, (x:xs)) = Right (cl, x :| xs)+  let (clcs, othercs) = partitionEithers $ map classify cms    -- We cluster the constraints by their metas.   let ccs = cluster' othercs@@ -167,25 +155,27 @@   -- Solve the clusters.    constrainedMetas <- Set.unions <$> do-    forM  (ccs) $ \ (cs :: [CC]) -> do-      when (null cs) __IMPOSSIBLE__+    forM  (ccs) $ \ (cs :: List1 ProblemConstraint) -> do +      reportSDoc "tc.size.solve" 60 $ vcat $+        "size constraint cluster:" <| fmap (text . show) cs+       -- Convert each constraint in the cluster to the largest context.       -- (Keep fingers crossed). -      enterClosure (List.maximumBy (compare `on` (length . envContext . clEnv)) cs) $ \ _ -> do+      enterClosure (Fold.maximumBy (compare `on` (length . envContext . clEnv)) $ fmap theConstraint cs) $ \ _ -> do         -- Get all constraints that can be cast to the longest context.-        cs' :: [TCM.Constraint] <- catMaybes <$> do+        cs' :: [ProblemConstraint] <- List1.catMaybes <$> do           mapM (runMaybeT . castConstraintToCurrentContext) cs          reportSDoc "tc.size.solve" 20 $ vcat $-          [ text "converted size constraints to context: " <+> do+          ( "converted size constraints to context: " <+> do               tel <- getContextTelescope               inTopContext $ prettyTCM tel-          ] ++ map (nest 2 . prettyTCM) cs'+          ) : map (nest 2 . prettyTCM) cs'          -- Solve the converted constraints.-        solveSizeConstraints_ flag =<<  mapM buildClosure cs'+        solveSizeConstraints_ flag cs'    -- 4. Possibly set remaining metas to infinity. @@ -196,7 +186,7 @@     --       for cs0 $ \ Closure{ clValue = ValueCmp _ _ u v } ->     --         allMetas u ++ allMetas v -    -- Set the unconstrained size metas to ∞.+    -- Set the unconstrained, open size metas to ∞.     ms <- S.getSizeMetas False -- do not get interaction metas     unless (null ms) $ do       inf <- primSizeInf@@ -204,20 +194,26 @@         unless (m `Set.member` constrainedMetas) $ do         unlessM (isFrozen m) $ do         reportSDoc "tc.size.solve" 20 $-          text "solution " <+> prettyTCM (MetaV m []) <+>-          text " := "      <+> prettyTCM inf+          "solution " <+> prettyTCM (MetaV m []) <+>+          " := "      <+> prettyTCM inf         assignMeta 0 m t (List.downFrom $ size tel) inf    -- -- Double check.+  -- let -- Error for giving up+  --     cannotSolve :: TCM a+  --     cannotSolve = typeError . GenericDocError =<<+  --       vcat ("Cannot solve size constraints" : map prettyTCM cs0)   -- unless (null cs0 && null ms) $ do   --   flip catchError (const cannotSolve) $   --     noConstraints $   --       forM_ cs0 $ \ cl -> enterClosure cl solveConstraint    -- 5. Make sure we did not lose any constraints.-  forM_ cs0 $ \ cl -> enterClosure cl solveConstraint +  -- This is necessary since we have removed the size constraints.+  forM_ cs0 $ withConstraint solveConstraint + -- | TODO: this does not actually work! -- --   We would like to use a constraint @c@ created in context @Δ@ from module @N@@@ -266,20 +262,20 @@   let gamma2 = gamma - size gamma1    -- Γ ⊢ σ : Δ₁-  sigma <- liftTCM $ getModuleParameterSub modN+  sigma <- liftTCM $ fromMaybe idS <$> getModuleParameterSub modN    -- Debug printing.-  reportSDoc "tc.constr.cast" 40 $ text "casting constraint" $$ do+  reportSDoc "tc.constr.cast" 40 $ "casting constraint" $$ do     tel <- getContextTelescope     inTopContext $ nest 2 $ vcat $-      [ text "current module                = " <+> prettyTCM modM-      , text "current module telescope      = " <+> prettyTCM gamma1-      , text "current context               = " <+> prettyTCM tel-      , text "constraint module             = " <+> prettyTCM modN-      , text "constraint module telescope   = " <+> prettyTCM delta1-      , text "constraint context            = " <+> (prettyTCM =<< enterClosure cl (const $ getContextTelescope))-      , text "constraint                    = " <+> enterClosure cl prettyTCM-      , text "module parameter substitution = " <+> prettyTCM sigma+      [ "current module                = " <+> prettyTCM modM+      , "current module telescope      = " <+> prettyTCM gamma1+      , "current context               = " <+> prettyTCM tel+      , "constraint module             = " <+> prettyTCM modN+      , "constraint module telescope   = " <+> prettyTCM delta1+      , "constraint context            = " <+> (prettyTCM =<< enterClosure cl (const $ getContextTelescope))+      , "constraint                    = " <+> enterClosure cl prettyTCM+      , "module parameter substitution = " <+> prettyTCM sigma       ]    -- If gamma2 < 0, we must be in the wrong context.@@ -308,7 +304,10 @@   where     raiseMaybe n c = do       -- Fine if we have to weaken or strengthening is safe.-      guard $ n >= 0 || List.all (>= -n) (VarSet.toList $ allVars $ freeVars c)+      guard $+        n >= 0 ||+        -- Are all free variables at least -n?+        IntSet.null (fst $ IntSet.split (-n) $ allFreeVars c)       return $ raise n c  @@ -319,67 +318,66 @@ -- --   This hack lets issue 2046 go through. -castConstraintToCurrentContext :: Closure TCM.Constraint -> MaybeT TCM TCM.Constraint-castConstraintToCurrentContext cl = do-  -- The target context-  gamma <- asks envContext-  -- The context where the constraint lives.-  let delta = envContext $ clEnv cl-  -- The constraint-  let c = clValue cl-  let findInGamma (Ctx cid (Dom _ (x, t))) =-        -- try to find same CtxId (safe)-        case List.findIndex ((cid ==) . ctxId) gamma of-          Just i -> Just i-          Nothing ->-            -- match by name (hazardous)-            -- This is one of the seven deadly sins (not respecting alpha).-            List.findIndex ((x ==) . fst . unDom . ctxEntry) gamma-  let cand = map findInGamma delta-  -- The domain of our substitution-  let coveredVars = VarSet.fromList $ catMaybes $ zipWith ($>) cand [0..]-  -- Check that all the free variables of the constraint are contained in-  -- coveredVars.-  -- We ignore the free variables occurring in sorts.-  guard $ getAll $ runFree (\ (i, _) -> All $ i `VarSet.member` coveredVars) IgnoreAll c-  -- Turn cand into a substitution.-  -- Since we ignored the free variables in sorts, we better patch up-  -- the substitution with some dummy term (Sort Prop) rather than __IMPOSSIBLE__.-  let dummy = Sort Prop-  let sigma = parallelS $ map (maybe dummy var) cand+castConstraintToCurrentContext :: ProblemConstraint -> MaybeT TCM ProblemConstraint+castConstraintToCurrentContext c = do+  -- The checkpoint of the contraint+  let cl = theConstraint c+      cp = envCurrentCheckpoint $ clEnv cl+  sigma <- caseMaybeM (viewTC $ eCheckpoints . key cp)+          (do+            -- We are not in a descendant of the constraint checkpoint.+            -- Here be dragons!!+            gamma <- getContext -- The target context+            let findInGamma ce =+                  -- match by name (hazardous)+                  -- This is one of the seven deadly sins (not respecting alpha).+                  List.findIndex (((==) `on` ctxEntryName) ce) gamma+            let delta = envContext $ clEnv cl+                cand  = map findInGamma delta+            -- The domain of our substitution+            let coveredVars = VarSet.fromList $ catMaybes $ zipWith ($>) cand [0..]+            -- Check that all the free variables of the constraint are contained in+            -- coveredVars.+            -- We ignore the free variables occurring in sorts.+            guard $ getAll $ runFree (All . (`VarSet.member` coveredVars)) IgnoreAll (clValue cl)+            -- Turn cand into a substitution.+            -- Since we ignored the free variables in sorts, we better patch up+            -- the substitution with some dummy term rather than __IMPOSSIBLE__.+            return $ parallelS $ map (maybe __DUMMY_TERM__ var) cand+          ) return -- Phew, we've got the checkpoint! All is well.   -- Apply substitution to constraint and pray that the Gods are merciful on us.-  return $ applySubst sigma c+  cl' <- buildClosure $ applySubst sigma (clValue cl)+  return $ c { theConstraint = cl' }   -- Note: the resulting constraint may not well-typed.   -- Even if it is, it may map variables to their wrong counterpart.  -- | Return the size metas occurring in the simplified constraints. --   A constraint like @↑ _j =< ∞ : Size@ simplifies to nothing, --   so @_j@ would not be in this set.-solveSizeConstraints_ :: DefaultToInfty -> [CC] -> TCM (Set MetaId)+solveSizeConstraints_ :: DefaultToInfty -> [ProblemConstraint] -> TCM (Set MetaId) solveSizeConstraints_ flag cs0 = do   -- Pair constraints with their representation as size constraints.   -- Discard constraints that do not have such a representation.-  ccs :: [(CC,HypSizeConstraint)] <- catMaybes <$> do+  ccs :: [(ProblemConstraint, HypSizeConstraint)] <- catMaybes <$> do     forM cs0 $ \ c0 -> fmap (c0,) <$> computeSizeConstraint c0    -- Simplify constraints and check for obvious inconsistencies.-  ccs' <- concat <$> do-    forM ccs $ \ (c0, HypSizeConstraint cxt hids hs sc) -> do+  ccs' :: [(ProblemConstraint, HypSizeConstraint)] <- concat <$> do+    forM ccs $ \ cc@(c0 :: ProblemConstraint, HypSizeConstraint cxt hids hs sc) -> do       case simplify1 (\ sc -> return [sc]) sc of-        Left _ -> typeError . GenericDocError =<< do-          text "Contradictory size constraint" <+> prettyTCM c0-        Right cs -> return $ (c0,) . HypSizeConstraint cxt hids hs <$> cs+        Nothing -> typeError $ ContradictorySizeConstraint cc+        Just cs -> return $ (c0,) . HypSizeConstraint cxt hids hs <$> cs    -- Cluster constraints according to the meta variables they mention.   -- @csNoM@ are the constraints that do not mention any meta.   let (csNoM, csMs) = (`List.partitionMaybe` ccs') $ \ p@(c0, c) ->-        fmap (p,) $ List.uncons $ map (metaId . sizeMetaId) $ Set.toList $ flexs c+        fmap (p,) $ nonEmpty $ map sizeMetaId $ Set.toList $ flexs c   -- @css@ are the clusters of constraints.-      css :: [[(CC,HypSizeConstraint)]]+      css :: [List1 (ProblemConstraint, HypSizeConstraint)]       css = cluster' csMs    -- Check that the closed constraints are valid.-  solveCluster flag csNoM+  whenJust (nonEmpty csNoM) $ solveCluster flag    -- Now, process the clusters.   forM_ css $ solveCluster flag@@ -388,16 +386,16 @@  -- | Solve a cluster of constraints sharing some metas. ---solveCluster :: DefaultToInfty -> [(CC,HypSizeConstraint)] -> TCM ()-solveCluster flag [] = return ()+solveCluster :: DefaultToInfty -> List1 (ProblemConstraint, HypSizeConstraint) -> TCM () solveCluster flag ccs = do-  let cs = map snd ccs-  let err reason = typeError . GenericDocError =<< do-        vcat $-          [ text $ "Cannot solve size constraints" ] ++ map prettyTCM cs ++-          [ text $ "Reason: " ++ reason ]+  let+    err :: TCM Doc -> TCM a+    err mdoc = typeError . CannotSolveSizeConstraints ccs =<< mdoc+    cs :: List1 HypSizeConstraint+    cs = fmap snd ccs   reportSDoc "tc.size.solve" 20 $ vcat $-    [ text "Solving constraint cluster" ] ++ map prettyTCM cs+    "Solving constraint cluster" <| fmap prettyTCM cs+   -- Find the super context of all contexts. {-   -- We use the @'ctxId'@s.@@ -412,7 +410,7 @@           _          -> a       res = foldl' max (Right ci) cis'       noContext ((c,is),(c',is')) = typeError . GenericDocError =<< vcat-        [ text "Cannot solve size constraints; the following constraints have no common typing context:"+        [ "Cannot solve size constraints; the following constraints have no common typing context:"         , prettyTCM c         , prettyTCM c'         ]@@ -420,7 +418,7 @@ -}   -- We rely on the fact that contexts are only extended...   -- Just take the longest context.-  let HypSizeConstraint gamma hids hs _ = List.maximumBy (compare `on` (length . sizeContext)) cs+  let HypSizeConstraint gamma hids hs _ = Fold.maximumBy (compare `on` (length . sizeContext)) cs   -- Length of longest context.   let n = size gamma @@ -429,11 +427,11 @@   -- Canonicalize the constraints.   -- This is unsound in the presence of hypotheses.       csC :: [SizeConstraint]-      csC = applyWhen (null hs) (mapMaybe canonicalizeSizeConstraint) csL+      csC = applyWhen (null hs) (mapMaybe canonicalizeSizeConstraint) $ List1.toList csL   reportSDoc "tc.size.solve" 30 $ vcat $-    [ text "Size hypotheses" ] +++    [ "Size hypotheses" ] ++     map (prettyTCM . HypSizeConstraint gamma hids hs) hs ++-    [ text "Canonicalized constraints" ] +++    [ "Canonicalized constraints" ] ++     map (prettyTCM . HypSizeConstraint gamma hids hs) csC    -- -- ALT:@@ -464,25 +462,25 @@   --     csC = for cs $ \ (HypSizeConstraint cxt _ _ c) -> sub (size cxt) c    -- reportSDoc "tc.size.solve" 30 $ vcat $-  --   [ text "Size hypotheses" ]           ++ map prettyC hs ++-  --   [ text "Canonicalized constraints" ] ++ map prettyC csC+  --   [ "Size hypotheses" ]           ++ map prettyC hs +++  --   [ "Canonicalized constraints" ] ++ map prettyC csC    -- Convert size metas to flexible vars.   let metas :: [SizeMeta]-      metas = concat $ map (foldMap (:[])) csC-      csF   :: [Size.Constraint' NamedRigid Int]-      csF   = map (fmap (metaId . sizeMetaId)) csC+      metas = concatMap (foldMap (:[])) csC+      csF   :: [Size.Constraint' NamedRigid MetaId]+      csF   = map (fmap sizeMetaId) csC    -- Construct the hypotheses graph.-  let hyps = map (fmap (metaId . sizeMetaId)) hs+  let hyps = map (fmap sizeMetaId) hs   -- There cannot be negative cycles in hypotheses graph due to scoping.-  let hg = fromRight __IMPOSSIBLE__ $ hypGraph (rigids csF) hyps+  let hg = either __IMPOSSIBLE__ id $ hypGraph (rigids csF) hyps    -- -- Construct the constraint graph.   -- --    g :: Size.Graph NamedRigid Int Label   -- g <- either err return $ constraintGraph csF hg   -- reportSDoc "tc.size.solve" 40 $ vcat $-  --   [ text "Constraint graph"+  --   [ "Constraint graph"   --   , text (show g)   --   ] @@ -492,35 +490,36 @@   -- Andreas, 2016-07-13, issue 2096.   -- Running the solver once might result in unsolvable left-over constraints.   -- We need to iterate the solver to detect this.-  sol :: Solution NamedRigid Int <- either err return $-    iterateSolver Map.empty hg csF Map.empty+  sol :: Solution NamedRigid MetaId <- either err return $+    iterateSolver Map.empty hg csF emptySolution    -- Convert solution to meta instantiation.-  forM_ (Map.assocs sol) $ \ (m, a) -> do+  solved <- fmap Set.unions $ forM (Map.assocs $ theSolution sol) $ \ (m, a) -> do     unless (validOffset a) __IMPOSSIBLE__     -- Solution does not contain metas     u <- unSizeExpr $ fmap __IMPOSSIBLE__ a-    let x = MetaId m     let SizeMeta _ xs = fromMaybe __IMPOSSIBLE__ $-          List.find ((m==) . metaId . sizeMetaId) metas+          List.find ((m ==) . sizeMetaId) metas     -- Check that solution is well-scoped     let ys = rigidIndex <$> Set.toList (rigids a)         ok = all (`elem` xs) ys -- TODO: more efficient     -- unless ok $ err "ill-scoped solution for size meta variable"     u <- if ok then return u else primSizeInf-    t <- getMetaType x-    reportSDoc "tc.size.solve" 20 $ inTopContext $ modifyContext (const gamma) $ do+    t <- getMetaType m+    reportSDoc "tc.size.solve" 20 $ unsafeModifyContext (const gamma) $ do       let args = map (Apply . defaultArg . var) xs-      text "solution " <+> prettyTCM (MetaV x args) <+> text " := " <+> prettyTCM u+      "solution " <+> prettyTCM (MetaV m args) <+> " := " <+> prettyTCM u     reportSDoc "tc.size.solve" 60 $ vcat       [ text $ "  xs = " ++ show xs       , text $ "  u  = " ++ show u       ]-    assignMeta n x t xs u+    ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do+      assignMeta n m t xs u+      return $ Set.singleton m     -- WRONG:     -- let partialSubst = List.sort $ zip xs $ map var $ downFrom n-    -- assignMeta' n x t (length xs) partialSubst u-    -- WRONG: assign DirEq x (map (defaultArg . var) xs) u+    -- assignMeta' n m t (length xs) partialSubst u+    -- WRONG: assign DirEq m (map (defaultArg . var) xs) u    -- Possibly set remaining size metas to ∞ (issue 1862)   -- unless we have an interaction meta in the cluster (issue 2095).@@ -528,13 +527,12 @@   ims <- Set.fromList <$> getInteractionMetas    --  ms = unsolved size metas from cluster-  let ms = Set.fromList (map sizeMetaId metas) Set.\\  -- Some CPP or ghc does not like trailing backslash, thus, this comment!-             Set.mapMonotonic MetaId (Map.keysSet sol)+  let ms = Set.fromList (map sizeMetaId metas) Set.\\ solved   --  Make sure they do not contain an interaction point-  let noIP = Set.null $ Set.intersection ims ms+  let noIP = Set.disjoint ims ms    unless (null ms) $ reportSDoc "tc.size.solve" 30 $ fsep $-    [ text "cluster did not solve these size metas: " ] ++ map prettyTCM (Set.toList ms)+    "cluster did not solve these size metas: " : map prettyTCM (Set.toList ms)    solvedAll <- do     -- If no metas are left, we have solved this cluster completely.@@ -550,13 +548,13 @@         -- If one variable is frozen, we cannot set it (and hence not all) to ∞         let no = do               reportSDoc "tc.size.solve" 30 $-                prettyTCM (MetaV m []) <+> text "is frozen, cannot set it to ∞"+                prettyTCM (MetaV m []) <+> "is frozen, cannot set it to ∞"               return False-        ifM (isFrozen m) no $ {-else-} do+        ifM (isFrozen m `or2M` do not <$> asksTC envAssignMetas) no $ {-else-} do           reportSDoc "tc.size.solve" 20 $-            text "solution " <+> prettyTCM (MetaV m []) <+>-            text " := "      <+> prettyTCM inf-          t <- jMetaType . mvJudgement <$> lookupMeta m+            "solution " <+> prettyTCM (MetaV m []) <+>+            " := "      <+> prettyTCM inf+          t <- metaType m           TelV tel core <- telView t           unlessM (isJust <$> isSizeType core) __IMPOSSIBLE__           assignMeta 0 m t (List.downFrom $ size tel) inf@@ -564,31 +562,27 @@    -- Double check.   when solvedAll $ do-    let cs0 = map fst ccs-        -- Error for giving up-        cannotSolve = typeError . GenericDocError =<<-          vcat (text "Cannot solve size constraints" : map prettyTCM cs0)-    flip catchError (const cannotSolve) $-      noConstraints $-        forM_ cs0 $ \ cl -> enterClosure cl solveConstraint+      noConstraints $ mapM_ (withConstraint solveConstraint . fst) ccs+    `catchError` \ _ ->+      typeError $ CannotSolveSizeConstraints ccs empty  -- | Collect constraints from a typing context, looking for SIZELT hypotheses.-getSizeHypotheses :: Context -> TCM [(CtxId, SizeConstraint)]-getSizeHypotheses gamma = inTopContext $ modifyContext (const gamma) $ do+getSizeHypotheses :: Context -> TCM [(Nat, SizeConstraint)]+getSizeHypotheses gamma = unsafeModifyContext (const gamma) $ do   (_, msizelt) <- getBuiltinSize   caseMaybe msizelt (return []) $ \ sizelt -> do     -- Traverse the context from newest to oldest de Bruijn Index     catMaybes <$> do-      forM (zip [0..] gamma) $ \ (i, ce) -> do-        -- Get name and type of variable i.-        let xt = unDom $ ctxEntry ce-            x  = show $ fst xt-        t <- reduce . raise (1 + i) . unEl . snd $ xt-        case ignoreSharing t of-          Def d [Apply u] | d == sizelt -> do-            caseMaybeM (sizeExpr $ unArg u) (return Nothing) $ \ a ->-              return $ Just $ (ctxId ce, Constraint (Rigid (NamedRigid x i) 0) Lt a)-          _ -> return Nothing+      forM (zip [0..] gamma) $ \case+        (i, CtxVar x a) -> do+          -- Get name and type of variable i.+          let s = prettyShow x+          t <- reduce . raise (1 + i) . unEl . unDom $ a+          case t of+            Def d [Apply u] | d == sizelt -> do+              caseMaybeM (sizeExpr $ unArg u) (return Nothing) $ \ a ->+                return $ Just $ (i, Constraint (Rigid (NamedRigid s i) 0) Lt a)+            _ -> return Nothing  -- | Convert size constraint into form where each meta is applied --   to indices @n-1,...,1,0@ where @n@ is the arity of that meta.@@ -652,38 +646,8 @@     _ -> return c -} --- | Identifiers for rigid variables.-data NamedRigid = NamedRigid-  { rigidName  :: String   -- ^ Name for printing in debug messages.-  , rigidIndex :: Int      -- ^ De Bruijn index.-  }--instance Eq NamedRigid where (==) = (==) `on` rigidIndex-instance Ord NamedRigid where compare = compare `on` rigidIndex-instance Show NamedRigid where show = rigidName-instance Plus NamedRigid Int NamedRigid where-  plus (NamedRigid x i) j = NamedRigid x (i + j)---- | Size metas in size expressions.-data SizeMeta = SizeMeta-  { sizeMetaId   :: MetaId-  -- TODO to fix issue 300?-  -- , sizeMetaPerm :: Permutation -- ^ Permutation from the current context-  --                               --   to the context of the meta.-  , sizeMetaArgs :: [Int]       -- ^ De Bruijn indices.-  }---- | An equality which ignores the meta arguments.-instance Eq  SizeMeta where (==)    = (==)    `on` sizeMetaId--- | An order which ignores the meta arguments.-instance Ord SizeMeta where compare = compare `on` sizeMetaId--instance Show SizeMeta where show = show . sizeMetaId--instance PrettyTCM SizeMeta where-  prettyTCM (SizeMeta x es) = prettyTCM (MetaV x $ map (Apply . defaultArg . var) es)--instance Subst Term SizeMeta where+instance Subst SizeMeta where+  type SubstArg SizeMeta = Term   applySubst sigma (SizeMeta x es) = SizeMeta x (map raise es)     where       raise i =@@ -691,15 +655,9 @@           Var j [] -> j           _        -> __IMPOSSIBLE__ --- | Size expression with de Bruijn indices.-type DBSizeExpr = SizeExpr' NamedRigid SizeMeta---- deriving instance Functor     (SizeExpr' Int)--- deriving instance Foldable    (SizeExpr' Int)--- deriving instance Traversable (SizeExpr' Int)- -- | Only for 'raise'.-instance Subst Term (SizeExpr' NamedRigid SizeMeta) where+instance Subst (SizeExpr' NamedRigid SizeMeta) where+  type SubstArg (SizeExpr' NamedRigid SizeMeta) = Term   applySubst sigma a =     case a of       Infty   -> a@@ -710,49 +668,20 @@           Var j [] -> Rigid r{ rigidIndex = j } n           _        -> __IMPOSSIBLE__ -type SizeConstraint = Constraint' NamedRigid SizeMeta--instance Subst Term SizeConstraint where+instance Subst SizeConstraint where+  type SubstArg SizeConstraint = Term   applySubst sigma (Constraint a cmp b) =     Constraint (applySubst sigma a) cmp (applySubst sigma b) --- | Assumes we are in the right context.-instance PrettyTCM (SizeConstraint) where-  prettyTCM (Constraint a cmp b) = do-    u <- unSizeExpr a-    v <- unSizeExpr b-    prettyTCM u <+> text (show cmp) <+> prettyTCM v---- | Size constraint with de Bruijn indices.-data HypSizeConstraint = HypSizeConstraint-  { sizeContext    :: Context-  , sizeHypIds     :: [CtxId]-  , sizeHypotheses :: [SizeConstraint]  -- ^ Living in @Context@.-  , sizeConstraint :: SizeConstraint    -- ^ Living in @Context@.-  }--instance Flexs SizeMeta HypSizeConstraint where-  flexs (HypSizeConstraint _ _ hs c) = flexs hs `mappend` flexs c--instance PrettyTCM HypSizeConstraint where-  prettyTCM (HypSizeConstraint cxt _ hs c) =-    inTopContext $ modifyContext (const cxt) $ do-      let cxtNames = reverse $ map (fst . unDom . ctxEntry) cxt-      -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do-      prettyList (map prettyTCM cxtNames) <+> do-      applyUnless (null hs)-       (((hcat $ punctuate (text ", ") $ map prettyTCM hs) <+> text "|-") <+>)-       (prettyTCM c)- -- | Turn a constraint over de Bruijn indices into a size constraint.-computeSizeConstraint :: Closure TCM.Constraint -> TCM (Maybe HypSizeConstraint)+computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint) computeSizeConstraint c = do-  let cxt = envContext $ clEnv c-  inTopContext $ modifyContext (const cxt) $ do-    case clValue c of+  let cxt = envContext $ clEnv $ theConstraint c+  unsafeModifyContext (const cxt) $ do+    case clValue $ theConstraint c of       ValueCmp CmpLeq _ u v -> do         reportSDoc "tc.size.solve" 50 $ sep $-          [ text "converting size constraint"+          [ "converting size constraint"           , prettyTCM c           ]         ma <- sizeExpr u@@ -772,32 +701,20 @@ sizeExpr u = do   u <- reduce u -- Andreas, 2009-02-09.                 -- This is necessary to surface the solutions of metavariables.-  reportSDoc "tc.conv.size" 60 $ text "sizeExpr:" <+> prettyTCM u+  reportSDoc "tc.conv.size" 60 $ "sizeExpr:" <+> prettyTCM u   s <- sizeView u   case s of     SizeInf     -> return $ Just Infty     SizeSuc u   -> fmap (`plus` (1 :: Offset)) <$> sizeExpr u-    OtherSize u -> case ignoreSharing u of-      Var i []    -> (\ x -> Just $ Rigid (NamedRigid x i) 0) . show <$> nameOfBV i+    OtherSize u -> case u of+      Var i []    -> (\ x -> Just $ Rigid (NamedRigid x i) 0) . prettyShow <$> nameOfBV i --      MetaV m es  -> return $ Just $ Flex (SizeMeta m es) 0       MetaV m es | Just xs <- mapM isVar es, List.fastDistinct xs                   -> return $ Just $ Flex (SizeMeta m xs) 0       _           -> return Nothing   where     isVar (Proj{})  = Nothing-    isVar (Apply v) = case ignoreSharing $ unArg v of+    isVar (IApply _ _ v) = isVar (Apply (defaultArg v))+    isVar (Apply v) = case unArg v of       Var i [] -> Just i       _        -> Nothing---- | Turn a de size expression into a term.-unSizeExpr :: DBSizeExpr -> TCM Term-unSizeExpr a =-  case a of-    Infty         -> primSizeInf-    Rigid r (O n) -> do-      unless (n >= 0) __IMPOSSIBLE__-      sizeSuc n $ var $ rigidIndex r-    Flex (SizeMeta x es) (O n) -> do-      unless (n >= 0) __IMPOSSIBLE__-      sizeSuc n $ MetaV x $ map (Apply . defaultArg . var) es-    Const{} -> __IMPOSSIBLE__
src/full/Agda/TypeChecking/SizedTypes/Syntax.hs view
@@ -1,29 +1,46 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Syntax of size expressions and constraints.  module Agda.TypeChecking.SizedTypes.Syntax where -import Data.Foldable (Foldable)+import Prelude hiding ( null )++import GHC.Generics (Generic)+import Control.DeepSeq+ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Traversable (Traversable) +import Agda.Syntax.Common++import Agda.TypeChecking.Monad.Base.Types hiding (Polarity) import Agda.TypeChecking.SizedTypes.Utils +import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty as P++import Agda.Utils.Impossible+ -- * Syntax  -- | Constant finite sizes @n >= 0@. newtype Offset = O Int-  deriving (Eq, Ord, Num, Enum)+  deriving (Eq, Ord, Generic, Num, Enum) +instance NFData Offset++-- This Show instance is ok because of the Num constraint. instance Show Offset where   show (O n) = show n +instance Pretty Offset where+  pretty (O n) = pretty n+ instance MeetSemiLattice Offset where   meet = min @@ -34,30 +51,42 @@ newtype Rigid  = RigidId { rigidId :: String }   deriving (Eq, Ord) -instance Show Rigid where show = rigidId+instance Show Rigid where+  show (RigidId s) = "RigidId " ++ show s +instance Pretty Rigid where+  pretty = text . rigidId+ -- | Size meta variables @X@ to solve for. newtype Flex   = FlexId { flexId :: String }   deriving (Eq, Ord) -instance Show Flex where show = flexId+instance Show Flex where+  show (FlexId s) = "FlexId " ++ show s +instance Pretty Flex where+  pretty = text . flexId+ -- | Size expressions appearing in constraints. data SizeExpr' rigid flex   = Const { offset :: Offset }                   -- ^ Constant number @n@.   | Rigid { rigid  :: rigid, offset :: Offset }  -- ^ Variable plus offset @i + n@.   | Infty                                        -- ^ Infinity @∞@.   | Flex  { flex   :: flex, offset :: Offset }   -- ^ Meta variable @X + n@.-    deriving (Eq, Ord, Functor, Foldable, Traversable)+    deriving (Show, Eq, Ord, Generic, Functor, Foldable, Traversable)  type SizeExpr = SizeExpr' Rigid Flex +instance (NFData r, NFData f) => NFData (SizeExpr' r f)+ -- | Comparison operator, e.g. for size expression. data Cmp   = Lt  -- ^ @<@.   | Le  -- ^ @≤@.-  deriving (Eq, Bounded, Enum)+  deriving (Show, Eq, Generic, Bounded, Enum) +instance NFData Cmp+ instance Dioid Cmp where   compose     = min   unitCompose = Le@@ -81,10 +110,12 @@   , cmp       :: Cmp   , rightExpr :: SizeExpr' rigid flex   }-  deriving (Functor, Foldable, Traversable)+  deriving (Show, Generic, Functor, Foldable, Traversable)  type Constraint = Constraint' Rigid Flex +instance (NFData r, NFData f) => NFData (Constraint' r f)+ -- * Polarities to specify solutions. ------------------------------------------------------------------------ @@ -101,8 +132,9 @@ emptyPolarities :: Polarities flex emptyPolarities = Map.empty +-- Used in size-solver (Andreas, 2021-08-20) polaritiesFromAssignments :: Ord flex => [PolarityAssignment flex] -> Polarities flex-polaritiesFromAssignments = Map.fromList . map (\ (PolarityAssignment p x) -> (x,p))+polaritiesFromAssignments = Map.fromListWith __IMPOSSIBLE__ . map (\ (PolarityAssignment p x) -> (x,p))  -- | Default polarity is 'Least'. getPolarity :: Ord flex => Polarities flex -> flex -> Polarity@@ -112,18 +144,24 @@ ------------------------------------------------------------------------  -- | Partial substitution from flexible variables to size expression.-type Solution rigid flex = Map flex (SizeExpr' rigid flex)+newtype Solution rigid flex = Solution { theSolution :: Map flex (SizeExpr' rigid flex) }+  deriving (Show, Null) --- emptySolution = Map.empty+instance (Pretty r, Pretty f) => Pretty (Solution r f) where+  pretty (Solution sol) = prettyList $ for (Map.toList sol) $ \ (x, e) ->+    pretty x <+> ":=" <+> pretty e +emptySolution :: Solution r f+emptySolution = Solution Map.empty+ -- | Executing a substitution. class Substitute r f a where   subst :: Solution r f -> a -> a  instance Ord f => Substitute r f (SizeExpr' r f) where-  subst sol e =+  subst (Solution sol) e =     case e of-      Flex x n -> Map.findWithDefault e x sol `plus` n+      Flex x n -> maybe e (`plus` n) $ Map.lookup x sol       _        -> e  instance Ord f => Substitute r f (Constraint' r f) where@@ -135,6 +173,9 @@ instance Substitute r f a => Substitute r f (Map k a) where   subst = fmap . subst +instance Ord f => Substitute r f (Solution r f) where+  subst s = Solution . subst s . theSolution+ -- | Add offset to size expression. instance Plus (SizeExpr' r f) Offset (SizeExpr' r f) where   plus e m =@@ -146,12 +187,12 @@  -- * Constraint simplification -type CTrans r f = Constraint' r f -> Either String [Constraint' r f]+type CTrans r f = Constraint' r f -> Maybe [Constraint' r f] --- | Returns an error message if we have a contradictory constraint.-simplify1 :: (Show f, Show r, Eq r) => CTrans r f -> CTrans r f+-- | Returns 'Nothing' if the constraint is contradictory.+simplify1 :: (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f simplify1 test c = do-  let err = Left $ "size constraint " ++ show c ++ " is inconsistent"+  let err = Nothing   case c of     -- rhs is Infty     Constraint a           Le  Infty -> return []@@ -212,27 +253,27 @@  -- * Printing -instance (Show r, Show f) => Show (SizeExpr' r f) where-  show (Const n)   = show n-  show (Infty)     = "∞"-  show (Rigid i 0) = show i-  show (Rigid i n) = show i ++ "+" ++ show n-  show (Flex  x 0) = show x-  show (Flex  x n) = show x ++ "+" ++ show n+instance (Pretty r, Pretty f) => Pretty (SizeExpr' r f) where+  pretty (Const n)   = pretty n+  pretty (Infty)     = "∞"+  pretty (Rigid i 0) = pretty i+  pretty (Rigid i n) = pretty i <> text ("+" ++ show n)+  pretty (Flex  x 0) = pretty x+  pretty (Flex  x n) = pretty x <> text ("+" ++ show n) -instance Show Polarity where-  show Least    = "-"-  show Greatest = "+"+instance Pretty Polarity where+  pretty Least    = "-"+  pretty Greatest = "+" -instance Show flex => Show (PolarityAssignment flex) where-  show (PolarityAssignment pol flex) = show pol ++ show flex+instance Pretty flex => Pretty (PolarityAssignment flex) where+  pretty (PolarityAssignment pol flex) = pretty pol <> pretty flex -instance Show Cmp where-  show Le = "≤"-  show Lt = "<"+instance Pretty Cmp where+  pretty Le = "≤"+  pretty Lt = "<" -instance (Show r, Show f) => Show (Constraint' r f) where-  show (Constraint a cmp b) = show a ++ " " ++ show cmp ++ " " ++ show b+instance (Pretty r, Pretty f) => Pretty (Constraint' r f) where+  pretty (Constraint a cmp b) = pretty a <+> pretty cmp <+> pretty b  -- * Wellformedness @@ -268,29 +309,100 @@ -- * Computing variable sets  -- | The rigid variables contained in a pice of syntax.-class Rigids r a where-  rigids :: a -> Set r+class Ord (RigidOf a) => Rigids a where+  type RigidOf a+  rigids :: a -> Set (RigidOf a) -instance (Ord r, Rigids r a) => Rigids r [a] where+instance Rigids a => Rigids [a] where+  type RigidOf [a] = RigidOf a   rigids as = Set.unions (map rigids as) -instance Rigids r (SizeExpr' r f) where+instance Ord r => Rigids (SizeExpr' r f) where+  type RigidOf (SizeExpr' r f) = r   rigids (Rigid x _) = Set.singleton x+   rigids _           = Set.empty -instance Ord r => Rigids r (Constraint' r f) where+instance Ord r => Rigids (Constraint' r f) where+  type RigidOf (Constraint' r f) = r   rigids (Constraint l _ r) = Set.union (rigids l) (rigids r)  -- | The flexibe variables contained in a pice of syntax.-class Flexs flex a | a -> flex where-  flexs :: a -> Set flex+class Ord (FlexOf a) => Flexs a where+  type FlexOf a+  flexs :: a -> Set (FlexOf a) -instance (Ord flex, Flexs flex a) => Flexs flex [a] where+instance Flexs a => Flexs [a] where+  type FlexOf [a] = FlexOf a   flexs as = Set.unions (map flexs as) -instance Flexs flex (SizeExpr' rigid flex) where+instance Ord flex => Flexs (SizeExpr' rigid flex) where+  type FlexOf (SizeExpr' rigid flex) = flex   flexs (Flex x _) = Set.singleton x   flexs _          = Set.empty -instance (Ord flex) => Flexs flex (Constraint' rigid flex) where+instance Ord flex => Flexs (Constraint' rigid flex) where+  type FlexOf (Constraint' rigid flex) = flex   flexs (Constraint l _ r) = Set.union (flexs l) (flexs r)++-- | Identifiers for rigid variables.+data NamedRigid = NamedRigid+  { rigidName  :: String   -- ^ Name for printing in debug messages.+  , rigidIndex :: Int      -- ^ De Bruijn index.+  } deriving (Show, Generic)++instance NFData NamedRigid++instance Eq NamedRigid where+  (==) = (==) `on` rigidIndex++instance Ord NamedRigid where+  compare = compare `on` rigidIndex++instance Pretty NamedRigid where+  pretty = P.text . rigidName++instance Plus NamedRigid Int NamedRigid where+  plus (NamedRigid x i) j = NamedRigid x (i + j)++-- | Size metas in size expressions.+data SizeMeta = SizeMeta+  { sizeMetaId   :: MetaId+  -- TODO to fix issue 300?+  -- , sizeMetaPerm :: Permutation -- ^ Permutation from the current context+  --                               --   to the context of the meta.+  , sizeMetaArgs :: [Int]       -- ^ De Bruijn indices.+  } deriving (Show, Generic)++instance NFData SizeMeta++-- | An equality which ignores the meta arguments.+instance Eq  SizeMeta where+  (==) = (==) `on` sizeMetaId++-- | An order which ignores the meta arguments.+instance Ord SizeMeta where+  compare = compare `on` sizeMetaId++instance Pretty SizeMeta where+  pretty = P.pretty . sizeMetaId++-- | Size expression with de Bruijn indices.+type DBSizeExpr = SizeExpr' NamedRigid SizeMeta++type SizeConstraint = Constraint' NamedRigid SizeMeta++-- | Size constraint with de Bruijn indices.+data HypSizeConstraint = HypSizeConstraint+  { sizeContext    :: Context+  , sizeHypIds     :: [Nat] -- ^ DeBruijn indices+  , sizeHypotheses :: [SizeConstraint]  -- ^ Living in @Context@.+  , sizeConstraint :: SizeConstraint    -- ^ Living in @Context@.+  }+  deriving (Show, Generic)++instance Flexs HypSizeConstraint where+  type FlexOf HypSizeConstraint = SizeMeta+  flexs (HypSizeConstraint _ _ hs c) = flexs hs `mappend` flexs c++instance NFData HypSizeConstraint
src/full/Agda/TypeChecking/SizedTypes/Utils.hs view
@@ -1,15 +1,22 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.SizedTypes.Utils where -import Control.Applicative+import Data.IORef import qualified Debug.Trace as Debug+import System.IO.Unsafe+ import Agda.Utils.Function -debug :: Bool-debug = False+{-# NOINLINE debug #-}+debug :: IORef Bool+debug = unsafePerformIO $ newIORef False +setDebugging :: Bool -> IO ()+setDebugging = writeIORef debug+ trace :: String -> a -> a-trace  s = applyWhen debug $ Debug.trace s+trace s = applyWhen (unsafePerformIO $ readIORef debug) $ Debug.trace s  traceM :: Applicative f => String -> f () traceM s = trace s $ pure ()@@ -17,7 +24,7 @@ class Eq a => Top a where   top   :: a   isTop :: a -> Bool-  isTop = (==top)+  isTop = (== top)  class Plus a b c where   plus :: a -> b -> c
src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables       #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.SizedTypes.WarshallSolver where -import Prelude hiding (truncate)+import Prelude hiding ( null, truncate ) -import Control.Applicative hiding (Const)+ import Control.Monad  import Data.Function (on)-import Data.List as List+import qualified Data.List as List import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map-import Data.Traversable (for) -import Agda.TypeChecking.SizedTypes.Syntax+import Agda.TypeChecking.Monad.Base (TCM)+import Agda.TypeChecking.Pretty (PrettyTCM)+import qualified Agda.TypeChecking.Pretty as P+import Agda.TypeChecking.SizedTypes.Syntax hiding (CTrans, simplify1)+import qualified Agda.TypeChecking.SizedTypes.Syntax as S import Agda.TypeChecking.SizedTypes.Utils  import Agda.Utils.Graph.AdjacencyMap.Unidirectional@@ -26,32 +27,35 @@ -- (Edge'(..), allNodes, emptyGraph, insertEdge, graphToList, graphFromList, nodes, lookupEdge, outgoing, incoming, diagonal, transClos) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph -#include "undefined.h"+import Agda.Utils.Functor+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty+ import Agda.Utils.Impossible -type Graph r f a = Graph.Graph (Node r f) (Node r f) a-type Edge' r f a = Graph.Edge  (Node r f) (Node r f) a+type Graph r f a = Graph.Graph (Node r f) a+type Edge' r f a = Graph.Edge  (Node r f) a type Key r f = Edge' r f () type Nodes r f = Graph.Nodes (Node r f) type LabelledEdge r f = Edge' r f Label -src :: Edge s t e -> s+src :: Edge n e -> n src = Graph.source -dest :: Edge s t e -> t+dest :: Edge n e -> n dest = Graph.target -lookupEdge :: (Ord s, Ord t) => Graph.Graph s t e -> s -> t -> Maybe e+lookupEdge :: Ord n => Graph.Graph n e -> n -> n -> Maybe e lookupEdge g s t = Graph.lookup s t g -graphToList :: Graph.Graph s t e -> [Edge s t e]-graphToList = Graph.toList+graphToList :: Graph.Graph n e -> [Edge n e]+graphToList = Graph.edges -graphFromList :: (Ord s, Ord t) => [Edge s t e] -> Graph.Graph s t e-graphFromList = Graph.fromList+graphFromList :: Ord n => [Edge n e] -> Graph.Graph n e+graphFromList = Graph.fromEdges -insertEdge :: (Ord s, Ord t, MeetSemiLattice e, Top e) =>-              Edge s t e -> Graph.Graph s t e -> Graph.Graph s t e+insertEdge :: (Ord n, MeetSemiLattice e, Top e) =>+              Edge n e -> Graph.Graph n e -> Graph.Graph n e insertEdge e g   | isTop (label e) = g   | otherwise       = Graph.insertEdgeWith meet e g@@ -72,11 +76,11 @@ -- setFoldl = Set.foldl'  -- | Floyd-Warshall algorithm.-transClos :: forall n a . (Ord n, Dioid a) => Graph.Graph n n a -> Graph.Graph n n a+transClos :: forall n a . (Ord n, Dioid a) => Graph.Graph n a -> Graph.Graph n a transClos g = setFoldl step g $ allNodes ns   where     ns       = computeNodes g-    srcs     = Set.toAscList $ srcNodes  ns+    srcs     = Set.toAscList $ srcNodes ns     dests    = Set.toAscList $ tgtNodes ns     -- @step g v@ adds all intermediate edges @u --> w@ via @v@ to @g@     -- step :: (Ord n, Dioid a) => Graph.Graph n n a -> n -> Graph.Graph n n a@@ -93,11 +97,11 @@ data Weight   = Offset Offset   | Infinity-  deriving (Eq)+  deriving (Eq, Show) -instance Show Weight where-  show (Offset x) = show x-  show Infinity   = "∞"+instance Pretty Weight where+  pretty (Offset x) = pretty x+  pretty Infinity   = "∞"  instance Ord Weight where   x        <= Infinity = True@@ -167,6 +171,7 @@ data Label   = Label { lcmp :: Cmp, loffset :: Offset }   | LInf  -- ^ Nodes not connected.+  deriving (Show)   -- | Convert a label to a weight, decrementing in case of 'Lt'.@@ -191,9 +196,9 @@   _           <= LInf        = True   LInf{}      <= Label{}     = False -instance Show Label where-  show (Label cmp w) = show cmp ++ show w-  show LInf          = "∞"+instance Pretty Label where+  pretty (Label cmp w) = pretty cmp <> pretty w+  pretty LInf          = "∞"  instance MeetSemiLattice Label where   -- one label is neutral@@ -232,13 +237,13 @@   | NodeInfty   | NodeRigid rigid   | NodeFlex  flex-  deriving (Eq, Ord)+  deriving (Show, Eq, Ord) -instance (Show rigid, Show flex) => Show (Node rigid flex) where-  show NodeZero      = "0"-  show NodeInfty     = "∞"-  show (NodeRigid x) = show x-  show (NodeFlex  x) = show x+instance (Pretty rigid, Pretty flex) => Pretty (Node rigid flex) where+  pretty NodeZero      = "0"+  pretty NodeInfty     = "∞"+  pretty (NodeRigid x) = pretty x+  pretty (NodeFlex  x) = pretty x  isFlexNode :: Node rigid flex -> Maybe flex isFlexNode (NodeFlex x) = Just x@@ -266,9 +271,6 @@ instance Negative a => Negative (Edge' r f a) where   negative = negative . label --- instance Show a => Show (Edge' a) where---   show (Edge u v l) = show u ++ " -(" ++ show l ++ ")-> " ++ show v- instance (Ord r, Ord f, MeetSemiLattice a) => MeetSemiLattice (Edge' r f a) where   e@(Edge u v l) `meet` e'@(Edge u' v' l')     | u == u' && v == v' = Edge u v $ l `meet` l'@@ -300,7 +302,7 @@ mentions NodeZero    gs = ([], gs) mentions NodeInfty   gs = ([], gs) mentions NodeRigid{} gs = ([], gs)-mentions n           gs = partition (Set.member n . nodes) gs+mentions n           gs = List.partition (Set.member n . nodes) gs  -- | Add an edge to a graph forest. --   Graphs that share a node with the edge are joined.@@ -327,7 +329,7 @@  -- UNUSED -- -- | Reflexive-transitive closure.--- complete :: (Show a, Dioid a) => Graph r f a -> Graph r f a+-- complete :: (Pretty a, Dioid a) => Graph r f a -> Graph r f a -- complete = transClos . reflClos  -- | A graph is 'negative' if it contains a negative loop (diagonal edge).@@ -344,13 +346,13 @@ -- --   Application: Constraint implication: Constraints are compatible --   with hypotheses.-implies :: (Ord r, Ord f, Show r, Show f, Show a, Top a, Ord a, Negative a)+implies :: (Ord r, Ord f, Pretty r, Pretty f, Pretty a, Top a, Ord a, Negative a)   => Graph r f a -> Graph r f a -> Bool -- iterate 'test' over all edges in g-implies h g = and $ map test $ graphToList g-  -- NB: doing the @test k l@ before the recursive @b@ gives-  -- opportunity to short-cut the conjunction @&&@.+implies h g = all test (graphToList g)   where+    -- NB: doing the @test k l@ before the recursive @b@ gives+    -- opportunity to short-cut the conjunction @&&@.     -- test :: Key -> a -> Bool     test k@(Edge src dest l)       | isZeroNode src, not (negative l) = True@@ -360,9 +362,15 @@       | isTop l                          = True       | otherwise = case lookupEdge h src dest of         Nothing -> False-        Just l' -> if l' <= l then True else-          trace ("edge " ++ show (l <$ k) ++ " not implied by " ++ show (l' <$ k)) $-            False+        Just l' ->+          (l' <= l) || ( trace+                           ( "edge " ++ prettyShow (l <$ k)+                               ++ " not implied by "+                               ++ prettyShow (l' <$ k)+                           )+                           $ False+                       )+ -- implies h g = Map.foldlWithKey (\ b k l -> test k l && b) True g --   -- NB: doing the @test k l@ before the recursive @b@ gives --   -- opportunity to short-cut the conjunction @&&@.@@ -381,7 +389,7 @@ --             False  nodeFromSizeExpr :: SizeExpr' rigid flex -> (Node rigid flex, Offset)-nodeFromSizeExpr e = case e of+nodeFromSizeExpr = \case   Const   n -> (NodeZero   , n)   Rigid i n -> (NodeRigid i, n)   Flex  x n -> (NodeFlex x , n)@@ -410,7 +418,7 @@       -- get all the flexibles mentioned in constraints       xs    = Set.toList $ flexs cs       -- for each flexible X, add edges 0 <= X and X <= oo-      fedges = concat $ for xs $ \ x ->+      fedges = concat $ forM xs $ \ x ->         [ Edge NodeZero (NodeFlex x) (Label Le 0)         , Edge (NodeFlex x) NodeInfty (Label Le 0)         ]@@ -418,14 +426,28 @@       gs    = foldl (flip addEdge) emptyGraphs (fedges ++ edges)   in  gs ++-- | Error messages produced by the solver.++type Error = TCM Doc++type CTrans r f = Constraint' r f -> Either Error [Constraint' r f]++simplify1 :: (Pretty f, Pretty r, Eq r)+  => CTrans r f+  -> CTrans r f+simplify1 f c = case S.simplify1 (either (const Nothing) Just . f) c of+  Nothing -> Left $ "size constraint" P.<+> P.pretty c P.<+> "is inconsistent"+  Just cs -> Right cs+ -- Build hypotheses graph, complete it, check for negative loops.  type Hyp = Constraint type Hyp' = Constraint' type HypGraph r f = Graph r f Label -hypGraph :: (Ord rigid, Ord flex, Show rigid, Show flex) =>-  Set rigid -> [Hyp' rigid flex] -> Either String (HypGraph rigid flex)+hypGraph :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>+  Set rigid -> [Hyp' rigid flex] -> Either Error (HypGraph rigid flex) hypGraph is hyps0 = do   -- get a list of hypothesis from a list of constraints   hyps <- concat <$> mapM (simplify1 $ \ c -> return [c]) hyps0@@ -443,8 +465,10 @@   | Just l <- lookupEdge hg n1 n2 = l   | otherwise                               = top -simplifyWithHypotheses :: (Ord rigid, Ord flex, Show rigid, Show flex) =>-  HypGraph rigid flex -> [Constraint' rigid flex] -> Either String [Constraint' rigid flex]+simplifyWithHypotheses ::+  (Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>+  HypGraph rigid flex -> [Constraint' rigid flex] ->+  Either Error [Constraint' rigid flex] simplifyWithHypotheses hg cons = concat <$> mapM (simplify1 test) cons   where     -- Test whether a constraint is compatible with the hypotheses:@@ -455,7 +479,8 @@           l' = hypConn hg n1 n2       -- l' <- lookupEdge hg n1 n2       unless (l' <= l) $ Left $-        "size constraint " ++ show c ++ " not consistent with size hypotheses"+        "size constraint" P.<+> P.pretty c P.<+>+        "not consistent with size hypotheses"       return [c]       -- if (l' <= l) then Just [c] else Nothing @@ -464,13 +489,18 @@  type ConGraph r f = Graph r f Label -constraintGraph :: (Ord r, Ord f, Show r, Show f) => [Constraint' r f] -> HypGraph r f -> Either String (ConGraph r f)+constraintGraph ::+  (Ord r, Ord f, Pretty r, Pretty f) =>+  [Constraint' r f] -> HypGraph r f -> Either Error (ConGraph r f) constraintGraph cons0 hg = do+  traceM $ "original constraints cons0 = " ++ prettyShow cons0   -- Simplify constraints, ensure they are locally consistent with   -- hypotheses.   cons <- simplifyWithHypotheses hg cons0+  traceM $ "simplified constraints cons = " ++ prettyShow cons   -- Build a transitive graph from constraints.   let g = transClos $ graphFromConstraints cons+  traceM $ "transitive graph g = " ++ prettyShow (graphToList g)   -- Ensure it has no negative loops.   when (negative g) $ Left $     "size constraint graph has negative loops"@@ -481,24 +511,26 @@  type ConGraphs r f = Graphs r f Label -constraintGraphs :: (Ord r, Ord f, Show r, Show f) => [Constraint' r f] -> HypGraph r f -> Either String ([f], ConGraphs r f)+constraintGraphs ::+  (Ord r, Ord f, Pretty r, Pretty f) =>+  [Constraint' r f] -> HypGraph r f -> Either Error ([f], ConGraphs r f) constraintGraphs cons0 hg = do-  traceM $ "original constraints cons0 = " ++ show cons0+  traceM $ "original constraints cons0 = " ++ prettyShow cons0   -- Simplify constraints, ensure they are locally consistent with   -- hypotheses.   cons <- simplifyWithHypotheses hg cons0-  traceM $ "simplified constraints cons = " ++ show cons+  traceM $ "simplified constraints cons = " ++ prettyShow cons   -- Build a transitive graph forest from constraints.   let gs0 = graphsFromConstraints cons-  traceM $ "constraint forest gs0 = " ++ show (map graphToList gs0)+  traceM $ "constraint forest gs0 = " ++ prettyShow (map graphToList gs0)   let gs1 = map transClos gs0-  traceM $ "transitive forest gs1 = " ++ show (map graphToList gs1)+  traceM $ "transitive forest gs1 = " ++ prettyShow (map graphToList gs1)   -- Check for flexibles to be set to infinity   let (xss,gs) = unzip $ map infinityFlexs gs1       xs       = concat xss   unless (null xs) $ do-    traceM $ "flexibles to set to oo = " ++ show xs-    traceM $ "forest after oo-subst  = " ++ show (map graphToList gs)+    traceM $ "flexibles to set to oo = " ++ prettyShow xs+    traceM $ "forest after oo-subst  = " ++ prettyShow (map graphToList gs)   -- Ensure none has negative loops.   when (negative gs) $ Left $ "size constraint graph has negative loop"   traceM $ "we are free of negative loops"@@ -647,7 +679,8 @@                Graph r f a -> [Node r f] -> Map (Node r f) [Edge' r f a] commonSuccs hg srcs = intersectAll $ map (buildmap . outgoing hg) srcs   where-   buildmap            = Map.fromList . map (\ e -> (dest e, [e]))+   buildmap            = Map.fromListWith __IMPOSSIBLE__ . map (\ e -> (dest e, [e]))+     -- __IMPOSSIBLE__ because it is not a multi-graph; there is at most one egde per (src,dest)    intersectAll []     = Map.empty    intersectAll (m:ms) = foldl (Map.intersectionWith (++)) m ms @@ -659,29 +692,38 @@ commonPreds :: (Ord r, Ord f) => Graph r f a -> [Node r f] -> Map (Node r f) [Edge' r f a] commonPreds hg tgts = intersectAll $  map (buildmap . incoming hg) tgts   where-   buildmap = Map.fromList . map (\ e -> (src e, [e]))+   buildmap = Map.fromListWith __IMPOSSIBLE__ . map (\ e -> (src e, [e]))    intersectAll []     = Map.empty    intersectAll (m:ms) = foldl (Map.intersectionWith (++)) m ms  -- | Compute the sup of two different rigids or a rigid and a constant.-lub' :: forall r f . (Ord r, Ord f, Show r, Show f) =>-        HypGraph r f -> (Node r f, Offset) -> (Node r f, Offset) -> Maybe (SizeExpr' r f)+lub'+  :: forall r f . (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  => HypGraph r f+  -> (Node r f, Offset)+  -> (Node r f, Offset)+  -> Maybe (SizeExpr' r f) lub' hg (node1, n) (node2, m) = do   let sucs     = commonSuccs hg [node1, node2]       sucNodes = smallest hg $ Map.keys sucs-  traceM ("lub': sucs = " ++ show sucs)+  traceM ("lub': sucs = " ++ show sucs) -- FIXME: prettyShow   case sucNodes of     -- there is a unique smallest common successor n0 of node1 and node2-    [n0] ->+    [n0] -> do       -- then there are exactly two edges node1 --l1--> n0 and node2 --l2--> n0-      -- with non-positive weigths l1, l2-      case Map.lookup n0 sucs of-        Just [ Edge node1' n1 l1-             , Edge node2' n2 l2-             ] | node1 == node1', node2 == node2'-               , n0 == n1, n0 == n2-               , toWeight l1 <= 0-               , toWeight l2 <= 0 -> do+      -- Andreas, 2017-04-28, issue #2558: The following invariant does not hold always+      -- -- with non-positive weights l1, l2+      let es = fromMaybe __IMPOSSIBLE__ $ Map.lookup n0 sucs+      case es of+        [ Edge node1x n1 l1 ,+          Edge node2x n2 l2 ] -> do+          unless (n0 == n1)         __IMPOSSIBLE__+          unless (n0 == n2)         __IMPOSSIBLE__+          unless (node1 == node1x)  __IMPOSSIBLE__+          unless (node2 == node2x)  __IMPOSSIBLE__+          -- Andreas, 2017-04-28, issue #2558: The following invariant does not hold always+          -- unless (toWeight l1 <= 0) __IMPOSSIBLE__+          -- unless (toWeight l2 <= 0) __IMPOSSIBLE__           let o :: Weight               o = max (n `plus` toWeight l1) (m `plus` toWeight l2)           return $ nodeToSizeExpr n0 `plus` o@@ -690,27 +732,37 @@     _ -> do       let a1 :: SizeExpr' r f = nodeToSizeExpr node1 `plus` n       let a2 :: SizeExpr' r f = nodeToSizeExpr node2 `plus` m-      traceM ("cannot compute lub of " ++ show a1 ++ " and " ++ show a2 ++ " because sucNodes = " ++ show sucNodes)+      traceM ("cannot compute lub of " ++ prettyShow a1 ++ " and " ++ prettyShow a2 ++ " because sucNodes = " ++ prettyShow sucNodes)       Nothing  -- | Compute the inf of two different rigids or a rigid and a constant.-glb' :: forall r f . (Ord r, Ord f, Show r, Show f) => HypGraph r f -> (Node r f, Offset) -> (Node r f, Offset) -> Maybe (SizeExpr' r f)+glb'+  :: forall r f . (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  => HypGraph r f+  -> (Node r f, Offset)+  -> (Node r f, Offset)+  -> Maybe (SizeExpr' r f) glb' hg (node1, n) (node2, m) = do   let preds     = commonPreds hg [node1, node2]       predNodes = largest hg $ Map.keys preds-  traceM ("glb': preds = " ++ show preds)+  traceM ("glb': preds = " ++ show preds) -- FIXME: prettyShow   case predNodes of     -- there is a unique greatest common predecessor n0 of node1 and node2-    [n0] ->+    [n0] -> do       -- then there are exactly two edges n0 --l1--> node1 and n0 --l2--> node2-      -- with non-positive weigths l1, l2-      case Map.lookup n0 preds of-        Just [ Edge n1 node1' l1-             , Edge n2 node2' l2-             ] | node1 == node1', node2 == node2'-               , n0 == n1, n0 == n2-               , toWeight l1 <= 0-               , toWeight l2 <= 0 -> do+      -- Andreas, 2017-04-28, issue #2558: The following invariant may not hold always+      -- -- with non-positive weigths l1, l2+      let es = fromMaybe __IMPOSSIBLE__ $ Map.lookup n0 preds+      case es of+        [ Edge n1 node1x l1 ,+          Edge n2 node2x l2] -> do+          unless (n0 == n1)         __IMPOSSIBLE__+          unless (n0 == n2)         __IMPOSSIBLE__+          unless (node1 == node1x)  __IMPOSSIBLE__+          unless (node2 == node2x)  __IMPOSSIBLE__+          -- Andreas, 2017-04-28, issue #2558: The following invariant may not hold always+          -- unless (toWeight l1 <= 0) __IMPOSSIBLE__+          -- unless (toWeight l2 <= 0) __IMPOSSIBLE__           let o :: Weight               o = max (n `plus` toWeight l1) (m `plus` toWeight l2)           return $ nodeToSizeExpr n0 `plus` o@@ -719,11 +771,16 @@     _ -> do       let a1 :: SizeExpr' r f = nodeToSizeExpr node1 `plus` n       let a2 :: SizeExpr' r f = nodeToSizeExpr node2 `plus` m-      traceM ("cannot compute glb of " ++ show a1 ++ " and " ++ show a2 ++ " because predNodes = " ++ show predNodes)+      traceM ("cannot compute glb of " ++ prettyShow a1 ++ " and " ++ prettyShow a2 ++ " because predNodes = " ++ prettyShow predNodes)       Nothing  -- | Compute the least upper bound (sup).-lub :: (Ord r, Ord f, Show r, Show f) => HypGraph r f -> (SizeExpr' r f) -> (SizeExpr' r f) -> Maybe (SizeExpr' r f)+lub+  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  => HypGraph r f+  -> SizeExpr' r f+  -> SizeExpr' r f+  -> Maybe (SizeExpr' r f) lub hg a1 a2 =   case (a1, a2) of     (Flex{}, _)   -> __IMPOSSIBLE__@@ -754,7 +811,12 @@  -- | Compute the greatest lower bound (inf) of size expressions relative --   to a hypotheses graph.-glb :: (Ord r, Ord f, Show r, Show f) => HypGraph r f -> (SizeExpr' r f) -> (SizeExpr' r f) -> Maybe (SizeExpr' r f)+glb+  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  => HypGraph r f+  -> SizeExpr' r f+  -> SizeExpr' r f+  -> Maybe (SizeExpr' r f) glb hg a1 a2 =   case (a1, a2) of     (Flex{}, _) -> __IMPOSSIBLE__@@ -791,7 +853,7 @@           srcj = Set.fromList $ map src lbj           srcs =  Set.intersection srci srcj -}-    _ -> trace ("cannot compute glb of " ++ show a1 ++ " and " ++ show a2) $+    _ -> trace ("cannot compute glb of " ++ prettyShow a1 ++ " and " ++ prettyShow a2) $       Nothing -- TODO! -} @@ -805,43 +867,50 @@             Infinity -> Nothing             Offset o -> if o <= m then Just (n, o) else Nothing         | otherwise = __IMPOSSIBLE__-            -- error $ "findRigidBelow: impossible: " ++ show e+            -- error $ "findRigidBelow: impossible: " ++ prettyShow e       cands = mapMaybe filt preds   (n, o) <- do     case cands of       []  -> Nothing       [c] -> return c       _   -> return $-               maximumBy (compare `on` snd) $+               List.maximumBy (compare `on` snd) $                  filter ((NodeZero /=) . fst) cands   let offset = m - o   unless (offset >= 0) __IMPOSSIBLE__   return $ nodeToSizeExpr n `plus` offset findRigidBelow hg e = __IMPOSSIBLE__-  -- error $ "findRigidBelow: impossible: " ++ show e+  -- error $ "findRigidBelow: impossible: " ++ prettyShow e  -solveGraph :: (Ord r, Ord f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraph r f -> Either String (Solution r f)+solveGraph+  :: forall r f. (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)+  => Polarities f+  -> HypGraph r f+  -> ConGraph r f+  -> Either Error (Solution r f) solveGraph pols hg g = do   let (Bounds lbs ubs fs) = bounds g       -- flexibles to solve for+      xs :: [f]       xs = Set.toAscList $ Set.unions [ Map.keysSet lbs, Map.keysSet ubs, fs ]   -- iterate over all flexible variables   xas <- catMaybes <$> do-    forM xs $ \ x -> do+    forM xs $ \ x -> fmap (x,) <$> do       -- get lower and upper bounds for flexible x       let lx = Set.toList $ Map.findWithDefault Set.empty x lbs           ux = Set.toList $ Map.findWithDefault Set.empty x ubs-      traceM ("lower bounds for " ++ show x ++ ": " ++ show lx)-      traceM ("upper bounds for " ++ show x ++ ": " ++ show ux)+      traceM ("lower bounds for " ++ prettyShow x ++ ": " ++ prettyShow lx)+      traceM ("upper bounds for " ++ prettyShow x ++ ": " ++ prettyShow ux)       -- compute maximum of lower bounds       lb <- do         case lx of           []     -> return $ Nothing           (a:as) -> do             case foldM (lub hg) a as of-              Nothing -> Left $ "inconsistent lower bound for " ++ show x               Just l  -> return $ Just $ truncateOffset l+              Nothing -> Left $+                "inconsistent lower bound for" P.<+> P.prettyTCM x       -- compute minimum of upper bounds       ub <- do         case ux of@@ -850,35 +919,47 @@             case foldM (glb hg) a as of               Just l | validOffset l                  -> return $ Just l                      | Just l' <- findRigidBelow hg l -> return $ Just l'-              _ -> Left $ "inconsistent upper bound for " ++ show x+              _ -> Left $+                "inconsistent upper bound for" P.<+> P.prettyTCM x       case (lb, ub) of-        (Just l, Nothing) -> return $ Just (x, l)  -- solve x = lower bound-        (Nothing, Just u) -> return $ Just (x, u)  -- solve x = upper bound+        (Just l, Nothing) -> return $ Just l  -- solve x = lower bound+        (Nothing, Just u) -> return $ Just u  -- solve x = upper bound         (Just l,  Just u) -> do-          traceM ("lower bound for " ++ show x ++ ": " ++ show l)-          traceM ("upper bound for " ++ show x ++ ": " ++ show u)+          traceM ("lower bound for " ++ prettyShow x ++ ": " ++ prettyShow l)+          traceM ("upper bound for " ++ prettyShow x ++ ": " ++ prettyShow u)           case getPolarity pols x of-            Least    -> return $ Just (x, l)-            Greatest -> return $ Just (x, u)+            Least    -> return $ Just l+            Greatest -> return $ Just u         _ -> return Nothing-  return $ Map.fromList xas+  return $ Solution $ Map.fromDistinctAscList xas  -- | Solve a forest of constraint graphs relative to a hypotheses graph. --   Concatenate individual solutions.-solveGraphs :: (Ord r, Ord f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraphs r f -> Either String (Solution r f)-solveGraphs pols hg gs = Map.unions <$> mapM (solveGraph pols hg) gs+solveGraphs+  :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)+  => Polarities f+  -> HypGraph r f+  -> ConGraphs r f+  -> Either Error (Solution r f)+solveGraphs pols hg gs =+  Solution . Map.unions <$> mapM (theSolution <.> solveGraph pols hg) gs  -- * Verify solution  -- | Check that after substitution of the solution, --   constraints are implied by hypotheses.-verifySolution :: (Ord r, Ord f, Show r, Show f) => HypGraph r f -> [Constraint' r f] -> Solution r f -> Either String ()+verifySolution+  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  => HypGraph r f+  -> [Constraint' r f]+  -> Solution r f+  -> Either Error () verifySolution hg cs sol = do   cs <- return $ subst sol cs-  traceM $ "substituted constraints " ++ show cs+  traceM $ "substituted constraints " ++ prettyShow cs   cs <- -- maybe (Left "solution produces inconsistency") Right $           concat <$> mapM (simplify1 $ \ c -> return [c]) cs-  traceM $ "simplified substituted constraints " ++ show cs+  traceM $ "simplified substituted constraints " ++ prettyShow cs   -- cs <- maybe (Left "solution produces inconsistency") Right $   --         simplifyWithHypotheses hg cs   let g = graphFromConstraints cs@@ -888,7 +969,7 @@   case simplifyWithHypotheses hg $ subst sol cs of     Nothing -> Left "solution produces inconsistency"     Just [] -> Right ()-    Just cs -> Left $ "solution leaves constraints " ++ show cs+    Just cs -> Left $ "solution leaves constraints " ++ prettyShow cs -}  -- | Iterate solver until no more metas can be solved.@@ -897,7 +978,7 @@ --   which would otherwise go unnoticed.  iterateSolver-  :: (Ord r, Ord f, Show r, Show f)+  :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)   => Polarities f      -- ^ Meta variable polarities (prefer lower or upper solution?).   -> HypGraph r f@@ -906,14 +987,17 @@      -- ^ Constraints to solve.   -> Solution r f      -- ^ Previous substitution (already applied to constraints).-  -> Either String (Solution r f)+  -> Either Error (Solution r f)      -- ^ Accumulated substition.  iterateSolver pols hg cs sol0 = do   g <- constraintGraph cs hg   sol <- solveGraph pols hg g-  if Map.null sol then return sol0 else-    iterateSolver pols hg (subst sol cs) (Map.unionWith __IMPOSSIBLE__ sol $ subst sol sol0)+  traceM $ "(partial) solution " ++ prettyShow sol+  if null sol then return sol0 else+    iterateSolver pols hg (subst sol cs) $ Solution $+      Map.unionWith __IMPOSSIBLE__ (theSolution sol) $+        theSolution $ subst sol sol0  -- * Tests @@ -925,7 +1009,7 @@     n3 = NodeRigid "k"     n4 = NodeRigid "l"     n5 = NodeRigid "m"-    hg = Graph.fromList+    hg = Graph.fromEdges          [ Graph.Edge n1 n3 $ Label Le 1          , Graph.Edge n1 n4 $ Label Le 2          , Graph.Edge n1 n5 $ Label Le 3@@ -935,7 +1019,7 @@          ]  -- testLub = smallest hg $ Map.keys $ commonSuccs hg [n1,n2] ---testLub :: (Show f, Ord f) => Maybe (SizeExpr' [Char] f)+testLub :: (Pretty f, Ord f, Show f) => Maybe (SizeExpr' [Char] f) testLub = lub hg (Rigid "i" 0) (Rigid "j" 2)   where     n1 = NodeRigid "i"@@ -943,7 +1027,7 @@     n3 = NodeRigid "k"     n4 = NodeRigid "l"     n5 = NodeRigid "m"-    hg = Graph.fromList+    hg = Graph.fromEdges          [ Graph.Edge n1 n3 $ Label Le 0          , Graph.Edge n1 n4 $ Label Le 2          , Graph.Edge n1 n5 $ Label Le 4
+ src/full/Agda/TypeChecking/Sort.hs view
@@ -0,0 +1,278 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | This module contains the rules for Agda's sort system viewed as a pure+--   type system (pts). The specification of a pts consists of a set+--   of axioms of the form @s1 : s2@ specifying when a sort fits in+--   another sort, and a set of rules of the form @(s1,s2,s3)@+--   specifying that a pi type with domain in @s1@ and codomain in+--   @s2@ itself fits into sort @s3@.+--+--   To ensure unique principal types, the axioms and rules of Agda's+--   pts are given by two partial functions @univSort'@ and @piSort'@+--   (see @Agda.TypeChecking.Substitute@). If these functions return+--   @Nothing@, a constraint is added to ensure that the sort will be+--   computed eventually.+--+--   One 'upgrade' over the standard definition of a pts is that in a+--   rule @(s1,s2,s3)@, in Agda the sort @s2@ can depend on a variable+--   of some type in @s1@. This is needed to support Agda's universe+--   polymorphism where we can have e.g. a function of type @∀ {ℓ} →+--   Set ℓ@.++module Agda.TypeChecking.Sort where++import Control.Monad+import Control.Monad.Except++import Data.Functor+import Data.Maybe++import Agda.Interaction.Options (optCumulativity, optRewriting)++import Agda.Syntax.Common+import Agda.Syntax.Internal++import {-# SOURCE #-} Agda.TypeChecking.Constraints () -- instance only+import {-# SOURCE #-} Agda.TypeChecking.Conversion+import {-# SOURCE #-} Agda.TypeChecking.MetaVars () -- instance only++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Constraints (addConstraint, MonadConstraint)+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.MetaVars (metaType)+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Signature (HasConstInfo(..), applyDef)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records (getDefType)+import Agda.TypeChecking.ProjectionLike+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Monad++import Agda.Utils.Impossible++{-# SPECIALIZE inferUnivSort :: Sort -> TCM Sort #-}+-- | Infer the sort of another sort. If we can compute the bigger sort+--   straight away, return that. Otherwise, return @UnivSort s@ and add a+--   constraint to ensure we can compute the sort eventually.+inferUnivSort+  :: (PureTCM m, MonadConstraint m)+  => Sort -> m Sort+inferUnivSort s = do+  s <- reduce s+  case univSort' s of+    Right s' -> return s'+    Left _ -> do+      -- Jesper, 2020-04-19: With the addition of Setωᵢ and the PTS+      -- rule SizeUniv : Setω, every sort (with no metas) now has a+      -- bigger sort, so we do not need to add a constraint.+      -- addConstraint $ HasBiggerSort s+      return $ UnivSort s++{-# SPECIALIZE sortFitsIn :: Sort -> Sort -> TCM () #-}+sortFitsIn :: MonadConversion m => Sort -> Sort -> m ()+sortFitsIn a b = do+  b' <- inferUnivSort a+  ifM (optCumulativity <$> pragmaOptions)+    (leqSort b' b)+    (equalSort b' b)++hasBiggerSort :: Sort -> TCM ()+hasBiggerSort = void . inferUnivSort++{-# SPECIALIZE inferPiSort :: Dom Type -> Abs Sort -> TCM Sort #-}+-- | Infer the sort of a Pi type.+--   If we can compute the sort straight away, return that.+--   Otherwise, return a 'PiSort' and add a constraint to ensure we can compute the sort eventually.+--+inferPiSort :: (PureTCM m, MonadConstraint m)+  => Dom Type  -- ^ Domain of the Pi type.+  -> Abs Sort  -- ^ (Dependent) sort of the codomain of the Pi type.+  -> m Sort    -- ^ Sort of the Pi type.+inferPiSort a s = do+  s1' <- reduceB $ getSort a+  s2' <- mapAbstraction a reduceB s+  let s1 = ignoreBlocking s1'+  let s2 = ignoreBlocking <$> s2'+  --Jesper, 2018-04-23: disabled PTS constraints for now,+  --this assumes that piSort can only be blocked by unsolved metas.+  --Arthur Adjedj, 2023-02-27, Turned PTS back on,+  --piSort can now be blocked by Leveluniv+  case piSort' (unEl <$> a) s1 s2 of+    Right s -> return s+    Left b -> do+      let b' = unblockOnEither (getBlocker s1') (getBlocker $ unAbs s2')+      addConstraint (unblockOnEither b b') $ HasPTSRule a s2+      return $ PiSort (unEl <$> a) s1 s2++{-# SPECIALIZE inferFunSort :: Dom Type -> Sort -> TCM Sort #-}+-- | As @inferPiSort@, but for a nondependent function type.+--+inferFunSort :: (PureTCM m, MonadConstraint m)+  => Dom Type  -- ^ Domain of the function type.+  -> Sort      -- ^ Sort of the codomain of the function type.+  -> m Sort    -- ^ Sort of the function type.+inferFunSort a s = do+  s1' <- reduceB $ getSort a+  s2' <- reduceB s+  let s1 = ignoreBlocking s1'+  let s2 = ignoreBlocking s2'+  case funSort' s1 s2 of+    Right s -> return s+    Left b -> do+      let b' = unblockOnEither (getBlocker s1') (getBlocker s2')+      addConstraint (unblockOnEither b b') $ HasPTSRule a (NoAbs "_" s2)+      return $ FunSort s1 s2+  -- Andreas, 2023-05-20:  I made inferFunSort step-by-step analogous to inferPiSort.+  -- Unifying them seems unfeasible, though; too much parametrization...++-- | @hasPTSRule a x.s@ checks that we can form a Pi-type @(x : a) -> b@ where @b : s@.+--+hasPTSRule :: Dom Type -> Abs Sort -> TCM ()+hasPTSRule a s = do+  reportSDoc "tc.conv.sort" 35 $ vcat+    [ "hasPTSRule"+    , "a =" <+> prettyTCM a+    , "s =" <+> prettyTCM (unAbs s)+    ]+  if alwaysValidCodomain $ unAbs s+  then yes+  else do+    sb <- reduceB =<< inferPiSort a s+    case sb of+      Blocked b t | neverUnblock == b -> no sb t+      NotBlocked _ t@FunSort{}        -> no sb t+      NotBlocked _ t@PiSort{}         -> no sb t+      _ -> yes+  where+    -- Do we end in a standard sort (Prop, Type, SSet)?+    alwaysValidCodomain = \case+      Inf{} -> True+      Univ{} -> True+      FunSort _ s -> alwaysValidCodomain s+      PiSort _ _ s -> alwaysValidCodomain $ unAbs s+      _ -> False++    yes = do+      reportSLn "tc.conv.sort" 35 "hasPTSRule succeeded"+    no sb t = do+      reportSDoc "tc.conv.sort" 35 $ "hasPTSRule fails on" <+> prettyTCM sb+      typeError $ InvalidTypeSort t++-- | Recursively check that an iterated function type constructed by @telePi@+--   is well-sorted.+checkTelePiSort :: Type -> TCM ()+-- Jesper, 2019-07-27: This is currently doing nothing (see comment in inferPiSort)+checkTelePiSort (El s (Pi a b)) = do+  -- Since the function type is assumed to be constructed by @telePi@,+  -- we already know that @s == piSort (getSort a) (getSort <$> b)@,+  -- so we just check that this sort is well-formed.+  hasPTSRule a (getSort <$> b)+  underAbstraction a b checkTelePiSort+checkTelePiSort _ = return ()++ifIsSort :: (MonadReduce m, MonadBlock m) => Type -> (Sort -> m a) -> m a -> m a+ifIsSort t yes no = do+  -- Jesper, 2020-09-06, subtle: do not use @abortIfBlocked@ here+  -- since we want to take the yes branch whenever the type is a sort,+  -- even if it is blocked.+  bt <- reduceB t+  case unEl (ignoreBlocking bt) of+    Sort s                     -> yes s+    _      | Blocked m _ <- bt -> patternViolation m+           | otherwise         -> no++{-# SPECIALIZE ifNotSort :: Type -> TCM a -> (Sort -> TCM a) -> TCM a #-}+ifNotSort :: (MonadReduce m, MonadBlock m) => Type -> m a -> (Sort -> m a) -> m a+ifNotSort t = flip $ ifIsSort t++{-# SPECIALIZE shouldBeSort :: Type -> TCM Sort #-}+-- | Result is in reduced form.+shouldBeSort+  :: (PureTCM m, MonadBlock m, MonadError TCErr m)+  => Type -> m Sort+shouldBeSort t = ifIsSort t return (typeError $ ShouldBeASort t)++{-# SPECIALIZE sortOf :: Term -> TCM Sort #-}+-- | Reconstruct the sort of a term.+--+--   Precondition: given term is a well-sorted type.+sortOf+  :: forall m. (PureTCM m, MonadBlock m, MonadConstraint m)+  => Term -> m Sort+sortOf t = do+  reportSDoc "tc.sort" 60 $ "sortOf" <+> prettyTCM t+  sortOfT =<< elimView EvenLone t++  where+    sortOfT :: Term -> m Sort+    sortOfT = \case+      Pi adom b -> do+        let a = unEl $ unDom adom+        sa <- sortOf a+        sb <- mapAbstraction adom (sortOf . unEl) b+        inferPiSort (adom $> El sa a) sb+      Sort s     -> return $ univSort s+      Var i es   -> do+        a <- typeOfBV i+        sortOfE a (Var i) es+      Def f es   -> do+        a <- defType <$> getConstInfo f+        sortOfE a (Def f) es+      MetaV x es -> do+        a <- metaType x+        sortOfE a (MetaV x) es+      Lam{}      -> __IMPOSSIBLE__+      Con{}      -> __IMPOSSIBLE__+      Lit{}      -> __IMPOSSIBLE__+      Level{}    -> __IMPOSSIBLE__+      DontCare{} -> __IMPOSSIBLE__+      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++    sortOfE :: Type -> (Elims -> Term) -> Elims -> m Sort+    sortOfE a hd []     = ifIsSort a return __IMPOSSIBLE__+    sortOfE a hd (e:es) = do+      reportSDoc "tc.sort" 50 $ vcat+        [ "sortOfE"+        , "  a  = " <+> prettyTCM a+        , "  hd = " <+> prettyTCM (hd [])+        , "  e  = " <+> prettyTCM e+        ]++      ba <- reduceB a++      let+        a' = ignoreBlocking ba+        fallback = case ba of+          Blocked m _ -> patternViolation m++          -- Not IMPOSSIBLE because of possible non-confluent rewriting (see #5531)+          _ -> ifM (optRewriting <$> pragmaOptions)+            {-then-} (patternViolation neverUnblock)+            {-else-} __IMPOSSIBLE__++      case e of+        Apply (Arg ai v) -> case unEl a' of+          Pi b c -> sortOfE (c `absApp` v) (hd . (e:)) es+          _ -> fallback++        Proj o f -> case unEl a' of+          Def{} -> do+            ~(El _ (Pi b c)) <- fromMaybe __IMPOSSIBLE__ <$> getDefType f a'+            hd' <- applyE <$> applyDef o f (argFromDom b $> hd [])+            sortOfE (c `absApp` (hd [])) hd' es+          _ -> fallback++        IApply x y r -> do+          (b , c) <- fromMaybe __IMPOSSIBLE__ <$> isPath a'+          sortOfE (c `absApp` r) (hd . (e:)) es++{-# INLINE sortOfType #-}+-- | Reconstruct the minimal sort of a type (ignoring the sort annotation).+sortOfType+  :: forall m. (PureTCM m, MonadBlock m,MonadConstraint m)+  => Type -> m Sort+sortOfType = sortOf . unEl
src/full/Agda/TypeChecking/Substitute.hs view
@@ -1,1253 +1,1787 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE UndecidableInstances   #-}--#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances #-}-#endif--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.TypeChecking.Substitute-  ( module Agda.TypeChecking.Substitute-  , module Agda.TypeChecking.Substitute.Class-  , module Agda.TypeChecking.Substitute.DeBruijn-  , Substitution'(..), Substitution-  ) where--import Control.Applicative-import Data.Function-import Data.Functor-import Data.List hiding (sort, drop)-import qualified Data.List as List-import Data.Map (Map)-import Data.Maybe-import Data.Monoid-import Data.Typeable (Typeable)--import Debug.Trace (trace)--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import qualified Agda.Syntax.Abstract as A--import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Free as Free-import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Positivity.Occurrence as Occ--import Agda.TypeChecking.Substitute.Class-import Agda.TypeChecking.Substitute.DeBruijn--import Agda.Utils.Empty-import Agda.Utils.Functor-import Agda.Utils.List-import Agda.Utils.Permutation-import Agda.Utils.Size-import Agda.Utils.Tuple-import Agda.Utils.HashMap (HashMap)--#include "undefined.h"-import Agda.Utils.Impossible--instance Apply Term where-  applyE m [] = m-  applyE m es =-    case m of-      Var i es'   -> Var i (es' ++ es)-      Def f es'   -> defApp f es' es  -- remove projection redexes-      Con c ci args -> conApp c ci args es-      Lam _ b     ->-        case es of-          Apply a : es0 -> lazyAbsApp b (unArg a) `applyE` es0-          _             -> __IMPOSSIBLE__-      MetaV x es' -> MetaV x (es' ++ es)-      Shared p    -> Shared $ applyE p es-      Lit{}       -> __IMPOSSIBLE__-      Level{}     -> __IMPOSSIBLE__-      Pi _ _      -> __IMPOSSIBLE__-      Sort _      -> __IMPOSSIBLE__-      DontCare mv -> dontCare $ mv `applyE` es  -- Andreas, 2011-10-02-        -- need to go under DontCare, since "with" might resurrect irrelevant term---- | If $v$ is a record value, @canProject f v@---   returns its field @f@.-canProject :: QName -> Term -> Maybe (Arg Term)-canProject f v =-  case ignoreSharing v of-    (Con (ConHead _ _ fs) _ vs) -> do-      i <- elemIndex f fs-      headMaybe (drop i vs)-    _ -> Nothing---- | Eliminate a constructed term.-conApp :: ConHead -> ConInfo -> Args -> Elims -> Term-conApp ch                  ci args []             = Con ch ci args-conApp ch                  ci args (Apply a : es) = conApp ch ci (args ++ [a]) es-conApp ch@(ConHead c _ fs) ci args (Proj o f : es) =-  let failure = flip trace __IMPOSSIBLE__ $-        "conApp: constructor " ++ show c ++-        " with fields " ++ show fs ++-        " projected by " ++ show f-      i = maybe failure id            $ elemIndex f fs-      v = maybe failure argToDontCare $ headMaybe $ drop i args-  in  applyE v es--  -- -- Andreas, 2016-07-20 futile attempt to magically fix ProjOrigin-  --     fallback = v-  -- in  if not $ null es then applyE v es else-  --     -- If we have no more eliminations, we can return v-  --     if o == ProjSystem then fallback else-  --       -- If the result is a projected term with ProjSystem,-  --       -- we can can restore it to ProjOrigin o.-  --       -- Otherwise, we get unpleasant printing with eta-expanded record metas.-  --     caseMaybe (hasElims v) fallback $ \ (hd, es0) ->-  --       caseMaybe (initLast es0) fallback $ \ (es1, e2) ->-  --         case e2 of-  --           -- We want to replace this ProjSystem by o.-  --           Proj ProjSystem q -> hd (es1 ++ [Proj o q])-  --             -- Andreas, 2016-07-21 for the whole testsuite-  --             -- this case was never triggered!-  --           _ -> fallback--{--      i = maybe failure id    $ elemIndex f $ map unArg fs-      v = maybe failure unArg $ headMaybe $ drop i args-      -- Andreas, 2013-10-20 see Issue543a:-      -- protect result of irrelevant projection.-      r = maybe __IMPOSSIBLE__ getRelevance $ headMaybe $ drop i fs-      u | Irrelevant <- r = DontCare v-        | otherwise       = v-  in  applyE v es--}---- | @defApp f us vs@ applies @Def f us@ to further arguments @vs@,---   eliminating top projection redexes.---   If @us@ is not empty, we cannot have a projection redex, since---   the record argument is the first one.-defApp :: QName -> Elims -> Elims -> Term-defApp f [] (Apply a : es) | Just v <- canProject f (unArg a)-  = argToDontCare v `applyE` es-defApp f es0 es = Def f $ es0 ++ es---- protect irrelevant fields (see issue 610)-argToDontCare :: Arg Term -> Term-argToDontCare (Arg ai v)-  | Irrelevant <- getRelevance ai     = dontCare v-  | otherwise                         = v---- Andreas, 2016-01-19: In connection with debugging issue #1783,--- I consider the Apply instance for Type harmful, as piApply is not--- safe if the type is not sufficiently reduced.--- (piApply is not in the monad and hence cannot unfold type synonyms).------ Without apply for types, one has to at least use piApply and be--- aware of doing something which has a precondition--- (type sufficiently reduced).------ By grepping for piApply, one can quickly get an overview over--- potentially harmful uses.------ In general, piApplyM is preferable over piApply since it is more robust--- and fails earlier than piApply, which may only fail at serialization time,--- when all thunks are forced.---- REMOVED:--- instance Apply Type where---   apply = piApply---   -- Maybe an @applyE@ instance would be useful here as well.---   -- A record type could be applied to a projection name---   -- to yield the field type.---   -- However, this works only in the monad where we can---   -- look up the fields of a record type.--instance Apply Sort where-  applyE s [] = s-  applyE s _  = __IMPOSSIBLE__--instance Apply a => Apply (Ptr a) where-  applyE p xs = fmap (`applyE` xs) p---- @applyE@ does not make sense for telecopes, definitions, clauses etc.--instance Subst Term a => Apply (Tele a) where-  apply tel               []       = tel-  apply EmptyTel          _        = __IMPOSSIBLE__-  apply (ExtendTel _ tel) (t : ts) = lazyAbsApp tel (unArg t) `apply` ts--instance Apply Definition where-  apply (Defn info x t pol occ df m c inst copy ma d) args =-    Defn info x (piApply t args) (apply pol args) (apply occ args) df m c inst copy ma (apply d args)--instance Apply RewriteRule where-  apply r args = RewriteRule-    { rewName    = rewName r-    , rewContext = apply (rewContext r) args-    , rewHead    = rewHead r-    , rewPats    = applySubst sub (rewPats r)-    , rewRHS     = applySubst sub (rewRHS r)-    , rewType    = applySubst sub (rewType r)-    }-    where sub = parallelS (map unArg args)--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Apply [Occ.Occurrence] where-#else-instance Apply [Occ.Occurrence] where-#endif-  apply occ args = List.drop (length args) occ--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Apply [Polarity] where-#else-instance Apply [Polarity] where-#endif-  apply pol args = List.drop (length args) pol---- | Make sure we only drop variable patterns.-#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Apply [NamedArg (Pattern' a)] where-#else-instance Apply [NamedArg (Pattern' a)] where-#endif-  apply ps args = loop (length args) ps-    where-    loop 0 ps = ps-    loop n [] = __IMPOSSIBLE__-    loop n (p : ps) =-      let recurse = loop (n - 1) ps-      in  case namedArg p of-            VarP{}  -> recurse-            DotP{}  -> __IMPOSSIBLE__-            LitP{}  -> __IMPOSSIBLE__-            ConP{}  -> __IMPOSSIBLE__-            ProjP{} -> __IMPOSSIBLE__--instance Apply Projection where-  apply p args = p-    { projIndex = projIndex p - size args-    , projLams  = projLams p `apply` args-    }--instance Apply ProjLams where-  apply (ProjLams lams) args = ProjLams $ List.drop (length args) lams--instance Apply Defn where-  apply d [] = d-  apply d args = case d of-    Axiom{} -> d-    AbstractDefn -> d-    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Nothing } ->-      d { funClauses    = apply cs args-        , funCompiled   = apply cc args-        , funInv        = apply inv args-        }--    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Just p0} ->-      case p0 `apply` args of-        p@Projection{ projIndex = n }-          | n < 0     -> __IMPOSSIBLE__-          -- case: applied only to parameters-          | n > 0     -> d { funProjection = Just p }-          -- case: applied also to record value (n == 0)-          | otherwise ->-              d { funClauses        = apply cs args'-                , funCompiled       = apply cc args'-                , funInv            = apply inv args'-                , funProjection     = if isVar0 then Just p{ projIndex = 0 } else Nothing-                }-              where-                larg  = last args -- the record value-                args' = [larg]-                isVar0 = case ignoreSharing $ unArg larg of Var 0 [] -> True; _ -> False-{--    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Just p@Projection{ projIndex = n } }-        -- case: only applying parameters-      | size args < n -> d { funProjection = Just $ p `apply` args }-        -- case: apply also to record value-      | otherwise     ->-        d { funClauses        = apply cs args'-          , funCompiled       = apply cc args'-          , funInv            = apply inv args'-          , funProjection     = Just $ p { projIndex = 0 } -- Nothing ?-          }-      where args' = [last args]  -- the record value--}-    Datatype{ dataPars = np, dataSmallPars = sps, dataNonLinPars = nlps, dataClause = cl-            {-, dataArgOccurrences = occ-} } ->-      d { dataPars = np - size args-        , dataSmallPars  = apply sps args-        , dataNonLinPars = apply nlps args-        , dataClause     = apply cl args---        , dataArgOccurrences = List.drop (length args) occ-        }-    Record{ recPars = np, recClause = cl, recTel = tel-          {-, recArgOccurrences = occ-} } ->-      d { recPars = np - size args-        , recClause = apply cl args, recTel = apply tel args---        , recArgOccurrences = List.drop (length args) occ-        }-    Constructor{ conPars = np } ->-      d { conPars = np - size args }-    Primitive{ primClauses = cs } ->-      d { primClauses = apply cs args }--instance Apply PrimFun where-    apply (PrimFun x ar def) args   = PrimFun x (ar - size args) $ \vs -> def (args ++ vs)--instance Apply Clause where-    -- This one is a little bit tricksy after the parameter refinement change.-    -- It is assumed that we only apply a clause to "parameters", i.e.-    -- arguments introduced by lambda lifting. The problem is that these aren't-    -- necessarily the first elements of the clause telescope.-    apply cls@(Clause r tel ps b t catchall) args-      | length args > length ps = __IMPOSSIBLE__-      | otherwise =-      Clause r-             tel'-             (applySubst rhoP $ drop (length args) ps)-             (applySubst rho b)-             (applySubst rho t)-             catchall-      where-        -- We have-        --  Γ ⊢ args, for some outer context Γ-        --  Δ ⊢ ps,   where Δ is the clause telescope (tel)-        rargs = map unArg $ reverse args-        rps   = reverse $ take (length args) ps-        n     = size tel--        -- This is the new telescope. Created by substituting the args into the-        -- appropriate places in the old telescope. We know where those are by-        -- looking at the deBruijn indices of the patterns.-        tel' = newTel n tel rps rargs--        -- We then have to create a substitution from the old telescope to the-        -- new telescope that we can apply to dot patterns and the clause body.-        rhoP :: PatternSubstitution-        rhoP = mkSub DotP n rps rargs-        rho  = mkSub id   n rps rargs--        substP :: Nat -> Term -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]-        substP i v = subst i (DotP v)--        -- Building the substitution from the old telescope to the new. The-        -- interesting case is when we have a variable pattern:-        --  We need Δ′ ⊢ ρ : Δ-        --  where Δ′ = newTel Δ (xⁱ : ps) (v : vs)-        --           = newTel Δ[xⁱ:=v] ps[xⁱ:=v'] vs-        --  Note that we need v' = raise (|Δ| - 1) v, to make Γ ⊢ v valid in-        --  ΓΔ[xⁱ:=v].-        --  A recursive call ρ′ = mkSub (substP i v' ps) vs gets us-        --    Δ′ ⊢ ρ′ : Δ[xⁱ:=v]-        --  so we just need Δ[xⁱ:=v] ⊢ σ : Δ and then ρ = ρ′ ∘ σ.-        --  That's achieved by σ = singletonS i v'.-        mkSub :: Subst a a => (Term -> a) -> Nat -> [NamedArg DeBruijnPattern] -> [Term] -> Substitution' a-        mkSub _ _ [] [] = idS-        mkSub tm n (p : ps) (v : vs) =-          case namedArg p of-            VarP (DBPatVar _ i) -> mkSub tm (n - 1) (substP i v' ps) vs `composeS` singletonS i (tm v')-              where v' = raise (n - 1) v-            DotP{}  -> mkSub tm n ps vs-            LitP{}  -> __IMPOSSIBLE__-            ConP{}  -> __IMPOSSIBLE__-            ProjP{} -> __IMPOSSIBLE__-        mkSub _ _ _ _ = __IMPOSSIBLE__--        -- The parameter patterns 'ps' are all variables or dot patterns. If they-        -- are variables they can appear anywhere in the clause telescope. This-        -- function constructs the new telescope with 'vs' substituted for 'ps'.-        -- Example:-        --    tel = (x : A) (y : B) (z : C) (w : D)-        --    ps  = y@3 w@0-        --    vs  = u v-        --    newTel tel ps vs = (x : A) (z : C[u/y])-        newTel n tel [] [] = tel-        newTel n tel (p : ps) (v : vs) =-          case namedArg p of-            VarP (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs-            DotP{}              -> newTel n tel ps vs-            LitP{}              -> __IMPOSSIBLE__-            ConP{}              -> __IMPOSSIBLE__-            ProjP{}             -> __IMPOSSIBLE__-        newTel _ tel _ _ = __IMPOSSIBLE__--        -- subTel i v (Δ₁ (xᵢ : A) Δ₂) = Δ₁ Δ₂[xᵢ = v]-        subTel i v EmptyTel = __IMPOSSIBLE__-        subTel 0 v (ExtendTel _ tel) = absApp tel v-        subTel i v (ExtendTel a tel) = ExtendTel a $ subTel (i - 1) (raise 1 v) <$> tel--instance Apply CompiledClauses where-  apply cc args = case cc of-    Fail     -> Fail-    Done hs t-      | length hs >= len ->-         let sub = parallelS $ map var [0..length hs - len - 1] ++ map unArg args-         in  Done (List.drop len hs) $ applySubst sub t-      | otherwise -> __IMPOSSIBLE__-    Case n bs-      | unArg n >= len -> Case (n <&> \ m -> m - len) (apply bs args)-      | otherwise -> __IMPOSSIBLE__-    where-      len = length args--instance Apply a => Apply (WithArity a) where-  apply  (WithArity n a) args = WithArity n $ apply  a args-  applyE (WithArity n a) es   = WithArity n $ applyE a es--instance Apply a => Apply (Case a) where-  apply (Branches cop cs ls m) args =-    Branches cop (apply cs args) (apply ls args) (apply m args)-  applyE (Branches cop cs ls m) es =-    Branches cop (applyE cs es) (applyE ls es) (applyE m es)--instance Apply FunctionInverse where-  apply NotInjective  args = NotInjective-  apply (Inverse inv) args = Inverse $ apply inv args--instance Apply DisplayTerm where-  apply (DTerm v)          args = DTerm $ apply v args-  apply (DDot v)           args = DDot  $ apply v args-  apply (DCon c ci vs)     args = DCon c ci $ vs ++ map (fmap DTerm) args-  apply (DDef c es)        args = DDef c $ es ++ map (Apply . fmap DTerm) args-  apply (DWithApp v ws es) args = DWithApp v ws $ es ++ map Apply args--  applyE (DTerm v)           es = DTerm $ applyE v es-  applyE (DDot v)            es = DDot  $ applyE v es-  applyE (DCon c ci vs)      es = DCon c ci $ vs ++ map (fmap DTerm) ws-    where ws = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-  applyE (DDef c es')        es = DDef c $ es' ++ map (fmap DTerm) es-  applyE (DWithApp v ws es') es = DWithApp v ws $ es' ++ es--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} Apply t => Apply [t] where-#else-instance Apply t => Apply [t] where-#endif-  apply  ts args = map (`apply` args) ts-  applyE ts es   = map (`applyE` es) ts--instance Apply t => Apply (Blocked t) where-  apply  b args = fmap (`apply` args) b-  applyE b es   = fmap (`applyE` es) b--instance Apply t => Apply (Maybe t) where-  apply  x args = fmap (`apply` args) x-  applyE x es   = fmap (`applyE` es) x--instance Apply v => Apply (Map k v) where-  apply  x args = fmap (`apply` args) x-  applyE x es   = fmap (`applyE` es) x--instance Apply v => Apply (HashMap k v) where-  apply  x args = fmap (`apply` args) x-  applyE x es   = fmap (`applyE` es) x--instance (Apply a, Apply b) => Apply (a,b) where-  apply  (x,y) args = (apply  x args, apply  y args)-  applyE (x,y) es   = (applyE x es  , applyE y es  )--instance (Apply a, Apply b, Apply c) => Apply (a,b,c) where-  apply  (x,y,z) args = (apply  x args, apply  y args, apply  z args)-  applyE (x,y,z) es   = (applyE x es  , applyE y es  , applyE z es  )--instance DoDrop a => Apply (Drop a) where-  apply x args = dropMore (size args) x--instance DoDrop a => Abstract (Drop a) where-  abstract tel x = unDrop (size tel) x--instance Apply Permutation where-  -- The permutation must start with [0..m - 1]-  -- NB: section (- m) not possible (unary minus), hence (flip (-) m)-  apply (Perm n xs) args = Perm (n - m) $ map (flip (-) m) $ genericDrop m xs-    where-      m = size args--instance Abstract Permutation where-  abstract tel (Perm n xs) = Perm (n + m) $ [0..m - 1] ++ map (+ m) xs-    where-      m = size tel---- | @(x:A)->B(x) `piApply` [u] = B(u)@------   Precondition: The type must contain the right number of pis without---   having to perform any reduction.------   @piApply@ is potentially unsafe, the monadic 'piApplyM' is preferable.-piApply :: Type -> Args -> Type-piApply t []                      = t-piApply (El _ (Pi  _ b)) (a:args) = lazyAbsApp b (unArg a) `piApply` args-piApply (El s (Shared p)) args    = piApply (El s $ derefPtr p) args-piApply t args                    =-  trace ("piApply t = " ++ show t ++ "\n  args = " ++ show args) __IMPOSSIBLE__-------------------------------------------------------------------------------- * Abstraction------------------------------------------------------------------------------instance Abstract Term where-  abstract = teleLam--instance Abstract Type where-  abstract = telePi_--instance Abstract Sort where-  abstract EmptyTel s = s-  abstract _        s = __IMPOSSIBLE__--instance Abstract Telescope where-  EmptyTel           `abstract` tel = tel-  ExtendTel arg xtel `abstract` tel = ExtendTel arg $ xtel <&> (`abstract` tel)--instance Abstract Definition where-  abstract tel (Defn info x t pol occ df m c inst copy ma d) =-    Defn info x (abstract tel t) (abstract tel pol) (abstract tel occ) df m c inst copy ma (abstract tel d)---- | @tel ⊢ (Γ ⊢ lhs ↦ rhs : t)@ becomes @tel, Γ ⊢ lhs ↦ rhs : t)@---   we do not need to change lhs, rhs, and t since they live in Γ.---   See 'Abstract Clause'.-instance Abstract RewriteRule where-  abstract tel (RewriteRule q gamma f ps rhs t) =-    RewriteRule q (abstract tel gamma) f ps rhs t--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Abstract [Occ.Occurrence] where-#else-instance Abstract [Occ.Occurrence] where-#endif-  abstract tel []  = []-  abstract tel occ = replicate (size tel) Mixed ++ occ -- TODO: check occurrence--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Abstract [Polarity] where-#else-instance Abstract [Polarity] where-#endif-  abstract tel []  = []-  abstract tel pol = replicate (size tel) Invariant ++ pol -- TODO: check polarity--instance Abstract Projection where-  abstract tel p = p-    { projIndex = size tel + projIndex p-    , projLams  = abstract tel $ projLams p-    }--instance Abstract ProjLams where-  abstract tel (ProjLams lams) = ProjLams $-    map (\ (Dom ai (x, _)) -> Arg ai x) (telToList tel) ++ lams--instance Abstract Defn where-  abstract tel d = case d of-    Axiom{} -> d-    AbstractDefn -> d-    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Nothing  } ->-      d { funClauses  = abstract tel cs-        , funCompiled = abstract tel cc-        , funInv      = abstract tel inv-        }-    Function{ funClauses = cs, funCompiled = cc, funInv = inv-            , funProjection = Just p } ->-      -- Andreas, 2015-05-11 if projection was applied to Var 0-      -- then abstract over last element of tel (the others are params).-      if projIndex p > 0 then d' else-        d' { funClauses  = abstract tel1 cs-           , funCompiled = abstract tel1 cc-           , funInv      = abstract tel1 inv-           }-        where-          d' = d { funProjection = Just $ abstract tel p }-          tel1 = telFromList $ drop (size tel - 1) $ telToList tel--    Datatype{ dataPars = np, dataSmallPars = sps, dataNonLinPars = nlps, dataClause = cl } ->-      d { dataPars       = np + size tel-        , dataSmallPars  = abstract tel sps-        , dataNonLinPars = abstract tel nlps-        , dataClause     = abstract tel cl-        }-    Record{ recPars = np, recClause = cl, recTel = tel' } ->-      d { recPars    = np + size tel-        , recClause  = abstract tel cl-        , recTel     = abstract tel tel'-        }-    Constructor{ conPars = np } ->-      d { conPars = np + size tel }-    Primitive{ primClauses = cs } ->-      d { primClauses = abstract tel cs }--instance Abstract PrimFun where-    abstract tel (PrimFun x ar def) = PrimFun x (ar + n) $ \ts -> def $ genericDrop n ts-        where n = size tel--instance Abstract Clause where-  abstract tel (Clause r tel' ps b t catchall) =-    Clause r (abstract tel tel')-           (namedTelVars m tel ++ ps)-           b-           t -- nothing to do for t, since it lives under the telescope-           catchall-      where m = size tel + size tel'--instance Abstract CompiledClauses where-  abstract tel Fail = Fail-  abstract tel (Done xs t) = Done (map (argFromDom . fmap fst) (telToList tel) ++ xs) t-  abstract tel (Case n bs) =-    Case (n <&> \ i -> i + fromIntegral (size tel)) (abstract tel bs)--instance Abstract a => Abstract (WithArity a) where-  abstract tel (WithArity n a) = WithArity n $ abstract tel a--instance Abstract a => Abstract (Case a) where-  abstract tel (Branches cop cs ls m) =-    Branches cop (abstract tel cs) (abstract tel ls) (abstract tel m)--telVars :: Int -> Telescope -> [Arg DeBruijnPattern]-telVars m = map (fmap namedThing) . (namedTelVars m)--namedTelVars :: Int -> Telescope -> [NamedArg DeBruijnPattern]-namedTelVars m EmptyTel                     = []-namedTelVars m (ExtendTel (Dom info a) tel) =-  Arg info (namedDBVarP (m-1) $ absName tel) :-  namedTelVars (m-1) (unAbs tel)--instance Abstract FunctionInverse where-  abstract tel NotInjective  = NotInjective-  abstract tel (Inverse inv) = Inverse $ abstract tel inv--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPABLE #-} Abstract t => Abstract [t] where-#else-instance Abstract t => Abstract [t] where-#endif-  abstract tel = map (abstract tel)--instance Abstract t => Abstract (Maybe t) where-  abstract tel x = fmap (abstract tel) x--instance Abstract v => Abstract (Map k v) where-  abstract tel m = fmap (abstract tel) m--instance Abstract v => Abstract (HashMap k v) where-  abstract tel m = fmap (abstract tel) m--abstractArgs :: Abstract a => Args -> a -> a-abstractArgs args x = abstract tel x-    where-        tel   = foldr (\(Arg info x) -> ExtendTel (Dom info $ sort Prop) . Abs x)-                      EmptyTel-              $ zipWith (<$) names args-        names = cycle $ map (stringToArgName . (:[])) ['a'..'z']-------------------------------------------------------------------------------- * Substitution and raising/shifting/weakening-------------------------------------------------------------------------------- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renaming _ π) : Term Γ -> Term Δ@-renaming :: forall a. DeBruijn a => Empty -> Permutation -> Substitution' a-renaming err p = prependS err gamma $ raiseS $ size p-  where-    gamma :: [Maybe a]-    gamma = inversePermute p (deBruijnVar :: Int -> a)-    -- gamma = safePermute (invertP (-1) p) $ map deBruijnVar [0..]---- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renamingR π) : Term Δ -> Term Γ@-renamingR :: DeBruijn a => Permutation -> Substitution' a-renamingR p@(Perm n _) = permute (reverseP p) (map deBruijnVar [0..]) ++# raiseS n---- | The permutation should permute the corresponding context. (right-to-left list)-renameP :: Subst t a => Empty -> Permutation -> a -> a-renameP err p = applySubst (renaming err p)--instance Subst a a => Subst a (Substitution' a) where-  applySubst rho sgm = composeS rho sgm--instance Subst Term Term where-  applySubst IdS t = t-  applySubst rho t    = case t of-    Var i es    -> lookupS rho i `applyE` applySubst rho es-    Lam h m     -> Lam h $ applySubst rho m-    Def f es    -> defApp f [] $ applySubst rho es-    Con c ci vs -> Con c ci $ applySubst rho vs-    MetaV x es  -> MetaV x $ applySubst rho es-    Lit l       -> Lit l-    Level l     -> levelTm $ applySubst rho l-    Pi a b      -> uncurry Pi $ applySubst rho (a,b)-    Sort s      -> sortTm $ applySubst rho s-    Shared p    -> Shared $ applySubst rho p-    DontCare mv -> dontCare $ applySubst rho mv--instance Subst t a => Subst t (Ptr a) where-  applySubst rho = fmap (applySubst rho)--instance Subst Term a => Subst Term (Type' a) where-  applySubst rho (El s t) = applySubst rho s `El` applySubst rho t--instance Subst Term Sort where-  applySubst rho s = case s of-    Type n     -> levelSort $ sub n-    Prop       -> Prop-    Inf        -> Inf-    SizeUniv   -> SizeUniv-    DLub s1 s2 -> DLub (sub s1) (sub s2)-    where sub x = applySubst rho x--instance Subst Term Level where-  applySubst rho (Max as) = Max $ applySubst rho as--instance Subst Term PlusLevel where-  applySubst rho l@ClosedLevel{} = l-  applySubst rho (Plus n l) = Plus n $ applySubst rho l--instance Subst Term LevelAtom where-  applySubst rho (MetaLevel m vs)   = MetaLevel m    $ applySubst rho vs-  applySubst rho (BlockedLevel m v) = BlockedLevel m $ applySubst rho v-  applySubst rho (NeutralLevel _ v) = UnreducedLevel $ applySubst rho v-  applySubst rho (UnreducedLevel v) = UnreducedLevel $ applySubst rho v--instance Subst Term Name where-  applySubst rho = id--#if __GLASGOW_HASKELL__ >= 710-instance {-# OVERLAPPING #-} Subst Term String where-#else-instance Subst Term String where-#endif-  applySubst rho = id--instance Subst Term ConPatternInfo where-  applySubst rho (ConPatternInfo mr mt) = ConPatternInfo mr $ applySubst rho mt--instance Subst Term Pattern where-  applySubst rho p = case p of-    ConP c mt ps -> ConP c (applySubst rho mt) $ applySubst rho ps-    DotP t       -> DotP $ applySubst rho t-    VarP s       -> p-    LitP l       -> p-    ProjP{}      -> p--instance Subst Term NLPat where-  applySubst rho p = case p of-    PVar id i bvs -> p-    PWild  -> p-    PDef f es -> PDef f $ applySubst rho es-    PLam i u -> PLam i $ applySubst rho u-    PPi a b -> PPi (applySubst rho a) (applySubst rho b)-    PBoundVar i es -> PBoundVar i $ applySubst rho es-    PTerm u -> PTerm $ applySubst rho u--instance Subst Term NLPType where-  applySubst rho (NLPType s a) = NLPType (applySubst rho s) (applySubst rho a)--instance Subst Term RewriteRule where-  applySubst rho (RewriteRule q gamma f ps rhs t) =-    RewriteRule q (applySubst rho gamma)-                f (applySubst (liftS n rho) ps)-                  (applySubst (liftS n rho) rhs)-                  (applySubst (liftS n rho) t)-    where n = size gamma--instance Subst t a => Subst t (Blocked a) where-  applySubst rho b = fmap (applySubst rho) b--instance Subst Term DisplayForm where-  applySubst rho (Display n ps v) =-    Display n (applySubst (liftS 1 rho) ps)-              (applySubst (liftS n rho) v)--instance Subst Term DisplayTerm where-  applySubst rho (DTerm v)        = DTerm $ applySubst rho v-  applySubst rho (DDot v)         = DDot  $ applySubst rho v-  applySubst rho (DCon c ci vs)   = DCon c ci $ applySubst rho vs-  applySubst rho (DDef c es)      = DDef c $ applySubst rho es-  applySubst rho (DWithApp v vs es) = uncurry3 DWithApp $ applySubst rho (v, vs, es)--instance Subst t a => Subst t (Tele a) where-  applySubst rho  EmptyTel         = EmptyTel-  applySubst rho (ExtendTel t tel) = uncurry ExtendTel $ applySubst rho (t, tel)--instance Subst Term Constraint where-  applySubst rho c = case c of-    ValueCmp cmp a u v       -> ValueCmp cmp (rf a) (rf u) (rf v)-    ElimCmp ps a v e1 e2     -> ElimCmp ps (rf a) (rf v) (rf e1) (rf e2)-    TypeCmp cmp a b          -> TypeCmp cmp (rf a) (rf b)-    TelCmp a b cmp tel1 tel2 -> TelCmp (rf a) (rf b) cmp (rf tel1) (rf tel2)-    SortCmp cmp s1 s2        -> SortCmp cmp (rf s1) (rf s2)-    LevelCmp cmp l1 l2       -> LevelCmp cmp (rf l1) (rf l2)-    Guarded c cs             -> Guarded (rf c) cs-    IsEmpty r a              -> IsEmpty r (rf a)-    CheckSizeLtSat t         -> CheckSizeLtSat (rf t)-    FindInScope m b cands    -> FindInScope m b (rf cands)-    UnBlock{}                -> c-    where-      rf x = applySubst rho x--instance Subst Term ModuleParameters where-  applySubst rho mp = mp { mpSubstitution = applySubst rho $ mpSubstitution mp }--instance Subst Term A.NamedDotPattern where-  applySubst rho (A.NamedDot x v a) = A.NamedDot x (applySubst rho v) (applySubst rho a)--instance Subst t a => Subst t (Elim' a) where-  applySubst rho e = case e of-    Apply v -> Apply $ applySubst rho v-    Proj{}  -> e--instance Subst t a => Subst t (Abs a) where-  applySubst rho (Abs x a)   = Abs x $ applySubst (liftS 1 rho) a-  applySubst rho (NoAbs x a) = NoAbs x $ applySubst rho a--instance Subst t a => Subst t (Arg a) where-  applySubst rho = fmap (applySubst rho)--instance Subst t a => Subst t (Named name a) where-  applySubst rho = fmap (applySubst rho)--instance Subst t a => Subst t (Dom a) where-  applySubst rho = fmap (applySubst rho)--instance Subst t a => Subst t (Maybe a) where-  applySubst rho = fmap (applySubst rho)--instance Subst t a => Subst t [a] where-  applySubst rho = map (applySubst rho)--instance (Ord k, Subst t a) => Subst t (Map k a) where-  applySubst rho = fmap (applySubst rho)--instance Subst Term () where-  applySubst _ _ = ()--instance (Subst t a, Subst t b) => Subst t (a, b) where-  applySubst rho (x,y) = (applySubst rho x, applySubst rho y)--instance (Subst t a, Subst t b, Subst t c) => Subst t (a, b, c) where-  applySubst rho (x,y,z) = (applySubst rho x, applySubst rho y, applySubst rho z)--instance (Subst t a, Subst t b, Subst t c, Subst t d) => Subst t (a, b, c, d) where-  applySubst rho (x,y,z,u) = (applySubst rho x, applySubst rho y, applySubst rho z, applySubst rho u)--instance Subst Term Candidate where-  applySubst rho (Candidate u t eti ov) = Candidate (applySubst rho u) (applySubst rho t) eti ov--instance Subst Term EqualityView where-  applySubst rho (OtherType t) = OtherType-    (applySubst rho t)-  applySubst rho (EqualityType s eq l t a b) = EqualityType-    (applySubst rho s)-    eq-    (applySubst rho l)-    (applySubst rho t)-    (applySubst rho a)-    (applySubst rho b)--instance DeBruijn DeBruijnPattern where-  debruijnNamedVar n i  = VarP $ DBPatVar n i-  deBruijnView (VarP x) = Just $ dbPatVarIndex x-  deBruijnView _        = Nothing--fromPatternSubstitution :: PatternSubstitution -> Substitution-fromPatternSubstitution = fmap patternToTerm--applyPatSubst :: (Subst Term a) => PatternSubstitution -> a -> a-applyPatSubst = applySubst . fromPatternSubstitution--instance Subst DeBruijnPattern DeBruijnPattern where-  applySubst IdS p = p-  applySubst rho p = case p of-    VarP x       -> useName (dbPatVarName x) $ lookupS rho $ dbPatVarIndex x-    DotP u       -> DotP $ applyPatSubst rho u-    ConP c ci ps -> ConP c ci $ applySubst rho ps-    LitP x       -> p-    ProjP{}      -> p-    where-      useName :: PatVarName -> DeBruijnPattern -> DeBruijnPattern-      useName n (VarP x) | isUnderscore (dbPatVarName x) = debruijnNamedVar n (dbPatVarIndex x)-      useName _ x = x-------------------------------------------------------------------------------- * Projections-------------------------------------------------------------------------------- | @projDropParsApply proj o args = 'projDropPars' proj o `'apply'` args@------   This function is an optimization, saving us from construction lambdas we---   immediately remove through application.-projDropParsApply :: Projection -> ProjOrigin -> Args -> Term-projDropParsApply (Projection proper d r _ lams) o args =-  case initLast $ getProjLams lams of-    -- If we have no more abstractions, we must be a record field-    -- (projection applied already to record value).-    Nothing -> if proper then Def d $ map Apply args else __IMPOSSIBLE__-    Just (pars, Arg i y) ->-      let core = if proper then Lam i $ Abs y $ Var 0 [Proj o d]-                           else Lam i $ Abs y $ Def d [Apply $ Var 0 [] <$ r] -- Issue2226: get ArgInfo for principal argument from projFromType-      -- Now drop pars many args-          (pars', args') = dropCommon pars args-      -- We only have to abstract over the parameters that exceed the arguments.-      -- We only have to apply to the arguments that exceed the parameters.-      in List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (core `apply` args') pars'-------------------------------------------------------------------------------- * Telescopes------------------------------------------------------------------------------type TelView = TelV Type-data TelV a  = TelV { theTel :: Tele (Dom a), theCore :: a }-  deriving (Typeable, Show, Functor)--deriving instance (Subst t a, Eq  a) => Eq  (TelV a)-deriving instance (Subst t a, Ord a) => Ord (TelV a)--type ListTel' a = [Dom (a, Type)]-type ListTel = ListTel' ArgName--telFromList' :: (a -> ArgName) -> ListTel' a -> Telescope-telFromList' f = foldr extTel EmptyTel-  where-    extTel (Dom info (x, a)) = ExtendTel (Dom info a) . Abs (f x)--telFromList :: ListTel -> Telescope-telFromList = telFromList' id--telToList :: Telescope -> ListTel-telToList EmptyTel            = []-telToList (ExtendTel arg tel) = fmap (absName tel,) arg : telToList (absBody tel)-  -- Andreas, 2013-12-14: This would work also for 'NoAbs',-  -- since 'absBody' raises.--telToArgs :: Telescope -> [Arg ArgName]-telToArgs tel = [ Arg (domInfo d) (fst $ unDom d) | d <- telToList tel ]---- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.-bindsToTel' :: (Name -> a) -> [Name] -> Dom Type -> ListTel' a-bindsToTel' f []     t = []-bindsToTel' f (x:xs) t = fmap (f x,) t : bindsToTel' f xs (raise 1 t)--bindsToTel :: [Name] -> Dom Type -> ListTel-bindsToTel = bindsToTel' nameToArgName---- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.-bindsWithHidingToTel' :: (Name -> a) -> [WithHiding Name] -> Dom Type -> ListTel' a-bindsWithHidingToTel' f []                    t = []-bindsWithHidingToTel' f (WithHiding h x : xs) t =-  fmap (f x,) (mapHiding (mappend h) t) : bindsWithHidingToTel' f xs (raise 1 t)--bindsWithHidingToTel :: [WithHiding Name] -> Dom Type -> ListTel-bindsWithHidingToTel = bindsWithHidingToTel' nameToArgName---- | Takes off all exposed function domains from the given type.---   This means that it does not reduce to expose @Pi@-types.-telView' :: Type -> TelView-telView' = telView'UpTo (-1)---- | @telView'UpTo n t@ takes off the first @n@ exposed function types of @t@.--- Takes off all (exposed ones) if @n < 0@.-telView'UpTo :: Int -> Type -> TelView-telView'UpTo 0 t = TelV EmptyTel t-telView'UpTo n t = case ignoreSharing $ unEl t of-  Pi a b  -> absV a (absName b) $ telView'UpTo (n - 1) (absBody b)-  _       -> TelV EmptyTel t-  where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t---- | @mkPi dom t = telePi (telFromList [dom]) t@-mkPi :: Dom (ArgName, Type) -> Type -> Type-mkPi (Dom info (x, a)) b = el $ Pi (Dom info a) (mkAbs x b)-  where-    el = El $ dLub (getSort a) (Abs x (getSort b)) -- dLub checks x freeIn--mkLam :: Arg ArgName -> Term -> Term-mkLam a v = Lam (argInfo a) (Abs (unArg a) v)--telePi' :: (Abs Type -> Abs Type) -> Telescope -> Type -> Type-telePi' reAbs = telePi where-  telePi EmptyTel          t = t-  telePi (ExtendTel u tel) t = el $ Pi u $ reAbs b-    where-      b  = (`telePi` t) <$> tel-      s1 = getSort u-      s2 = getSort <$> b-      el = El $ dLub s1 s2---- | Uses free variable analysis to introduce 'noAbs' bindings.-telePi :: Telescope -> Type -> Type-telePi = telePi' reAbs---- | Everything will be a 'Abs'.-telePi_ :: Telescope -> Type -> Type-telePi_ = telePi' id--{- OLD--- | Everything will be a pi.-telePi_  EmptyTel        t = t-telePi_ (ExtendTel u tel) t = el $ Pi u b-  where-    el = El (dLub s1 s2)-    b  = fmap (flip telePi_ t) tel-    s1 = getSort $ unDom u-    s2 = fmap getSort b--}--teleLam :: Telescope -> Term -> Term-teleLam  EmptyTel         t = t-teleLam (ExtendTel u tel) t = Lam (domInfo u) $ flip teleLam t <$> tel---- | Performs void ('noAbs') abstraction over telescope.-class TeleNoAbs a where-  teleNoAbs :: a -> Term -> Term--instance TeleNoAbs ListTel where-  teleNoAbs tel t = foldr (\ (Dom ai (x, _)) -> Lam ai . NoAbs x) t tel--instance TeleNoAbs Telescope where-  teleNoAbs tel = teleNoAbs $ telToList tel---- | In compiled clauses, the variables in the clause body are relative to the---   pattern variables (including dot patterns) instead of the clause telescope.-compiledClauseBody :: Clause -> Maybe Term-compiledClauseBody cl = applySubst (renamingR perm) $ clauseBody cl-  where perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl-------------------------------------------------------------------------------- * Syntactic equality and order------------------------------------------------------------------------------deriving instance Eq Substitution-deriving instance Ord Substitution--deriving instance Eq Sort-deriving instance Ord Sort-deriving instance Eq Level-deriving instance Ord Level-deriving instance Eq PlusLevel-deriving instance Ord LevelAtom-deriving instance Eq NotBlocked-deriving instance Ord NotBlocked-deriving instance Eq t => Eq (Blocked t)-deriving instance Ord t => Ord (Blocked t)-deriving instance Eq Candidate--deriving instance (Subst t a, Eq a)  => Eq  (Tele a)-deriving instance (Subst t a, Ord a) => Ord (Tele a)--deriving instance Eq Constraint-deriving instance Eq Section--instance Ord PlusLevel where-  compare ClosedLevel{} Plus{}            = LT-  compare Plus{} ClosedLevel{}            = GT-  compare (ClosedLevel n) (ClosedLevel m) = compare n m-  -- Compare on the atom first. Makes most sense for levelMax.-  compare (Plus n a) (Plus m b)           = compare (a,n) (b,m)--instance Eq LevelAtom where-  (==) = (==) `on` unLevelAtom---- | Syntactic 'Type' equality, ignores sort annotations.-instance Eq a => Eq (Type' a) where-  (==) = (==) `on` unEl--instance Ord a => Ord (Type' a) where-  compare = compare `on` unEl---- | Syntactic 'Term' equality, ignores stuff below @DontCare@ and sharing.-instance Eq Term where-  Var x vs   == Var x' vs'   = x == x' && vs == vs'-  Lam h v    == Lam h' v'    = h == h' && v  == v'-  Lit l      == Lit l'       = l == l'-  Def x vs   == Def x' vs'   = x == x' && vs == vs'-  Con x _ vs == Con x' _ vs' = x == x' && vs == vs'-  Pi a b     == Pi a' b'     = a == a' && b == b'-  Sort s     == Sort s'      = s == s'-  Level l    == Level l'     = l == l'-  MetaV m vs == MetaV m' vs' = m == m' && vs == vs'-  DontCare _ == DontCare _   = True-  Shared p   == Shared q     = p == q || derefPtr p == derefPtr q-  Shared p   == b            = derefPtr p == b-  a          == Shared q     = a == derefPtr q-  _          == _            = False--instance Ord Term where-  Shared a   `compare` Shared x | a == x = EQ-  Shared a   `compare` x          = compare (derefPtr a) x-  a          `compare` Shared x   = compare a (derefPtr x)-  Var a b    `compare` Var x y    = compare (a, b) (x, y)-  Var{}      `compare` _          = LT-  _          `compare` Var{}      = GT-  Def a b    `compare` Def x y    = compare (a, b) (x, y)-  Def{}      `compare` _          = LT-  _          `compare` Def{}      = GT-  Con a _ b  `compare` Con x _ y  = compare (a, b) (x, y)-  Con{}      `compare` _          = LT-  _          `compare` Con{}      = GT-  Lit a      `compare` Lit x      = compare a x-  Lit{}      `compare` _          = LT-  _          `compare` Lit{}      = GT-  Lam a b    `compare` Lam x y    = compare (a, b) (x, y)-  Lam{}      `compare` _          = LT-  _          `compare` Lam{}      = GT-  Pi a b     `compare` Pi x y     = compare (a, b) (x, y)-  Pi{}       `compare` _          = LT-  _          `compare` Pi{}       = GT-  Sort a     `compare` Sort x     = compare a x-  Sort{}     `compare` _          = LT-  _          `compare` Sort{}     = GT-  Level a    `compare` Level x    = compare a x-  Level{}    `compare` _          = LT-  _          `compare` Level{}    = GT-  MetaV a b  `compare` MetaV x y  = compare (a, b) (x, y)-  MetaV{}    `compare` _          = LT-  _          `compare` MetaV{}    = GT-  DontCare{} `compare` DontCare{} = EQ--instance (Subst t a, Eq a) => Eq (Abs a) where-  NoAbs _ a == NoAbs _ b = a == b-  Abs   _ a == Abs   _ b = a == b-  a         == b         = absBody a == absBody b--instance (Subst t a, Ord a) => Ord (Abs a) where-  NoAbs _ a `compare` NoAbs _ b = a `compare` b-  Abs   _ a `compare` Abs   _ b = a `compare` b-  a         `compare` b         = absBody a `compare` absBody b--instance (Subst t a, Eq a)  => Eq  (Elim' a) where-  Apply  a == Apply  b = a == b-  Proj _ x == Proj _ y = x == y-  _ == _ = False--instance (Subst t a, Ord a) => Ord (Elim' a) where-  Apply  a `compare` Apply  b = a `compare` b-  Proj _ x `compare` Proj _ y = x `compare` y-  Apply{}  `compare` Proj{}   = LT-  Proj{}   `compare` Apply{}  = GT-------------------------------------------------------------------------------- * Level stuff-------------------------------------------------------------------------------- | The ``rule'', if Agda is considered as a functional---   pure type system (pts).------   TODO: This needs to be properly implemented, requiring---   refactoring of Agda's handling of levels.---   Without impredicativity or 'SizeUniv', Agda's pts rule is---   just the least upper bound, which is total and commutative.---   The handling of levels relies on this simplification.-pts :: Sort -> Sort -> Sort-pts = sLub--sLub :: Sort -> Sort -> Sort-sLub s Prop = s-sLub Prop s = s-sLub Inf _ = Inf-sLub _ Inf = Inf-sLub SizeUniv s = s         -- one can freely quantify over sizes in any Set-sLub _ SizeUniv = SizeUniv  -- but everything resulting in a size lives in the SizeUniv-sLub (Type (Max as)) (Type (Max bs)) = Type $ levelMax (as ++ bs)--- sLub (DLub a b) c = DLub (sLub a c) b -- no longer commutative!-sLub (DLub a NoAbs{}) c = __IMPOSSIBLE__-sLub (DLub a (Abs x b)) c = DLub a $ Abs x $ sLub b $ raise 1 c-sLub a (DLub b c) = DLub (sLub a b) c---- | Dependent least upper bound, to assign a level to expressions---   like @forall i -> Set i@.------   @dLub s1 \i.s2 = \omega@ if @i@ appears in the rigid variables of @s2@.-dLub :: Sort -> Abs Sort -> Sort-dLub s1 (NoAbs _ s2) = sLub s1 s2-dLub s1 b@(Abs _ s2) = case occurrence 0 s2 of-  Flexible _    -> DLub s1 b-  Irrelevantly  -> DLub s1 b-  NoOccurrence  -> sLub s1 (noabsApp __IMPOSSIBLE__ b)---  Free.Unused   -> sLub s1 (absApp b __IMPOSSIBLE__) -- triggers Issue784-  Free.Unused   -> DLub s1 b-  StronglyRigid -> Inf-  Unguarded     -> Inf-  WeaklyRigid   -> Inf--lvlView :: Term -> Level-lvlView v = case ignoreSharing v of-  Level l       -> l-  Sort (Type l) -> l-  _             -> Max [Plus 0 $ UnreducedLevel v]--levelMax :: [PlusLevel] -> Level-levelMax as0 = Max $ ns ++ List.sort bs-  where-    as = Prelude.concatMap expand as0-    -- ns is empty or a singleton-    ns = case [ n | ClosedLevel n <- as, n > 0 ] of-      []  -> []-      ns  -> [ ClosedLevel n | let n = Prelude.maximum ns, n > greatestB ]-    bs = subsume [ b | b@Plus{} <- as ]-    greatestB | null bs   = 0-              | otherwise = Prelude.maximum [ n | Plus n _ <- bs ]--    expand l@ClosedLevel{} = [l]-    expand (Plus n l) = map (plus n) $ expand0 $ expandAtom l--    expand0 [] = [ClosedLevel 0]-    expand0 as = as--    expandAtom l = case l of-      BlockedLevel _ v -> expandTm v-      NeutralLevel _ v -> expandTm v-      UnreducedLevel v -> expandTm v-      MetaLevel{}      -> [Plus 0 l]-      where-        expandTm v = case ignoreSharing v of-          Level (Max as)       -> as-          Sort (Type (Max as)) -> as-          _                    -> [Plus 0 l]--    plus n (ClosedLevel m) = ClosedLevel (n + m)-    plus n (Plus m l)      = Plus (n + m) l--    subsume (ClosedLevel{} : _) = __IMPOSSIBLE__-    subsume [] = []-    subsume (Plus n a : bs)-      | not $ null ns = subsume bs-      | otherwise     = Plus n a : subsume [ b | b@(Plus _ a') <- bs, a /= a' ]-      where-        ns = [ m | Plus m a'  <- bs, a == a', m > n ]--sortTm :: Sort -> Term-sortTm (Type l) = Sort $ levelSort l-sortTm s        = Sort s--levelSort :: Level -> Sort-levelSort (Max as)-  | List.any (levelIs Inf     ) as = Inf-  | List.any (levelIs SizeUniv) as = SizeUniv-  where-    levelIs s ClosedLevel{}     = False-    levelIs s (Plus _ l)        = atomIs s l-    atomIs s (NeutralLevel _ a) = tmIs s a-    atomIs s (UnreducedLevel a) = tmIs s a-    atomIs s MetaLevel{}        = False-    atomIs s BlockedLevel{}     = False-    tmIs s (Sort s')            = s == s'-    tmIs s (Shared p)           = tmIs s $ derefPtr p-    tmIs s _                    = False-levelSort l =-  case ignoreSharing $ levelTm l of-    Sort s -> s-    _      -> Type l--levelTm :: Level -> Term-levelTm l =-  case l of-    Max [Plus 0 l] -> unLevelAtom l-    _              -> Level l--unLevelAtom :: LevelAtom -> Term-unLevelAtom (MetaLevel x es)   = MetaV x es-unLevelAtom (NeutralLevel _ v) = v-unLevelAtom (UnreducedLevel v) = v-unLevelAtom (BlockedLevel _ v) = v+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications    #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -ddump-to-file #-}++-- | This module contains the definition of hereditary substitution+-- and application operating on internal syntax which is in β-normal+-- form (β including projection reductions).+--+-- Further, it contains auxiliary functions which rely on substitution+-- but not on reduction.++module Agda.TypeChecking.Substitute+  ( module Agda.TypeChecking.Substitute+  , module Agda.TypeChecking.Substitute.Class+  , module Agda.TypeChecking.Substitute.DeBruijn+  , Substitution'(..), Substitution+  ) where++import Control.Arrow (first, second)++import Data.Coerce+import Data.Function (on)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map.Strict as MapS+import Data.Maybe+import Data.HashMap.Strict (HashMap)++import Debug.Trace (trace)++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import qualified Agda.Syntax.Abstract as A++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Free as Free+import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Positivity.Occurrence as Occ++import Agda.TypeChecking.Substitute.Class+import Agda.TypeChecking.Substitute.DeBruijn++import Agda.Utils.Either+import Agda.Utils.Empty+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible+++-- | Apply @Elims@ while using the given function to report ill-typed+--   redexes.+--   Recursive calls for @applyE@ and @applySubst@ happen at type @t@ to+--   propagate the same strategy to subtrees.+{-# SPECIALIZE applyTermE :: (Empty -> Term -> Elims -> Term) -> Term -> Elims -> Term #-}+{-# SPECIALIZE applyTermE :: (Empty -> Term -> Elims -> Term) -> BraveTerm -> Elims -> BraveTerm #-}+applyTermE :: forall t. (Coercible Term t, Apply t, EndoSubst t)+           => (Empty -> Term -> Elims -> Term) -> t -> Elims -> t+applyTermE err' m [] = m+applyTermE err' m es = coerce $+    case coerce m of+      Var i es'   -> Var i (es' ++ es)+      Def f es'   -> defApp f es' es  -- remove projection redexes+      Con c ci args -> conApp @t err' c ci args es+      Lam _ b     ->+        case es of+          Apply a : es0      -> lazyAbsApp (coerce b :: Abs t) (coerce $ unArg a) `app` es0+          IApply _ _ a : es0 -> lazyAbsApp (coerce b :: Abs t) (coerce a)         `app` es0+          _                  -> err __IMPOSSIBLE__+      MetaV x es' -> MetaV x (es' ++ es)+      Lit{}       -> err __IMPOSSIBLE__+      Level{}     -> err __IMPOSSIBLE__+      Pi _ _      -> err __IMPOSSIBLE__+      Sort s      -> Sort $ s `applyE` es+      Dummy s es' -> Dummy s (es' ++ es)+      DontCare mv -> dontCare $ mv `app` es  -- Andreas, 2011-10-02+        -- need to go under DontCare, since "with" might resurrect irrelevant term+   where+     app :: Coercible t a => a -> Elims -> Term+     app u es = coerce $ (coerce u :: t) `applyE` es+     err e = err' e (coerce m) es++instance Apply Term where+  applyE = applyTermE absurd++instance Apply BraveTerm where+  applyE = applyTermE (\ _ t es ->  Dummy "applyE" (Apply (defaultArg t) : es))++-- | If @v@ is a record or constructed value, @canProject f v@+--   returns its field @f@.+canProject :: QName -> Term -> Maybe (Arg Term)+canProject f v =+  case v of+    -- Andreas, 2022-06-10, issue #5922: also unfold data projections+    -- (not just record projections).+    (Con (ConHead _ _ _ fs) _ vs) -> do+      (fld, i) <- findWithIndex ((f ==) . unArg) fs+      -- Jesper, 2019-10-17: dont unfold irrelevant projections+      guard $ not $ isIrrelevant fld+      -- Andreas, 2018-06-12, issue #2170+      -- The ArgInfo from the ConHead is more accurate (relevance subtyping!).+      setArgInfo (getArgInfo fld) <.> isApplyElim =<< listToMaybe (drop i vs)+    _ -> Nothing++-- | Eliminate a constructed term.+conApp :: forall t. (Coercible t Term, Apply t) => (Empty -> Term -> Elims -> Term) -> ConHead -> ConInfo -> Elims -> Elims -> Term+conApp fallback ch                    ci args []                  = Con ch ci args+conApp fallback ch                    ci args    (a@Apply{} : es) = conApp @t fallback ch ci (args ++ [a]) es+conApp fallback ch                    ci args   (a@IApply{} : es) = conApp @t fallback ch ci (args ++ [a]) es+conApp fallback ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) =+  let failure :: forall a. a -> a+      failure err = flip trace err $ concat+        [ "conApp: constructor ", prettyShow c+        , unlines $ " with fields" : map (("  " ++) . prettyShow) fs+        , unlines $ " and args"    : map (("  " ++) . prettyShow) args+        , " projected by ", prettyShow f+        ]+      isApply e = fromMaybe (failure __IMPOSSIBLE__) $ isApplyElim e+      stuck err = fallback err (Con ch ci args) [Proj o f]+      -- Recurse using the instance for 't', see @applyTermE@+      app :: Term -> Elims -> Term+      app v es = coerce $ applyE (coerce v :: t) es+  in+   case findWithIndex ((f ==) . unArg) fs of+     Nothing -> failure $ stuck __IMPOSSIBLE__ `app` es+     Just (fld, i) -> let+      -- Andreas, 2018-06-12, issue #2170+      -- We safe-guard the projected value by DontCare using the ArgInfo stored at the record constructor,+      -- since the ArgInfo in the constructor application might be inaccurate because of subtyping.+      v = maybe (failure $ stuck __IMPOSSIBLE__) (relToDontCare fld . argToDontCare . isApply) $ listToMaybe $ drop i args+      in v `app` es++  -- -- Andreas, 2016-07-20 futile attempt to magically fix ProjOrigin+  --     fallback = v+  -- in  if not $ null es then applyE v es else+  --     -- If we have no more eliminations, we can return v+  --     if o == ProjSystem then fallback else+  --       -- If the result is a projected term with ProjSystem,+  --       -- we can can restore it to ProjOrigin o.+  --       -- Otherwise, we get unpleasant printing with eta-expanded record metas.+  --     caseMaybe (hasElims v) fallback $ \ (hd, es0) ->+  --       caseMaybe (initLast es0) fallback $ \ (es1, e2) ->+  --         case e2 of+  --           -- We want to replace this ProjSystem by o.+  --           Proj ProjSystem q -> hd (es1 ++ [Proj o q])+  --             -- Andreas, 2016-07-21 for the whole testsuite+  --             -- this case was never triggered!+  --           _ -> fallback++{-+      i = maybe failure id    $ elemIndex f $ map unArg fs+      v = maybe failure unArg $ listToMaybe $ drop i args+      -- Andreas, 2013-10-20 see Issue543a:+      -- protect result of irrelevant projection.+      r = maybe __IMPOSSIBLE__ getRelevance $ listToMaybe $ drop i fs+      u | Irrelevant <- r = DontCare v+        | otherwise       = v+  in  applyE v es+-}++-- | @defApp f us vs@ applies @Def f us@ to further arguments @vs@,+--   eliminating top projection redexes.+--   If @us@ is not empty, we cannot have a projection redex, since+--   the record argument is the first one.+defApp :: QName -> Elims -> Elims -> Term+defApp f [] (Apply a : es) | Just v <- canProject f (unArg a)+  = argToDontCare v `applyE` es+defApp f es0 es = Def f $ es0 ++ es++-- protect irrelevant fields (see issue 610)+argToDontCare :: Arg Term -> Term+argToDontCare (Arg ai v) = relToDontCare ai v++relToDontCare :: LensRelevance a => a -> Term -> Term+relToDontCare ai = applyWhen (isIrrelevant ai) dontCare++-- Andreas, 2016-01-19: In connection with debugging issue #1783,+-- I consider the Apply instance for Type harmful, as piApply is not+-- safe if the type is not sufficiently reduced.+-- (piApply is not in the monad and hence cannot unfold type synonyms).+--+-- Without apply for types, one has to at least use piApply and be+-- aware of doing something which has a precondition+-- (type sufficiently reduced).+--+-- By grepping for piApply, one can quickly get an overview over+-- potentially harmful uses.+--+-- In general, piApplyM is preferable over piApply since it is more robust+-- and fails earlier than piApply, which may only fail at serialization time,+-- when all thunks are forced.++-- REMOVED:+-- instance Apply Type where+--   apply = piApply+--   -- Maybe an @applyE@ instance would be useful here as well.+--   -- A record type could be applied to a projection name+--   -- to yield the field type.+--   -- However, this works only in the monad where we can+--   -- look up the fields of a record type.++instance Apply Sort where+  applyE s [] = s+  applyE s es = case s of+    MetaS x es' -> MetaS x $ es' ++ es+    DefS  d es' -> DefS  d $ es' ++ es+    _ -> __IMPOSSIBLE__++-- @applyE@ does not make sense for telecopes, definitions, clauses etc.++instance TermSubst a => Apply (Tele a) where+  apply tel               []       = tel+  apply EmptyTel          _        = __IMPOSSIBLE__+  apply (ExtendTel _ tel) (t : ts) = lazyAbsApp tel (unArg t) `apply` ts++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply Definition where+  apply (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang d) args =+    Defn info x (piApply t args) (apply pol args) (apply occ args) (drop (length args) gpars) df m c inst copy ma nc inj copat blk lang (apply d args)++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply RewriteRule where+  apply r args =+    let newContext = apply (rewContext r) args+        sub        = liftS (size newContext) $ parallelS $+                       reverse $ map (PTerm . unArg) args+    in RewriteRule+       { rewName    = rewName r+       , rewContext = newContext+       , rewHead    = rewHead r+       , rewPats    = applySubst sub (rewPats r)+       , rewRHS     = applyNLPatSubst sub (rewRHS r)+       , rewType    = applyNLPatSubst sub (rewType r)+       , rewFromClause = rewFromClause r+       , rewTopModule  = rewTopModule r+       }++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance {-# OVERLAPPING #-} Apply [Occ.Occurrence] where+  apply occ args = List.drop (length args) occ+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance {-# OVERLAPPING #-} Apply [Polarity] where+  apply pol args = List.drop (length args) pol+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply NumGeneralizableArgs where+  apply NoGeneralizableArgs       args = NoGeneralizableArgs+  apply (SomeGeneralizableArgs n) args = SomeGeneralizableArgs (n - length args)+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++-- | Make sure we only drop variable patterns.+instance {-# OVERLAPPING #-} Apply [NamedArg (Pattern' a)] where+  apply ps args = loop (length args) ps+    where+    loop 0 ps = ps+    loop n [] = __IMPOSSIBLE__+    loop n (p : ps) =+      let recurse = loop (n - 1) ps+      in  case namedArg p of+            VarP{}  -> recurse+            DotP{}  -> __IMPOSSIBLE__+            LitP{}  -> __IMPOSSIBLE__+            ConP{}  -> __IMPOSSIBLE__+            DefP{}  -> __IMPOSSIBLE__+            ProjP{} -> __IMPOSSIBLE__+            IApplyP{} -> recurse++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply Projection where+  apply p args = p+    { projIndex = projIndex p - size args+    , projLams  = projLams p `apply` args+    }+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply ProjLams where+  apply (ProjLams lams) args = ProjLams $ List.drop (length args) lams+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply Defn where+  apply d [] = d+  apply d args@(arg1:args1) = case d of+    Axiom{} -> d+    DataOrRecSig n -> DataOrRecSig (n - length args)+    GeneralizableVar gv -> GeneralizableVar $ apply gv args+    AbstractDefn d -> AbstractDefn $ apply d args+    Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv+            , funExtLam = extLam+            , funProjection = Left _ } ->+      d { funClauses    = apply cs args+        , funCompiled   = apply cc args+        , funCovering   = apply cov args+        , funInv        = apply inv args+        , funExtLam     = modifySystem (`apply` args) <$> extLam+        }++    Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv+            , funExtLam = extLam+            , funProjection = Right p0 } ->+      case p0 `apply` args of+        p@Projection{ projIndex = n }+          | n < 0     -> d { funProjection = __IMPOSSIBLE__ } -- TODO (#3123): we actually get here!+          -- case: applied only to parameters+          | n > 0     -> d { funProjection = Right p }+          -- case: applied also to record value (n == 0)+          | otherwise ->+              d { funClauses        = apply cs args'+                , funCompiled       = apply cc args'+                , funCovering       = apply cov args'+                , funInv            = apply inv args'+                , funProjection     = if isVar0 then Right p{ projIndex = 0 } else Left MaybeProjection+                , funExtLam         = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam+                }+              where+                larg  = last1 arg1 args1 -- the record value+                args' = [larg]+                isVar0 = case unArg larg of Var 0 [] -> True; _ -> False++    Datatype{ dataPars = np, dataClause = cl } ->+      d { dataPars = np - size args+        , dataClause     = apply cl args+        }+    Record{ recPars = np, recClause = cl, recTel = tel+          {-, recArgOccurrences = occ-} } ->+      d { recPars = np - size args+        , recClause = apply cl args, recTel = apply tel args+--        , recArgOccurrences = List.drop (length args) occ+        }+    Constructor{ conPars = np } ->+      d { conPars = np - size args }+    Primitive{ primClauses = cs } ->+      d { primClauses = apply cs args }+    PrimitiveSort{} -> d++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply PrimFun where+  apply (PrimFun x ar occs def) args =+    PrimFun x (ar - n) (drop n occs) $ \ vs -> def (args ++ vs)+    where+    n = size args+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply Clause where+    -- This one is a little bit tricksy after the parameter refinement change.+    -- It is assumed that we only apply a clause to "parameters", i.e.+    -- arguments introduced by lambda lifting. The problem is that these aren't+    -- necessarily the first elements of the clause telescope.+    apply cls@(Clause rl rf tel ps b t catchall recursive unreachable ell wm) args+      | length args > length ps = __IMPOSSIBLE__+      | otherwise =+      Clause rl rf+             tel'+             (applySubst rhoP $ drop (length args) ps)+             (applySubst rho b)+             (applySubst rho t)+             catchall+             recursive+             unreachable+             ell+             wm+      where+        -- We have+        --  Γ ⊢ args, for some outer context Γ+        --  Δ ⊢ ps,   where Δ is the clause telescope (tel)+        rargs = map unArg $ reverse args+        rps   = reverse $ take (length args) ps+        n     = size tel++        -- This is the new telescope. Created by substituting the args into the+        -- appropriate places in the old telescope. We know where those are by+        -- looking at the deBruijn indices of the patterns.+        tel' = newTel n tel rps rargs++        -- We then have to create a substitution from the old telescope to the+        -- new telescope that we can apply to dot patterns and the clause body.+        rhoP :: PatternSubstitution+        rhoP = mkSub dotP n rps rargs+        rho  = mkSub id   n rps rargs++        substP :: Nat -> Term -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]+        substP i v = subst i (dotP v)++        -- Building the substitution from the old telescope to the new. The+        -- interesting case is when we have a variable pattern:+        --  We need Δ′ ⊢ ρ : Δ+        --  where Δ′ = newTel Δ (xⁱ : ps) (v : vs)+        --           = newTel Δ[xⁱ:=v] ps[xⁱ:=v'] vs+        --  Note that we need v' = raise (|Δ| - 1) v, to make Γ ⊢ v valid in+        --  ΓΔ[xⁱ:=v].+        --  A recursive call ρ′ = mkSub (substP i v' ps) vs gets us+        --    Δ′ ⊢ ρ′ : Δ[xⁱ:=v]+        --  so we just need Δ[xⁱ:=v] ⊢ σ : Δ and then ρ = ρ′ ∘ σ.+        --  That's achieved by σ = singletonS i v'.+        mkSub :: EndoSubst a => (Term -> a) -> Nat -> [NamedArg DeBruijnPattern] -> [Term] -> Substitution' a+        mkSub _ _ [] [] = idS+        mkSub tm n (p : ps) (v : vs) =+          case namedArg p of+            VarP _ (DBPatVar _ i) -> mkSub tm (n - 1) (substP i v' ps) vs `composeS` singletonS i (tm v')+              where v' = raise (n - 1) v+            DotP{}  -> mkSub tm n ps vs+            ConP c _ ps' -> mkSub tm n (ps' ++ ps) (projections c v ++ vs)+            DefP{}  -> __IMPOSSIBLE__+            LitP{}  -> __IMPOSSIBLE__+            ProjP{} -> __IMPOSSIBLE__+            IApplyP _ _ _ (DBPatVar _ i) -> mkSub tm (n - 1) (substP i v' ps) vs `composeS` singletonS i (tm v')+              where v' = raise (n - 1) v+        mkSub _ _ _ _ = __IMPOSSIBLE__++        -- The parameter patterns 'ps' are all variables or dot patterns, or eta+        -- expanded record patterns (issue #2550). If they are variables they+        -- can appear anywhere in the clause telescope. This function+        -- constructs the new telescope with 'vs' substituted for 'ps'.+        -- Example:+        --    tel = (x : A) (y : B) (z : C) (w : D)+        --    ps  = y@3 w@0+        --    vs  = u v+        --    newTel tel ps vs = (x : A) (z : C[u/y])+        newTel :: Nat -> Telescope -> [NamedArg DeBruijnPattern] -> [Term] -> Telescope+        newTel n tel [] [] = tel+        newTel n tel (p : ps) (v : vs) =+          case namedArg p of+            VarP _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs+            DotP{}              -> newTel n tel ps vs+            ConP c _ ps'        -> newTel n tel (ps' ++ ps) (projections c v ++ vs)+            DefP{}  -> __IMPOSSIBLE__+            LitP{}  -> __IMPOSSIBLE__+            ProjP{} -> __IMPOSSIBLE__+            IApplyP _ _ _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs+        newTel _ tel _ _ = __IMPOSSIBLE__++        projections :: ConHead -> Term -> [Term]+        projections c v = [ relToDontCare ai $+                            -- #4528: We might have bogus terms here when printing a clause that+                            --        cannot be taken. To mitigate the problem we use a Def instead+                            --        a Proj elim for data constructors, which at least stops conApp+                            --        from crashing. See #4989 for not printing bogus terms at all.+                            case conDataRecord c of+                              IsData     -> defApp f [] [Apply (Arg ai v)]+                                              -- Andreas, 2022-06-10, issue #5922.+                                              -- This was @Def f [Apply (Arg ai v)]@, but are we sure+                                              -- that @v@ isn't a matching @Con@?  The testcase for+                                              -- #5922 does not require this precaution,+                                              -- but I sleep better this way...+                              IsRecord{} -> applyE v [Proj ProjSystem f]+                          | Arg ai f <- conFields c ]++        -- subTel i v (Δ₁ (xᵢ : A) Δ₂) = Δ₁ Δ₂[xᵢ = v]+        subTel i v EmptyTel = __IMPOSSIBLE__+        subTel 0 v (ExtendTel _ tel) = absApp tel v+        subTel i v (ExtendTel a tel) = ExtendTel a $ subTel (i - 1) (raise 1 v) <$> tel++    applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply CompiledClauses where+  apply cc args = case cc of+    Fail hs -> Fail (drop len hs)+    Done hs t+      | length hs >= len ->+         let sub = parallelS $ map var [0..length hs - len - 1] ++ map unArg args+         in  Done (List.drop len hs) $ applySubst sub t+      | otherwise -> __IMPOSSIBLE__+    Case n bs+      | unArg n >= len -> Case (n <&> \ m -> m - len) (apply bs args)+      | otherwise -> __IMPOSSIBLE__+    where+      len = length args+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply ExtLamInfo where+  apply (ExtLamInfo m b sys) args = ExtLamInfo m b (apply sys args)+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply System where+  -- We assume we apply a system only to arguments introduced by+  -- lambda lifting.+  apply (System tel sys) args+      = if nargs > ntel then __IMPOSSIBLE__+        else System newTel (map (map (f -*- id) -*- f) sys)++    where+      f = applySubst sigma+      nargs = length args+      ntel = size tel+      newTel = apply tel args+      -- newTel ⊢ σ : tel+      sigma = liftS (ntel - nargs) (parallelS (reverse $ map unArg args))++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply a => Apply (WithArity a) where+  apply  (WithArity n a) args = WithArity n $ apply  a args+  applyE (WithArity n a) es   = WithArity n $ applyE a es++instance Apply a => Apply (Case a) where+  apply (Branches cop cs eta ls m b lz) args =+    Branches cop (apply cs args) (second (`apply` args) <$> eta) (apply ls args) (apply m args) b lz+  applyE (Branches cop cs eta ls m b lz) es =+    Branches cop (applyE cs es) (second (`applyE` es) <$> eta)(applyE ls es) (applyE m es) b lz++instance Apply FunctionInverse where+  apply NotInjective  args = NotInjective+  apply (Inverse inv) args = Inverse $ apply inv args++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Apply DisplayTerm where+  apply (DTerm' v es)      args = DTerm' v       $ es ++ map Apply args+  apply (DDot' v es)       args = DDot' v        $ es ++ map Apply args+  apply (DCon c ci vs)     args = DCon c ci     $ vs ++ map (fmap DTerm) args+  apply (DDef c es)        args = DDef c        $ es ++ map (Apply . fmap DTerm) args+  apply (DWithApp v ws es) args = DWithApp v ws $ es ++ map Apply args++  applyE (DTerm' v es')      es = DTerm' v $ es' ++ es+  applyE (DDot' v es')       es = DDot' v $ es' ++ es+  applyE (DCon c ci vs)      es = DCon c ci $ vs ++ map (fmap DTerm) ws+    where ws = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+  applyE (DDef c es')        es = DDef c $ es' ++ map (fmap DTerm) es+  applyE (DWithApp v ws es') es = DWithApp v ws $ es' ++ es++instance {-# OVERLAPPABLE #-} Apply t => Apply [t] where+  apply  ts args = map (`apply` args) ts+  applyE ts es   = map (`applyE` es) ts++instance Apply t => Apply (Blocked t) where+  apply  b args = fmap (`apply` args) b+  applyE b es   = fmap (`applyE` es) b++instance Apply t => Apply (Maybe t) where+  apply  x args = fmap (`apply` args) x+  applyE x es   = fmap (`applyE` es) x++instance Apply t => Apply (Strict.Maybe t) where+  apply  x args = fmap (`apply` args) x+  applyE x es   = fmap (`applyE` es) x++instance Apply v => Apply (Map k v) where+  apply  x args = fmap (`apply` args) x+  applyE x es   = fmap (`applyE` es) x++instance Apply v => Apply (HashMap k v) where+  apply  x args = fmap (`apply` args) x+  applyE x es   = fmap (`applyE` es) x++instance (Apply a, Apply b) => Apply (a,b) where+  apply  (x,y) args = (apply  x args, apply  y args)+  applyE (x,y) es   = (applyE x es  , applyE y es  )++instance (Apply a, Apply b, Apply c) => Apply (a,b,c) where+  apply  (x,y,z) args = (apply  x args, apply  y args, apply  z args)+  applyE (x,y,z) es   = (applyE x es  , applyE y es  , applyE z es  )++instance DoDrop a => Apply (Drop a) where+  apply x args = dropMore (size args) x+  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance DoDrop a => Abstract (Drop a) where+  abstract tel x = unDrop (size tel) x++instance Apply Permutation where+  -- The permutation must start with [0..m - 1]+  -- NB: section (- m) not possible (unary minus), hence (flip (-) m)+  apply (Perm n xs) args = Perm (n - m) $ map (flip (-) m) $ drop m xs+    where+      m = size args++  applyE t es = apply t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++instance Abstract Permutation where+  abstract tel (Perm n xs) = Perm (n + m) $ [0..m - 1] ++ map (+ m) xs+    where+      m = size tel++-- | @(x:A)->B(x) `piApply` [u] = B(u)@+--+--   Precondition: The type must contain the right number of pis without+--   having to perform any reduction.+--+--   @piApply@ is potentially unsafe, the monadic 'piApplyM' is preferable.+piApply :: Type -> Args -> Type+piApply t []                      = t+piApply (El _ (Pi  _ b)) (a:args) = lazyAbsApp b (unArg a) `piApply` args+piApply t args                    =+  trace ("piApply t = " ++ prettyShow t ++ "\n  args = " ++ prettyShow args) __IMPOSSIBLE__++---------------------------------------------------------------------------+-- * Abstraction+---------------------------------------------------------------------------++instance Abstract Term where+  abstract = teleLam++instance Abstract Type where+  abstract = telePi_++instance Abstract Sort where+  abstract EmptyTel s = s+  abstract _        s = __IMPOSSIBLE__++instance Abstract Telescope where+  EmptyTel           `abstract` tel = tel+  ExtendTel arg xtel `abstract` tel = ExtendTel arg $ xtel <&> (`abstract` tel)++instance Abstract Definition where+  abstract tel (Defn info x t pol occ gpars df m c inst copy ma nc inj copat blk lang d) =+    Defn info x (abstract tel t) (abstract tel pol) (abstract tel occ)+      (replicate (size tel) Nothing ++ gpars)+      df m c inst copy ma nc inj copat blk lang (abstract tel d)++-- | @tel ⊢ (Γ ⊢ lhs ↦ rhs : t)@ becomes @tel, Γ ⊢ lhs ↦ rhs : t)@+--   we do not need to change lhs, rhs, and t since they live in Γ.+--   See 'Abstract Clause'.+instance Abstract RewriteRule where+  abstract tel (RewriteRule q gamma f ps rhs t c top) =+    RewriteRule q (abstract tel gamma) f ps rhs t c top++instance {-# OVERLAPPING #-} Abstract [Occ.Occurrence] where+  abstract tel []  = []+  abstract tel occ = replicate (size tel) Mixed ++ occ -- TODO: check occurrence++instance {-# OVERLAPPING #-} Abstract [Polarity] where+  abstract tel []  = []+  abstract tel pol = replicate (size tel) Invariant ++ pol -- TODO: check polarity++instance Abstract NumGeneralizableArgs where+  abstract tel NoGeneralizableArgs       = NoGeneralizableArgs+  abstract tel (SomeGeneralizableArgs n) = SomeGeneralizableArgs (size tel + n)++instance Abstract Projection where+  abstract tel p = p+    { projIndex = size tel + projIndex p+    , projLams  = abstract tel $ projLams p+    }++instance Abstract ProjLams where+  abstract tel (ProjLams lams) = ProjLams $+    map (\ !dom -> argFromDom (fst <$> dom)) (telToList tel) ++ lams++instance Abstract System where+  abstract tel (System tel1 sys) = System (abstract tel tel1) sys++instance Abstract Defn where+  abstract tel d = case d of+    Axiom{} -> d+    DataOrRecSig n -> DataOrRecSig (size tel + n)+    GeneralizableVar gv -> GeneralizableVar $ abstract tel gv+    AbstractDefn d -> AbstractDefn $ abstract tel d+    Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv+            , funExtLam = extLam+            , funProjection = Left _  } ->+      d { funClauses  = abstract tel cs+        , funCompiled = abstract tel cc+        , funCovering = abstract tel cov+        , funInv      = abstract tel inv+        , funExtLam   = modifySystem (abstract tel) <$> extLam+        }+    Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv+            , funExtLam = extLam+            , funProjection = Right p } ->+      -- Andreas, 2015-05-11 if projection was applied to Var 0+      -- then abstract over last element of tel (the others are params).+      if projIndex p > 0 then+        d { funProjection = Right $ abstract tel p+          , funClauses    = map (abstractClause EmptyTel) cs+          }+      else+        d { funProjection = Right $ abstract tel p+          , funClauses    = map (abstractClause tel1) cs+          , funCompiled   = abstract tel1 cc+          , funCovering   = abstract tel1 cov+          , funInv        = abstract tel1 inv+          , funExtLam     = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam+          }+        where+          tel1 = telFromList $ drop (size tel - 1) $ telToList tel+          -- #5128: clause telescopes should be abstracted over the full telescope, regardless of+          --        projection shenanigans.+          abstractClause tel1 c = (abstract tel1 c) { clauseTel = abstract tel $ clauseTel c }++    Datatype{ dataPars = np, dataClause = cl } ->+      d { dataPars       = np + size tel+        , dataClause     = abstract tel cl+        }+    Record{ recPars = np, recClause = cl, recTel = tel' } ->+      d { recPars    = np + size tel+        , recClause  = abstract tel cl+        , recTel     = abstract tel tel'+        }+    Constructor{ conPars = np } ->+      d { conPars = np + size tel }+    Primitive{ primClauses = cs } ->+      d { primClauses = abstract tel cs }+    PrimitiveSort{} -> d++instance Abstract PrimFun where+    abstract tel (PrimFun x ar occs def) =+      PrimFun x (ar + n) (replicate n Mixed ++ occs) $ \ts ->+        def $ drop n ts+        where n = size tel++instance Abstract Clause where+  abstract tel (Clause rl rf tel' ps b t catchall recursive unreachable ell wm) =+    Clause rl rf (abstract tel tel')+           (namedTelVars m tel ++ ps)+           b+           t -- nothing to do for t, since it lives under the telescope+           catchall+           recursive+           unreachable+           ell+           wm+      where m = size tel + size tel'++instance Abstract CompiledClauses where+  abstract tel cc = case cc of+      Fail xs   -> Fail (hs ++ xs)+      Done xs t -> Done (hs ++ xs) t+      Case n bs -> Case (n <&> \ i -> i + size tel) (abstract tel bs)+    where+      hs = map (argFromDom . fmap fst) $ telToList tel++instance Abstract a => Abstract (WithArity a) where+  abstract tel (WithArity n a) = WithArity n $ abstract tel a++instance Abstract a => Abstract (Case a) where+  abstract tel (Branches cop cs eta ls m b lz) =+    Branches cop (abstract tel cs) (second (abstract tel) <$> eta)+                 (abstract tel ls) (abstract tel m) b lz++telVars :: Int -> Telescope -> [Arg DeBruijnPattern]+telVars m = map (fmap namedThing) . (namedTelVars m)++namedTelVars :: Int -> Telescope -> [NamedArg DeBruijnPattern]+namedTelVars m EmptyTel                     = []+namedTelVars m (ExtendTel !dom tel) =+  Arg (domInfo dom) (namedDBVarP (m-1) $ absName tel) :+  namedTelVars (m-1) (unAbs tel)++instance Abstract FunctionInverse where+  abstract tel NotInjective  = NotInjective+  abstract tel (Inverse inv) = Inverse $ abstract tel inv++instance {-# OVERLAPPABLE #-} Abstract t => Abstract [t] where+  abstract tel = map (abstract tel)++instance Abstract t => Abstract (Maybe t) where+  abstract tel x = fmap (abstract tel) x++instance Abstract v => Abstract (Map k v) where+  abstract tel m = fmap (abstract tel) m++instance Abstract v => Abstract (HashMap k v) where+  abstract tel m = fmap (abstract tel) m++abstractArgs :: Abstract a => Args -> a -> a+abstractArgs args x = abstract tel x+    where+        tel   = foldr (\arg@(Arg info x) -> ExtendTel (__DUMMY_TYPE__ <$ domFromArg arg) . Abs x)+                      EmptyTel+              $ zipWith (<$) names args+        names = cycle $ map (stringToArgName . (:[])) ['a'..'z']++---------------------------------------------------------------------------+-- * Substitution and shifting\/weakening\/strengthening+---------------------------------------------------------------------------++-- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renaming _ π) : Term Γ -> Term Δ@+renaming :: forall a. DeBruijn a => Impossible -> Permutation -> Substitution' a+renaming err p = prependS err gamma $ raiseS $ size p+  where+    gamma :: [Maybe a]+    gamma = inversePermute p (deBruijnVar :: Int -> a)+    -- gamma = safePermute (invertP (-1) p) $ map deBruijnVar [0..]++-- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renamingR π) : Term Δ -> Term Γ@+renamingR :: DeBruijn a => Permutation -> Substitution' a+renamingR p@(Perm n is) = xs ++# raiseS n+  where+  xs = map (\i -> deBruijnVar (n - 1 - i)) (reverse is)++  -- The list xs used to be defined in the following way:+  --+  --   permute (reverseP p) (map deBruijnVar [0..])+  --+  -- We have that+  --+  --     permute (reverseP p) (map deBruijnVar [0..])+  --   = permute (Perm n $ map ((n - 1) -) $ reverse is)+  --       (map deBruijnVar [0..])+  --   = map (map deBruijnVar [0..] !!)+  --       (map ((n - 1) -) $ reverse is)+  --   = map deBruijnVar (map ((n - 1) -) $ reverse is)+  --   = map (\i -> deBruijnVar (n - 1 - i)) (reverse is).+  --+  -- The latter code is linear in the length of is (if deBruijnVar+  -- takes constant time), while the time complexity of the former+  -- code depends on the value of the largest index in is.++-- | The permutation should permute the corresponding context. (right-to-left list)+renameP :: Subst a => Impossible -> Permutation -> a -> a+renameP err p = applySubst (renaming err p)++instance EndoSubst a => Subst (Substitution' a) where+  type SubstArg (Substitution' a) = a+  applySubst rho sgm = composeS rho sgm++{-# SPECIALIZE applySubstTerm :: Substitution -> Term -> Term #-}+{-# SPECIALIZE applySubstTerm :: Substitution' BraveTerm -> BraveTerm -> BraveTerm #-}+applySubstTerm :: forall t. (Coercible t Term, EndoSubst t, Apply t) => Substitution' t -> t -> t+applySubstTerm IdS t = t+applySubstTerm rho t    = coerce $ case coerce t of+    Var i es    -> coerce $ lookupS rho i  `applyE` subE es+    Lam h m     -> Lam h $ sub @(Abs t) m+    Def f es    -> defApp f [] $ subE es+    Con c ci vs -> Con c ci $ subE vs+    MetaV x es  -> MetaV x $ subE es+    Lit l       -> Lit l+    Level l     -> levelTm $ sub @(Level' t) l+    Pi a b      -> uncurry Pi $ subPi (a,b)+    Sort s      -> Sort $ sub @(Sort' t) s+    DontCare mv -> dontCare $ sub @t mv+    Dummy s es  -> Dummy s $ subE es+ where+   sub :: forall a b. (Coercible b a, SubstWith t a) => b -> b+   sub t = coerce $ applySubst rho (coerce t :: a)+   subE :: Elims -> Elims+   subE  = sub @[Elim' t]+   subPi :: (Dom Type, Abs Type) -> (Dom Type, Abs Type)+   subPi = sub @(Dom' t (Type'' t t), Abs (Type'' t t))++instance Subst Term where+  type SubstArg Term = Term+  applySubst = applySubstTerm++-- András 2023-09-25: we can only put this here, because at the original definition site there's no Subst Term instance.+{-# SPECIALIZE lookupS :: Substitution' Term -> Nat -> Term #-}+{-# SPECIALIZE isNoAbs :: Abs Term -> Maybe Term #-}++instance Subst BraveTerm where+  type SubstArg BraveTerm = BraveTerm+  applySubst = applySubstTerm++instance (Coercible a Term, Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Type'' a b) where+  type SubstArg (Type'' a b) = SubstArg a+  applySubst rho (El s t) = applySubst rho s `El` applySubst rho t++instance (Coercible a Term, Subst a) => Subst (Sort' a) where+  type SubstArg (Sort' a) = SubstArg a+  applySubst rho = \case+    Univ u n   -> Univ u $ sub n+    Inf u n    -> Inf u n+    SizeUniv   -> SizeUniv+    LockUniv   -> LockUniv+    LevelUniv  -> LevelUniv+    IntervalUniv -> IntervalUniv+    PiSort a s1 s2 -> coerce $ piSort (coerce $ sub a) (coerce $ sub s1) (coerce $ sub s2)+    FunSort s1 s2 -> coerce $ funSort (coerce $ sub s1) (coerce $ sub s2)+    UnivSort s -> coerce $ univSort $ coerce $ sub s+    MetaS x es -> MetaS x $ sub es+    DefS d es  -> DefS d $ sub es+    s@DummyS{} -> s+    where+      sub :: forall b. (Subst b, SubstArg a ~ SubstArg b) => b -> b+      sub x = applySubst rho x++instance Subst a => Subst (Level' a) where+  type SubstArg (Level' a) = SubstArg a+  applySubst rho (Max n as) = Max n $ applySubst rho as++instance Subst a => Subst (PlusLevel' a) where+  type SubstArg (PlusLevel' a) = SubstArg a+  applySubst rho (Plus n l) = Plus n $ applySubst rho l++instance Subst Name where+  type SubstArg Name = Term+  applySubst rho = id++instance Subst ConPatternInfo where+  type SubstArg ConPatternInfo = Term+  applySubst rho i = i{ conPType = applySubst rho $ conPType i }++instance Subst Pattern where+  type SubstArg Pattern = Term+  applySubst rho = \case+    ConP c mt ps    -> ConP c (applySubst rho mt) $ applySubst rho ps+    DefP o q ps     -> DefP o q $ applySubst rho ps+    DotP o t        -> DotP o $ applySubst rho t+    p@(VarP _o _x)  -> p+    p@(LitP _o _l)  -> p+    p@(ProjP _o _x) -> p+    IApplyP o t u x -> IApplyP o (applySubst rho t) (applySubst rho u) x++instance Subst A.ProblemEq where+  type SubstArg A.ProblemEq = Term+  applySubst rho (A.ProblemEq p v a) =+    uncurry (A.ProblemEq p) $ applySubst rho (v,a)++instance DeBruijn BraveTerm where+  deBruijnVar = BraveTerm . deBruijnVar+  deBruijnView = deBruijnView . unBrave++instance DeBruijn NLPat where+  deBruijnVar i = PVar i []+  deBruijnView = \case+    PVar i []   -> Just i+    PVar{}      -> Nothing+    PDef{}      -> Nothing+    PLam{}      -> Nothing+    PPi{}       -> Nothing+    PSort{}     -> Nothing+    PBoundVar{} -> Nothing -- or... ?+    PTerm{}     -> Nothing -- or... ?++applyNLPatSubst :: TermSubst a => Substitution' NLPat -> a -> a+applyNLPatSubst = applySubst . fmap nlPatToTerm+  where+    nlPatToTerm :: NLPat -> Term+    nlPatToTerm = \case+      PVar i xs      -> Var i $ map (Apply . fmap var) xs+      PTerm u        -> u+      PDef f es      -> __IMPOSSIBLE__+      PLam i u       -> __IMPOSSIBLE__+      PPi a b        -> __IMPOSSIBLE__+      PSort s        -> __IMPOSSIBLE__+      PBoundVar i es -> __IMPOSSIBLE__++applyNLSubstToDom :: SubstWith NLPat a => Substitution' NLPat -> Dom a -> Dom a+applyNLSubstToDom rho dom = applySubst rho <$> dom{ domTactic = applyNLPatSubst rho $ domTactic dom }++instance Subst NLPat where+  type SubstArg NLPat = NLPat+  applySubst rho = \case+    PVar i bvs     -> lookupS rho i `applyBV` bvs+    PDef f es      -> PDef f $ applySubst rho es+    PLam i u       -> PLam i $ applySubst rho u+    PPi a b        -> PPi (applyNLSubstToDom rho a) (applySubst rho b)+    PSort s        -> PSort $ applySubst rho s+    PBoundVar i es -> PBoundVar i $ applySubst rho es+    PTerm u        -> PTerm $ applyNLPatSubst rho u++    where+      applyBV :: NLPat -> [Arg Int] -> NLPat+      applyBV p ys = case p of+        PVar i xs      -> PVar i (xs ++ ys)+        PTerm u        -> PTerm $ u `apply` map (fmap var) ys+        PDef f es      -> __IMPOSSIBLE__+        PLam i u       -> __IMPOSSIBLE__+        PPi a b        -> __IMPOSSIBLE__+        PSort s        -> __IMPOSSIBLE__+        PBoundVar i es -> __IMPOSSIBLE__++instance Subst NLPType where+  type SubstArg NLPType = NLPat+  applySubst rho (NLPType s a) = NLPType (applySubst rho s) (applySubst rho a)++instance Subst NLPSort where+  type SubstArg NLPSort = NLPat+  applySubst rho = \case+    PUniv u l -> PUniv u $ applySubst rho l+    PInf f n  -> PInf f n+    PSizeUniv -> PSizeUniv+    PLockUniv -> PLockUniv+    PLevelUniv -> PLevelUniv+    PIntervalUniv -> PIntervalUniv++instance Subst RewriteRule where+  type SubstArg RewriteRule = NLPat+  applySubst rho (RewriteRule q gamma f ps rhs t c top) =+    RewriteRule q (applyNLPatSubst rho gamma)+                f (applySubst (liftS n rho) ps)+                  (applyNLPatSubst (liftS n rho) rhs)+                  (applyNLPatSubst (liftS n rho) t)+                  c top+    where n = size gamma++instance Subst a => Subst (Blocked a) where+  type SubstArg (Blocked a) = SubstArg a+  applySubst rho b = fmap (applySubst rho) b++instance Subst DisplayForm where+  type SubstArg DisplayForm = Term+  applySubst rho (Display n ps v) =+    Display n (applySubst (liftS n rho) ps)+              (applySubst (liftS n rho) v)++instance Subst DisplayTerm where+  type SubstArg DisplayTerm = Term+  applySubst rho (DTerm' v es)      = DTerm' (applySubst rho v) $ applySubst rho es+  applySubst rho (DDot' v es)       = DDot'  (applySubst rho v) $ applySubst rho es+  applySubst rho (DCon c ci vs)     = DCon c ci $ applySubst rho vs+  applySubst rho (DDef c es)        = DDef c $ applySubst rho es+  applySubst rho (DWithApp v vs es) = uncurry3 DWithApp $ applySubst rho (v, vs, es)++instance Subst a => Subst (Tele a) where+  type SubstArg (Tele a) = SubstArg a+  applySubst rho  EmptyTel         = EmptyTel+  applySubst rho (ExtendTel t tel) = uncurry ExtendTel $ applySubst rho (t, tel)++instance Subst Constraint where+  type SubstArg Constraint = Term++  applySubst rho = \case+    ValueCmp cmp a u v       -> ValueCmp cmp (rf a) (rf u) (rf v)+    ValueCmpOnFace cmp p t u v -> ValueCmpOnFace cmp (rf p) (rf t) (rf u) (rf v)+    ElimCmp ps fs a v e1 e2  -> ElimCmp ps fs (rf a) (rf v) (rf e1) (rf e2)+    SortCmp cmp s1 s2        -> SortCmp cmp (rf s1) (rf s2)+    LevelCmp cmp l1 l2       -> LevelCmp cmp (rf l1) (rf l2)+    IsEmpty r a              -> IsEmpty r (rf a)+    CheckSizeLtSat t         -> CheckSizeLtSat (rf t)+    FindInstance r m cands   -> FindInstance r m (rf cands)+    ResolveInstanceHead q    -> ResolveInstanceHead (rf q)+    c@UnBlock{}              -> c+    c@CheckFunDef{}          -> c+    HasBiggerSort s          -> HasBiggerSort (rf s)+    HasPTSRule a s           -> HasPTSRule (rf a) (rf s)+    CheckLockedVars a b c d  -> CheckLockedVars (rf a) (rf b) (rf c) (rf d)+    UnquoteTactic t h g      -> UnquoteTactic (rf t) (rf h) (rf g)+    CheckDataSort q s        -> CheckDataSort q (rf s)+    CheckMetaInst m          -> CheckMetaInst m+    CheckType t              -> CheckType (rf t)+    UsableAtModality cc ms mod m -> UsableAtModality cc (rf ms) mod (rf m)+    where+      rf :: forall a. TermSubst a => a -> a+      rf x = applySubst rho x++instance Subst CompareAs where+  type SubstArg CompareAs = Term+  applySubst rho (AsTermsOf a) = AsTermsOf $ applySubst rho a+  applySubst rho AsSizes       = AsSizes+  applySubst rho AsTypes       = AsTypes++instance Subst a => Subst (Elim' a) where+  type SubstArg (Elim' a) = SubstArg a+  applySubst rho = \case+    Apply v      -> Apply $ applySubst rho v+    IApply x y r -> IApply (applySubst rho x) (applySubst rho y) (applySubst rho r)+    e@Proj{}     -> e++instance Subst a => Subst (Abs a) where+  type SubstArg (Abs a) = SubstArg a+  applySubst rho (Abs x a)   = Abs x $ applySubst (liftS 1 rho) a+  applySubst rho (NoAbs x a) = NoAbs x $ applySubst rho a++instance Subst a => Subst (Arg a) where+  type SubstArg (Arg a) = SubstArg a+  applySubst IdS arg = arg+  applySubst rho arg = setFreeVariables unknownFreeVariables $ fmap (applySubst rho) arg++instance Subst a => Subst (Named name a) where+  type SubstArg (Named name a) = SubstArg a+  applySubst rho = fmap (applySubst rho)++instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (Dom' a b) where+  type SubstArg (Dom' a b) = SubstArg a++  applySubst IdS dom = dom+  applySubst rho dom = setFreeVariables unknownFreeVariables $+    fmap (applySubst rho) dom{ domTactic = applySubst rho (domTactic dom) }+  {-# INLINABLE applySubst #-}++instance Subst LetBinding where+  type SubstArg LetBinding = Term+  applySubst rho (LetBinding o v t) = LetBinding o (applySubst rho v) (applySubst rho t)++instance Subst ContextEntry where+  type SubstArg ContextEntry = Term+  applySubst rho (CtxVar x a)   = CtxVar x $ applySubst rho a++instance Subst a => Subst (Maybe a) where+  type SubstArg (Maybe a) = SubstArg a++instance Subst a => Subst [a] where+  type SubstArg [a] = SubstArg a++instance Subst a => Subst (List1 a) where+  type SubstArg (List1 a) = SubstArg a++instance (Ord k, Subst a) => Subst (Map k a) where+  type SubstArg (Map k a) = SubstArg a++instance Subst a => Subst (Ranged a) where+  type SubstArg (Ranged a) = SubstArg a++instance Subst a => Subst (WithHiding a) where+  type SubstArg (WithHiding a) = SubstArg a++instance Subst () where+  type SubstArg () = Term+  applySubst _ _ = ()++instance (Subst a, Subst b, SubstArg a ~ SubstArg b) => Subst (a, b) where+  type SubstArg (a, b) = SubstArg a+  applySubst rho (x,y) = (applySubst rho x, applySubst rho y)++instance (Subst a, Subst b, Subst c, SubstArg a ~ SubstArg b, SubstArg b ~ SubstArg c) => Subst (a, b, c) where+  type SubstArg (a, b, c) = SubstArg a+  applySubst rho (x,y,z) = (applySubst rho x, applySubst rho y, applySubst rho z)++instance+  ( Subst a, Subst b, Subst c, Subst d+  , SubstArg a ~ SubstArg b+  , SubstArg b ~ SubstArg c+  , SubstArg c ~ SubstArg d+  ) => Subst (a, b, c, d) where+  type SubstArg (a, b, c, d) = SubstArg a+  applySubst rho (x,y,z,u) = (applySubst rho x, applySubst rho y, applySubst rho z, applySubst rho u)++instance Subst Candidate where+  type SubstArg Candidate = Term+  applySubst rho (Candidate q u t ov) = Candidate q (applySubst rho u) (applySubst rho t) ov++instance Subst EqualityView where+  type SubstArg EqualityView = Term+  applySubst rho = \case+    OtherType t          -> OtherType $ applySubst rho t+    IdiomType t          -> IdiomType $ applySubst rho t+    EqualityViewType eqt -> EqualityViewType $ applySubst rho eqt++instance Subst EqualityTypeData where+  type SubstArg EqualityTypeData = Term+  applySubst rho (EqualityTypeData r s eq l t a b) = EqualityTypeData r+    (applySubst rho s)+    eq+    (map (applySubst rho) l)+    (applySubst rho t)+    (applySubst rho a)+    (applySubst rho b)++instance DeBruijn a => DeBruijn (Pattern' a) where+  deBruijnNamedVar n i             = varP $ deBruijnNamedVar n i+  -- deBruijnView returns Nothing, to prevent consS and the like+  -- from dropping the names and origins when building a substitution.+  deBruijnView _                   = Nothing++fromPatternSubstitution :: PatternSubstitution -> Substitution+fromPatternSubstitution = fmap patternToTerm++applyPatSubst :: TermSubst a => PatternSubstitution -> a -> a+applyPatSubst = applySubst . fromPatternSubstitution+++usePatOrigin :: PatOrigin -> Pattern' a -> Pattern' a+usePatOrigin o p = case patternInfo p of+  Nothing -> p+  Just i  -> usePatternInfo (i { patOrigin = o }) p++usePatternInfo :: PatternInfo -> Pattern' a -> Pattern' a+usePatternInfo i p = case patternOrigin p of+  Nothing         -> p+  Just PatOSplit  -> p+  Just PatOAbsurd -> p+  Just _          -> case p of+    (VarP _ x) -> VarP i x+    (DotP _ u) -> DotP i u+    (ConP c (ConPatternInfo _ r ft b l) ps)+      -> ConP c (ConPatternInfo i r ft b l) ps+    DefP _ q ps -> DefP i q ps+    (LitP _ l) -> LitP i l+    ProjP{} -> __IMPOSSIBLE__+    (IApplyP _ t u x) -> IApplyP i t u x++instance Subst DeBruijnPattern where+  type SubstArg DeBruijnPattern = DeBruijnPattern+  applySubst IdS = id+  applySubst rho = \case+    VarP i x     ->+      usePatternInfo i $+      useName (dbPatVarName x) $+      lookupS rho $ dbPatVarIndex x+    DotP i u     -> DotP i $ applyPatSubst rho u+    ConP c ci ps -> ConP c ci {conPType = applyPatSubst rho (conPType ci)} $ applySubst rho ps+    DefP i q ps  -> DefP i q $ applySubst rho ps+    p@(LitP _ _) -> p+    p@ProjP{}    -> p+    IApplyP i t u x ->+      case useName (dbPatVarName x) $ lookupS rho $ dbPatVarIndex x of+        IApplyP _ _ _ y -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y+        VarP  _ y       -> IApplyP i (applyPatSubst rho t) (applyPatSubst rho u) y+        _ -> __IMPOSSIBLE__+    where+      useName :: PatVarName -> DeBruijnPattern -> DeBruijnPattern+      useName n (VarP o x)+        | isUnderscore (dbPatVarName x)+        = VarP o $ x { dbPatVarName = n }+      useName _ x = x++instance Subst Range where+  type SubstArg Range = Term+  applySubst _ = id++---------------------------------------------------------------------------+-- * Projections+---------------------------------------------------------------------------++-- | @projDropParsApply proj o args = 'projDropPars' proj o `'apply'` args@+--+--   This function is an optimization, saving us from construction lambdas we+--   immediately remove through application.+projDropParsApply :: Projection -> ProjOrigin -> Relevance -> Args -> Term+projDropParsApply (Projection prop d r _ lams) o rel args =+  case initLast $ getProjLams lams of+    -- If we have no more abstractions, we must be a record field+    -- (projection applied already to record value).+    Nothing -> if proper then Def d $ map Apply args else __IMPOSSIBLE__+    Just (pars, Arg i y) ->+      let irr = isIrrelevant rel+          core+            | proper && not irr = Lam i $ Abs y $ Var 0 [Proj o d]+            | otherwise         = Lam i $ Abs y $ Def d [Apply $ Var 0 [] <$ r]+            -- Issue2226: get ArgInfo for principal argument from projFromType+      -- Now drop pars many args+          (pars', args') = dropCommon pars args+      -- We only have to abstract over the parameters that exceed the arguments.+      -- We only have to apply to the arguments that exceed the parameters.+      in List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (core `apply` args') pars'+  where proper = isJust prop++---------------------------------------------------------------------------+-- * Telescopes+---------------------------------------------------------------------------++-- ** Telescope view of a type++type TelView = TelV Type+data TelV a  = TelV { theTel :: Tele (Dom a), theCore :: a }+  deriving (Show, Functor)++deriving instance (TermSubst a, Eq  a) => Eq  (TelV a)+deriving instance (TermSubst a, Ord a) => Ord (TelV a)++-- | Takes off all exposed function domains from the given type.+--   This means that it does not reduce to expose @Pi@-types.+telView' :: Type -> TelView+telView' = telView'UpTo (-1)++-- | @telView'UpTo n t@ takes off the first @n@ exposed function types of @t@.+-- Takes off all (exposed ones) if @n < 0@.+telView'UpTo :: Int -> Type -> TelView+telView'UpTo 0 t = TelV EmptyTel t+telView'UpTo n t = case unEl t of+  Pi a b  -> absV a (absName b) $ telView'UpTo (n - 1) (absBody b)+  _       -> TelV EmptyTel t++-- | Add given binding to the front of the telescope.+absV :: Dom a -> ArgName -> TelV a -> TelV a+absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t+++-- ** Creating telescopes from lists of types++-- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.+bindsToTel' :: (Name -> a) -> [Name] -> Dom Type -> ListTel' a+bindsToTel' f []     t = []+bindsToTel' f (x:xs) t = fmap (f x,) t : bindsToTel' f xs (raise 1 t)++bindsToTel :: [Name] -> Dom Type -> ListTel+bindsToTel = bindsToTel' nameToArgName++bindsToTel'1 :: (Name -> a) -> List1 Name -> Dom Type -> ListTel' a+bindsToTel'1 f = bindsToTel' f . List1.toList++bindsToTel1 :: List1 Name -> Dom Type -> ListTel+bindsToTel1 = bindsToTel . List1.toList++-- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.+namedBindsToTel :: [NamedArg Name] -> Type -> Telescope+namedBindsToTel []       t = EmptyTel+namedBindsToTel (x : xs) t =+  ExtendTel (t <$ domFromNamedArgName x) $ Abs (nameToArgName $ namedArg x) $ namedBindsToTel xs (raise 1 t)++namedBindsToTel1 :: List1 (NamedArg Name) -> Type -> Telescope+namedBindsToTel1 = namedBindsToTel . List1.toList++domFromNamedArgName :: NamedArg Name -> Dom ()+domFromNamedArgName x = () <$ domFromNamedArg (fmap forceName x)+  where+    -- If no explicit name is given we use the bound name for the label.+    forceName (Named Nothing x) = Named (Just $ WithOrigin Inserted $ Ranged (getRange x) $ nameToArgName x) x+    forceName x = x++-- ** Abstracting in terms and types++mkPiSort :: Dom Type -> Abs Type -> Sort+mkPiSort a b = piSort (unEl <$> a) (getSort $ unDom a) (getSort <$> b)++-- | @mkPi dom t = telePi (telFromList [dom]) t@+mkPi :: Dom (ArgName, Type) -> Type -> Type+mkPi !dom b = el $ Pi a (mkAbs x b)+  where+    x = fst $ unDom dom+    a = snd <$> dom+    el = El $ mkPiSort a (Abs x b)++mkLam :: Arg ArgName -> Term -> Term+mkLam a v = Lam (argInfo a) (Abs (unArg a) v)++lamView :: Term -> ([Arg ArgName], Term)+lamView (Lam h (Abs   x b)) = first (Arg h x :) $ lamView b+lamView (Lam h (NoAbs x b)) = first (Arg h x :) $ lamView (raise 1 b)+lamView t                   = ([], t)++unlamView :: [Arg ArgName] -> Term -> Term+unlamView xs b = foldr mkLam b xs++telePi' :: (Abs Type -> Abs Type) -> Telescope -> Type -> Type+telePi' reAbs = telePi where+  telePi EmptyTel          t = t+  telePi (ExtendTel u tel) t = el $ Pi u $ reAbs b+    where+      b  = (`telePi` t) <$> tel+      el = El $ mkPiSort u b++-- | Uses free variable analysis to introduce 'NoAbs' bindings.+telePi :: Telescope -> Type -> Type+telePi = telePi' reAbs++-- | Everything will be an 'Abs'.+telePi_ :: Telescope -> Type -> Type+telePi_ = telePi' id++-- | Only abstract the visible components of the telescope,+--   and all that bind variables.  Everything will be an 'Abs'!+-- Caution: quadratic time!++telePiVisible :: Telescope -> Type -> Type+telePiVisible EmptyTel t = t+telePiVisible (ExtendTel u tel) t+    -- If u is not declared visible and b can be strengthened, skip quantification of u.+    | notVisible u, NoAbs x t' <- b' = t'+    -- Otherwise, include quantification over u.+    | otherwise = El (mkPiSort u b) $ Pi u b+  where+    b  = tel <&> (`telePiVisible` t)+    b' = reAbs b++-- | Abstract over a telescope in a term, producing lambdas.+--   Dumb abstraction: Always produces 'Abs', never 'NoAbs'.+--+--   The implementation is sound because 'Telescope' does not use 'NoAbs'.+teleLam :: Telescope -> Term -> Term+teleLam  EmptyTel         t = t+teleLam (ExtendTel u tel) t = Lam (domInfo u) $ flip teleLam t <$> tel++-- | Performs void ('noAbs') abstraction over telescope.+class TeleNoAbs a where+  teleNoAbs :: a -> Term -> Term++instance TeleNoAbs ListTel where+  teleNoAbs tel t = foldr (\ Dom{domInfo = ai, unDom = (x, _)} -> Lam ai . NoAbs x) t tel++instance TeleNoAbs Telescope where+  teleNoAbs tel = teleNoAbs $ telToList tel+++-- ** Telescope typing++-- | Given arguments @vs : tel@ (vector typing), extract their individual types.+--   Returns @Nothing@ is @tel@ is not long enough.++typeArgsWithTel :: Telescope -> [Term] -> Maybe [Dom Type]+typeArgsWithTel _ []                         = return []+typeArgsWithTel (ExtendTel dom tel) (v : vs) = (dom :) <$> typeArgsWithTel (absApp tel v) vs+typeArgsWithTel EmptyTel{} (_:_)             = Nothing++---------------------------------------------------------------------------+-- * Clauses+---------------------------------------------------------------------------++-- | In compiled clauses, the variables in the clause body are relative to the+--   pattern variables (including dot patterns) instead of the clause telescope.+compiledClauseBody :: Clause -> Maybe Term+compiledClauseBody cl = applySubst (renamingR perm) $ clauseBody cl+  where perm = fromMaybe __IMPOSSIBLE__ $ clausePerm cl++---------------------------------------------------------------------------+-- * Syntactic equality and order+--+-- Needs weakening.+---------------------------------------------------------------------------++deriving instance Eq Substitution+deriving instance Ord Substitution++deriving instance Eq Sort+deriving instance Ord Sort+deriving instance Eq Level+deriving instance Ord Level+deriving instance Eq PlusLevel+deriving instance Eq NotBlocked+deriving instance Eq t => Eq (Blocked t)+deriving instance Eq CandidateKind+deriving instance Eq Candidate+deriving instance Ord CandidateKind+deriving instance Ord Candidate++deriving instance (Subst a, Eq a)  => Eq  (Tele a)+deriving instance (Subst a, Ord a) => Ord (Tele a)++-- Andreas, 2019-11-16, issue #4201: to avoid potential unintended+-- performance loss, the Eq instance for Constraint is disabled:+--+-- -- deriving instance Eq Constraint+--+-- I am tempted to write+--+--   instance Eq Constraint where (==) = undefined+--+-- but this does not give a compilation error anymore when trying+-- to use equality on constraints.+-- Therefore, I hope this comment is sufficient to prevent a resurrection+-- of the Eq instance for Constraint.++deriving instance Eq Section++instance Ord PlusLevel where+  -- Compare on the atom first. Makes most sense for levelMax.+  compare (Plus n a) (Plus m b) = compare (a,n) (b,m)++-- | Syntactic 'Type' equality, ignores sort annotations.+instance Eq a => Eq (Type' a) where+  (==) = (==) `on` unEl++instance Ord a => Ord (Type' a) where+  compare = compare `on` unEl++-- | Syntactic 'Term' equality, ignores stuff below @DontCare@ and sharing.+instance Eq Term where+  Var x vs   == Var x' vs'   = x == x' && vs == vs'+  Lam h v    == Lam h' v'    = h == h' && v  == v'+  Lit l      == Lit l'       = l == l'+  Def x vs   == Def x' vs'   = x == x' && vs == vs'+  Con x _ vs == Con x' _ vs' = x == x' && vs == vs'+  Pi a b     == Pi a' b'     = a == a' && b == b'+  Sort s     == Sort s'      = s == s'+  Level l    == Level l'     = l == l'+  MetaV m vs == MetaV m' vs' = m == m' && vs == vs'+  DontCare _ == DontCare _   = True+  Dummy{}    == Dummy{}      = True+  _          == _            = False++instance Eq a => Eq (Pattern' a) where+  VarP _ x        == VarP _ y          = x == y+  DotP _ u        == DotP _ v          = u == v+  ConP c _ ps     == ConP c' _ qs      = c == c && ps == qs+  LitP _ l        == LitP _ l'         = l == l'+  ProjP _ f       == ProjP _ g         = f == g+  IApplyP _ u v x == IApplyP _ u' v' y = u == u' && v == v' && x == y+  DefP _ f ps     == DefP _ g qs       = f == g && ps == qs+  _               == _                 = False++instance Ord Term where+  Var a b    `compare` Var x y    = compare (x, b) (a, y)+                                    -- sort de Bruijn indices down (#2765)+  Var{}      `compare` _          = LT+  _          `compare` Var{}      = GT+  Def a b    `compare` Def x y    = compare (a, b) (x, y)+  Def{}      `compare` _          = LT+  _          `compare` Def{}      = GT+  Con a _ b  `compare` Con x _ y  = compare (a, b) (x, y)+  Con{}      `compare` _          = LT+  _          `compare` Con{}      = GT+  Lit a      `compare` Lit x      = compare a x+  Lit{}      `compare` _          = LT+  _          `compare` Lit{}      = GT+  Lam a b    `compare` Lam x y    = compare (a, b) (x, y)+  Lam{}      `compare` _          = LT+  _          `compare` Lam{}      = GT+  Pi a b     `compare` Pi x y     = compare (a, b) (x, y)+  Pi{}       `compare` _          = LT+  _          `compare` Pi{}       = GT+  Sort a     `compare` Sort x     = compare a x+  Sort{}     `compare` _          = LT+  _          `compare` Sort{}     = GT+  Level a    `compare` Level x    = compare a x+  Level{}    `compare` _          = LT+  _          `compare` Level{}    = GT+  MetaV a b  `compare` MetaV x y  = compare (a, b) (x, y)+  MetaV{}    `compare` _          = LT+  _          `compare` MetaV{}    = GT+  DontCare{} `compare` DontCare{} = EQ+  DontCare{} `compare` _          = LT+  _          `compare` DontCare{} = GT+  Dummy{}    `compare` Dummy{}    = EQ++-- Andreas, 2017-10-04, issue #2775, ignore irrelevant arguments during with-abstraction.+--+-- For reasons beyond my comprehension, the following Eq instances are not employed+-- by with-abstraction in TypeChecking.Abstract.isPrefixOf.+-- Instead, I modified the general Eq instance for Arg to ignore the argument+-- if irrelevant.++-- -- | Ignore irrelevant arguments in equality check.+-- --   Also ignore origin.+-- instance {-# OVERLAPPING #-} Eq (Arg Term) where+--   a@(Arg (ArgInfo h r _o) t) == a'@(Arg (ArgInfo h' r' _o') t') = trace ("Eq (Arg Term) on " ++ show a ++ " and " ++ show a') $+--     h == h' && ((r == Irrelevant) || (r' == Irrelevant) || (t == t'))+--     -- Andreas, 2017-10-04: According to Syntax.Common, equality on Arg ignores Relevance and Origin.++-- instance {-# OVERLAPPING #-} Eq Args where+--   us == vs = length us == length vs && and (zipWith (==) us vs)++-- instance {-# OVERLAPPING #-} Eq Elims where+--   us == vs = length us == length vs && and (zipWith (==) us vs)++-- | Equality of binders relies on weakening+--   which is a special case of renaming+--   which is a special case of substitution.+instance (Subst a, Eq a) => Eq (Abs a) where+  NoAbs _ a == NoAbs _ b = a == b  -- no need to raise if both are NoAbs+  a         == b         = absBody a == absBody b++instance (Subst a, Ord a) => Ord (Abs a) where+  NoAbs _ a `compare` NoAbs _ b = a `compare` b  -- no need to raise if both are NoAbs+  a         `compare` b         = absBody a `compare` absBody b++deriving instance Ord a => Ord (Dom a)++instance (Subst a, Eq a)  => Eq  (Elim' a) where+  Apply  a == Apply  b = a == b+  Proj _ x == Proj _ y = x == y+  IApply x y r == IApply x' y' r' = x == x' && y == y' && r == r'+  _ == _ = False++instance (Subst a, Ord a) => Ord (Elim' a) where+  Apply  a `compare` Apply  b = a `compare` b+  Proj _ x `compare` Proj _ y = x `compare` y+  IApply x y r `compare` IApply x' y' r' = compare x x' `mappend` compare y y' `mappend` compare r r'+  Apply{}  `compare` _        = LT+  _        `compare` Apply{}  = GT+  Proj{}   `compare` _        = LT+  _        `compare` Proj{}   = GT+++---------------------------------------------------------------------------+-- * Sort stuff+---------------------------------------------------------------------------++-- | @univSort' univInf s@ gets the next higher sort of @s@, if it is+--   known (i.e. it is not just @UnivSort s@).+--+--   Precondition: @s@ is reduced+univSort' :: Sort -> Either Blocker Sort+univSort' (Univ u l)   = Right $ Univ (univUniv u) $ levelSuc l+univSort' (Inf u n)    = Right $ Inf (univUniv u) $ 1 + n+univSort' SizeUniv     = Right $ Inf UType 0+univSort' LockUniv     = Right $ Type $ ClosedLevel 1+univSort' LevelUniv    = Right $ Type $ ClosedLevel 1+univSort' IntervalUniv = Right $ SSet $ ClosedLevel 1+univSort' (MetaS m _)  = Left neverUnblock+univSort' FunSort{}    = Left neverUnblock+univSort' PiSort{}     = Left neverUnblock+univSort' UnivSort{}   = Left neverUnblock+univSort' DefS{}       = Left neverUnblock+univSort' DummyS{}     = Left neverUnblock++univSort :: Sort -> Sort+univSort s = fromRight (const $ UnivSort s) $ univSort' s++sort :: Sort -> Type+sort s = El (univSort s) $ Sort s++ssort :: Level -> Type+ssort l = sort (SSet l)++-- | A sort can either be small (Set l, Prop l, Size, ...)  or large+--   (Setω n).+data SizeOfSort = SizeOfSort+  { szSortUniv :: Univ+  , szSortSize :: Integer+  }++pattern SmallSort :: Univ -> SizeOfSort+pattern SmallSort u = SizeOfSort u (-1)++pattern LargeSort :: Univ -> Integer -> SizeOfSort+-- What I want to write here is:+-- @+--   pattern LargeSort u n = SizeOfSort u n | n >= 0+-- @+-- But I have to write:+pattern LargeSort u n <- ((\ x@(SizeOfSort u n) -> guard (n >= 0) $> x) -> Just (SizeOfSort u n))+-- DON'T WORK:+-- pattern LargeSort u n <- (n >= 0 -> True)+-- pattern LargeSort u n <- (n >= 0 -> SizeOfSort u n)+-- pattern LargeSort u n <- ((>= 0) . szSortSize -> SizeOfSort u n)+  where LargeSort u n = SizeOfSort u n++{-# COMPLETE SmallSort, LargeSort #-}++-- | Returns @Left blocker@ for unknown (blocked) sorts, and otherwise+--   returns @Right s@ where @s@ indicates the size and fibrancy.+sizeOfSort :: Sort -> Either Blocker SizeOfSort+sizeOfSort = \case+  Univ u _     -> Right $ SmallSort u+  SizeUniv     -> Right $ SmallSort UType+  LockUniv     -> Right $ SmallSort UType+  LevelUniv    -> Right $ SmallSort UType+  IntervalUniv -> Right $ SmallSort USSet+  Inf u n      -> Right $ LargeSort u n+  MetaS m _    -> Left $ unblockOnMeta m+  FunSort{}    -> Left neverUnblock+  PiSort{}     -> Left neverUnblock+  UnivSort{}   -> Left neverUnblock+  DefS{}       -> Left neverUnblock+  DummyS{}     -> Left neverUnblock++isSmallSort :: Sort -> Bool+isSmallSort s = case sizeOfSort s of+  Right SmallSort{} -> True+  _                 -> False++-- | Compute the sort of a function type from the sorts of its domain and codomain.+--+--   This function should only be called on reduced sorts,+--   since the @LevelUniv@ rules should only apply when the sort does not reduce to @Set@.+funSort' :: Sort -> Sort -> Either Blocker Sort+-- Andreas, 2023-05-12, AIM XXXVI, pri #6623:+-- On GHC 8.6 and 8.8 this pattern matching triggers warning+-- "Pattern match checker exceeded (2000000) iterations in a case alternative."+-- No clue how to turn off this warning, so we have to turn off -Werror for GHC < 8.10.+funSort' = curry \case+  (Univ u a      , Univ u' b    ) -> Right $ Univ (funUniv u u') $ levelLub a b+  (Inf ua m      , b            ) -> sizeOfSort b <&> \ (SizeOfSort ub n) -> Inf (funUniv ua ub) (max m n)+  (a             , Inf ub n     ) -> sizeOfSort a <&> \ (SizeOfSort ua m) -> Inf (funUniv ua ub) (max m n)+  (LockUniv      , LevelUniv    ) -> Left neverUnblock+  (LockUniv      , b            ) -> Right b+  -- No functions into lock types+  (a             , LockUniv     ) -> Left neverUnblock+  -- @IntervalUniv@ behaves like @SSet@, but functions into @Type@ land in @Type@+  (IntervalUniv  , IntervalUniv ) -> Right $ SSet $ ClosedLevel 0+  (IntervalUniv  , Univ u b     ) -> Right $ Univ u b+  (IntervalUniv  , _            ) -> Left neverUnblock+  (Univ u a      , IntervalUniv ) -> Right $ SSet $ a+  (_             , IntervalUniv ) -> Left neverUnblock+  (SizeUniv      , b            ) -> Right b+  (a             , SizeUniv     ) -> sizeOfSort a >>= \case+    SmallSort{} -> Right SizeUniv+    LargeSort{} -> Left neverUnblock+  -- No need to handle @LevelUniv@ in a special way here when --level-universe isn't on,+  -- since this function is currently always called after reduction.+  -- It would be safer to take it into account here, but would imply passing the option along as an argument.+  (LevelUniv     , LevelUniv    ) -> Right LevelUniv+  (_             , LevelUniv    ) -> Left neverUnblock+  (LevelUniv     , b            ) -> sizeOfSort b <&> \case+    SmallSort ub -> Inf ub 0+    LargeSort{}  -> b+  (MetaS m _     , _            ) -> Left $ unblockOnMeta m+  (_             , MetaS m _    ) -> Left $ unblockOnMeta m+  (FunSort{}     , _            ) -> Left neverUnblock+  (_             , FunSort{}    ) -> Left neverUnblock+  (PiSort{}      , _            ) -> Left neverUnblock+  (_             , PiSort{}     ) -> Left neverUnblock+  (UnivSort{}    , _            ) -> Left neverUnblock+  (_             , UnivSort{}   ) -> Left neverUnblock+  (DefS{}        , _            ) -> Left neverUnblock+  (_             , DefS{}       ) -> Left neverUnblock+  (DummyS{}      , _            ) -> Left neverUnblock+  (_             , DummyS{}     ) -> Left neverUnblock++funSort :: Sort -> Sort -> Sort+funSort a b = fromRight (const $ FunSort a b) $ funSort' a b++-- | Compute the sort of a pi type from the sorts of its domain+--   and codomain.+-- This function should only be called on reduced sorts, since the @LevelUniv@ rules should only apply when the sort doesn't reduce to @Set@+piSort' :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort+piSort' a s1       (NoAbs _ s2) = Right $ FunSort s1 s2+piSort' a s1 s2Abs@(Abs   _ s2) = case flexRigOccurrenceIn 0 s2 of+  Nothing -> Right $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs+  Just o  -> case (sizeOfSort s1 , sizeOfSort s2) of+    (Right (SmallSort u1) , Right (SmallSort u2)) -> case o of+      StronglyRigid -> Right $ Inf (funUniv u1 u2) 0+      Unguarded     -> Right $ Inf (funUniv u1 u2) 0+      WeaklyRigid   -> Right $ Inf (funUniv u1 u2) 0+      Flexible ms   -> Left $ metaSetToBlocker ms+    (Right (LargeSort u1 n) , Right (SmallSort u2)) -> Right $ Inf (funUniv u1 u2) n+    (_                     , Right LargeSort{}    ) ->+       -- large sorts cannot depend on variables+       __IMPOSSIBLE__+       -- (`trace` __IMPOSSIBLE__) $ unlines+       --   [ "piSort': unexpected dependency in large codomain s2"+       --   , "- a  = " ++ prettyShow a+       --   , "- s1 = " ++ prettyShow s1+       --   , "- s2 = " ++ prettyShow s2+       --   , "- s2 (raw) = " ++ show s2+       --   ]+    (Left blocker          , Right _              ) -> Left blocker+    (Right _               , Left blocker         ) -> Left blocker+    (Left blocker1         , Left blocker2        ) -> Left $ unblockOnBoth blocker1 blocker2++-- Andreas, 2019-06-20+-- KEEP the following commented out code for the sake of the discussion on irrelevance.+-- piSort' a bAbs@(Abs   _ b) = case occurrence 0 b of+--     -- Andreas, Jesper, AIM XXIX, 2019-03-18, issue #3631+--     -- Remember the NoAbs here!+--     NoOccurrence  -> Just $ funSort a $ noabsApp __IMPOSSIBLE__ bAbs+--     -- Andreas, 2017-01-18, issue #2408:+--     -- The sort of @.(a : A) → Set (f a)@ in context @f : .A → Level@+--     -- is @dLub Set λ a → Set (lsuc (f a))@, but @DLub@s are not serialized.+--     -- Alternatives:+--     -- 1. -- Irrelevantly -> sLub s1 (absApp b $ DontCare $ Sort Prop)+--     --    We cheat here by simplifying the sort to @Set (lsuc (f *))@+--     --    where * is a dummy value.  The rationale is that @f * = f a@ (irrelevance!)+--     --    and that if we already have a neutral level @f a@+--     --    it should not hurt to have @f *@ even if type @A@ is empty.+--     --    However: sorts are printed in error messages when sorts do not match.+--     --    Also, sorts with a dummy like Prop would be ill-typed.+--     -- 2. We keep the DLub, and serialize it.+--     --    That's clean and principled, even though DLubs make level solving harder.+--     -- Jesper, 2018-04-20: another alternative:+--     -- 3. Return @Inf@ as in the relevant case. This is conservative and might result+--     --    in more occurrences of @Setω@ than desired, but at least it doesn't pollute+--     --    the sort system with new 'exotic' sorts.+--     Irrelevantly  -> Just Inf+--     StronglyRigid -> Just Inf+--     Unguarded     -> Just Inf+--     WeaklyRigid   -> Just Inf+--     Flexible _    -> Nothing++piSort :: Dom Term -> Sort -> Abs Sort -> Sort+piSort a s1 s2 = fromRight (const $ PiSort a s1 s2) $ piSort' a s1 s2++---------------------------------------------------------------------------+-- * Level stuff+---------------------------------------------------------------------------++-- ^ Computes @n0 ⊔ a₁ ⊔ a₂ ⊔ ... ⊔ aₙ@ and return its canonical form.+levelMax :: Integer -> [PlusLevel] -> Level+levelMax !n0 as0 = Max n as+  where+    -- step 1: flatten nested @Level@ expressions in @PlusLevel@s+    Max n1 as1 = expandLevel $ Max n0 as0+    -- step 2: remove subsumed @PlusLevel@s and sort what remains+    as        = removeSubsumed as1+    -- step 3: set constant to 0 if it is subsumed by one of the @PlusLevel@s+    greatestB = Prelude.maximum $ 0 : [ n | Plus n _ <- as ]+    n | n1 > greatestB = n1+      | otherwise      = 0++    lmax :: Integer -> [PlusLevel] -> [Level] -> Level+    lmax m as []              = Max m as+    lmax m as (Max n bs : ls) = lmax (max m n) (bs ++ as) ls++    expandLevel :: Level -> Level+    expandLevel (Max m as) = lmax m [] $ map expandPlus as++    expandPlus :: PlusLevel -> Level+    expandPlus (Plus m l) = levelPlus m (expandTm l)++    expandTm (Level l)       = expandLevel l+    expandTm l               = atomicLevel l++    removeSubsumed =+      map (\(a, n) -> Plus n a) .+      MapS.toAscList .+      MapS.fromListWith max .+      map (\(Plus n a) -> (a, n))++-- | Given two levels @a@ and @b@, compute @a ⊔ b@ and return its+--   canonical form.+levelLub :: Level -> Level -> Level+levelLub (Max m as) (Max n bs) = levelMax (max m n) $ as ++ bs++levelTm :: Level -> Term+levelTm l =+  case l of+    Max 0 [Plus 0 l] -> l+    _                -> Level l
src/full/Agda/TypeChecking/Substitute/Class.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Substitute.Class where  import Control.Arrow ((***), second)+import Control.DeepSeq+import GHC.Generics  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -10,9 +12,6 @@ import Agda.TypeChecking.Free import Agda.TypeChecking.Substitute.DeBruijn -import Agda.Utils.Empty--#include "undefined.h" import Agda.Utils.Impossible  ---------------------------------------------------------------------------@@ -26,7 +25,10 @@   applyE :: t -> Elims -> t    apply t args = applyE t $ map Apply args-  applyE t es  = apply  t $ map argFromElim es+  -- Andreas, 2018-06-18, issue #3136+  -- This default instance should be removed to get more precise+  -- crash locations (raise the IMPOSSIBLE in a more specific place).+  -- applyE t es  = apply  t $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es     -- precondition: all @es@ are @Apply@s  -- | Apply to some default arguments.@@ -37,6 +39,10 @@ apply1 :: Apply t => t -> Term -> t apply1 t u = applys t [ u ] +-- | Apply to two default arguments.+apply2 :: Apply t => t -> Term -> Term -> t+apply2 t u v = applys t [u, v]+ --------------------------------------------------------------------------- -- * Abstraction ---------------------------------------------------------------------------@@ -46,7 +52,7 @@   abstract :: Telescope -> t -> t  ------------------------------------------------------------------------------ * Substitution and raising/shifting/weakening+-- * Substitution and shifting\/weakening\/strengthening ---------------------------------------------------------------------------  -- | Apply a substitution.@@ -54,31 +60,71 @@ -- For terms: -- --  Γ ⊢ ρ : Δ---  Δ ⊢ t : σ+--  Δ ⊢ t : A -- -------------- Γ ⊢ tρ : σρ+-- Γ ⊢ tρ : Aρ -class DeBruijn t => Subst t a | a -> t where-  applySubst :: Substitution' t -> a -> a+class DeBruijn (SubstArg a) => Subst a where+  type SubstArg a+  applySubst :: Substitution' (SubstArg a) -> a -> a -raise :: Subst t a => Nat -> a -> a+  default applySubst :: (a ~ f b, Functor f, Subst b, SubstArg a ~ SubstArg b) => Substitution' (SubstArg a) -> a -> a+  applySubst rho = fmap (applySubst rho)++-- | Simple constraint alias for a `Subst` instance `a` with arg type `t`.+type SubstWith t a = (Subst a, SubstArg a ~ t)++-- | `Subst` instance whose agument type is itself+type EndoSubst a = SubstWith a a++-- | `Subst` instance whose argument type is `Term`+type TermSubst a = SubstWith Term a++-- | Raise de Bruijn index, i.e. weakening+raise :: Subst a => Nat -> a -> a raise = raiseFrom 0 -raiseFrom :: Subst t a => Nat -> Nat -> a -> a-raiseFrom n k = applySubst (liftS n $ raiseS k)+raiseFrom :: Subst a => Nat -> Nat -> a -> a+raiseFrom n k = applySubst (raiseFromS n k)  -- | Replace de Bruijn index i by a 'Term' in something.-subst :: Subst t a => Int -> t -> a -> a+subst :: Subst a => Int -> SubstArg a -> a -> a subst i u = applySubst $ singletonS i u -strengthen :: Subst t a => Empty -> a -> a-strengthen err = applySubst (compactS err [Nothing])+strengthen :: Subst a => Impossible -> a -> a+strengthen err = applySubst (strengthenS err 1)  -- | Replace what is now de Bruijn index 0, but go under n binders. --   @substUnder n u == subst n (raise n u)@.-substUnder :: Subst t a => Nat -> t -> a -> a+substUnder :: Subst a => Nat -> SubstArg a -> a -> a substUnder n u = applySubst (liftS n (singletonS 0 u)) +-- | Checks whether the variable bound by the abstraction is actually+-- used, and, if /not/, returns the term within, 'strengthen'ed to live in+-- the context /outside/ the abstraction.+-- See also 'Agda.TypeChecking.Free.isBinderUsed'.+isNoAbs :: (Free a, Subst a) => Abs a -> Maybe a+isNoAbs (NoAbs _ b) = Just b+isNoAbs (Abs _ b)+  | not (0 `freeIn` b) = Just (strengthen __IMPOSSIBLE__ b)+  | otherwise          = Nothing++-- ** Identity instances++instance Subst QName where+  type SubstArg QName = Term+  applySubst _ q = q++-- | Wrapper for types that do not contain variables (so applying a substitution is the identity).+--   Useful if you have a structure of types that support substitution mixed with types that don't+--   and need to apply a substitution to the full structure.+newtype NoSubst t a = NoSubst { unNoSubst :: a }+  deriving (Generic, NFData, Functor)++instance DeBruijn t => Subst (NoSubst t a) where+  type SubstArg (NoSubst t a) = t+  applySubst _ x = x+ --------------------------------------------------------------------------- -- * Explicit substitutions ---------------------------------------------------------------------------@@ -91,29 +137,41 @@ wkS :: Int -> Substitution' a -> Substitution' a wkS 0 rho        = rho wkS n (Wk m rho) = Wk (n + m) rho-wkS n EmptyS     = EmptyS+wkS n (EmptyS err) = EmptyS err wkS n rho        = Wk n rho  raiseS :: Int -> Substitution' a raiseS n = wkS n idS +{-# INLINABLE consS #-} consS :: DeBruijn a => a -> Substitution' a -> Substitution' a consS t (Wk m rho)   | Just n <- deBruijnView t,     n + 1 == m = wkS (m - 1) (liftS 1 rho) consS u rho = seq u (u :# rho)+{-# SPECIALIZE consS :: Term  -> Substitution' Term  -> Substitution' Term #-}+{-# SPECIALIZE consS :: Level -> Substitution' Level -> Substitution' Level #-} +{-# INLINABLE singletonS #-} -- | To replace index @n@ by term @u@, do @applySubst (singletonS n u)@.+--   @+--               Γ, Δ ⊢ u : A+--    ---------------------------------+--    Γ, Δ ⊢ singletonS |Δ| u : Γ, A, Δ+--   @ singletonS :: DeBruijn a => Int -> a -> Substitution' a singletonS n u = map deBruijnVar [0..n-1] ++# consS u (raiseS n)   -- ALT: foldl (\ s i -> deBruijnVar i `consS` s) (consS u $ raiseS n) $ downFrom n+{-# SPECIALIZE singletonS :: Int -> Term -> Substitution' Term #-}+{-# SPECIALIZE singletonS :: Int -> Level -> Substitution' Level #-}  -- | Single substitution without disturbing any deBruijn indices. --   @ --             Γ, A, Δ ⊢ u : A --    ------------------------------------   @Γ, A, Δ ⊢ inplace |Δ| u : Γ, A, Δ-inplaceS :: Subst a a => Int -> a -> Substitution' a+--    Γ, A, Δ ⊢ inplace |Δ| u : Γ, A, Δ+--   @+inplaceS :: EndoSubst a => Int -> a -> Substitution' a inplaceS k u = singletonS k u `composeS` liftS (k + 1) (raiseS 1)  -- | Lift a substitution under k binders.@@ -123,24 +181,35 @@ liftS k (Lift n rho) = Lift (n + k) rho liftS k rho          = Lift k rho +-- | @+--         Γ ⊢ ρ : Δ, Ψ+--      -------------------+--      Γ ⊢ dropS |Ψ| ρ : Δ+--   @ dropS :: Int -> Substitution' a -> Substitution' a dropS 0 rho                = rho dropS n IdS                = raiseS n dropS n (Wk m rho)         = wkS m (dropS n rho) dropS n (u :# rho)         = dropS (n - 1) rho-dropS n (Strengthen _ rho) = dropS (n - 1) rho-dropS n (Lift 0 rho)       = __IMPOSSIBLE__-dropS n (Lift m rho)       = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho-dropS n EmptyS             = __IMPOSSIBLE__+dropS n (EmptyS err)       = throwImpossible err+dropS n (Lift m rho)+  -- dropS n (Lift m rho) =+  --   wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho+  | n > m     = wkS m $ dropS (n - m) rho+  | otherwise = wkS n $ liftS (m - n) rho+dropS n (Strengthen err m rho)+  | n < m     = Strengthen err (m - n) rho+  | otherwise = dropS (n - m) rho +{-# INLINABLE composeS #-} -- | @applySubst (ρ `composeS` σ) v == applySubst ρ (applySubst σ v)@-composeS :: Subst a a => Substitution' a -> Substitution' a -> Substitution' a+composeS :: EndoSubst a => Substitution' a -> Substitution' a -> Substitution' a composeS rho IdS = rho composeS IdS sgm = sgm-composeS rho EmptyS = EmptyS+composeS rho (EmptyS err) = EmptyS err composeS rho (Wk n sgm) = composeS (dropS n rho) sgm composeS rho (u :# sgm) = applySubst rho u :# composeS rho sgm-composeS rho (Strengthen err sgm) = Strengthen err (composeS rho sgm)+composeS rho (Strengthen err n sgm) = Strengthen err n (composeS rho sgm) composeS rho (Lift 0 sgm) = __IMPOSSIBLE__ composeS (u :# rho) (Lift n sgm) = u :# composeS rho (liftS (n - 1) sgm) composeS rho (Lift n sgm) = lookupS rho 0 :# composeS rho (wkS 1 (liftS (n - 1) sgm))@@ -149,39 +218,78 @@ --   Γ ⊢ σ : Δ --   Γ ⊢ δ : Θσ splitS :: Int -> Substitution' a -> (Substitution' a, Substitution' a)-splitS 0 rho                  = (rho, EmptyS)-splitS n (u :# rho)           = second (u :#) $ splitS (n - 1) rho-splitS n (Strengthen err rho) = second (Strengthen err) $ splitS (n - 1) rho-splitS n (Lift 0 _)           = __IMPOSSIBLE__-splitS n (Wk m rho)           = wkS m *** wkS m $ splitS n rho-splitS n IdS                  = (raiseS n, liftS n EmptyS)-splitS n (Lift m rho)         = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho)-splitS n EmptyS               = __IMPOSSIBLE__+splitS 0 rho                    = (rho, EmptyS impossible)+splitS n (u :# rho)             = second (u :#) $ splitS (n - 1) rho+splitS n (Lift 0 _)             = __IMPOSSIBLE__+splitS n (Wk m rho)             = wkS m *** wkS m $ splitS n rho+splitS n IdS                    = ( raiseS n+                                  , liftS n $ EmptyS impossible+                                  )+splitS n (Lift m rho)           = wkS 1 *** liftS 1 $+                                  splitS (n - 1) (liftS (m - 1) rho)+splitS n (EmptyS err)           = __IMPOSSIBLE__+splitS n (Strengthen err m rho)+  -- splitS n (Strengthen err 1 rho) =+  --   second (Strengthen err) $ splitS (n - 1) rho+  | n > m     = second (Strengthen err m) $+                splitS (n - m) rho+  | otherwise = second (Strengthen err n) $+                splitS 0 (Strengthen err (m - n) rho)  infixr 4 ++#  (++#) :: DeBruijn a => [a] -> Substitution' a -> Substitution' a us ++# rho = foldr consS rho us -prependS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a -> Substitution' a-prependS err us rho = foldr f rho us+-- | @+--      Γ ⊢ ρ : Δ  Γ ⊢ reverse vs : Θ+--      ----------------------------- (treating Nothing as having any type)+--        Γ ⊢ prependS vs ρ : Δ, Θ+--   @+prependS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -> Substitution' a+prependS err us rho = go 0 us   where-    f Nothing  rho = Strengthen err rho-    f (Just u) rho = consS u rho+  -- The function strengthenS' is not used here, to avoid replacing+  -- the "error message" of a potential outermost Strengthen+  -- constructor in rho.+  str 0 = id+  str n = Strengthen err n +  go !n (Just u  : us) = str n (consS u (go 0 us))+  go  n (Nothing : us) = go (1 + n) us+  go  n []             = str n rho++-- | @+--        Γ ⊢ reverse vs : Δ+--      -----------------------------+--        Γ ⊢ parallelS vs ρ : Γ, Δ+--   @+--+--   Note the @Γ@ in @Γ, Δ@. parallelS :: DeBruijn a => [a] -> Substitution' a parallelS us = us ++# idS -compactS :: DeBruijn a => Empty -> [Maybe a] -> Substitution' a-compactS err us = prependS err us idS- -- | Γ ⊢ (strengthenS ⊥ |Δ|) : Γ,Δ-strengthenS :: Empty -> Int -> Substitution' a-strengthenS err n-  | n < 0     = __IMPOSSIBLE__-  | otherwise = iterate (Strengthen err) idS !! n+strengthenS :: Impossible -> Int -> Substitution' a+strengthenS err n = case compare n 0 of+  LT -> __IMPOSSIBLE__+  EQ -> idS+  GT -> Strengthen err n idS -lookupS :: Subst a a => Substitution' a -> Nat -> a+-- | A \"smart\" variant of 'Strengthen'. If 'strengthenS' is applied+-- to a substitution with an outermost 'Strengthen' constructor, then+-- the \"error message\" of that constructor is discarded in favour of+-- the 'Impossible' argument of this function.+strengthenS' :: Impossible -> Int -> Substitution' a -> Substitution' a+strengthenS' err m rho = case compare m 0 of+  LT -> __IMPOSSIBLE__+  EQ -> rho+  GT -> case rho of+    Strengthen _ n rho -> Strengthen err (m + n) rho+    _                  -> Strengthen err m       rho++{-# INLINABLE lookupS #-}+lookupS :: EndoSubst a => Substitution' a -> Nat -> a lookupS rho i = case rho of   IdS                    -> deBruijnVar i   Wk n IdS               -> let j = i + n in@@ -190,67 +298,57 @@   u :# rho   | i == 0    -> u              | i < 0     -> __IMPOSSIBLE__              | otherwise -> lookupS rho (i - 1)-  Strengthen err rho-             | i == 0    -> absurd err+  Strengthen err n rho              | i < 0     -> __IMPOSSIBLE__-             | otherwise -> lookupS rho (i - 1)+             | i < n     -> throwImpossible err+             | otherwise -> lookupS rho (i - n)   Lift n rho | i < n     -> deBruijnVar i              | otherwise -> raise n $ lookupS rho (i - n)-  EmptyS                 -> __IMPOSSIBLE__+  EmptyS err             -> throwImpossible err ++-- | lookupS (listS [(x0,t0)..(xn,tn)]) xi = ti, assuming x0 < .. < xn.+++listS :: EndoSubst a => [(Int,a)] -> Substitution' a+listS ((i,t):ts) = singletonS i t `composeS` listS ts+listS []         = IdS++-- | @Γ, Ξ, Δ ⊢ raiseFromS |Δ| |Ξ| : Γ, Δ@+raiseFromS :: Nat -> Nat -> Substitution' a+raiseFromS n k = liftS n $ raiseS k++ --------------------------------------------------------------------------- -- * Functions on abstractions --   and things we couldn't do before we could define 'absBody' ---------------------------------------------------------------------------  -- | Instantiate an abstraction. Strict in the term.-absApp :: Subst t a => Abs a -> t -> a+absApp :: Subst a => Abs a -> SubstArg a -> a absApp (Abs   _ v) u = subst 0 u v absApp (NoAbs _ v) _ = v  -- | Instantiate an abstraction. Lazy in the term, which allow it to be --   __IMPOSSIBLE__ in the case where the variable shouldn't be used but we --   cannot use 'noabsApp'. Used in Apply.-lazyAbsApp :: Subst t a => Abs a -> t -> a+lazyAbsApp :: Subst a => Abs a -> SubstArg a -> a lazyAbsApp (Abs   _ v) u = applySubst (u :# IdS) v  -- Note: do not use consS here! lazyAbsApp (NoAbs _ v) _ = v  -- | Instantiate an abstraction that doesn't use its argument.-noabsApp :: Subst t a => Empty -> Abs a -> a+noabsApp :: Subst a => Impossible -> Abs a -> a noabsApp err (Abs   _ v) = strengthen err v noabsApp _   (NoAbs _ v) = v -absBody :: Subst t a => Abs a -> a+absBody :: Subst a => Abs a -> a absBody (Abs   _ v) = v absBody (NoAbs _ v) = raise 1 v -mkAbs :: (Subst t a, Free a) => ArgName -> a -> Abs a+mkAbs :: (Subst a, Free a) => ArgName -> a -> Abs a mkAbs x v | 0 `freeIn` v = Abs x v           | otherwise    = NoAbs x (raise (-1) v) -reAbs :: (Subst t a, Free a) => Abs a -> Abs a+reAbs :: (Subst a, Free a) => Abs a -> Abs a reAbs (NoAbs x v) = NoAbs x v reAbs (Abs x v)   = mkAbs x v---- | @underAbs k a b@ applies @k@ to @a@ and the content of---   abstraction @b@ and puts the abstraction back.---   @a@ is raised if abstraction was proper such that---   at point of application of @k@ and the content of @b@---   are at the same context.---   Precondition: @a@ and @b@ are at the same context at call time.-underAbs :: Subst t a => (a -> b -> b) -> a -> Abs b -> Abs b-underAbs cont a b = case b of-  Abs   x t -> Abs   x $ cont (raise 1 a) t-  NoAbs x t -> NoAbs x $ cont a t---- | @underLambdas n k a b@ drops @n@ initial 'Lam's from @b@,---   performs operation @k@ on @a@ and the body of @b@,---   and puts the 'Lam's back.  @a@ is raised correctly---   according to the number of abstractions.-underLambdas :: Subst Term a => Int -> (a -> Term -> Term) -> a -> Term -> Term-underLambdas n cont a v = loop n a v where-  loop 0 a v = cont a v-  loop n a v = case ignoreSharing v of-    Lam h b -> Lam h $ underAbs (loop $ n-1) a b-    _       -> __IMPOSSIBLE__-
src/full/Agda/TypeChecking/Substitute/DeBruijn.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Substitute.DeBruijn where @@ -10,34 +11,27 @@    -- | Produce a variable without name suggestion.   deBruijnVar  :: Int -> a-  deBruijnVar = debruijnNamedVar underscore+  deBruijnVar = deBruijnNamedVar underscore    -- | Produce a variable with name suggestion.-  debruijnNamedVar :: String -> Int -> a-  debruijnNamedVar _ = deBruijnVar+  deBruijnNamedVar :: String -> Int -> a+  deBruijnNamedVar _ = deBruijnVar    -- | Are we dealing with a variable?   --   If yes, what is its index?   deBruijnView :: a -> Maybe Int +  {-# MINIMAL (deBruijnVar | deBruijnNamedVar) , deBruijnView #-}+ -- | We can substitute @Term@s for variables. instance DeBruijn Term where   deBruijnVar = var   deBruijnView u =-    case ignoreSharing u of+    case u of       Var i [] -> Just i       Level l -> deBruijnView l       _ -> Nothing -instance DeBruijn LevelAtom where-  deBruijnVar = NeutralLevel ReallyNotBlocked . deBruijnVar-  deBruijnView l =-    case l of-      NeutralLevel _ u -> deBruijnView u-      UnreducedLevel u -> deBruijnView u-      MetaLevel{}    -> Nothing-      BlockedLevel{} -> Nothing- instance DeBruijn PlusLevel where   deBruijnVar = Plus 0 . deBruijnVar   deBruijnView l =@@ -46,9 +40,17 @@       _ -> Nothing  instance DeBruijn Level where-  deBruijnVar i = Max [deBruijnVar i]+  deBruijnVar i = Max 0 [deBruijnVar i]   deBruijnView l =     case l of-      Max [p] -> deBruijnView p+      Max 0 [p] -> deBruijnView p       _ -> Nothing +instance DeBruijn DBPatVar where+  deBruijnNamedVar = DBPatVar+  deBruijnView = Just . dbPatVarIndex+++instance DeBruijn a => DeBruijn (Named_ a) where+  deBruijnNamedVar nm i = unnamed $ deBruijnNamedVar nm i+  deBruijnView = deBruijnView . namedThing
src/full/Agda/TypeChecking/SyntacticEquality.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | A syntactic equality check that takes meta instantiations into account, --   but does not reduce.  It replaces@@ -10,41 +9,110 @@ --   by a more efficient routine which only traverses and instantiates the terms --   as long as they are equal. -module Agda.TypeChecking.SyntacticEquality (SynEq, checkSyntacticEquality) where--import Prelude hiding (mapM)+module Agda.TypeChecking.SyntacticEquality+  ( SynEq+  , checkSyntacticEquality+  , checkSyntacticEquality'+  , syntacticEqualityFuelRemains+  )+  where -import Control.Applicative hiding ((<**>))-import Control.Arrow ((***))-import Control.Monad.State hiding (mapM)+import Control.Arrow            ( (***) )+import Control.Monad            ( zipWithM )+import Control.Monad.State      ( MonadState(..), StateT, runStateT )+import Control.Monad.Trans      ( lift )  import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Monad (ReduceM)+import Agda.TypeChecking.Monad  ( ReduceM, MonadReduce(..), TCEnv(..), MonadTCEnv(..) ) import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad (ifM)--#include "undefined.h"-import Agda.Utils.Impossible+import Agda.Utils.Unsafe (unsafeComparePointers) --- | Syntactic equality check for terms.+-- | Syntactic equality check for terms. If syntactic equality+-- checking has fuel left, then 'checkSyntacticEquality' behaves as if+-- it were implemented in the following way (which does not match the+-- given type signature), only that @v@ and @v'@ are only fully+-- instantiated to the depth where they are equal (and the amount of+-- fuel is reduced by one unit in the failure branch): --   @---      checkSyntacticEquality v v' = do---        (v,v') <- instantiateFull (v,v')---         return ((v,v'), v==v')+--      checkSyntacticEquality v v' s f = do+--        (v, v') <- instantiateFull (v, v')+--        if v == v' then s v v' else f v v' --   @---   only that @v,v'@ are only fully instantiated to the depth---   where they are equal.+-- If syntactic equality checking does not have fuel left, then+-- 'checkSyntacticEquality' instantiates the two terms and takes the+-- failure branch.+--+-- Note that in either case the returned values @v@ and @v'@ cannot be+-- @MetaV@s that are instantiated. -{-# SPECIALIZE checkSyntacticEquality :: Term -> Term -> ReduceM ((Term, Term), Bool) #-}-{-# SPECIALIZE checkSyntacticEquality :: Type -> Type -> ReduceM ((Type, Type), Bool) #-}-checkSyntacticEquality :: (SynEq a) => a -> a -> ReduceM ((a, a), Bool)-checkSyntacticEquality v v' = synEq v v' `runStateT` True+{-# SPECIALIZE checkSyntacticEquality ::+      Term -> Term ->+      (Term -> Term -> ReduceM a) ->+      (Term -> Term -> ReduceM a) ->+      ReduceM a #-}+{-# SPECIALIZE checkSyntacticEquality ::+      Type -> Type ->+      (Type -> Type -> ReduceM a) ->+      (Type -> Type -> ReduceM a) ->+      ReduceM a #-}+checkSyntacticEquality+  :: (Instantiate a, SynEq a, MonadReduce m)+  => a+  -> a+  -> (a -> a -> m b)  -- ^ Continuation used upon success.+  -> (a -> a -> m b)  -- ^ Continuation used upon failure, or if+                      --   syntactic equality checking has been turned+                      --   off.+  -> m b+checkSyntacticEquality u v s f =+  ifM syntacticEqualityFuelRemains+  {-then-} (checkSyntacticEquality' u v s (\u v -> localTC decreaseFuel (f u v)))+  {-else-} (uncurry f =<< instantiate (u, v))+  where+  decreaseFuel env =+    case envSyntacticEqualityFuel env of+      Strict.Nothing -> env+      Strict.Just n  ->+        env { envSyntacticEqualityFuel = Strict.Just (pred n) } +-- | Syntactic equality check for terms without checking remaining fuel.++{-# SPECIALIZE checkSyntacticEquality' ::+      Term -> Term ->+      (Term -> Term -> ReduceM a) ->+      (Term -> Term -> ReduceM a) ->+      ReduceM a #-}+{-# SPECIALIZE checkSyntacticEquality' ::+      Type -> Type ->+      (Type -> Type -> ReduceM a) ->+      (Type -> Type -> ReduceM a) ->+      ReduceM a #-}+checkSyntacticEquality'+  :: (Instantiate a, SynEq a, MonadReduce m)+  => a+  -> a+  -> (a -> a -> m b)  -- ^ Continuation used upon success.+  -> (a -> a -> m b)  -- ^ Continuation used upon failure.+  -> m b+checkSyntacticEquality' u v s f = do+  ((u, v), equal) <- liftReduce $ synEq u v `runStateT` True+  if equal then s u v else f u v++-- | Does the syntactic equality check have any remaining fuel?++syntacticEqualityFuelRemains :: MonadReduce m => m Bool+syntacticEqualityFuelRemains = do+  fuel <- envSyntacticEqualityFuel <$> askTC+  return $ case fuel of+    Strict.Nothing -> True+    Strict.Just n  -> n > 0+ -- | Monad for checking syntactic equality type SynEqM = StateT Bool ReduceM @@ -59,97 +127,74 @@ -- Since List2 is only Applicative, not a monad, I cannot -- define a List2T monad transformer, so we do it manually: -(<$$>) :: Functor f => (a -> b) -> f (a,a) -> f (b,b)+(<$$>) :: Functor f => (a -> b) -> f (a, a) -> f (b, b) f <$$> xx = (f *** f) <$> xx -pure2 :: Applicative f => a -> f (a,a)-pure2 a = pure (a,a)--(<**>) :: Applicative f => f (a -> b, a -> b) -> f (a,a) -> f (b,b)-ff <**> xx = pure (uncurry (***)) <*> ff <*> xx--{--updateSharedM2 :: Monad m =>  (Term -> Term -> m (Term, Term)) -> Term -> Term -> m (Term, Term)-updateSharedM2 f v0@(Shared p) = do-  v <- f (derefPtr p)-  case derefPtr (setPtr v p) of-    Var _ [] -> return v-    _        -> compressPointerChain v0 `pseq` return v0-updateSharedM2 f v = f v+pure2 :: Applicative f => a -> f (a, a)+pure2 a = pure (a, a) -updateSharedTerm2 :: MonadTCM tcm => (Term -> Term -> tcm (Term, Term)) -> Term -> Term -> tcm (Term, Term)-updateSharedTerm f v v' =-  ifM (liftTCM $ asks envAllowDestructiveUpdate)-      (updateSharedM2 f v v')-      (f (ignoreSharing v) (ignoreSharing v'))--}+(<**>) :: Applicative f => f (a -> b, a -> b) -> f (a, a) -> f (b, b)+ff <**> xx = (uncurry (***)) <$> ff <*> xx  -- | Instantiate full as long as things are equal class SynEq a where-  synEq  :: a -> a -> SynEqM (a,a)-  synEq' :: a -> a -> SynEqM (a,a)+  synEq  :: a -> a -> SynEqM (a, a)+  synEq' :: a -> a -> SynEqM (a, a)   synEq' a a' = ifEqual (uncurry synEq) (a, a') +instance SynEq Bool where+  synEq x y | x == y    = return (x, y)+  synEq x y | otherwise = inequal (x, y)+ -- | Syntactic term equality ignores 'DontCare' stuff. instance SynEq Term where-  synEq v v' = do+  synEq v v' = if unsafeComparePointers v v' then return (v, v') else do     (v, v') <- lift $ instantiate' (v, v')-    -- currently destroys sharing-    -- TODO: preserve sharing!-    case (ignoreSharing v, ignoreSharing v') of+    case (v, v') of       (Var   i vs, Var   i' vs') | i == i' -> Var i   <$$> synEq vs vs'-      (Con c ci vs,Con c' ci' vs') | c == c' -> Con c (bestConInfo ci ci') <$$> synEq vs vs'+      (Con c i vs, Con c' i' vs') | c == c' -> Con c (bestConInfo i i') <$$> synEq vs vs'       (Def   f vs, Def   f' vs') | f == f' -> Def f   <$$> synEq vs vs'       (MetaV x vs, MetaV x' vs') | x == x' -> MetaV x <$$> synEq vs vs'       (Lit   l   , Lit   l'    ) | l == l' -> pure2 $ v-      (Lam   h b , Lam   h' b' ) | h == h' -> Lam h   <$$> synEq b b'+      (Lam   h b , Lam   h' b' )           -> Lam <$$> synEq h h' <**> synEq b b'       (Level l   , Level l'    )           -> levelTm <$$> synEq l l'-      (Sort  s   , Sort  s'    )           -> sortTm  <$$> synEq s s'+      (Sort  s   , Sort  s'    )           -> Sort    <$$> synEq s s'       (Pi    a b , Pi    a' b' )           -> Pi      <$$> synEq a a' <**> synEq' b b'-      (DontCare _, DontCare _  )           -> pure (v, v')-         -- Irrelevant things are syntactically equal. ALT:-         -- DontCare <$$> synEq v v'-      (Shared{}  , _           )           -> __IMPOSSIBLE__-      (_         , Shared{}    )           -> __IMPOSSIBLE__+      (DontCare u, DontCare u' )           -> DontCare <$$> synEq u u'+         -- Irrelevant things are not syntactically equal. ALT:+         -- pure (u, u')+         -- Jesper, 2019-10-21: considering irrelevant things to be+         -- syntactically equal causes implicit arguments to go+         -- unsolved, so it is better to go under the DontCare.+      (Dummy{}   , Dummy{}     )           -> pure (v, v')       _                                    -> inequal (v, v')  instance SynEq Level where-  synEq (Max vs) (Max vs') = levelMax <$$> synEq vs vs'+  synEq l@(Max n vs) l'@(Max n' vs')+    | n == n'   = levelMax n <$$> synEq vs vs'+    | otherwise = inequal (l, l')  instance SynEq PlusLevel where-  synEq l l' = do-    case (l, l') of-      (ClosedLevel v, ClosedLevel v') | v == v' -> pure2 l-      (Plus n v,      Plus n' v')     | n == n' -> Plus n <$$> synEq v v'-      _ -> inequal (l, l')--instance SynEq LevelAtom where-  synEq l l' = do-    l  <- lift (unBlock =<< instantiate' l)-    case (l, l') of-      (MetaLevel m vs  , MetaLevel m' vs'  ) | m == m' -> MetaLevel m    <$$> synEq vs vs'-      (UnreducedLevel v, UnreducedLevel v' )           -> UnreducedLevel <$$> synEq v v'-      -- The reason for being blocked should not matter for equality.-      (NeutralLevel r v, NeutralLevel r' v')           -> NeutralLevel r <$$> synEq v v'-      (BlockedLevel m v, BlockedLevel m' v')           -> BlockedLevel m <$$> synEq v v'-      _ -> inequal (l, l')-    where-      unBlock l =-        case l of-          BlockedLevel m v ->-            ifM (isInstantiatedMeta m)-                (pure $ UnreducedLevel v)-                (pure l)-          _ -> pure l+  synEq l@(Plus n v) l'@(Plus n' v')+    | n == n'   = Plus n <$$> synEq v v'+    | otherwise = inequal (l, l')  instance SynEq Sort where-  synEq s s' = do+  synEq s s' = if unsafeComparePointers s s' then return (s, s') else do     (s, s') <- lift $ instantiate' (s, s')     case (s, s') of-      (Type l  , Type l'   ) -> levelSort <$$> synEq l l'-      (DLub a b, DLub a' b') -> dLub <$$> synEq a a' <**> synEq' b b'-      (Prop    , Prop      ) -> pure2 s-      (Inf     , Inf       ) -> pure2 s+      (Univ u l, Univ u' l') | u == u' -> Univ u <$$> synEq l l'+      (PiSort a b c, PiSort a' b' c') -> piSort <$$> synEq a a' <**> synEq' b b' <**> synEq' c c'+      (FunSort a b, FunSort a' b') -> funSort <$$> synEq a a' <**> synEq' b b'+      (UnivSort a, UnivSort a') -> UnivSort <$$> synEq a a'+      (SizeUniv, SizeUniv  ) -> pure2 s+      (LockUniv, LockUniv  ) -> pure2 s+      (LevelUniv, LevelUniv  ) -> pure2 s+      (IntervalUniv, IntervalUniv) -> pure2 s+      (Inf u m , Inf u' n) | u == u', m == n -> pure2 s+      (MetaS x es , MetaS x' es') | x == x' -> MetaS x <$$> synEq es es'+      (DefS  d es , DefS  d' es') | d == d' -> DefS d  <$$> synEq es es'+      (DummyS{}, DummyS{}) -> pure (s, s')       _ -> inequal (s, s')  -- | Syntactic equality ignores sorts.@@ -161,14 +206,19 @@     | length as == length as' = unzip <$> zipWithM synEq' as as'     | otherwise               = inequal (as, as') +instance (SynEq a, SynEq b) => SynEq (a,b) where+  synEq (a,b) (a',b') = (,) <$$> synEq a a' <**> synEq b b'+ instance SynEq a => SynEq (Elim' a) where   synEq e e' =     case (e, e') of       (Proj _ f, Proj _ f') | f == f' -> pure2 e       (Apply a, Apply a') -> Apply <$$> synEq a a'+      (IApply u v r, IApply u' v' r')+                          -> (IApply u v *** IApply u' v') <$> synEq r r'       _                   -> inequal (e, e') -instance (Subst t a, SynEq a) => SynEq (Abs a) where+instance (Subst a, SynEq a) => SynEq (Abs a) where   synEq a a' =     case (a, a') of       (NoAbs x b, NoAbs x' b') -> (NoAbs x *** NoAbs x') <$>  synEq b b'@@ -176,23 +226,17 @@       (Abs   x b, NoAbs x' b') -> Abs x  <$$> synEq b (raise 1 b')  -- TODO: mkAbs?       (NoAbs x b, Abs   x' b') -> Abs x' <$$> synEq (raise 1 b) b' -{- TRIGGERS test/fail/UnequalHiding--- | Ignores 'ArgInfo'.-instance SynEq a => SynEq (Arg c a) where-  synEq (Arg ai a) (Arg ai' a') = (Arg ai *** Arg ai') <$> synEq a a'---- | Ignores 'ArgInfo'.-instance SynEq a => SynEq (Dom c a) where-  synEq (Dom ai a) (Dom ai' a') = (Dom ai *** Dom ai') <$> synEq a a'--}-+-- NOTE: Do not ignore 'ArgInfo', or test/fail/UnequalHiding will pass. instance SynEq a => SynEq (Arg a) where   synEq (Arg ai a) (Arg ai' a') = Arg <$$> synEq ai ai' <**> synEq a a' +-- Ignore the tactic. instance SynEq a => SynEq (Dom a) where-  synEq (Dom ai a) (Dom ai' a') = Dom <$$> synEq ai ai' <**> synEq a a'+  synEq d@(Dom ai x f t a) d'@(Dom ai' x' f' _ a')+    | x == x'   = Dom <$$> synEq ai ai' <**> pure2 x <**> synEq f f' <**> pure2 t <**> synEq a a'+    | otherwise = inequal (d, d')  instance SynEq ArgInfo where-  synEq ai@(ArgInfo h r o v) ai'@(ArgInfo h' r' o' v')-    | h == h', r == r', v == v' = pure2 ai-    | otherwise                 = inequal (ai, ai')+  synEq ai@(ArgInfo h r o _ a) ai'@(ArgInfo h' r' o' _ a')+    | h == h', sameModality r r', a == a' = pure2 ai+    | otherwise        = inequal (ai, ai')
src/full/Agda/TypeChecking/Telescope.hs view
@@ -1,72 +1,62 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Telescope where  import Prelude hiding (null) -import Control.Applicative hiding (empty)-import Control.Monad (unless, guard)+import Control.Monad -import Data.Foldable (forM_)+import Data.Bifunctor (first)+import Data.Foldable (find) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import Data.List hiding (null)+import qualified Data.List as List import Data.Maybe+import Data.Monoid  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( Pretty ) import Agda.Syntax.Internal-import Agda.Syntax.Internal.Pattern-import Agda.Syntax.Position+import Agda.Syntax.Internal.Pattern ( patternToTerm ) +import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free +import Agda.Utils.CallStack ( withCallerCallStack )+import Agda.Utils.Either+import Agda.Utils.Empty import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Null import Agda.Utils.Permutation+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet -#include "undefined.h" import Agda.Utils.Impossible -data OutputTypeName-  = OutputTypeName QName-  | OutputTypeVar-  | OutputTypeNameNotYetKnown-  | NoOutputTypeName---- | Strips all Pi's and return the head definition name, if possible.-getOutputTypeName :: Type -> TCM OutputTypeName-getOutputTypeName t = do-  TelV tel t' <- telView t-  ifBlocked (unEl t') (\ _ _ -> return OutputTypeNameNotYetKnown) $ \ v ->-    case ignoreSharing v of-      -- Possible base types:-      Def n _  -> return $ OutputTypeName n-      Sort{}   -> return NoOutputTypeName-      Var n _  -> return OutputTypeVar-      -- Not base types:-      Con{}    -> __IMPOSSIBLE__-      Lam{}    -> __IMPOSSIBLE__-      Lit{}    -> __IMPOSSIBLE__-      Level{}  -> __IMPOSSIBLE__-      MetaV{}  -> __IMPOSSIBLE__-      Pi{}     -> __IMPOSSIBLE__-      Shared{} -> __IMPOSSIBLE__-      DontCare{} -> __IMPOSSIBLE__---- | Flatten telescope: (Γ : Tel) -> [Type Γ]-flattenTel :: Telescope -> [Dom Type]+-- | Flatten telescope: @(Γ : Tel) -> [Type Γ]@+flattenTel :: TermSubst a => Tele (Dom a) -> [Dom a] flattenTel EmptyTel          = [] flattenTel (ExtendTel a tel) = raise (size tel + 1) a : flattenTel (absBody tel) +{-# SPECIALIZE flattenTel :: Telescope -> [Dom Type] #-}++-- | Turn a context into a flat telescope: all entries live in the whole context.+-- @+--    (Γ : Context) -> [Type Γ]+-- @+flattenContext :: Context -> [ContextEntry]+flattenContext = loop 1 []+  where+    loop n tel []       = tel+    loop n tel (ce:ctx) = loop (n + 1) (raise n ce : tel) ctx+ -- | Order a flattened telescope in the correct dependeny order: Γ -> --   Permutation (Γ -> Γ~) --@@ -79,53 +69,85 @@     (i, _) `comesBefore` (_, a) = i `freeIn` unEl (unDom a) -- a tiny bit unsafe  reorderTel_ :: [Dom Type] -> Permutation-reorderTel_ tel = case reorderTel tel of-  Nothing -> __IMPOSSIBLE__-  Just p  -> p+reorderTel_ tel = fromMaybe __IMPOSSIBLE__ (reorderTel tel)  -- | Unflatten: turns a flattened telescope into a proper telescope. Must be --   properly ordered. unflattenTel :: [ArgName] -> [Dom Type] -> Telescope-unflattenTel []   []            = EmptyTel-unflattenTel (x : xs) (a : tel) = ExtendTel a' (Abs x tel')-  where-    tel' = unflattenTel xs tel+unflattenTel xs tel = unflattenTel' (size tel) xs tel++-- | A variant of 'unflattenTel' which takes the size of the last+-- argument as an argument.+unflattenTel' :: Int -> [ArgName] -> [Dom Type] -> Telescope+unflattenTel' !n xs tel = case (xs, tel) of+  ([],     [])      -> EmptyTel+  (x : xs, a : tel) -> ExtendTel a' (Abs x tel')+    where+    tel' = unflattenTel' (n - 1) xs tel     a'   = applySubst rho a-    rho  = parallelS (replicate (size tel + 1) __IMPOSSIBLE_TERM__)-unflattenTel [] (_ : _) = __IMPOSSIBLE__-unflattenTel (_ : _) [] = __IMPOSSIBLE__+    rho  = parallelS $+           replicate n (withCallerCallStack impossibleTerm)+  ([],    _ : _) -> __IMPOSSIBLE__+  (_ : _, [])    -> __IMPOSSIBLE__ +-- | Rename the variables in the telescope to the given names+--   Precondition: @size xs == size tel@.+renameTel :: [Maybe ArgName] -> Telescope -> Telescope+renameTel []           EmptyTel           = EmptyTel+renameTel (Nothing:xs) (ExtendTel a tel') = ExtendTel a $ renameTel xs <$> tel'+renameTel (Just x :xs) (ExtendTel a tel') = ExtendTel a $ renameTel xs <$> (tel' { absName = x })+renameTel []           (ExtendTel _ _   ) = __IMPOSSIBLE__+renameTel (_      :_ ) EmptyTel           = __IMPOSSIBLE__+ -- | Get the suggested names from a telescope teleNames :: Telescope -> [ArgName] teleNames = map (fst . unDom) . telToList  teleArgNames :: Telescope -> [Arg ArgName]-teleArgNames = map (argFromDom . fmap fst) . telToList+teleArgNames = telToArgs -teleArgs :: (DeBruijn a) => Telescope -> [Arg a]-teleArgs tel =-  [ Arg info (debruijnNamedVar n i)-  | (i, Dom info (n,_)) <- zip (downFrom $ size l) l ]-  where l = telToList tel+teleArgs :: (DeBruijn a) => Tele (Dom t) -> [Arg a]+teleArgs = map argFromDom . teleDoms -teleNamedArgs :: (DeBruijn a) => Telescope -> [NamedArg a]-teleNamedArgs tel =-  [ Arg info (Named (Just $ Ranged noRange $ argNameToString name) (debruijnNamedVar name i))-  | (i, Dom info (name,_)) <- zip (downFrom $ size l) l ]+teleDoms :: (DeBruijn a) => Tele (Dom t) -> [Dom a]+teleDoms tel = zipWith (\ i dom -> deBruijnVar i <$ dom) (downFrom $ size l) l   where l = telToList tel +-- UNUSED+-- withNamedArgsFromTel :: [a] -> Telescope -> [NamedArg a]+-- xs `withNamedArgsFromTel` tel =+--   [ Arg info (Named (Just $ Ranged empty $ argNameToString name) x)+--   | (x, Dom {domInfo = info, unDom = (name,_)}) <- zip xs l ]+--   where l = telToList tel++teleNamedArgs :: (DeBruijn a) => Tele (Dom t) -> [NamedArg a]+teleNamedArgs = map namedArgFromDom . teleDoms++{-# INLINABLE tele2NamedArgs #-} -- | A variant of `teleNamedArgs` which takes the argument names (and the argument info) --   from the first telescope and the variable names from the second telescope. -- --   Precondition: the two telescopes have the same length. tele2NamedArgs :: (DeBruijn a) => Telescope -> Telescope -> [NamedArg a] tele2NamedArgs tel0 tel =-  [ Arg info (Named (Just $ Ranged noRange $ argNameToString argName) (debruijnNamedVar varName i))-  | (i, Dom info (argName,_), Dom _ (varName,_)) <- zip3 (downFrom $ size l) l0 l ]+  [ Arg info (Named (Just $ WithOrigin Inserted $ unranged $ argNameToString argName) (deBruijnNamedVar varName i))+  | (i, Dom{domInfo = info, unDom = (argName,_)}, Dom{unDom = (varName,_)}) <- zip3 (downFrom $ size l) l0 l ]   where   l  = telToList tel   l0 = telToList tel0 +-- | Split the telescope at the specified position.+splitTelescopeAt :: Int -> Telescope -> (Telescope,Telescope)+splitTelescopeAt n tel+  | n <= 0    = (EmptyTel, tel)+  | otherwise = splitTelescopeAt' n tel+    where+      splitTelescopeAt' _ EmptyTel          = (EmptyTel,EmptyTel)+      splitTelescopeAt' 1 (ExtendTel a tel) = (ExtendTel a (tel $> EmptyTel), absBody tel)+      splitTelescopeAt' m (ExtendTel a tel) = (ExtendTel a (tel $> tel'), tel'')+        where+          (tel', tel'') = splitTelescopeAt (m - 1) $ absBody tel+ -- | Permute telescope: permutes or drops the types in the telescope according --   to the given permutation. Assumes that the permutation preserves the --   dependencies in the telescope.@@ -146,19 +168,29 @@ permuteTel :: Permutation -> Telescope -> Telescope permuteTel perm tel =   let names = permute perm $ teleNames tel-      types = permute perm $ renameP __IMPOSSIBLE__ (flipP perm) $ flattenTel tel+      types = permute perm $ renameP impossible (flipP perm) $ flattenTel tel   in  unflattenTel names types +-- | Like 'permuteTel', but start with a context.+--+permuteContext :: Permutation -> Context -> Telescope+permuteContext perm ctx = permuteTel perm $ contextToTel ctx+ -- | Recursively computes dependencies of a set of variables in a given --   telescope. Any dependencies outside of the telescope are ignored. varDependencies :: Telescope -> IntSet -> IntSet-varDependencies tel = allDependencies IntSet.empty+varDependencies tel = addLocks . allDependencies IntSet.empty   where+    addLocks s | IntSet.null s = s+               | otherwise = IntSet.union s $ IntSet.fromList $ filter (>= m) locks+      where+        locks = catMaybes [ deBruijnView (unArg a) | (a :: Arg Term) <- teleArgs tel, IsLock{} <- pure (getLock a)]+        m = IntSet.findMin s     n  = size tel     ts = flattenTel tel      directDependencies :: Int -> IntSet-    directDependencies i = allFreeVars $ ts !! (n-1-i)+    directDependencies i = allFreeVars $ indexWithDefault __IMPOSSIBLE__ ts (n-1-i)      allDependencies :: IntSet -> IntSet -> IntSet     allDependencies =@@ -167,6 +199,29 @@         then soFar         else IntSet.insert j $ allDependencies soFar $ directDependencies j +-- | Computes the set of variables in a telescope whose type depend on+--   one of the variables in the given set (including recursive+--   dependencies). Any dependencies outside of the telescope are+--   ignored.+varDependents :: Telescope -> IntSet -> IntSet+varDependents tel = allDependents+  where+    n  = size tel+    ts = flattenTel tel++    directDependents :: IntSet -> IntSet+    directDependents is = IntSet.fromList+      [ j | j <- downFrom n+          , let tj = indexWithDefault __IMPOSSIBLE__ ts (n-1-j)+          , getAny $ runFree (Any . (`IntSet.member` is)) IgnoreNot tj+          ]++    allDependents :: IntSet -> IntSet+    allDependents is+     | null new  = empty+     | otherwise = new `IntSet.union` allDependents new+      where new = directDependents is+ -- | A telescope split in two. data SplitTel = SplitTel   { firstPart  :: Telescope@@ -195,7 +250,7 @@      perm  = Perm n $ map (n-1-) $ VarSet.toDescList is ++ VarSet.toDescList isC -    ts1   = renameP __IMPOSSIBLE__ (reverseP perm) (permute perm ts0)+    ts1   = renameP impossible (reverseP perm) (permute perm ts0)      tel'  = unflattenTel (permute perm names) ts1 @@ -219,17 +274,20 @@     checkDependencies soFar []     = True     checkDependencies soFar (j:js) = ok && checkDependencies (IntSet.insert j soFar) js       where-        fv' = allFreeVars $ ts0 !! (n-1-j)-        fv  = fv' `IntSet.intersection` IntSet.fromAscList [ 0 .. n-1 ]-        ok  = fv `IntSet.isSubsetOf` soFar+        t   = indexWithDefault __IMPOSSIBLE__ ts0 (n-1-j)  -- ts0[n-1-j]+        -- Skip the construction of intermediate @IntSet@s in the check @ok@.+        -- ok  = (allFreeVars t `IntSet.intersection` IntSet.fromAscList [ 0 .. n-1 ])+        --       `IntSet.isSubsetOf` soFar+        good i = All $ (i < n) `implies` (i `IntSet.member` soFar) where implies = (<=)+        ok = getAll $ runFree good IgnoreNot t -    ok    = all (<n) is && checkDependencies IntSet.empty is+    ok    = all (< n) is && checkDependencies IntSet.empty is -    isC   = downFrom n \\ is+    isC   = downFrom n List.\\ is      perm  = Perm n $ map (n-1-) $ is ++ isC -    ts1   = renameP __IMPOSSIBLE__ (reverseP perm) (permute perm ts0)+    ts1   = renameP impossible (reverseP perm) (permute perm ts0)      tel'  = unflattenTel (permute perm names) ts1 @@ -242,25 +300,42 @@ --   (directly or indirectly) on the variable. instantiateTelescope   :: Telescope -- ^ ⊢ Γ-  -> Int       -- ^ Γ ⊢ var k : A-  -> Term      -- ^ Γ ⊢ u : A+  -> Int       -- ^ Γ ⊢ var k : A   de Bruijn _level_+  -> DeBruijnPattern -- ^ Γ ⊢ u : A   -> Maybe (Telescope,           -- ⊢ Γ'             PatternSubstitution, -- Γ' ⊢ σ : Γ             Permutation)         -- Γ  ⊢ flipP ρ : Γ'-instantiateTelescope tel k u = guard ok $> (tel', sigma, rho)+instantiateTelescope tel k p = guard ok $> (tel', sigma, rho)   where     names = teleNames tel     ts0   = flattenTel tel     n     = size tel     j     = n-1-k+    u     = patternToTerm p +    -- Jesper, 2019-12-31: Previous implementation that does some+    -- unneccessary reordering but is otherwise correct (keep!)+    -- -- is0 is the part of Γ that is needed to type u+    -- is0   = varDependencies tel $ allFreeVars u+    -- -- is1 is the rest of Γ (minus the variable we are instantiating)+    -- is1   = IntSet.delete j $+    --           IntSet.fromAscList [ 0 .. n-1 ] `IntSet.difference` is0+    -- -- we work on de Bruijn indices, so later parts come first+    -- is    = IntSet.toAscList is1 ++ IntSet.toAscList is0++    -- -- if u depends on var j, we cannot instantiate+    -- ok    = not $ j `IntSet.member` is0+     -- is0 is the part of Γ that is needed to type u     is0   = varDependencies tel $ allFreeVars u-    -- is1 is the rest of Γ (minus the variable we are instantiating)-    is1   = IntSet.delete j $-              IntSet.fromAscList [ 0 .. n-1 ] `IntSet.difference` is0-    -- we work on de Bruijn indices, so later parts come first-    is    = IntSet.toAscList is1 ++ IntSet.toAscList is0+    -- is1 is the part of Γ that depends on variable j+    is1   = varDependents tel $ singleton j+    -- lasti is the last (rightmost) variable of is0+    lasti = if null is0 then n else IntSet.findMin is0+    -- we move each variable in is1 to the right until it comes after+    -- all variables in is0 (i.e. after lasti)+    (as,bs) = List.partition (`IntSet.member` is1) [ n-1 , n-2 .. lasti ]+    is    = reverse $ List.delete j $ bs ++ as ++ downFrom lasti      -- if u depends on var j, we cannot instantiate     ok    = not $ j `IntSet.member` is0@@ -268,8 +343,8 @@     perm  = Perm n $ is    -- works on de Bruijn indices     rho   = reverseP perm  -- works on de Bruijn levels -    u1    = renameP __IMPOSSIBLE__ perm u -- Γ' ⊢ u1 : A'-    us    = map (\i -> fromMaybe (DotP u1) (deBruijnVar <$> findIndex (i ==) is)) [ 0 .. n-1 ]+    p1    = renameP impossible perm p -- Γ' ⊢ p1 : A'+    us    = map (\i -> maybe p1 deBruijnVar (List.elemIndex i is)) [ 0 .. n-1 ]     sigma = us ++# raiseS (n-1)      ts1   = permute rho $ applyPatSubst sigma ts0@@ -286,12 +361,17 @@      , PatternSubstitution) -- Γ' ⊢ ρ : Γ expandTelescopeVar gamma k delta c = (tel', rho)   where-    (ts1,a:ts2) = fromMaybe __IMPOSSIBLE__ $+    (ts1,xa:ts2) = fromMaybe __IMPOSSIBLE__ $                     splitExactlyAt k $ telToList gamma+    a = raise (size delta) (snd <$> xa) -- Γ₁Δ ⊢ D pars      cpi         = ConPatternInfo-      { conPRecord = Just ConOSystem-      , conPType   = Just $ snd <$> argFromDom a+      { conPInfo   = defaultPatternInfo+      , conPRecord = True+      , conPFallThrough+                   = False+      , conPType   = Just $ argFromDom a+      , conPLazy   = True       }     cargs       = map (setOrigin Inserted) $ teleNamedArgs delta     cdelta      = ConP c cpi cargs                    -- Γ₁Δ ⊢ c Δ : D pars@@ -304,102 +384,367 @@     tel'        = gamma1 `abstract` (delta `abstract` gamma2')  -telView :: Type -> TCM TelView+{-# INLINE telView #-}+-- | Gather leading Πs of a type in a telescope.+telView :: (MonadReduce m, MonadAddContext m) => Type -> m TelView telView = telViewUpTo (-1) +{-# INLINE telViewUpTo #-} -- | @telViewUpTo n t@ takes off the first @n@ function types of @t@. -- Takes off all if @n < 0@.-telViewUpTo :: Int -> Type -> TCM TelView+telViewUpTo :: (MonadReduce m, MonadAddContext m) => Int -> Type -> m TelView telViewUpTo n t = telViewUpTo' n (const True) t +{-# SPECIALIZE telViewUpTo' :: Int -> (Dom Type -> Bool) -> Type -> TCM TelView #-} -- | @telViewUpTo' n p t@ takes off $t$ --   the first @n@ (or arbitrary many if @n < 0@) function domains --   as long as they satify @p@.-telViewUpTo' :: Int -> (Dom Type -> Bool) -> Type -> TCM TelView+telViewUpTo' :: (MonadReduce m, MonadAddContext m) => Int -> (Dom Type -> Bool) -> Type -> m TelView telViewUpTo' 0 p t = return $ TelV EmptyTel t telViewUpTo' n p t = do   t <- reduce t-  case ignoreSharing $ unEl t of-    Pi a b | p a -> absV a (absName b) <$> telViewUpTo' (n - 1) p (absBody b)-    _            -> return $ TelV EmptyTel t+  case unEl t of+    Pi a b | p a ->+          -- Force the name to avoid retaining the rest of b.+      let !bn = absName b in+      absV a bn <$> do+        underAbstractionAbs a b $ \b -> telViewUpTo' (n - 1) p b+    _ -> return $ TelV EmptyTel t++{-# INLINE telViewPath #-}+telViewPath :: PureTCM m => Type -> m TelView+telViewPath = telViewUpToPath (-1)++{-# SPECIALIZE telViewUpToPath :: Int -> Type -> TCM TelView #-}+-- | @telViewUpToPath n t@ takes off @t@+--   the first @n@ (or arbitrary many if @n < 0@) function domains or Path types.+--+-- @telViewUpToPath n t = fst <$> telViewUpToPathBoundary' n t@+telViewUpToPath :: PureTCM m => Int -> Type -> m TelView+telViewUpToPath n t = if n == 0 then done t else do+  pathViewAsPi t >>= \case+    Left  (a, b)          -> recurse a b+    Right (El _ (Pi a b)) -> recurse a b+    Right t               -> done t   where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t+    done t      = return $ TelV EmptyTel t+    recurse a b = absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) +-- | Boundary conditions @[[ (i,(x,y)) ]] = [(i=0) -> x, (i=1) -> y]@.+-- For instance, if @p : Path A a b@, then @p i@ has boundary condition @(i,(a,b))@.+-- We call @i@ the /dimension/ and @(x,y)@ its /boundary/.+newtype Boundary' x a = Boundary { theBoundary :: [(x,(a,a))] }+  deriving (Show, Null)++-- | Usually, the dimensions of a boundary condition are interval /variables/,+-- represented by a de Bruijn index @Int@.+type Boundary = Boundary' Int Term++-- | Substitution formally creates dimensions that are interval /expressions/,+-- represented by a @Term@.+-- However, in practice these terms should be of the form @'var' i@.+type TmBoundary = Boundary' Term Term++-- | Turn dimension variables @i@ into dimension expressions @'var' i@.+tmBoundary :: Boundary' Int a -> Boundary' Term a+tmBoundary = Boundary . map (first var) . theBoundary++-- | Turn dimension expressions into dimension variables.+-- Formally this is a partial operation, but should only be called when the precondition is met.+--+-- Precondition: the dimension terms in the boundary are all of the form @'var' i@.+varBoundary :: Boundary' Term a -> Boundary' Int a+varBoundary = Boundary . map (first unVar) . theBoundary+  where+    unVar (Var i []) = i+    unVar _ = __IMPOSSIBLE__++-- | Substitution into a 'Boundary' a priori creates a 'TmBoundary' which we convert back via 'varBoundary'.+-- A priori, this is a partial operation.+instance Subst Boundary where+  type SubstArg Boundary = Term+  applySubst sub = varBoundary . applySubst sub . tmBoundary++instance Subst TmBoundary where+  type SubstArg TmBoundary = Term+  applySubst sub = Boundary . applySubst sub . theBoundary++deriving instance (Pretty x, Pretty a) => Pretty (Boundary' x a)++{-# SPECIALIZE telViewUpToPathBoundary' :: Int -> Type -> TCM (TelView, Boundary) #-}+-- | Like 'telViewUpToPath' but also returns the 'Boundary' expected by the Path types encountered.+-- The boundary terms live in the telescope given by the 'TelView'.+-- Each point of the boundary has the type of the codomain of the Path type it got taken from, see 'fullBoundary'.+--+-- @+--  (TelV Γ b, [(i,t_i,u_i)]) <- telViewUpToPathBoundary' n a+--  Input:  Δ ⊢ a+--  Output: Δ.Γ ⊢ b+--          Δ.Γ ⊢ T is the codomain of the PathP at variable i+--          Δ.Γ ⊢ i : I+--          Δ.Γ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : T+-- @+--+-- Useful to reconstruct IApplyP patterns after teleNamedArgs Γ.+--+telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView, Boundary)+telViewUpToPathBoundary' n t = if n == 0 then done t else do+  pathViewAsPi' t >>= \case+    Left ((a, b), xy)     -> addEndPoints xy <$> recurse a b+    Right (El _ (Pi a b)) -> recurse a b+    Right t               -> done t+  where+    done t      = return (TelV EmptyTel t, empty)+    recurse a b = first (absV a (absName b)) <$> do+      underAbstractionAbs a b $ \b -> telViewUpToPathBoundary' (n - 1) b+    addEndPoints xy (telv@(TelV tel _), Boundary cs) =+      (telv, Boundary $ (size tel - 1, raise (size tel) xy) : cs)+++fullBoundary :: Telescope -> Boundary -> Boundary+fullBoundary tel bs =+      -- tel = Γ+      -- ΔΓ ⊢ b+      -- Δ ⊢ a = PiPath Γ bs b+      -- Δ.Γ ⊢ T is the codomain of the PathP at variable i+      -- Δ.Γ ⊢ i : I+      -- Δ.Γ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : T+      -- Δ.Γ | PiPath Γ bs A ⊢ teleElims tel bs : b+   let es = teleElims tel bs+       l  = size tel+   in Boundary $ map (\ (i, xy) -> (i, xy `applyE` (drop (l - i) es))) $ theBoundary bs++{-# SPECIALIZE telViewUpToPathBoundary :: Int -> Type -> TCM (TelView, Boundary) #-}+-- | @(TelV Γ b, [(i,t_i,u_i)]) <- telViewUpToPathBoundary n a@+--  Input:  Δ ⊢ a+--  Output: ΔΓ ⊢ b+--          ΔΓ ⊢ i : I+--          ΔΓ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : b+telViewUpToPathBoundary :: PureTCM m => Int -> Type -> m (TelView, Boundary)+telViewUpToPathBoundary i a = do+   (telv@(TelV tel b), bs) <- telViewUpToPathBoundary' i a+   return (telv, fullBoundary tel bs)++{-# INLINE telViewPathBoundary #-}+telViewPathBoundary :: PureTCM m => Type -> m (TelView, Boundary)+telViewPathBoundary = telViewUpToPathBoundary' (-1)+++-- | @teleElimsB args bs = es@+--  Input:  Δ.Γ ⊢ args : Γ+--          Δ.Γ ⊢ T is the codomain of the PathP at variable i+--          Δ.Γ ⊢ i : I+--          Δ.Γ ⊢ bs = [ (i=0) -> t_i; (i=1) -> u_i ] : T+--  Output: Δ.Γ | PiPath Γ bs A ⊢ es : A+teleElims :: DeBruijn a => Telescope -> Boundary' Int a -> [Elim' a]+teleElims tel (Boundary []) = map Apply $ teleArgs tel+teleElims tel (Boundary boundary) = map updateArg $ teleArgs tel+  where+    matchVar i = snd <$> find ((i ==) . fst) boundary+    updateArg a@(Arg info p) =+      case deBruijnView p of+        Just i | Just (t,u) <- matchVar i -> IApply t u p+        _                                 -> Apply a++{-# SPECIALIZE pathViewAsPi :: Type -> TCM (Either (Dom Type, Abs Type) Type) #-}+-- | Reduces 'Type'.+pathViewAsPi+  :: PureTCM m => Type -> m (Either (Dom Type, Abs Type) Type)+pathViewAsPi t = either (Left . fst) Right <$> pathViewAsPi' t++{-# SPECIALIZE pathViewAsPi' :: Type -> TCM (Either ((Dom Type, Abs Type), (Term,Term)) Type) #-}+-- | Reduces 'Type'.+pathViewAsPi'+  :: PureTCM m => Type -> m (Either ((Dom Type, Abs Type), (Term,Term)) Type)+pathViewAsPi' t = do+  pathViewAsPi'whnf <*> reduce t++{-# SPECIALIZE pathViewAsPi'whnf :: TCM (Type -> Either ((Dom Type, Abs Type), (Term,Term)) Type) #-}+pathViewAsPi'whnf+  :: (HasBuiltins m)+  => m (Type -> Either ((Dom Type, Abs Type), (Term,Term)) Type)+pathViewAsPi'whnf = do+  view <- pathView'+  minterval  <- getTerm' builtinInterval+  return $ \case+    (view -> PathType s l p a x y) | Just interval <- minterval ->+      let name | Lam _ (Abs n _) <- unArg a = n+               | otherwise = "i"+      in+        Left ( ( defaultDom $ El intervalSort interval+               , Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0]+               )+             , (unArg x, unArg y)+             )++    t    -> Right t++-- | Returns @Left (a,b)@ in case the type is @Pi a b@ or @PathP b _ _@.+--   Assumes the 'Type' is in whnf.+piOrPath :: HasBuiltins m => Type -> m (Either (Dom Type, Abs Type) Type)+piOrPath t = do+  (pathViewAsPi'whnf <*> pure t) <&> \case+    Left (p, _)           -> Left p+    Right (El _ (Pi a b)) -> Left (a,b)+    Right _               -> Right t++-- | Assumes 'Type' is in whnf.+telView'UpToPath :: Int -> Type -> TCM TelView+telView'UpToPath n t = if n == 0 then done else do+  piOrPath t >>= \case+    Left (a, b) -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)+    Right _     -> done+  where+    done = return $ TelV EmptyTel t++telView'Path :: Type -> TCM TelView+telView'Path = telView'UpToPath (-1)++isPath :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type))+isPath t = ifPath t (\a b -> return $ Just (a,b)) (const $ return Nothing)++ifPath :: PureTCM m => Type -> (Dom Type -> Abs Type -> m a) -> (Type -> m a) -> m a+ifPath t yes no = ifPathB t yes $ no . ignoreBlocking++{-# SPECIALIZE ifPathB :: Type -> (Dom Type -> Abs Type -> TCM a) -> (Blocked Type -> TCM a) -> TCM a #-}+ifPathB :: PureTCM m => Type -> (Dom Type -> Abs Type -> m a) -> (Blocked Type -> m a) -> m a+ifPathB t yes no = ifBlocked t+  (\b t -> no $ Blocked b t)+  (\nb t -> caseEitherM (pathViewAsPi'whnf <*> pure t)+    (uncurry yes . fst)+    (no . NotBlocked nb))++ifNotPathB :: PureTCM m => Type -> (Blocked Type -> m a) -> (Dom Type -> Abs Type -> m a) -> m a+ifNotPathB = flip . ifPathB++ifPiOrPathB :: PureTCM m => Type -> (Dom Type -> Abs Type -> m a) -> (Blocked Type -> m a) -> m a+ifPiOrPathB t yes no = ifPiTypeB t+  (\a b -> yes a b)+  (\bt -> caseEitherM (pathViewAsPi'whnf <*> pure (ignoreBlocking bt))+    (uncurry yes . fst)+    (no . (bt $>)))++ifNotPiOrPathB :: PureTCM m => Type -> (Blocked Type -> m a) -> (Dom Type -> Abs Type -> m a) -> m a+ifNotPiOrPathB = flip . ifPiOrPathB++telePatterns :: DeBruijn a => Telescope -> Boundary -> [NamedArg (Pattern' a)]+telePatterns = telePatterns' teleNamedArgs++telePatterns' :: DeBruijn a =>+                (forall a. (DeBruijn a) => Telescope -> [NamedArg a]) -> Telescope -> Boundary -> [NamedArg (Pattern' a)]+telePatterns' f tel (Boundary []) = f tel+telePatterns' f tel (Boundary boundary) = recurse $ f tel+  where+    recurse = (fmap . fmap . fmap) updateVar+    matchVar i = snd <$> find ((i ==) . fst) boundary+    updateVar x =+      case deBruijnView x of+        Just i | Just (t,u) <- matchVar i -> IApplyP defaultPatternInfo t u x+        _                                 -> VarP defaultPatternInfo x+ -- | Decomposing a function type. -mustBePi :: MonadTCM tcm => Type -> tcm (Dom Type, Abs Type)-mustBePi t = ifNotPiType t __IMPOSSIBLE__ $ \ a b -> return (a,b)+mustBePi :: MonadReduce m => Type -> m (Dom Type, Abs Type)+mustBePi t = ifNotPiType t __IMPOSSIBLE__ $ curry return  -- | If the given type is a @Pi@, pass its parts to the first continuation. --   If not (or blocked), pass the reduced type to the second continuation.-ifPi :: MonadTCM tcm => Term -> (Dom Type -> Abs Type -> tcm a) -> (Term -> tcm a) -> tcm a-ifPi t yes no = do-  t <- liftTCM $ reduce t-  case ignoreSharing t of+ifPi :: MonadReduce m => Term -> (Dom Type -> Abs Type -> m a) -> (Term -> m a) -> m a+ifPi t yes no = ifPiB t yes (no . ignoreBlocking)++ifPiB :: (MonadReduce m) => Term -> (Dom Type -> Abs Type -> m a) -> (Blocked Term -> m a) -> m a+ifPiB t yes no = ifBlocked t+  (\b t -> no $ Blocked b t) -- Pi type is never blocked+  (\nb t -> case t of     Pi a b -> yes a b-    _      -> no t+    _      -> no $ NotBlocked nb t) +ifPiTypeB :: (MonadReduce m) => Type -> (Dom Type -> Abs Type -> m a) -> (Blocked Type -> m a) -> m a+ifPiTypeB (El s t) yes no = ifPiB t yes (\bt -> no $ El s <$> bt)+ -- | If the given type is a @Pi@, pass its parts to the first continuation. --   If not (or blocked), pass the reduced type to the second continuation.-ifPiType :: MonadTCM tcm => Type -> (Dom Type -> Abs Type -> tcm a) -> (Type -> tcm a) -> tcm a+ifPiType :: MonadReduce m => Type -> (Dom Type -> Abs Type -> m a) -> (Type -> m a) -> m a ifPiType (El s t) yes no = ifPi t yes (no . El s)  -- | If the given type is blocked or not a @Pi@, pass it reduced to the first continuation. --   If it is a @Pi@, pass its parts to the second continuation.-ifNotPi :: MonadTCM tcm => Term -> (Term -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a+ifNotPi :: MonadReduce m => Term -> (Term -> m a) -> (Dom Type -> Abs Type -> m a) -> m a ifNotPi = flip . ifPi  -- | If the given type is blocked or not a @Pi@, pass it reduced to the first continuation. --   If it is a @Pi@, pass its parts to the second continuation.-ifNotPiType :: MonadTCM tcm => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a+ifNotPiType :: MonadReduce m => Type -> (Type -> m a) -> (Dom Type -> Abs Type -> m a) -> m a ifNotPiType = flip . ifPiType --- | A safe variant of piApply.+ifNotPiOrPathType :: (MonadReduce tcm, HasBuiltins tcm) => Type -> (Type -> tcm a) -> (Dom Type -> Abs Type -> tcm a) -> tcm a+ifNotPiOrPathType t no yes = do+  ifPiType t yes (\ t -> either (uncurry yes . fst) (const $ no t) =<< (pathViewAsPi'whnf <*> pure t)) -piApplyM :: Type -> Args -> TCM Type-piApplyM t []           = return t-piApplyM t (arg : args) = do-  (_, b) <- mustBePi t-  absApp b (unArg arg) `piApplyM` args+shouldBePath :: (PureTCM m, MonadBlock m, MonadTCError m) => Type -> m (Dom Type, Abs Type)+shouldBePath t = ifPathB t+  (curry return)+  (fromBlocked >=> \case+    El _ Dummy{} -> return (__DUMMY_DOM__, Abs "x" __DUMMY_TYPE__)+    t -> typeError $ ShouldBePath t) -piApply1 :: MonadTCM tcm => Type -> Term -> tcm Type-piApply1 t v = do-  (_, b) <- mustBePi t-  return $ absApp b v+shouldBePi :: (PureTCM m, MonadBlock m, MonadTCError m) => Type -> m (Dom Type, Abs Type)+shouldBePi t = ifPiTypeB t+  (curry return)+  (fromBlocked >=> \case+    El _ Dummy{} -> return (__DUMMY_DOM__, Abs "x" __DUMMY_TYPE__)+    t -> typeError $ ShouldBePi t) --- | Given a function type, introduce its domain into---   the context and continue with its codomain.+shouldBePiOrPath :: (PureTCM m, MonadBlock m, MonadTCError m) => Type -> m (Dom Type, Abs Type)+shouldBePiOrPath t = ifPiOrPathB t+  (curry return)+  (fromBlocked >=> \case+    El _ Dummy{} -> return (__DUMMY_DOM__, Abs "x" __DUMMY_TYPE__)+    t -> typeError $ ShouldBePi t) -- TODO: separate error -intro1 :: (MonadTCM tcm) => Type -> (Type -> tcm a) -> tcm a-intro1 t cont = do-  (a, b) <- mustBePi t-  underAbstraction a b cont+-- | A safe variant of 'piApply'. ------------------------------------------------------------------------------- * Instance definitions----------------------------------------------------------------------------+class PiApplyM a where+  piApplyM' :: (MonadReduce m, HasBuiltins m) => m Empty -> Type -> a -> m Type -addTypedInstance :: QName -> Type -> TCM ()-addTypedInstance x t = do-  n <- getOutputTypeName t-  case n of-    OutputTypeName n -> addNamedInstance x n-    OutputTypeNameNotYetKnown -> addUnknownInstance x-    NoOutputTypeName -> typeError $ WrongInstanceDeclaration-    OutputTypeVar -> typeError $ WrongInstanceDeclaration+  piApplyM :: (MonadReduce m, HasBuiltins m) => Type -> a -> m Type+  piApplyM = piApplyM' __IMPOSSIBLE__+  {-# INLINE piApplyM #-} -resolveUnknownInstanceDefs :: TCM ()-resolveUnknownInstanceDefs = do-  anonInstanceDefs <- getAnonInstanceDefs-  clearAnonInstanceDefs-  forM_ anonInstanceDefs $ \ n -> addTypedInstance n =<< typeOfConst n+instance PiApplyM Term where+  piApplyM' err t v = ifNotPiOrPathType t (\_ -> absurd <$> err) {-else-} $ \ _ b -> return $ absApp b v+  {-# INLINABLE piApplyM' #-} --- | 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-  resolveUnknownInstanceDefs-  insts <- getAllInstanceDefs-  unless (null $ snd insts) $-    typeError $ GenericError $ "There are instances whose type is still unsolved"-  return $ fst insts+{-# SPECIALIZE piApplyM' :: TCM Empty -> Type -> Term -> TCM Type #-}++instance PiApplyM a => PiApplyM (Arg a) where+  piApplyM' err t = piApplyM' err t . unArg++instance PiApplyM a => PiApplyM (Named n a) where+  piApplyM' err t = piApplyM' err t . namedThing++instance PiApplyM a => PiApplyM [a] where+  piApplyM' err t = foldl (\ mt v -> mt >>= \t -> (piApplyM' err t v)) (return t)+++-- | Compute type arity++typeArity :: Type -> TCM Nat+typeArity t = do+  TelV tel _ <- telView t+  return (size tel)++-- | Fold a telescope into a monadic computation, adding variables to the+-- context at each step.++foldrTelescopeM+  :: MonadAddContext m+  => (Dom (ArgName, Type) -> m b -> m b)+  -> m b+  -> Telescope+  -> m b+foldrTelescopeM f b = go+  where+    go EmptyTel = b+    go (ExtendTel a tel) =+      f ((absName tel,) <$> a) $ underAbstraction a tel go
src/full/Agda/TypeChecking/Telescope.hs-boot view
@@ -1,9 +1,23 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Telescope where +import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Context (MonadAddContext)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Substitute+import Agda.Utils.Empty (Empty) -piApplyM :: Type -> Args -> TCM Type-telView :: Type -> TCM TelView+class PiApplyM a where+  piApplyM' :: (MonadReduce m, HasBuiltins m) => m Empty -> Type -> a -> m Type++  piApplyM :: (MonadReduce m, HasBuiltins m) => Type -> a -> m Type+  piApplyM = piApplyM' __IMPOSSIBLE__++instance PiApplyM Term where+instance PiApplyM a => PiApplyM (Arg a) where+instance PiApplyM a => PiApplyM [a] where++telView :: (MonadReduce m, MonadAddContext m) => Type -> m TelView
+ src/full/Agda/TypeChecking/Telescope/Path.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Telescope.Path where++import Prelude hiding (null)++import qualified Data.List as List+import Data.Maybe++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope++import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Size++import Agda.Utils.Impossible+++-- | In an ambient context Γ, @telePiPath f lams Δ t bs@ builds a type that+-- can be @'telViewPathBoundary'@ed into (TelV Δ t, bs').+--   Γ.Δ ⊢ t+--   bs = [(i,u_i)]+--   Δ = Δ0,(i : I),Δ1+--   ∀ b ∈ {0,1}.  Γ.Δ0 | lams Δ1 (u_i .b) : (telePiPath f Δ1 t bs)(i = b) -- kinda: see lams+--   Γ ⊢ telePiPath f Δ t bs+telePiPath :: (Abs Type -> Abs Type) -> ([Arg ArgName] -> Term -> Term) -> Telescope -> Type -> Boundary -> TCM Type+telePiPath = \ reAbs lams tel t (Boundary bs) -> do+  pathP <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPathP+  let+    loop :: [Int] -> Telescope -> TCM Type+    loop []     EmptyTel          = return t+    loop (x:xs) (ExtendTel a tel) = do+        b <- traverse (loop xs) tel+        case List.find ((x ==) . fst) bs of+          -- Create a Path type.+          Just (_,(u0,u1)) -> do+            let names = teleArgNames $ unAbs tel+            -- assume a = 𝕀+            l <- getLevel b+            return $ El (Type l) $+              pathP `apply`+                [ argH (Level l)+                , argN (Lam defaultArgInfo (unEl <$> b))+                , argN $ lams names u0+                , argN $ lams names u1+                ]+          Nothing    -> do+            -- Create a Π type.+            return $ El (mkPiSort a b) (Pi a (reAbs b))+    loop (_:_) EmptyTel    = __IMPOSSIBLE__+    loop []    ExtendTel{} = __IMPOSSIBLE__+  loop (downFrom (size tel)) tel+  where+    argN = Arg defaultArgInfo+    argH = Arg $ setHiding Hidden defaultArgInfo+    getLevel :: Abs Type -> TCM Level+    getLevel b = do+      s <- reduce $ getSort <$> b+      -- 'reAbs' ensures that 'Abs' correctly indicates an occurrence of the bound variable.+      case reAbs s of+        NoAbs _ (Type l) -> return l+        _ -> typeError $ PathAbstractionFailed b+          -- Andreas, 2025-04-17, not impossible after all, see issue #7803.+          --+          -- Previously: 2024-10-07, issue #7413+          -- Andrea writes in https://github.com/agda/agda/issues/7413#issuecomment-2396146135+          --+          -- I believe this is actually impossible at the moment+          -- unless generalized Path types were implemented while I wasn't looking:+          --+          -- telePathPi only does this check if there's a boundary,+          -- which should only be introduced by a PathP copattern,+          -- which then should ensure the result type is in Type lvl+          -- for some lvl that does not depend on on the interval+          -- variable of the path.++-- | @telePiPath_ Δ t [(i,u)]@+--   Δ ⊢ t+--   i ∈ Δ+--   Δ ⊢ u_b : t  for  b ∈ {0,1}+telePiPath_ :: Telescope -> Type -> Boundary -> TCM Type+telePiPath_ tel t bndry = do+  reportSDoc "tc.tel.path" 40                  $ text "tel  " <+> prettyTCM tel+  reportSDoc "tc.tel.path" 40 $ addContext tel $ text "type " <+> prettyTCM t+  reportSDoc "tc.tel.path" 40 $ addContext tel $ text "bndry" <+> pretty bndry++  telePiPath id argsLam tel t bndry+ where+   argsLam args tm = strengthenS impossible 1 `applySubst`+     foldr (\ Arg{argInfo = ai, unArg = x} -> Lam ai . Abs x) tm args++-- | arity of the type, including both Pi and Path.+--   Does not reduce the type.+arityPiPath :: Type -> TCM Int+arityPiPath t = do+  piOrPath t >>= \case+    Left (_, u) -> (+ 1) <$> arityPiPath (unAbs u)+    Right _     -> return 0++-- | Collect the interval copattern variables as list of de Bruijn indices.+class IApplyVars p where+  iApplyVars :: p -> [Int]++instance DeBruijn a => IApplyVars (Pattern' a) where+  iApplyVars = \case+    IApplyP _ t u x -> [ fromMaybe __IMPOSSIBLE__ $ deBruijnView x ]+    VarP{}          -> []+    ProjP{}         -> []+    LitP{}          -> []+    DotP{}          -> []+    DefP _ _ ps     -> iApplyVars ps+    ConP _ _ ps     -> iApplyVars ps++instance IApplyVars p => IApplyVars (NamedArg p) where+  iApplyVars = iApplyVars . namedArg++instance IApplyVars p => IApplyVars [p] where+  iApplyVars = concatMap iApplyVars++{-# SPECIALIZE isInterval :: Type -> TCM Bool #-}+-- | Check whether a type is the built-in interval type.+isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool+isInterval t = liftTCM $ do+  caseMaybeM (getName' builtinInterval) (return False) $ \ i -> do+  reduce (unEl t) <&> \case+    Def q [] -> q == i+    _        -> False
src/full/Agda/TypeChecking/Unquote.hs view
@@ -1,687 +1,1215 @@-{-# LANGUAGE CPP               #-}--module Agda.TypeChecking.Unquote where--import Control.Arrow ((&&&), (***), first, second)-import Control.Applicative-import Control.Monad.State (StateT(..), evalStateT, get, gets, put, modify)-import Control.Monad.Reader (ReaderT(..), ask, asks)-import Control.Monad.Writer (WriterT(..), execWriterT, runWriterT, tell)-import Control.Monad.Trans (lift)-import Control.Monad--import Data.Char-import Data.Maybe (fromMaybe)-import Data.Traversable (traverse)-import Data.Map (Map)-import qualified Data.Map as Map--import Agda.Syntax.Common-import Agda.Syntax.Internal as I-import qualified Agda.Syntax.Reflected as R-import Agda.Syntax.Literal-import Agda.Syntax.Position-import Agda.Syntax.Fixity-import Agda.Syntax.Info-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Translation.ReflectedToAbstract--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Datatypes ( getConHead )-import Agda.TypeChecking.DropArgs-import Agda.TypeChecking.Free-import Agda.TypeChecking.Level-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Exception-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Reduce.Monad-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Quote-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.EtaContract-import Agda.TypeChecking.Primitive--import {-# SOURCE #-} Agda.TypeChecking.Rules.Term-import {-# SOURCE #-} Agda.TypeChecking.Rules.Def--import Agda.Utils.Except-import Agda.Utils.Impossible-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Permutation ( Permutation(Perm), compactP )-import Agda.Utils.String ( Str(Str), unStr )-import Agda.Utils.VarSet (VarSet)-import qualified Agda.Utils.VarSet as Set-import Agda.Utils.Maybe.Strict (toLazy)-import Agda.Utils.FileName-import Agda.Utils.Lens--#include "undefined.h"--agdaTermType :: TCM Type-agdaTermType = El (mkType 0) <$> primAgdaTerm--agdaTypeType :: TCM Type-agdaTypeType = agdaTermType--qNameType :: TCM Type-qNameType = El (mkType 0) <$> primQName--data Dirty = Dirty | Clean-  deriving (Eq)---- Keep track of the original context. We need to use that when adding new--- definitions. Also state snapshot from last commit and whether the state is--- dirty (definitions have been added).-type UnquoteState = (Dirty, TCState)-type UnquoteM = ReaderT Context (StateT UnquoteState (WriterT [QName] (ExceptionT UnquoteError TCM)))--type UnquoteRes a = Either UnquoteError ((a, UnquoteState), [QName])--unpackUnquoteM :: UnquoteM a -> Context -> UnquoteState -> TCM (UnquoteRes a)-unpackUnquoteM m cxt s = runExceptionT $ runWriterT $ runStateT (runReaderT m cxt) s--packUnquoteM :: (Context -> UnquoteState -> TCM (UnquoteRes a)) -> UnquoteM a-packUnquoteM f = ReaderT $ \ cxt -> StateT $ \ s -> WriterT $ ExceptionT $ f cxt s--runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError (a, [QName]))-runUnquoteM m = do-  cxt <- asks envContext-  s   <- get-  z   <- unpackUnquoteM m cxt (Clean, s)-  case z of-    Left err              -> return $ Left err-    Right ((x, _), decls) -> Right (x, decls) <$ mapM_ isDefined decls-  where-    isDefined x = do-      def <- theDef <$> getConstInfo x-      case def of-        Function{funClauses = []} -> genericError $ "Missing definition for " ++ show x-        _       -> return ()--liftU :: TCM a -> UnquoteM a-liftU = lift . lift . lift . lift--liftU1 :: (TCM (UnquoteRes a) -> TCM (UnquoteRes b)) -> UnquoteM a -> UnquoteM b-liftU1 f m = packUnquoteM $ \ cxt s -> f (unpackUnquoteM m cxt s)--liftU2 :: (TCM (UnquoteRes a) -> TCM (UnquoteRes b) -> TCM (UnquoteRes c)) -> UnquoteM a -> UnquoteM b -> UnquoteM c-liftU2 f m1 m2 = packUnquoteM $ \ cxt s -> f (unpackUnquoteM m1 cxt s) (unpackUnquoteM m2 cxt s)--inOriginalContext :: UnquoteM a -> UnquoteM a-inOriginalContext m =-  packUnquoteM $ \ cxt s ->-    modifyContext (const cxt) $ unpackUnquoteM m cxt s--isCon :: ConHead -> TCM Term -> UnquoteM Bool-isCon con tm = do t <- liftU tm-                  case ignoreSharing t of-                    Con con' _ _ -> return (con == con')-                    _ -> return False--isDef :: QName -> TCM Term -> UnquoteM Bool-isDef f tm = do-  t <- liftU (etaContract =<< normalise =<< tm)-  case ignoreSharing t of-    Def g _ -> return (f == g)-    _       -> return False--reduceQuotedTerm :: Term -> UnquoteM Term-reduceQuotedTerm t = do-  b <- liftU $ ifBlocked t (\ m _ -> pure $ Left  m)-                           (\ t   -> pure $ Right t)-  case b of-    Left m  -> do s <- gets snd; throwException $ BlockedOnMeta s m-    Right t -> return t--class Unquote a where-  unquote :: I.Term -> UnquoteM a--unquoteN :: Unquote a => Arg Term -> UnquoteM a-unquoteN a | notHidden a && isRelevant a =-    unquote $ unArg a-unquoteN a = throwException $ BadVisibility "visible" a--choice :: Monad m => [(m Bool, m a)] -> m a -> m a-choice [] dflt = dflt-choice ((mb, mx) : mxs) dflt = ifM mb mx $ choice mxs dflt--ensureDef :: QName -> UnquoteM QName-ensureDef x = do-  i <- liftU $ (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom  -- for recursive unquoteDecl-  case i of-    Constructor{} -> do-      def <- liftU $ prettyTCM =<< primAgdaTermDef-      con <- liftU $ prettyTCM =<< primAgdaTermCon-      throwException $ ConInsteadOfDef x (show def) (show con)-    _ -> return x--ensureCon :: QName -> UnquoteM QName-ensureCon x = do-  i <- liftU $ (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom  -- for recursive unquoteDecl-  case i of-    Constructor{} -> return x-    _ -> do-      def <- liftU $ prettyTCM =<< primAgdaTermDef-      con <- liftU $ prettyTCM =<< primAgdaTermCon-      throwException $ DefInsteadOfCon x (show def) (show con)--pickName :: R.Type -> String-pickName a =-  case a of-    R.Pi{}   -> "f"-    R.Sort{} -> "A"-    R.Def d _ | c:_ <- show (qnameName d),-              isAlpha c -> [toLower c]-    _        -> "_"--instance Unquote ArgInfo where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [h,r] -> do-        choice-          [(c `isCon` primArgArgInfo, ArgInfo <$> unquoteN h <*> unquoteN r <*> pure Reflected <*> pure False)]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "arg info" t--instance Unquote a => Unquote (Arg a) where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [info,x] -> do-        choice-          [(c `isCon` primArgArg, Arg <$> unquoteN info <*> unquoteN x)]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "arg" t---- Andreas, 2013-10-20: currently, post-fix projections are not part of the--- quoted syntax.-instance Unquote R.Elim where-  unquote t = R.Apply <$> unquote t--instance Unquote Bool where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] ->-        choice [ (c `isCon` primTrue,  pure True)-               , (c `isCon` primFalse, pure False) ]-               __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "boolean" t--instance Unquote Integer where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitNat _ n) -> return n-      _ -> throwException $ NonCanonical "integer" t--instance Unquote Double where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitFloat _ x) -> return x-      _ -> throwException $ NonCanonical "float" t--instance Unquote Char where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitChar _ x) -> return x-      _ -> throwException $ NonCanonical "char" t--instance Unquote Str where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitString _ x) -> return (Str x)-      _ -> throwException $ NonCanonical "string" t--unquoteString :: Term -> UnquoteM String-unquoteString x = unStr <$> unquote x--unquoteNString :: Arg Term -> UnquoteM String-unquoteNString x = unStr <$> unquoteN x--data ErrorPart = StrPart String | TermPart R.Term | NamePart QName--instance PrettyTCM ErrorPart where-  prettyTCM (StrPart s) = text s-  prettyTCM (TermPart t) = prettyTCM t-  prettyTCM (NamePart x) = prettyTCM x--instance Unquote ErrorPart where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [x] ->-        choice [ (c `isCon` primAgdaErrorPartString, StrPart  <$> unquoteNString x)-               , (c `isCon` primAgdaErrorPartTerm,   TermPart <$> unquoteN x)-               , (c `isCon` primAgdaErrorPartName,   NamePart <$> unquoteN x) ]-               __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "error part" t--instance Unquote a => Unquote [a] where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [x,xs] -> do-        choice-          [(c `isCon` primCons, (:) <$> unquoteN x <*> unquoteN xs)]-          __IMPOSSIBLE__-      Con c _ [] -> do-        choice-          [(c `isCon` primNil, return [])]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "list" t--instance Unquote Hiding where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] -> do-        choice-          [(c `isCon` primHidden,  return Hidden)-          ,(c `isCon` primInstance, return Instance)-          ,(c `isCon` primVisible, return NotHidden)]-          __IMPOSSIBLE__-      Con c _ vs -> __IMPOSSIBLE__-      _        -> throwException $ NonCanonical "visibility" t--instance Unquote Relevance where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] -> do-        choice-          [(c `isCon` primRelevant,   return Relevant)-          ,(c `isCon` primIrrelevant, return Irrelevant)]-          __IMPOSSIBLE__-      Con c _ vs -> __IMPOSSIBLE__-      _        -> throwException $ NonCanonical "relevance" t--instance Unquote QName where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitQName _ x) -> return x-      _                  -> throwException $ NonCanonical "name" t--instance Unquote a => Unquote (R.Abs a) where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [x,y] -> do-        choice-          [(c `isCon` primAbsAbs, R.Abs <$> (hint <$> unquoteNString x) <*> unquoteN y)]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "abstraction" t--    where hint x | not (null x) = x-                 | otherwise    = "_"--getCurrentPath :: TCM AbsolutePath-getCurrentPath = fromMaybe __IMPOSSIBLE__ <$> asks envCurrentPath--instance Unquote MetaId where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Lit (LitMeta r f x) -> liftU $ do-        live <- (f ==) <$> getCurrentPath-        unless live $ do-            m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f-            typeError . GenericDocError =<<-              sep [ text "Can't unquote stale metavariable"-                  , pretty m <> text "." <> pretty x ]-        return x-      _ -> throwException $ NonCanonical "meta variable" t--instance Unquote a => Unquote (Dom a) where-  unquote t = domFromArg <$> unquote t--instance Unquote R.Sort where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] -> do-        choice-          [(c `isCon` primAgdaSortUnsupported, return R.UnknownS)]-          __IMPOSSIBLE__-      Con c _ [u] -> do-        choice-          [(c `isCon` primAgdaSortSet, R.SetS <$> unquoteN u)-          ,(c `isCon` primAgdaSortLit, R.LitS <$> unquoteN u)]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "sort" t--instance Unquote Literal where-  unquote t = do-    t <- reduceQuotedTerm t-    let litMeta r x = do-          file <- liftU getCurrentPath-          return $ LitMeta r file x-    case ignoreSharing t of-      Con c _ [x] ->-        choice-          [ (c `isCon` primAgdaLitNat,    LitNat    noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitFloat,  LitFloat  noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitChar,   LitChar   noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitString, LitString noRange <$> unquoteNString x)-          , (c `isCon` primAgdaLitQName,  LitQName  noRange <$> unquoteN x)-          , (c `isCon` primAgdaLitMeta,   litMeta   noRange =<< unquoteN x) ]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "literal" t--instance Unquote R.Term where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] ->-        choice-          [ (c `isCon` primAgdaTermUnsupported, return R.Unknown) ]-          __IMPOSSIBLE__--      Con c _ [x] -> do-        choice-          [ (c `isCon` primAgdaTermSort,      R.Sort      <$> unquoteN x)-          , (c `isCon` primAgdaTermLit,       R.Lit       <$> unquoteN x) ]-          __IMPOSSIBLE__--      Con c _ [x, y] ->-        choice-          [ (c `isCon` primAgdaTermVar,     R.Var     <$> (fromInteger <$> unquoteN x) <*> unquoteN y)-          , (c `isCon` primAgdaTermCon,     R.Con     <$> (ensureCon =<< unquoteN x) <*> unquoteN y)-          , (c `isCon` primAgdaTermDef,     R.Def     <$> (ensureDef =<< unquoteN x) <*> unquoteN y)-          , (c `isCon` primAgdaTermMeta,    R.Meta    <$> unquoteN x <*> unquoteN y)-          , (c `isCon` primAgdaTermLam,     R.Lam     <$> unquoteN x <*> unquoteN y)-          , (c `isCon` primAgdaTermPi,      mkPi      <$> unquoteN x <*> unquoteN y)-          , (c `isCon` primAgdaTermExtLam,  R.ExtLam  <$> unquoteN x <*> unquoteN y) ]-          __IMPOSSIBLE__-        where-          mkPi :: Dom R.Type -> R.Abs R.Type -> R.Term-          -- TODO: implement Free for reflected syntax so this works again-          --mkPi a (R.Abs "_" b) = R.Pi a (R.Abs x b)-          --  where x | 0 `freeIn` b = pickName (unDom a)-          --          | otherwise    = "_"-          mkPi a (R.Abs "_" b) = R.Pi a (R.Abs (pickName (unDom a)) b)-          mkPi a b = R.Pi a b--      Con{} -> __IMPOSSIBLE__-      Lit{} -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "term" t--instance Unquote R.Pattern where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [] -> do-        choice-          [ (c `isCon` primAgdaPatAbsurd, return R.AbsurdP)-          , (c `isCon` primAgdaPatDot,    return R.DotP)-          ] __IMPOSSIBLE__-      Con c _ [x] -> do-        choice-          [ (c `isCon` primAgdaPatVar,  R.VarP  <$> unquoteNString x)-          , (c `isCon` primAgdaPatProj, R.ProjP <$> unquoteN x)-          , (c `isCon` primAgdaPatLit,  R.LitP  <$> unquoteN x) ]-          __IMPOSSIBLE__-      Con c _ [x, y] -> do-        choice-          [ (c `isCon` primAgdaPatCon, R.ConP <$> unquoteN x <*> unquoteN y) ]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "pattern" t--instance Unquote R.Clause where-  unquote t = do-    t <- reduceQuotedTerm t-    case ignoreSharing t of-      Con c _ [x] -> do-        choice-          [ (c `isCon` primAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x) ]-          __IMPOSSIBLE__-      Con c _ [x, y] -> do-        choice-          [ (c `isCon` primAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y) ]-          __IMPOSSIBLE__-      Con c _ _ -> __IMPOSSIBLE__-      _ -> throwException $ NonCanonical "clause" t---- Unquoting TCM computations ------------------------------------------------- | Argument should be a term of type @Term → TCM A@ for some A. Returns the---   resulting term of type @A@. The second argument is the term for the hole,---   which will typically be a metavariable. This is passed to the computation---   (quoted).-unquoteTCM :: I.Term -> I.Term -> UnquoteM I.Term-unquoteTCM m hole = do-  qhole <- liftU $ quoteTerm hole-  evalTCM (m `apply` [defaultArg qhole])--evalTCM :: I.Term -> UnquoteM I.Term-evalTCM v = do-  v <- reduceQuotedTerm v-  liftU $ reportSDoc "tc.unquote.eval" 90 $ text "evalTCM" <+> prettyTCM v-  let failEval = throwException $ NonCanonical "type checking computation" v--  case ignoreSharing v of-    I.Def f [] ->-      choice [ (f `isDef` primAgdaTCMGetContext, tcGetContext)-             , (f `isDef` primAgdaTCMCommit,     tcCommit) ]-             failEval-    I.Def f [u] ->-      choice [ (f `isDef` primAgdaTCMInferType,          tcFun1 tcInferType          u)-             , (f `isDef` primAgdaTCMNormalise,          tcFun1 tcNormalise          u)-             , (f `isDef` primAgdaTCMReduce,             tcFun1 tcReduce             u)-             , (f `isDef` primAgdaTCMGetType,            tcFun1 tcGetType            u)-             , (f `isDef` primAgdaTCMGetDefinition,      tcFun1 tcGetDefinition      u)-             , (f `isDef` primAgdaTCMIsMacro,            tcFun1 tcIsMacro            u)-             , (f `isDef` primAgdaTCMFreshName,          tcFun1 tcFreshName          u) ]-             failEval-    I.Def f [u, v] ->-      choice [ (f `isDef` primAgdaTCMUnify,      tcFun2 tcUnify      u v)-             , (f `isDef` primAgdaTCMCheckType,  tcFun2 tcCheckType  u v)-             , (f `isDef` primAgdaTCMDeclareDef, uqFun2 tcDeclareDef u v)-             , (f `isDef` primAgdaTCMDefineFun,  uqFun2 tcDefineFun  u v) ]-             failEval-    I.Def f [l, a, u] ->-      choice [ (f `isDef` primAgdaTCMReturn,      return (unElim u))-             , (f `isDef` primAgdaTCMTypeError,   tcFun1 tcTypeError   u)-             , (f `isDef` primAgdaTCMQuoteTerm,   tcQuoteTerm (unElim u))-             , (f `isDef` primAgdaTCMUnquoteTerm, tcFun1 (tcUnquoteTerm (mkT (unElim l) (unElim a))) u)-             , (f `isDef` primAgdaTCMBlockOnMeta, uqFun1 tcBlockOnMeta u) ]-             failEval-    I.Def f [_, _, u, v] ->-      choice [ (f `isDef` primAgdaTCMCatchError,    tcCatchError    (unElim u) (unElim v))-             , (f `isDef` primAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v))-             , (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v))-             , (f `isDef` primAgdaTCMInContext,     tcInContext     (unElim u) (unElim v)) ]-             failEval-    I.Def f [_, _, _, _, m, k] ->-      choice [ (f `isDef` primAgdaTCMBind, tcBind (unElim m) (unElim k)) ]-             failEval-    _ -> failEval-  where-    unElim = unArg . argFromElim-    tcBind m k = do v <- evalTCM m-                    evalTCM (k `apply` [defaultArg v])--    process :: (InstantiateFull a, Normalise a) => a -> TCM a-    process v = do-      norm <- view eUnquoteNormalise-      if norm then normalise v else instantiateFull v--    mkT l a = El s a-      where s = Type $ Max [Plus 0 $ UnreducedLevel l]--    -- Don't catch Unquote errors!-    tcCatchError :: Term -> Term -> UnquoteM Term-    tcCatchError m h =-      liftU2 (\ m1 m2 -> m1 `catchError` \ _ -> m2) (evalTCM m) (evalTCM h)--    tcWithNormalisation :: Term -> Term -> UnquoteM Term-    tcWithNormalisation b m = do-      v <- unquote b-      liftU1 (locally eUnquoteNormalise $ const v) (evalTCM m)--    uqFun1 :: Unquote a => (a -> UnquoteM b) -> Elim -> UnquoteM b-    uqFun1 fun a = do-      a <- unquote (unElim a)-      fun a--    tcFun1 :: Unquote a => (a -> TCM b) -> Elim -> UnquoteM b-    tcFun1 fun = uqFun1 (liftU . fun)--    uqFun2 :: (Unquote a, Unquote b) => (a -> b -> UnquoteM c) -> Elim -> Elim -> UnquoteM c-    uqFun2 fun a b = do-      a <- unquote (unElim a)-      b <- unquote (unElim b)-      fun a b--    tcFun2 :: (Unquote a, Unquote b) => (a -> b -> TCM c) -> Elim -> Elim -> UnquoteM c-    tcFun2 fun = uqFun2 (\ x y -> liftU (fun x y))--    tcFreshName :: Str -> TCM Term-    tcFreshName s = do-      m <- currentModule-      quoteName . qualify m <$> freshName_ (unStr s)--    tcUnify :: R.Term -> R.Term -> TCM Term-    tcUnify u v = do-      (u, a) <- inferExpr        =<< toAbstract_ u-      v      <- flip checkExpr a =<< toAbstract_ v-      equalTerm a u v-      primUnitUnit--    tcBlockOnMeta :: MetaId -> UnquoteM Term-    tcBlockOnMeta x = do-      s <- gets snd-      throwException (BlockedOnMeta s x)--    tcCommit :: UnquoteM Term-    tcCommit = do-      dirty <- gets fst-      when (dirty == Dirty) $-        liftU $ typeError $ GenericError "Cannot use commitTC after declaring new definitions."-      s <- liftU get-      modify (second $ const s)-      liftU primUnitUnit--    tcTypeError :: [ErrorPart] -> TCM a-    tcTypeError err = typeError . GenericDocError =<< fsep (map prettyTCM err)--    tcInferType :: R.Term -> TCM Term-    tcInferType v = do-      (_, a) <- inferExpr =<< toAbstract_ v-      quoteType =<< process a--    tcCheckType :: R.Term -> R.Type -> TCM Term-    tcCheckType v a = do-      a <- isType_ =<< toAbstract_ a-      e <- toAbstract_ v-      v <- checkExpr e a-      quoteTerm =<< process v--    tcQuoteTerm :: Term -> UnquoteM Term-    tcQuoteTerm v = liftU $ quoteTerm =<< process v--    tcUnquoteTerm :: Type -> R.Term -> TCM Term-    tcUnquoteTerm a v = do-      e <- toAbstract_ v-      v <- checkExpr e a-      return v--    tcNormalise :: R.Term -> TCM Term-    tcNormalise v = do-      (v, _) <- inferExpr =<< toAbstract_ v-      quoteTerm =<< normalise v--    tcReduce :: R.Term -> TCM Term-    tcReduce v = do-      (v, _) <- inferExpr =<< toAbstract_ v-      quoteTerm =<< reduce =<< instantiateFull v--    tcGetContext :: UnquoteM Term-    tcGetContext = liftU $ do-      as <- map (fmap snd) <$> getContext-      as <- etaContract =<< process as-      buildList <*> mapM quoteDom as--    extendCxt :: Arg R.Type -> UnquoteM a -> UnquoteM a-    extendCxt a m = do-      a <- liftU $ traverse (isType_ <=< toAbstract_) a-      liftU1 (addContext (domFromArg a :: Dom Type)) m--    tcExtendContext :: Term -> Term -> UnquoteM Term-    tcExtendContext a m = do-      a <- unquote a-      extendCxt a (evalTCM m)--    tcInContext :: Term -> Term -> UnquoteM Term-    tcInContext c m = do-      c <- unquote c-      liftU1 inTopContext $ go c m-      where-        go :: [Arg R.Type] -> Term -> UnquoteM Term-        go []       m = evalTCM m-        go (a : as) m = extendCxt a $ go as m--    constInfo :: QName -> TCM Definition-    constInfo x = getConstInfo x `catchError` \ _ ->-                  genericError $ "Unbound name: " ++ show x--    tcGetType :: QName -> TCM Term-    tcGetType x = quoteType . defType =<< constInfo x--    tcIsMacro :: QName -> TCM Term-    tcIsMacro x = do-      true  <- primTrue-      false <- primFalse-      let qBool True  = true-          qBool False = false-      qBool . isMacro . theDef <$> constInfo x--    tcGetDefinition :: QName -> TCM Term-    tcGetDefinition x = quoteDefn =<< constInfo x--    setDirty :: UnquoteM ()-    setDirty = modify (first $ const Dirty)--    tcDeclareDef :: Arg QName -> R.Type -> UnquoteM Term-    tcDeclareDef (Arg i x) a = inOriginalContext $ do-      setDirty-      let h = getHiding i-          r = getRelevance i-      when (h == Hidden) $ liftU $ typeError . GenericDocError =<< text "Cannot declare hidden function" <+> prettyTCM x-      tell [x]-      liftU $ do-        reportSDoc "tc.unquote.decl" 10 $ sep [ text "declare" <+> prettyTCM x <+> text ":"-                                              , nest 2 $ prettyTCM a ]-        a <- isType_ =<< toAbstract_ a-        alreadyDefined <- isJust <$> tryMaybe (getConstInfo x)-        when alreadyDefined $ genericError $ "Multiple declarations of " ++ show x-        addConstant x $ defaultDefn i x a emptyFunction-        when (h == Instance) $ addTypedInstance x a-        primUnitUnit--    tcDefineFun :: QName -> [R.Clause] -> UnquoteM Term-    tcDefineFun x cs = inOriginalContext $ (setDirty >>) $ liftU $ do-      _ <- getConstInfo x `catchError` \ _ ->-        genericError $ "Missing declaration for " ++ show x-      cs <- mapM (toAbstract_ . QNamed x) cs-      reportSDoc "tc.unquote.def" 10 $ vcat $ map prettyA cs-      let i = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ConcreteDef noRange-      checkFunDef NotDelayed i x cs-      primUnitUnit+module Agda.TypeChecking.Unquote where++import Prelude hiding (null)++import Control.Arrow          ( first, second, (&&&) )+import Control.Monad          ( (<=<) )+import Control.Monad.Except   ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Reader   ( ReaderT(..), runReaderT )+import Control.Monad.State    ( gets, modify, StateT(..), runStateT )+import Control.Monad.Writer   ( MonadWriter(..), WriterT(..), runWriterT )+import Control.Monad.Trans    ( lift )++import Data.Char+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word++import System.Directory (doesFileExist, getPermissions, executable)+import System.Process.Text ( readProcessWithExitCode )+import System.Exit ( ExitCode(..) )++import Agda.Syntax.Common hiding ( Nat )+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Internal as I+import qualified Agda.Syntax.Reflected as R+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract (TypedBindingInfo(tbTacticAttr))+import Agda.Syntax.Abstract.Views+import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.Translation.ConcreteToAbstract+import Agda.Syntax.Literal+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Name (simpleName)+import Agda.Syntax.Position+import Agda.Syntax.Info as Info+import Agda.Syntax.Translation.ReflectedToAbstract+import Agda.Syntax.Scope.Base (KindOfName(ConName, DataName)+                              , scopeLocals, LocalVar(LocalVar), BindingSource(MacroBound) )+import Agda.Syntax.Parser++import Agda.Interaction.Library ( ExeName )+import Agda.Interaction.Options ( optTrustedExecutables, optAllowExec )++import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Free+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Quote+import Agda.TypeChecking.Conversion+import Agda.TypeChecking.EtaContract+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.ReconstructParameters+import Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.Warnings++import {-# SOURCE #-} Agda.TypeChecking.Rules.Term+import {-# SOURCE #-} Agda.TypeChecking.Rules.Def+import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl+import Agda.TypeChecking.Rules.Data++import Agda.Utils.CallStack           ( HasCallStack )+import Agda.Utils.Either+import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Monad+import Agda.Utils.Null+import qualified Agda.Interaction.Options.Lenses as Lens++import Agda.Utils.Impossible++agdaTermType :: TCM Type+agdaTermType = El (mkType 0) <$> primAgdaTerm++agdaTypeType :: TCM Type+agdaTypeType = agdaTermType++qNameType :: TCM Type+qNameType = El (mkType 0) <$> primQName++data Dirty = Dirty | Clean+  deriving (Eq)++-- Keep track of the original context. We need to use that when adding new+-- definitions. Also state snapshot from last commit and whether the state is+-- dirty (definitions have been added).+type UnquoteState = (Dirty, TCState)+type UnquoteM = ReaderT Context (StateT UnquoteState (WriterT [QName] (ExceptT UnquoteError TCM)))++type UnquoteRes a = Either UnquoteError ((a, UnquoteState), [QName])++unpackUnquoteM :: UnquoteM a -> Context -> UnquoteState -> TCM (UnquoteRes a)+unpackUnquoteM m cxt s = runExceptT $ runWriterT $ runStateT (runReaderT m cxt) s++packUnquoteM :: (Context -> UnquoteState -> TCM (UnquoteRes a)) -> UnquoteM a+packUnquoteM f = ReaderT $ \ cxt -> StateT $ \ s -> WriterT $ ExceptT $ f cxt s++runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError (a, [QName]))+runUnquoteM m = do+  cxt <- getContext+  s   <- getTC+  pid <- fresh  -- Create a fresh problem for the unquote call. Used in tcSolveInstances.+  z   <- localTC (\ e -> e { envUnquoteProblem = Just pid })+       $ solvingProblem pid+       $ unpackUnquoteM m cxt (Clean, s)+  case z of+    Left err              -> return $ Left err+    Right ((v, _), decls) -> Right (v, decls) <$ mapM_ isDefined decls+  where+    isDefined x = do+      getConstInfo x <&> theDef >>= \case+        FunctionDefn FunctionData{ _funClauses = cl } -> when (null cl) $+          unquoteError $ MissingDefinition x+        -- Andreas, 2024-10-11:+        -- some of the following cases might be __IMPOSSIBLE__+        AxiomDefn         {} -> return ()+        DataOrRecSigDefn  {} -> return ()+        GeneralizableVar  {} -> return ()+        AbstractDefn      {} -> return ()+        DatatypeDefn      {} -> return ()+        RecordDefn        {} -> return ()+        ConstructorDefn   {} -> return ()+        PrimitiveDefn     {} -> return ()+        PrimitiveSortDefn {} -> return ()++liftU1 :: (TCM (UnquoteRes a) -> TCM (UnquoteRes b)) -> UnquoteM a -> UnquoteM b+liftU1 f m = packUnquoteM $ \ cxt s -> f (unpackUnquoteM m cxt s)++liftU2 :: (TCM (UnquoteRes a) -> TCM (UnquoteRes b) -> TCM (UnquoteRes c)) -> UnquoteM a -> UnquoteM b -> UnquoteM c+liftU2 f m1 m2 = packUnquoteM $ \ cxt s -> f (unpackUnquoteM m1 cxt s) (unpackUnquoteM m2 cxt s)++inOriginalContext :: UnquoteM a -> UnquoteM a+inOriginalContext m =+  packUnquoteM $ \ cxt s -> do+    n <- getContextSize+    escapeContext __IMPOSSIBLE__ (n - length cxt) $ unpackUnquoteM m cxt s++isCon :: ConHead -> TCM (Maybe Term) -> UnquoteM Bool+isCon con tm = do t <- liftTCM tm+                  case t of+                    Just (Con con' _ _) -> return (con == con')+                    _ -> return False++isDef :: QName -> TCM (Maybe Term) -> UnquoteM Bool+isDef f tm = maybe False loop <$> liftTCM tm+  where+    loop (Def g _) = f == g+    loop (Lam _ b) = loop $ unAbs b+    loop _         = False++reduceQuotedTerm :: Term -> UnquoteM Term+reduceQuotedTerm t = locallyReduceAllDefs $ do+  ifBlocked t {-then-} (\ m _ -> do s <- gets snd; throwError $ BlockedOnMeta s m)+              {-else-} (\ _ t -> return t)++class Unquote a where+  unquote :: I.Term -> UnquoteM a++-- | Unquote an @'Arg' 'Term'@ assuming the 'ArgInfo' does not contain information.+-- (This means, it should be visible, relevant, etc., like 'defaultArg').+unquoteN :: (HasCallStack, Unquote a) => Arg Term -> UnquoteM a+unquoteN (Arg info v) =+  if null info then unquote v else __IMPOSSIBLE__+    -- because we have a CallStack, this also includes the caller++choice :: Monad m => [(m Bool, m a)] -> m a -> m a+choice [] dflt = dflt+choice ((mb, mx) : mxs) dflt = ifM mb mx $ choice mxs dflt++ensureDef :: QName -> UnquoteM QName+ensureDef x = do+  i <- either (const defaultAxiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl+  case i of+    Constructor{} -> do+      def <- liftTCM $ prettyTCM =<< primAgdaTermDef+      con <- liftTCM $ prettyTCM =<< primAgdaTermCon+      throwError $ ConInsteadOfDef x (show def) (show con)+    _ -> return x++ensureCon :: QName -> UnquoteM QName+ensureCon x = do+  i <- either (const defaultAxiom) theDef <$> getConstInfo' x  -- for recursive unquoteDecl+  case i of+    Constructor{} -> return x+    _ -> do+      def <- liftTCM $ prettyTCM =<< primAgdaTermDef+      con <- liftTCM $ prettyTCM =<< primAgdaTermCon+      throwError $ DefInsteadOfCon x (show def) (show con)++pickName :: R.Type -> String+pickName a =+  case a of+    R.Pi{}   -> "f"+    R.Sort{} -> "A"+    R.Def d _+      | c : cs  <- prettyShow (qnameName d),+        Just lc <- reallyToLower c,+        not (null cs) || isUpper c -> [lc]+    _        -> "_"+  where+    -- Heuristic (see #5048 for some discussion):+    -- If first character can be `toLower`ed use that, unless the name has only one character and is+    -- already lower case. (to avoid using the same name for the type and the bound variable).+    reallyToLower c+      | toUpper lc /= lc = Just lc+      | otherwise        = Nothing+      where lc = toLower c++-- TODO: reflect Cohesion+-- TODO: reflect ModalPolarity+instance Unquote Modality where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [r,q] <- allApplyElims es ->+        choice+          [(c `isCon` getBuiltin' builtinModalityConstructor,+              Modality <$> unquoteN r+                       <*> unquoteN q+                       <*> pure defaultCohesion+                       <*> pure defaultPolarity)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "modality" t++instance Unquote ArgInfo where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [h,m] <- allApplyElims es ->+        choice+          [(c `isCon` getBuiltin' builtinArgArgInfo,+              ArgInfo <$> unquoteN h+                      <*> unquoteN m+                      <*> pure Reflected+                      <*> pure unknownFreeVariables+                      <*> pure defaultAnnotation)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "arg info" t++instance Unquote a => Unquote (Arg a) where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [info,x] <- allApplyElims es ->+        choice+          [(c `isCon` getBuiltin' builtinArgArg, Arg <$> unquoteN info <*> unquoteN x)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "arg" t++-- Andreas, 2013-10-20: currently, post-fix projections are not part of the+-- quoted syntax.+instance Unquote R.Elim where+  unquote t = R.Apply <$> unquote t++instance Unquote Bool where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice [ (c `isCon` getBuiltin' builtinTrue,  pure True)+               , (c `isCon` getBuiltin' builtinFalse, pure False) ]+               __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "boolean" t++instance Unquote Integer where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitNat n) -> return n+      _ -> throwError $ NonCanonical "integer" t++instance Unquote Word64 where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitWord64 n) -> return n+      _ -> throwError $ NonCanonical "word64" t++instance Unquote Double where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitFloat x) -> return x+      _ -> throwError $ NonCanonical "float" t++instance Unquote Char where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitChar x) -> return x+      _ -> throwError $ NonCanonical "char" t++instance Unquote Text where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitString x) -> return x+      _ -> throwError $ NonCanonical "string" t++unquoteString :: Term -> UnquoteM String+unquoteString x = T.unpack <$> unquote x++unquoteNString :: Arg Term -> UnquoteM Text+unquoteNString = unquoteN++data ErrorPart = StrPart String | TermPart A.Expr | PattPart A.Pattern | NamePart QName++instance PrettyTCM ErrorPart where+  prettyTCM (StrPart s)  = text s+  prettyTCM (TermPart t) = prettyTCM t+  prettyTCM (PattPart p) = prettyTCM p+  prettyTCM (NamePart x) = prettyTCM x++-- | We do a little bit of work here to make it possible to generate nice+--   layout for multi-line error messages. Specifically we split the parts+--   into lines (indicated by \n in a string part) and vcat all the lines.+renderErrorParts :: [ErrorPart] -> TCM Doc+renderErrorParts = vcat . map (hcat . map prettyTCM) . splitLines+  where+    splitLines [] = []+    splitLines (StrPart s : ss) =+      case break (== '\n') s of+        (s0, '\n' : s1) -> [StrPart s0] : splitLines (StrPart s1 : ss)+        (s0, "")        -> consLine (StrPart s0) (splitLines ss)+        _               -> __IMPOSSIBLE__+    splitLines (p@TermPart{} : ss) = consLine p (splitLines ss)+    splitLines (p@PattPart{} : ss) = consLine p (splitLines ss)+    splitLines (p@NamePart{} : ss) = consLine p (splitLines ss)++    consLine l []        = [[l]]+    consLine l (l' : ls) = (l : l') : ls+++instance Unquote ErrorPart where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x] <- allApplyElims es ->+        choice [ (c `isCon` getBuiltin' builtinAgdaErrorPartString, StrPart . T.unpack <$> unquoteNString x)+               , (c `isCon` getBuiltin' builtinAgdaErrorPartTerm,   TermPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Term)))+               , (c `isCon` getBuiltin' builtinAgdaErrorPartPatt,   PattPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Pattern)))+               , (c `isCon` getBuiltin' builtinAgdaErrorPartName,   NamePart <$> unquoteN x) ]+               __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "error part" t++instance Unquote a => Unquote [a] where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x,xs] <- allApplyElims es ->+        choice+          [(c `isCon` getBuiltin' builtinCons, (:) <$> unquoteN x <*> unquoteN xs)]+          __IMPOSSIBLE__+      Con c _ [] ->+        choice+          [(c `isCon` getBuiltin' builtinNil, return [])]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "list" t++instance (Unquote a, Unquote b) => Unquote (a, b) where+  unquote t = do+    t <- reduceQuotedTerm t+    SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+    case t of+      Con c _ es | Just [x,y] <- allApplyElims es ->+        choice+          [(pure (c == sigmaCon), (,) <$> unquoteN x <*> unquoteN y)]+          __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "pair" t++instance Unquote Hiding where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [(c `isCon` getBuiltin' builtinHidden,  return Hidden)+          ,(c `isCon` getBuiltin' builtinInstance, return (Instance NoOverlap))+          ,(c `isCon` getBuiltin' builtinVisible, return NotHidden)]+          __IMPOSSIBLE__+      Con c _ vs -> __IMPOSSIBLE__+      _        -> throwError $ NonCanonical "visibility" t++instance Unquote Relevance where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [(c `isCon` getBuiltin' builtinRelevant,   return relevant)+          ,(c `isCon` getBuiltin' builtinIrrelevant, return irrelevant)]+          __IMPOSSIBLE__+      Con c _ vs -> __IMPOSSIBLE__+      _        -> throwError $ NonCanonical "relevance" t++instance Unquote Quantity where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [(c `isCon` getBuiltin' builtinQuantityω, return $ Quantityω QωInferred)+          ,(c `isCon` getBuiltin' builtinQuantity0, return $ Quantity0 Q0Inferred)]+          __IMPOSSIBLE__+      Con c _ vs -> __IMPOSSIBLE__+      _        -> throwError $ NonCanonical "quantity" t++instance Unquote QName where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Lit (LitQName x) -> return x+      _ -> throwError $ NonCanonical "name" t++instance Unquote a => Unquote (R.Abs a) where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x,y] <- allApplyElims es ->+        choice+          [(c `isCon` getBuiltin' builtinAbsAbs, R.Abs <$> (hint . T.unpack <$> unquoteNString x) <*> unquoteN y)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "abstraction" t++    where hint x | not (null x) = x+                 | otherwise    = "_"++instance Unquote Blocker where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaBlockerAny, UnblockOnAny . Set.fromList <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaBlockerAll, UnblockOnAll . Set.fromList <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaBlockerMeta, UnblockOnMeta <$> unquoteN x)]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "blocker" t++instance Unquote MetaId where+  unquote t = do+    reduceQuotedTerm t >>= \case+      Lit (LitMeta m x) -> x <$ do+        -- We cannot unquote a meta from a different file.+        unlessM ((Just m ==) <$> currentTopLevelModule) do+          throwError $ StaleMeta m x+      t -> throwError $ NonCanonical "meta variable" t++instance Unquote a => Unquote (Dom a) where+  unquote t = domFromArg <$> unquote t++instance Unquote R.Sort where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [(c `isCon` getBuiltin' builtinAgdaSortUnsupported, return R.UnknownS)]+          __IMPOSSIBLE__+      Con c _ es | Just [u] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaSortSet, R.SetS <$> unquoteN u)+          , (c `isCon` getBuiltin' builtinAgdaSortLit, R.LitS <$> unquoteN u)+          , (c `isCon` getBuiltin' builtinAgdaSortProp, R.PropS <$> unquoteN u)+          , (c `isCon` getBuiltin' builtinAgdaSortPropLit, R.PropLitS <$> unquoteN u)+          , (c `isCon` getBuiltin' builtinAgdaSortInf, R.InfS <$> unquoteN u)+          ]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "sort" t++instance Unquote Literal where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaLitNat,    LitNat    <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaLitFloat,  LitFloat  <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaLitChar,   LitChar   <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaLitString, LitString <$> unquoteNString x)+          , (c `isCon` getBuiltin' builtinAgdaLitQName,  LitQName  <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaLitMeta,+             LitMeta+               <$> (fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule)+               <*> unquoteN x)+          ]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "literal" t++instance Unquote R.Term where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ [] ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaTermUnsupported, return R.Unknown) ]+          __IMPOSSIBLE__++      Con c _ es | Just [x] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaTermSort,      R.Sort      <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaTermLit,       R.Lit       <$> unquoteN x)+          ]+          __IMPOSSIBLE__++      Con c _ es | Just [x, y] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaTermVar,     R.Var     <$> (fromInteger <$> unquoteN x) <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermCon,     R.Con     <$> (ensureCon =<< unquoteN x) <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermDef,     R.Def     <$> (ensureDef =<< unquoteN x) <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermMeta,    R.Meta    <$> unquoteN x <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermLam,     R.Lam     <$> unquoteN x <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermPi,      mkPi      <$> unquoteN x <*> unquoteN y)+          , (c `isCon` getBuiltin' builtinAgdaTermExtLam,  do+              ps <- unquoteN x+              es <- unquoteN y+              case ps of+                []     -> throwError $ PatLamWithoutClauses t+                p : ps -> pure $ R.ExtLam (p :| ps) es+            )+          ]+          __IMPOSSIBLE__+        where+          mkPi :: Dom R.Type -> R.Abs R.Type -> R.Term+          -- TODO: implement Free for reflected syntax so this works again+          --mkPi a (R.Abs "_" b) = R.Pi a (R.Abs x b)+          --  where x | 0 `freeIn` b = pickName (unDom a)+          --          | otherwise    = "_"+          mkPi a (R.Abs "_" b) = R.Pi a (R.Abs (pickName (unDom a)) b)+          mkPi a b = R.Pi a b++      Con{} -> __IMPOSSIBLE__+      Lit{} -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "term" t++instance Unquote R.Pattern where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaPatVar,    R.VarP    . fromInteger <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaPatAbsurd, R.AbsurdP . fromInteger <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaPatDot,    R.DotP  <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaPatProj,   R.ProjP <$> unquoteN x)+          , (c `isCon` getBuiltin' builtinAgdaPatLit,    R.LitP  <$> unquoteN x) ]+          __IMPOSSIBLE__+      Con c _ es | Just [x, y] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaPatCon, R.ConP <$> unquoteN x <*> unquoteN y) ]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "pattern" t++instance Unquote R.Clause where+  unquote t = do+    t <- reduceQuotedTerm t+    case t of+      Con c _ es | Just [x, y] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x <*> unquoteN y) ]+          __IMPOSSIBLE__+      Con c _ es | Just [x, y, z] <- allApplyElims es ->+        choice+          [ (c `isCon` getBuiltin' builtinAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y <*> unquoteN z) ]+          __IMPOSSIBLE__+      Con c _ _ -> __IMPOSSIBLE__+      _ -> throwError $ NonCanonical "clause" t++-- Unquoting TCM computations ---------------------------------------------++-- | Argument should be a term of type @Term → TCM A@ for some A. Returns the+--   resulting term of type @A@. The second argument is the term for the hole,+--   which will typically be a metavariable. This is passed to the computation+--   (quoted).+unquoteTCM :: I.Term -> I.Term -> UnquoteM I.Term+unquoteTCM m hole = do+  qhole <- liftTCM $ quoteTerm hole+  evalTCM (m `apply` [defaultArg qhole])++evalTCM :: I.Term -> UnquoteM I.Term+evalTCM v = Bench.billTo [Bench.Typing, Bench.Reflection] do+  v <- reduceQuotedTerm v+  liftTCM $ reportSDoc "tc.unquote.eval" 90 $ "evalTCM" <+> prettyTCM v+  let failEval = throwError $ NonCanonical "type checking computation" v++  case v of+    I.Def f [] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMGetContext,       tcGetContext)+             , (f `isDef` getBuiltin' builtinAgdaTCMCommit,           tcCommit)+             , (f `isDef` getBuiltin' builtinAgdaTCMAskNormalisation, tcAskNormalisation)+             , (f `isDef` getBuiltin' builtinAgdaTCMAskReconstructed, tcAskReconstructed)+             , (f `isDef` getBuiltin' builtinAgdaTCMAskExpandLast,    tcAskExpandLast)+             , (f `isDef` getBuiltin' builtinAgdaTCMAskReduceDefs,    tcAskReduceDefs)+             , (f `isDef` getBuiltin' builtinAgdaTCMSolveInstances,   tcSolveInstances)+             ]+             failEval+    I.Def f [u] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMInferType,                  tcFun1 tcInferType                  u)+             , (f `isDef` getBuiltin' builtinAgdaTCMNormalise,                  tcFun1 tcNormalise                  u)+             , (f `isDef` getBuiltin' builtinAgdaTCMReduce,                     tcFun1 tcReduce                     u)+             , (f `isDef` getBuiltin' builtinAgdaTCMGetType,                    tcFun1 tcGetType                    u)+             , (f `isDef` getBuiltin' builtinAgdaTCMGetDefinition,              tcFun1 tcGetDefinition              u)+             , (f `isDef` getBuiltin' builtinAgdaTCMFormatErrorParts,           tcFun1 tcFormatErrorParts           u)+             , (f `isDef` getBuiltin' builtinAgdaTCMIsMacro,                    tcFun1 tcIsMacro                    u)+             , (f `isDef` getBuiltin' builtinAgdaTCMFreshName,                  tcFun1 tcFreshName                  u)+             , (f `isDef` getBuiltin' builtinAgdaTCMGetInstances,               uqFun1 tcGetInstances               u)+             ]+             failEval+    I.Def f [u, v] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMUnify,      tcFun2 tcUnify      u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMCheckType,  tcFun2 tcCheckType  u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMDeclareDef, uqFun2 tcDeclareDef u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMDeclarePostulate, uqFun2 tcDeclarePostulate u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMDefineData, uqFun2 tcDefineData u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMDefineFun,  uqFun2 tcDefineFun  u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMQuoteOmegaTerm, tcQuoteTerm (sort $ Inf UType 0) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMPragmaForeign, tcFun2 tcPragmaForeign u v)+             , (f `isDef` getBuiltin' builtinAgdaTCMCheckFromString, tcFun2 tcCheckFromString u v)+             ]+             failEval+    I.Def f [l, a, u] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMReturn,             return (unElim u))+             , (f `isDef` getBuiltin' builtinAgdaTCMTypeError,          tcFun1 tcTypeError   u)+             , (f `isDef` getBuiltin' builtinAgdaTCMQuoteTerm,          tcQuoteTerm (mkT (unElim l) (unElim a)) (unElim u))+             , (f `isDef` getBuiltin' builtinAgdaTCMUnquoteTerm,        tcFun1 (tcUnquoteTerm (mkT (unElim l) (unElim a))) u)+             , (f `isDef` getBuiltin' builtinAgdaTCMBlock,              uqFun1 tcBlock u)+             , (f `isDef` getBuiltin' builtinAgdaTCMDebugPrint,         tcFun3 tcDebugPrint l a u)+             , (f `isDef` getBuiltin' builtinAgdaTCMNoConstraints,      tcNoConstraints (unElim u))+             , (f `isDef` getBuiltin' builtinAgdaTCMDeclareData, uqFun3 tcDeclareData l a u)+             , (f `isDef` getBuiltin' builtinAgdaTCMRunSpeculative,     tcRunSpeculative (unElim u))+             , (f `isDef` getBuiltin' builtinAgdaTCMExec, tcFun3 tcExec l a u)+             , (f `isDef` getBuiltin' builtinAgdaTCMPragmaCompile, tcFun3 tcPragmaCompile l a u)+             , (f `isDef` getBuiltin' builtinAgdaTCMWorkOnTypes, tcWorkOnTypes (unElim u))+             ]+             failEval+    I.Def f [_, _, u, v] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMCatchError,        tcCatchError    (unElim u) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMWithReconstructed, tcWithReconstructed (unElim u) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMWithExpandLast,    tcWithExpandLast (unElim u) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMWithReduceDefs,    tcWithReduceDefs (unElim u) (unElim v))+             , (f `isDef` getBuiltin' builtinAgdaTCMInContext,         tcInContext     (unElim u) (unElim v))+             ]+             failEval+    I.Def f [_, _, u, v, w] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v) (unElim w))+             ]+             failEval+    I.Def f [_, _, _, _, m, k] ->+      choice [ (f `isDef` getBuiltin' builtinAgdaTCMBind, tcBind (unElim m) (unElim k)) ]+             failEval+    _ -> failEval+  where+    unElim = unArg . fromMaybe __IMPOSSIBLE__ . isApplyElim+    tcBind m k = do v <- evalTCM m+                    evalTCM (k `apply` [defaultArg v])++    process :: (InstantiateFull a, Normalise a) => a -> TCM a+    process v = do+      norm <- viewTC eUnquoteNormalise+      if norm then normalise v else instantiateFull v++    mkT l a = El s a+      where s = Type $ atomicLevel l++    -- Don't catch Unquote errors!+    tcCatchError :: Term -> Term -> UnquoteM Term+    tcCatchError m h =+      liftU2 (\ m1 m2 -> m1 `catchError` \ _ -> m2) (evalTCM m) (evalTCM h)++    tcAskLens :: ToTerm a => Lens' TCEnv a -> UnquoteM Term+    tcAskLens l = liftTCM $ do+      toTm <- toTermTCM+      toTm =<< asksTC (\ e -> e ^. l)++    tcWithLens :: Unquote a => Lens' TCEnv a -> Term -> Term -> UnquoteM Term+    tcWithLens l b m = do+      v <- unquote b+      liftU1 (locallyTC l $ const v) (evalTCM m)++    tcWithNormalisation, tcWithReconstructed, tcWithExpandLast, tcWithReduceDefs :: Term -> Term -> UnquoteM Term+    tcWithNormalisation = tcWithLens eUnquoteNormalise+    tcWithReconstructed = tcWithLens eReconstructed+    tcWithExpandLast    = tcWithLens eExpandLastBool+    tcWithReduceDefs    = tcWithLens eReduceDefsPair++    tcAskNormalisation, tcAskReconstructed, tcAskExpandLast, tcAskReduceDefs :: UnquoteM Term+    tcAskNormalisation = tcAskLens eUnquoteNormalise+    tcAskReconstructed = tcAskLens eReconstructed+    tcAskExpandLast    = tcAskLens eExpandLastBool+    tcAskReduceDefs    = tcAskLens eReduceDefsPair++    uqFun1 :: Unquote a => (a -> UnquoteM b) -> Elim -> UnquoteM b+    uqFun1 fun a = do+      a <- unquote (unElim a)+      fun a++    tcFun1 :: Unquote a => (a -> TCM b) -> Elim -> UnquoteM b+    tcFun1 fun = uqFun1 (liftTCM . fun)++    uqFun2 :: (Unquote a, Unquote b) => (a -> b -> UnquoteM c) -> Elim -> Elim -> UnquoteM c+    uqFun2 fun a b = do+      a <- unquote (unElim a)+      b <- unquote (unElim b)+      fun a b++    uqFun3 :: (Unquote a, Unquote b, Unquote c) => (a -> b -> c -> UnquoteM d) -> Elim -> Elim -> Elim -> UnquoteM d+    uqFun3 fun a b c = do+      a <- unquote (unElim a)+      b <- unquote (unElim b)+      c <- unquote (unElim c)+      fun a b c++    tcFun2 :: (Unquote a, Unquote b) => (a -> b -> TCM c) -> Elim -> Elim -> UnquoteM c+    tcFun2 fun = uqFun2 (\ x y -> liftTCM (fun x y))++    tcFun3 :: (Unquote a, Unquote b, Unquote c) => (a -> b -> c -> TCM d) -> Elim -> Elim -> Elim -> UnquoteM d+    tcFun3 fun = uqFun3 (\ x y z -> liftTCM (fun x y z))++    tcFreshName :: Text -> TCM Term+    tcFreshName s = do+      whenM (viewTC eCurrentlyElaborating) $+        typeError $ NotSupported "declaring new names from an edit-time macro"+      m <- currentModule+      quoteName . qualify m <$> freshName_ (T.unpack s)++    tcUnify :: R.Term -> R.Term -> TCM Term+    tcUnify u v = do+      (u, a) <- locallyReduceAllDefs $ inferExpr        =<< toAbstract_ u+      v      <- locallyReduceAllDefs $ flip checkExpr a =<< toAbstract_ v+      equalTerm a u v+      primUnitUnit++    tcBlock :: Blocker -> UnquoteM Term+    tcBlock x = do+      s <- gets snd+      liftTCM $ reportSDoc "tc.unquote.block" 10 $ pretty (show x)+      throwError (BlockedOnMeta s x)++    tcCommit :: UnquoteM Term+    tcCommit = do+      dirty <- gets fst+      when (dirty == Dirty) $ throwError CommitAfterDef+      s <- getTC+      modify (second $ const s)+      liftTCM primUnitUnit++    tcFormatErrorParts :: [ErrorPart] -> TCM Term+    tcFormatErrorParts msg = quoteString . prettyShow <$> renderErrorParts msg++    tcTypeError :: [ErrorPart] -> TCM a+    tcTypeError err = typeError . GenericDocError =<< renderErrorParts err++    tcDebugPrint :: Text -> Integer -> [ErrorPart] -> TCM Term+    tcDebugPrint s n msg = do+      alwaysReportSDoc (T.unpack s) (fromIntegral n) $ renderErrorParts msg+      primUnitUnit++    tcNoConstraints :: Term -> UnquoteM Term+    tcNoConstraints m = liftU1 reallyNoConstraints (evalTCM m)++    tcWorkOnTypes :: Term -> UnquoteM Term+    tcWorkOnTypes m = liftU1 workOnTypes (evalTCM m)++    tcInferType :: R.Term -> TCM Term+    tcInferType v = do+      r <- isReconstructed+      (_, a) <- inferExpr =<< toAbstract_ v+      if r then do+        a <- process a+        a <- locallyReduceAllDefs $ reconstructParametersInType a+        reportSDoc "tc.reconstruct" 50 $ "Infer after reconstruct:"+          <+> pretty a+        locallyReconstructed (quoteType a)+      else+        quoteType =<< process a++    tcCheckType :: R.Term -> R.Type -> TCM Term+    tcCheckType v a = do+      r <- isReconstructed+      a <- workOnTypes $ locallyReduceAllDefs $ isType_ =<< toAbstract_ a+      e <- toAbstract_ v+      v <- checkExpr e a+      if r then do+        v <- process v+        v <- locallyReduceAllDefs $ reconstructParameters a v+        locallyReconstructed (quoteTerm v)+      else+        quoteTerm =<< process v+++    tcCheckFromString :: Text -> R.Type -> TCM Term+    tcCheckFromString str a = do+      (C.ExprWhere c wh , _) <- runPM $ parsePosString exprWhereParser (startPos Nothing) (T.unpack str)+      r <- isReconstructed+      e <- concreteToAbstract_ c+      a <- workOnTypes $ locallyReduceAllDefs $ isType_ =<< toAbstract_ a++      v <- checkExpr e a+      if r then do+        v <- process v+        v <- locallyReduceAllDefs $ reconstructParameters a v+        locallyReconstructed (quoteTerm v)+      else+        quoteTerm =<< process v+++    tcQuoteTerm :: Type -> Term -> UnquoteM Term+    tcQuoteTerm a v = liftTCM $ do+      r <- isReconstructed+      if r then do+        v <- process v+        v <- locallyReduceAllDefs $ reconstructParameters a v+        locallyReconstructed (quoteTerm v)+      else+        quoteTerm =<< process v++    tcUnquoteTerm :: Type -> R.Term -> TCM Term+    tcUnquoteTerm a v = do+      e <- toAbstract_ v+      checkExpr e a++    tcNormalise :: R.Term -> TCM Term+    tcNormalise v = do+      r <- isReconstructed+      (v, t) <- locallyReduceAllDefs $ inferExpr  =<< toAbstract_ v+      if r then do+        v <- normalise v+        t <- normalise t+        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction t v+        reportSDoc "tc.reconstruct" 50 $ "Normalise reconstruct:" <+> pretty v+        locallyReconstructed $ quoteTerm v+      else+       quoteTerm =<< normalise v++    tcReduce :: R.Term -> TCM Term+    tcReduce v = do+      r <- isReconstructed+      (v, t) <- locallyReduceAllDefs $ inferExpr =<< toAbstract_ v+      if r then do+        v <- reduce =<< instantiateFull v+        t <- reduce =<< instantiateFull t+        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction t v+        reportSDoc "tc.reconstruct" 50 $ "Reduce reconstruct:" <+> pretty v+        locallyReconstructed $ quoteTerm v+      else+        quoteTerm =<< reduce =<< instantiateFull v++    tcGetContext :: UnquoteM Term+    tcGetContext = liftTCM $ do+      r <- isReconstructed+      let getVar (CtxVar x a) = (nameToArgName x, a)+      as <- map getVar <$> getContext+      as <- etaContract =<< process as+      if r then do+        as <- recons (reverse as)+        locallyReconstructed $ buildList <*> mapM quoteDomWithName as+      else+        buildList <*> mapM quoteDomWithName as+      where+        recons :: [(ArgName, Dom Type)] -> TCM [(ArgName, Dom Type)]+        recons []                        = return []+        recons ((s, d@Dom {unDom=t}):ds) = do+          t <- locallyReduceAllDefs $ reconstructParametersInType t+          let d' = d{unDom=t}+          ds' <- addContext (s, d') $ recons ds+          return $ (s, d'):ds'++        quoteDomWithName :: (ArgName, Dom Type) -> TCM Term+        quoteDomWithName (x, a) = do+          toTm <- toTermTCM+          toTm (T.pack x, a)++    extendCxt :: Text -> Arg R.Type -> UnquoteM a -> UnquoteM a+    extendCxt s' a m = withFreshName noRange (T.unpack s') $ \s -> do+      a <- workOnTypes $ locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a++      locallyScope scopeLocals ((simpleName (T.unpack s') , LocalVar s MacroBound []) :)+          $ liftU1 (addContext (s, domFromArg a :: Dom Type)) m++    tcExtendContext :: Term -> Term -> Term -> UnquoteM Term+    tcExtendContext s a m = do+      s <- unquote s+      a <- unquote a+      fmap (strengthen impossible) $ extendCxt s a $ do+        v <- evalTCM $ raise 1 m+        -- 2024-04-20: free variable analysis only really makes sense on normal forms; see #7227+        v <- normalise v+        when (freeIn 0 v) $ liftTCM $ genericDocError =<<+          hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"]+            <?> prettyTCM v+        return v++    tcInContext :: Term -> Term -> UnquoteM Term+    tcInContext c m = do+      c <- unquote c+      inOriginalContext $ go c (evalTCM m)+      where+        go :: [(Text , Arg R.Type)] -> UnquoteM Term -> UnquoteM Term+        go []             m = m+        go ((s , a) : as) m = go as (extendCxt s a m)++    constInfo :: QName -> TCM Definition+    constInfo x = either err return =<< getConstInfo' x+      where err _ = unquoteError $ UnboundName x++    tcGetType :: QName -> TCM Term+    tcGetType x = do+      r  <- isReconstructed+      ci <- constInfo x >>= instantiateDef+      let t = defType ci+      if r then do+        t <- locallyReduceAllDefs $ reconstructParametersInType t+        quoteType t+      else+        quoteType t+++    tcIsMacro :: QName -> TCM Term+    tcIsMacro x = do+      true  <- primTrue+      false <- primFalse+      let qBool True  = true+          qBool False = false+      qBool . isMacro . theDef <$> constInfo x++    tcGetDefinition :: QName -> TCM Term+    tcGetDefinition x = do+      r <- isReconstructed+      if r then+        tcGetDefinitionRecons x+      else+        quoteDefn =<< instantiateDef =<< constInfo x++    tcGetDefinitionRecons :: QName -> TCM Term+    tcGetDefinitionRecons x = do+      ci@(Defn {theDef=d}) <- constInfo x >>= instantiateDef+      case d of+        f@(Function {funClauses=cs}) -> do+          cs' <- mapM reconsClause cs+          locallyReconstructed $ quoteDefn ci{theDef=f{funClauses=cs'}}++        _ -> quoteDefn ci++      where+        reconsClause :: Clause -> TCM Clause+        reconsClause c = do+          tel' <- reconsTel $ clauseTel c+          b' <- case (clauseType c, clauseBody c) of+                (Just t, Just b) ->+                  addContext (clauseTel c) $ do+                     bb <- locallyReduceAllDefs+                           $ reconstructParameters' defaultAction (unArg t) b+                     return $ Just bb+                _ -> return $ clauseBody c+          let c' = c{clauseBody=b', clauseTel=tel'}+          reportSDoc "tc.reconstruct" 50+                   $ "getDefinition reconstructed clause:" <+> pretty c'+          return c'++        reconsTel :: Telescope -> TCM Telescope+        reconsTel EmptyTel = return EmptyTel+        reconsTel (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__+        reconsTel (ExtendTel (d@Dom{unDom=t}) ds@Abs{unAbs=ts}) = do+           t <- locallyReduceAllDefs $ reconstructParametersInType t+           let d' = d{unDom=t}+           ts' <- addContext d' $ reconsTel ts+           return $ ExtendTel d' ds{unAbs=ts'}+++    setDirty :: UnquoteM ()+    setDirty = modify (first $ const Dirty)++    tcDeclareDef_ :: Arg QName -> R.Type -> String -> Defn -> UnquoteM Term+    tcDeclareDef_ (Arg i x) a doc defn = inOriginalContext $ do+      setDirty+      when (hidden i) $ liftTCM $ unquoteError $ CannotDeclareHiddenFunction x+      tell [x]+      liftTCM $ do+        alwaysReportSDoc "tc.unquote.decl" 10 $ sep+          [ "declare" <+> text doc <+> prettyTCM x <+> ":"+          , nest 2 $ prettyR a+          ]+        a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a+        getConstInfo' x >>= \case+          Left _    -> pure ()+          Right def -> typeError $ ClashingDefinition (qnameToConcrete x) (defName def) Nothing+        addConstant' x i a defn+        when (isInstance i) $ addTypedInstance x a+        primUnitUnit++    tcDeclareDef :: Arg QName -> R.Type -> UnquoteM Term+    tcDeclareDef arg a = tcDeclareDef_ arg a "" =<< emptyFunction++    tcDeclarePostulate :: Arg QName -> R.Type -> UnquoteM Term+    tcDeclarePostulate arg@(Arg i x) a = do+      clo <- commandLineOptions+      when (Lens.getSafeMode clo) $ liftTCM $ warning $ SafeFlagPostulate x+      tcDeclareDef_ arg a "Postulate" defaultAxiom++    -- A datatype is expected to be declared with a function type.+    -- The second argument indicates how many preceding types are parameters.+    tcDeclareData :: QName -> Integer -> R.Type -> UnquoteM Term+    tcDeclareData x npars t = inOriginalContext $ do+      setDirty+      tell [x]+      alwaysReportSDoc "tc.unquote.decl" 10 $ sep+        [ "declare Data" <+> prettyTCM x <+> ":"+        , nest 2 $ prettyR t+        ]+      getConstInfo' x >>= \case+        Left _    -> pure ()+        Right def -> liftTCM $ typeError $ ClashingDefinition (qnameToConcrete x) (defName def) Nothing+      e <- liftTCM $ toAbstract_ t+      -- The type to be checked with @checkSig@ is without parameters.+      (tel, e') <- splitPars (fromInteger npars) e+      ac <- asksTC (^. lensIsAbstract)+      let defIn = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange+      liftTCM $ checkSig DataName defIn defaultErased x (A.GeneralizeTel Map.empty tel) e'+      liftTCM primUnitUnit++    tcDefineData :: QName -> [(QName, (Quantity, R.Type))] -> UnquoteM Term+    tcDefineData x cs = inOriginalContext $ (setDirty >>) $ getConstInfo' x >>= \case+      Left _    -> throwError $ MissingDeclaration x+      Right def -> do+        npars <- case theDef def of+                   DataOrRecSig n -> return n+                   _              -> throwError $ DefineDataNotData x++        -- For some reasons, reifying parameters and adding them to the context via+        -- `addContext` before `toAbstract_` is different from substituting the type after+        -- `toAbstract_, so some dummy parameters are added and removed later.+        es <- liftTCM $ mapM (toAbstract_ . addDummy npars . snd . snd) cs+        alwaysReportSDoc "tc.unquote.def" 10 $ vcat $+          [ "declaring constructors of" <+> prettyTCM x <+> ":" ] ++ map prettyA es++        -- Translate parameters from internal definitions back to abstract syntax.+        t   <- instantiateFull . defType =<< instantiateDef def+        tel <- reify =<< theTel <$> telViewUpTo npars t++        es' <- forM es \ e -> do+          (ptel, core) <- splitPars npars e+          -- Mario, 2024-10-18: cannot trigger this error:+          -- genericError "Number of parameters doesn't match!"+          return $ fromMaybe __IMPOSSIBLE__ $ substNames' tel ptel core++        ac <- asksTC (^. lensIsAbstract)+        let i = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange+            conNames = map fst cs+            conQuantities = map (fst . snd) cs+            toAxiom c q e = A.Axiom ConName i (setQuantity q defaultArgInfo) Nothing c e+            as = zipWith3 toAxiom conNames conQuantities es'+            lams = map (\case {A.TBind _ tac (b :| []) _ -> A.DomainFree (tbTacticAttr tac) b+                              ;_ -> __IMPOSSIBLE__ }) tel+        alwaysReportSDoc "tc.unquote.def" 10 $ vcat $+          [ "checking datatype: " <+> prettyTCM x <+> " with constructors:"+          , nest 2 (vcat (map prettyTCM conNames))+          ]+        liftTCM $ checkDataDef i x YesUniverseCheck (A.DataDefParams Set.empty lams) as+        liftTCM primUnitUnit+      where+        addDummy :: Int -> R.Type -> R.Type+        addDummy 0 t = t+        addDummy n t = R.Pi (defaultDom (R.Sort $ R.LitS 0)) (R.Abs "dummy" $ addDummy (n - 1) t)++        substNames' :: [A.TypedBinding] -> [A.TypedBinding] -> A.Expr -> Maybe A.Expr+        substNames' (a : as) (b : bs) e = do+          let (A.TBind _ _ (na :| _) expra) = a+              (A.TBind _ _ (nb :| _) exprb) = b+              getName n = A.unBind . A.binderName $ namedArg n+          e' <- substNames' as bs e+          return $ mapExpr (substName (getName na) (getName nb)) e'+          where+            -- Substitute @Var x@ for @Var y@ in an @Expr@.+            substName :: Name -> Name -> (A.Expr -> A.Expr)+            substName x y e@(A.Var n)+                    | y == n    = A.Var x+                    | otherwise = e+            substName _ _ e = e+        substNames' [] [] e = return e+        substNames' _ _ _ = Nothing++    tcDefineFun :: QName -> [R.Clause] -> UnquoteM Term+    tcDefineFun x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do+      whenM (isLeft <$> getConstInfo' x) $+        unquoteError $ MissingDeclaration x+      cs <- mapM (toAbstract_ . QNamed x) cs+      alwaysReportSDoc "tc.unquote.def" 10 $ vcat $ map prettyA cs+      let accessDontCare = __IMPOSSIBLE__  -- or ConcreteDef, value not looked at+      ac <- asksTC (^. lensIsAbstract)     -- Issue #4012, respect AbstractMode+      oc <- asksTC (^. lensIsOpaque)       -- Issue #6959, respect current opaque block+      let+        i' = mkDefInfo (nameConcrete $ qnameName x) noFixity' accessDontCare ac noRange+        i = i' { Info.defOpaque = oc }+      locallyReduceAllDefs $ checkFunDef i x cs+      primUnitUnit++    tcPragmaForeign :: Text -> Text -> TCM Term+    tcPragmaForeign backend code = do+      addForeignCode backend (T.unpack code)+      primUnitUnit++    tcPragmaCompile :: Text -> QName -> Text -> TCM Term+    tcPragmaCompile backend name code = do+      modifySignature $ updateDefinition name $+        addCompilerPragma backend $ CompilerPragma noRange (T.unpack code)+      primUnitUnit++    tcRunSpeculative :: Term -> UnquoteM Term+    tcRunSpeculative mu = do+      oldState <- getTC+      u <- reduce =<< evalTCM mu+      case u of+        Con _ _ [Apply (Arg { unArg = x }), Apply (Arg { unArg = b })] -> do+          unlessM (unquote b) $ putTC oldState+          return x+        _ -> liftTCM $ typeError . GenericDocError =<<+          "Should be a pair: " <+> prettyTCM u++    tcGetInstances :: MetaId -> UnquoteM Term+    tcGetInstances m = liftTCM (getInstanceCandidates m) >>= \case+      Left unblock -> do+        s <- gets snd+        throwError (BlockedOnMeta s unblock)+      Right cands -> liftTCM $+        buildList <*> mapM (quoteTerm . candidateTerm) cands++    tcSolveInstances :: UnquoteM Term+    tcSolveInstances = liftTCM $ do+      locallyTCState stPostponeInstanceSearch (const False) $ do+        -- Steal instance constraints (TODO: not all!)+        current <- asksTC envActiveProblems+        topPid  <- fromMaybe __IMPOSSIBLE__ <$> asksTC envUnquoteProblem+        let steal pc@(PConstr pids u c)+              | isInstance pc+              , Set.member topPid pids = PConstr (Set.union current pids) u c+              | otherwise              = pc+            isInstance c | FindInstance{} <- clValue (theConstraint c) = True+                         | otherwise                                   = False+        modifyAwakeConstraints    $ map steal+        modifySleepingConstraints $ map steal+        wakeConstraints (wakeUpWhen_ isInstance)+        solveSomeAwakeConstraints isInstance True  -- Force solving them now!+      primUnitUnit++    splitPars :: Int -> A.Expr -> UnquoteM ([A.TypedBinding], A.Expr)+    splitPars 0     = return . ([],)+    splitPars npars = \case+      A.Pi _ (n :| _) e -> first (n :) <$> splitPars (npars - 1) e+      A.Fun{}           -> __IMPOSSIBLE__  -- trusting the original author of this function+      A.ScopedExpr{}    -> __IMPOSSIBLE__  -- trusting the original author of this function+      e                 -> throwError $ TooManyParameters npars e++------------------------------------------------------------------------+-- * Trusted executables+------------------------------------------------------------------------++type ExeArg  = Text+type StdIn   = Text+type StdOut  = Text+type StdErr  = Text++-- | Raise an error if the @--allow-exec@ option was not specified.+--+requireAllowExec :: TCM ()+requireAllowExec = do+  unlessM (optAllowExec <$> pragmaOptions) $ typeError NeedOptionAllowExec++-- | Convert an @ExitCode@ to an Agda natural number.+--+exitCodeToNat :: ExitCode -> Nat+exitCodeToNat  ExitSuccess    = Nat 0+exitCodeToNat (ExitFailure n) = Nat (toInteger n)++-- | Call a trusted executable with the given arguments and input.+--+--   Returns the exit code, stdout, and stderr.+--+tcExec :: ExeName -> [ExeArg] -> StdIn -> TCM Term+tcExec exe args stdIn = do+  requireAllowExec+  exes <- optTrustedExecutables <$> commandLineOptions+  case Map.lookup exe exes of+    Nothing -> execError $ ExeNotTrusted exe exes+    Just fp -> do+      -- Check that the executable exists.+      unlessM (liftIO $ doesFileExist fp) $ execError $ ExeNotFound exe fp+      -- Check that the executable is executable.+      unlessM (liftIO $ executable <$> getPermissions fp) $ execError $ ExeNotExecutable exe fp++      let strArgs    = T.unpack <$> args+      (datExitCode, txtStdOut, txtStdErr) <- liftIO $ readProcessWithExitCode fp strArgs stdIn+      let natExitCode = exitCodeToNat datExitCode+      toR <- toTerm+      runReduceM $ toR (natExitCode, (txtStdOut, txtStdErr))
+ src/full/Agda/TypeChecking/Warnings.hs view
@@ -0,0 +1,211 @@++module Agda.TypeChecking.Warnings+  ( MonadWarning(..)+  , warning'_, warning_, warning', warning, warnings+  , raiseWarningsOnUsage+  , isUnsolvedWarning+  , isMetaWarning+  , isMetaTCWarning+  , onlyShowIfUnsolved+  , WhichWarnings(..), classifyWarning+  -- not exporting constructor of WarningsAndNonFatalErrors+  , WarningsAndNonFatalErrors, tcWarnings, nonFatalErrors+  , classifyWarnings+  ) where++import Control.Monad ( forM, unless, when )+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Reader ( ReaderT )+import Control.Monad.State  ( StateT )+import Control.Monad.Trans  ( MonadTrans, lift )+import Control.Monad.Trans.Maybe+import Control.Monad.Writer ( WriterT )++import Data.Foldable+import qualified Data.List as List+import qualified Data.Map  as Map+import qualified Data.Set  as Set+import Data.Maybe     ( catMaybes )+import Data.Semigroup ( Semigroup, (<>) )++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Caching+import {-# SOURCE #-} Agda.TypeChecking.Pretty ( MonadPretty, prettyTCM, vcat, ($$) )+import {-# SOURCE #-} Agda.TypeChecking.Pretty.Call+import {-# SOURCE #-} Agda.TypeChecking.Pretty.Warning ( prettyWarning )++import Agda.Syntax.Abstract.Name ( QName )+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Position+import Agda.Syntax.Parser++import Agda.Interaction.Options+import Agda.Interaction.Options.Warnings+import {-# SOURCE #-} Agda.Interaction.Highlighting.Generate (highlightWarning)++import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.Function  ( applyUnless )+import Agda.Utils.Lens+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton++import Agda.Utils.Impossible+++-- * The warning monad+---------------------------------------------------------------------------++class (MonadPretty m, MonadError TCErr m) => MonadWarning m where+  -- | Store a warning and generate highlighting from it.+  addWarning ::+       Bool       -- ^ Is the warning enabled?+    -> TCWarning  -- ^ The warning.+    -> m ()++  default addWarning+    :: (MonadWarning n, MonadTrans t, t n ~ m)+    => Bool -> TCWarning -> m ()+  addWarning enabled = lift . addWarning enabled++-- instance MonadWarning m => MonadWarning (ExceptT e m)  -- Conflict with MonadError TCErr constraint+instance MonadWarning m => MonadWarning (MaybeT m)+instance MonadWarning m => MonadWarning (ReaderT r m)+instance MonadWarning m => MonadWarning (StateT s m)+instance (MonadWarning m, Monoid w) => MonadWarning (WriterT w m)++instance MonadWarning TCM where+  addWarning enabled tcwarn = do+    stTCWarnings `modifyTCLens` Set.insert tcwarn+    -- Andreas, 2025-04-01, issue #6994, no highlighting for disabled warnings+    when enabled $ highlightWarning tcwarn++-- * Raising warnings+---------------------------------------------------------------------------++{-# SPECIALIZE warning'_ :: CallStack -> Warning -> TCM TCWarning #-}+warning'_ :: (MonadWarning m) => CallStack -> Warning -> m TCWarning+warning'_ loc w = do+  r <- viewTC eRange+  c <- viewTC eCall+  b <- areWeCaching+  let r' = case w of+        -- Some warnings come with their own error locations.+        NicifierIssue             w0 -> getRange w0+        UnsolvedInteractionMetas  rs -> getRange rs+        UnsolvedMetaVariables     rs -> getRange rs+        UnsolvedConstraints       cs -> getRange cs+        InteractionMetaBoundaries rs -> getRange rs+        _ -> r+  let wn = warningName w+  let ws = warningName2String wn+  p <- vcat+    [ pure $ P.hsep+      [ if null r' then mempty else P.pretty r' P.<> P.colon+      , if wn `elem` errorWarnings then "error:" P.<+> P.brackets (P.text ws)+        else P.text $ "warning: -W[no]" ++ ws+        -- Only benign warnings can be deactivated with -WnoXXX.+      ]+    , prettyWarning w+    , prettyTCM c+    ]+  return $ TCWarning loc r' w p (P.render p) b++{-# SPECIALIZE warning_ :: Warning -> TCM TCWarning #-}+warning_ :: (HasCallStack, MonadWarning m) => Warning -> m TCWarning+warning_ = withCallerCallStack . flip warning'_++-- UNUSED Liang-Ting Chen 2019-07-16+---- | @applyWarningMode@ filters out the warnings the user has not requested+---- Users are not allowed to ignore non-fatal errors.+--+--applyWarningMode :: WarningMode -> Warning -> Maybe Warning+--applyWarningMode wm w = case classifyWarning w of+--  ErrorWarnings -> Just w+--  AllWarnings   -> w <$ guard (Set.member (warningName w) $ wm ^. warningSet)++{-# SPECIALIZE warnings' :: CallStack -> List1 Warning -> TCM () #-}+warnings' :: MonadWarning m => CallStack -> List1 Warning -> m ()+warnings' loc ws = do++  WarningMode enabledWarnings wError <- optWarningMode <$> pragmaOptions++  -- We collect *all* of the warnings no matter whether they are enabled or not.+  -- If we find an enabled warning which should be turned into an error, we keep processing+  -- the rest of the warnings and *then* report all of the errors at once.+  merrs <- forM ws $ \ w' -> do+    let wn = warningName w'+    let enabled = wn `elem` enabledWarnings+    tcwarn <- warning'_ loc w'+    if wError && enabled+    then pure (Just tcwarn)+    else Nothing <$ addWarning (enabled  || wn `elem` exactSplitWarnings) tcwarn+      -- Andreas, 2025-04-01, issue #6994: always highlight non-exact splits++  List1.unlessNull (List1.catMaybes merrs) \ errs ->+    typeError' loc $ NonFatalErrors $ Set1.fromList errs++{-# SPECIALIZE warnings :: HasCallStack => List1 Warning -> TCM () #-}+warnings :: (HasCallStack, MonadWarning m) => List1 Warning -> m ()+warnings = withCallerCallStack . flip warnings'++{-# SPECIALIZE warning' :: CallStack -> Warning -> TCM () #-}+warning' :: MonadWarning m => CallStack -> Warning -> m ()+warning' loc = warnings' loc . singleton++{-# SPECIALIZE warning :: HasCallStack => Warning -> TCM () #-}+warning :: (HasCallStack, MonadWarning m) => Warning -> m ()+warning = withCallerCallStack . flip warning'++-- | Raise every 'WARNING_ON_USAGE' connected to a name.+{-# SPECIALIZE raiseWarningsOnUsage :: QName -> TCM () #-}+raiseWarningsOnUsage :: (MonadWarning m, ReadTCState m) => QName -> m ()+raiseWarningsOnUsage d = do+  -- In case we find a defined name, we start by checking whether there's+  -- a warning attached to it+  reportSLn "scope.warning.usage" 50 $ "Checking usage of " ++ P.prettyShow d+  mapM_ (warning . UserWarning) =<< Map.lookup d <$> getUserWarnings+++-- * Classifying warnings+---------------------------------------------------------------------------++isUnsolvedWarning :: Warning -> Bool+isUnsolvedWarning w = warningName w `Set.member` unsolvedWarnings++isMetaWarning :: Warning -> Bool+isMetaWarning = \case+   UnsolvedInteractionMetas{} -> True+   UnsolvedMetaVariables{}    -> True+   _                          -> False++isMetaTCWarning :: TCWarning -> Bool+isMetaTCWarning = isMetaWarning . tcWarning++onlyShowIfUnsolved :: Warning -> Bool+onlyShowIfUnsolved InversionDepthReached{} = True+onlyShowIfUnsolved _ = False++-- | Classifying warnings: some are benign, others are (non-fatal) errors++data WhichWarnings =+    ErrorWarnings -- ^ warnings that will be turned into errors+  | AllWarnings   -- ^ all warnings, including errors and benign ones+  -- Note: order of constructors is important for the derived Ord instance+  deriving (Eq, Ord)++classifyWarning :: Warning -> WhichWarnings+classifyWarning w =+  if warningName w `Set.member` errorWarnings+  then ErrorWarnings+  else AllWarnings++classifyWarnings :: [TCWarning] -> WarningsAndNonFatalErrors+classifyWarnings ws =+    WarningsAndNonFatalErrors (Set.fromList warnings) (Set.fromList errors)+  where+    partite = (< AllWarnings) . classifyWarning . tcWarning+    (errors, warnings) = List.partition partite ws
src/full/Agda/TypeChecking/With.hs view
@@ -1,56 +1,58 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.With where -import Control.Arrow ((&&&), (***), first, second)-import Control.Applicative hiding (empty)-import Control.Monad+import Prelude hiding ((!!))+ import Control.Monad.Writer (WriterT, runWriterT, tell) -import Data.List+import qualified Data.List as List import Data.Maybe-import Data.Monoid-import Data.Traversable (traverse)+import Data.Foldable ( foldrM )+import Data.Semigroup ( sconcat )  import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pattern as A import Agda.Syntax.Abstract.Views import Agda.Syntax.Info import Agda.Syntax.Position -import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Abstract import Agda.TypeChecking.Datatypes import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Free+import Agda.TypeChecking.Monad import Agda.TypeChecking.Patterns.Abstract import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive ( getRefl ) import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rules.LHS.Implicit+import Agda.TypeChecking.Rules.LHS.Problem (ProblemEq(..)) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.ReconstructParameters--import Agda.TypeChecking.Abstract-import Agda.TypeChecking.Rules.LHS.Implicit-import Agda.TypeChecking.Rules.LHS (isFlexiblePattern)+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.Warnings ( warning )  import Agda.Utils.Functor 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 (empty) import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Utils.Singleton import Agda.Utils.Size -#include "undefined.h" import Agda.Utils.Impossible - -- | Split pattern variables according to with-expressions.  --   Input:@@ -59,39 +61,32 @@ -- --   [@Δ ⊢ t@]     type of rhs. -----   [@Δ ⊢ as@]    types of with arguments.------   [@Δ ⊢ vs@]    with arguments.---+--   [@Δ ⊢ vs : as@]    with arguments and their types -- --   Output: -----   [@Δ₁@]        part of context not needed for with arguments and their types.------   [@Δ₂@]        part of context needed for with arguments and their types.+--   [@Δ₁@]              part of context needed for with arguments and their types. -----   [@π@]         permutation from Δ to Δ₁Δ₂ as returned by 'splitTelescope'.+--   [@Δ₂@]              part of context not needed for with arguments and their types. -----   [@Δ₁Δ₂ ⊢ t'@] type of rhs under @π@+--   [@π@]               permutation from Δ to Δ₁Δ₂ as returned by 'splitTelescope'. -----   [@Δ₁ ⊢ as'@]  types of with-arguments depending only on @Δ₁@.+--   [@Δ₁Δ₂ ⊢ t'@]       type of rhs under @π@ -----   [@Δ₁ ⊢ vs'@]  with-arguments under @π@.+--   [@Δ₁ ⊢ vs' : as'@]  with-arguments and their types depending only on @Δ₁@.  splitTelForWith   -- Input:-  :: Telescope      -- ^ __@Δ@__        context of types and with-arguments.-  -> Type           -- ^ __@Δ ⊢ t@__    type of rhs.-  -> [EqualityView] -- ^ __@Δ ⊢ as@__   types of with arguments.-  -> [Term]         -- ^ __@Δ ⊢ vs@__   with arguments.+  :: Telescope                         -- ^ __@Δ@__             context of types and with-arguments.+  -> Type                              -- ^ __@Δ ⊢ t@__         type of rhs.+  -> List1 (Arg (Term, EqualityView))  -- ^ __@Δ ⊢ vs : as@__   with arguments and their types.   -- Output:-  -> ( Telescope    -- @Δ₁@       part of context needed for with arguments and their types.-     , Telescope    -- @Δ₂@       part of context not needed for with arguments and their types.-     , Permutation  -- @π@        permutation from Δ to Δ₁Δ₂ as returned by 'splitTelescope'.-     , Type         -- @Δ₁Δ₂ ⊢ t'@ type of rhs under @π@-     , [EqualityView] -- @Δ₁ ⊢ as'@ types of with- and rewrite-arguments depending only on @Δ₁@.-     , [Term]       -- @Δ₁ ⊢ vs'@ with- and rewrite-arguments under @π@.-     )              -- ^ (__@Δ₁@__,__@Δ₂@__,__@π@__,__@t'@__,__@as'@__,__@vs'@__) where+  -> ( Telescope                         -- @Δ₁@             part of context needed for with arguments and their types.+     , Telescope                         -- @Δ₂@             part of context not needed for with arguments and their types.+     , Permutation                       -- @π@              permutation from Δ to Δ₁Δ₂ as returned by 'splitTelescope'.+     , Type                              -- @Δ₁Δ₂ ⊢ t'@      type of rhs under @π@+     , List1 (Arg (Term, EqualityView))  -- @Δ₁ ⊢ vs' : as'@ with- and rewrite-arguments and types under @π@.+     )              -- ^ (__@Δ₁@__,__@Δ₂@__,__@π@__,__@t'@__,__@vtys'@__) where -- --   [@Δ₁@]        part of context needed for with arguments and their types. --@@ -101,39 +96,27 @@ -- --   [@Δ₁Δ₂ ⊢ t'@] type of rhs under @π@ -----   [@Δ₁ ⊢ as'@]  types with with-arguments depending only on @Δ₁@.------   [@Δ₁ ⊢ vs'@]  with-arguments under @π@.--splitTelForWith delta t as vs = let-    -- Andreas, 2016-01-27, unfixing issue 1692-    -- Due to public protests, we do not rewrite in the types of rewrite-    -- expressions.-    -- Otherwise, we cannot rewrite twice after another with the same equation-    -- as it turns into a reflexive equation in the first rewrite.-    -- Thus we include the fvs of the rewrite terms in Δ₁.-    rewriteTerms = map snd $ filter (isEqualityType . fst) $ zip as vs+--   [@Δ₁ ⊢ vtys'@]  with-arguments and their types under @π@. +splitTelForWith delta t vtys = let     -- Split the telescope into the part needed to type the with arguments     -- and all the other stuff.-    fv = allFreeVars (as, vs)+    fv = allFreeVars vtys     SplitTel delta1 delta2 perm = splitTelescope fv delta      -- Δ₁Δ₂ ⊢ π : Δ-    pi = renaming __IMPOSSIBLE__ (reverseP perm)+    pi = renaming impossible (reverseP perm)     -- Δ₁ ⊢ ρ : Δ₁Δ₂  (We know that as does not depend on Δ₂.)-    rho = strengthenS __IMPOSSIBLE__ $ size delta2+    rho = strengthenS impossible $ size delta2     -- Δ₁ ⊢ ρ ∘ π : Δ     rhopi = composeS rho pi      -- We need Δ₁Δ₂ ⊢ t'     t' = applySubst pi t-    -- and Δ₁ ⊢ as'-    as' = applySubst rhopi as-    -- and Δ₁ ⊢ vs' : as'-    vs' = applySubst rhopi vs+    -- and Δ₁ ⊢ vtys'+    vtys' = applySubst rhopi vtys -  in (delta1, delta2, perm, t', as', vs')+  in (delta1, delta2, perm, t', vtys')   -- | Abstract with-expressions @vs@ to generate type for with-helper function.@@ -141,18 +124,18 @@ -- Each @EqualityType@, coming from a @rewrite@, will turn into 2 abstractions.  withFunctionType-  :: Telescope      -- ^ @Δ₁@                       context for types of with types.-  -> [Term]         -- ^ @Δ₁,Δ₂ ⊢ vs : raise Δ₂ as@  with and rewrite-expressions.-  -> [EqualityView] -- ^ @Δ₁ ⊢ as@                  types of with and rewrite-expressions.-  -> Telescope      -- ^ @Δ₁ ⊢ Δ₂@                  context extension to type with-expressions.-  -> Type           -- ^ @Δ₁,Δ₂ ⊢ b@                type of rhs.-  -> TCM (Type, Nat)+  :: Telescope                          -- ^ @Δ₁@                        context for types of with-expressions.+  -> List1 (Arg (Term, EqualityView))   -- ^ @Δ₁,Δ₂ ⊢ vs : raise Δ₂ as@  with and rewrite-expressions and their type.+  -> Telescope                          -- ^ @Δ₁ ⊢ Δ₂@                   context extension to type with-expressions.+  -> Type                               -- ^ @Δ₁,Δ₂ ⊢ b@                 type of rhs.+  -> Boundary                           -- ^ @Δ₁,Δ₂ ⊢ [(i,(u0,u1))] : b@ boundary of rhs.+  -> TCM (Type, (Nat1, Nat))     -- ^ @Δ₁ → wtel → Δ₂′ → b′@ such that     --     @[vs/wtel]wtel = as@ and     --     @[vs/wtel]Δ₂′ = Δ₂@ and     --     @[vs/wtel]b′ = b@.-    -- Plus the final number of with-arguments.-withFunctionType delta1 vs as delta2 b = addContext delta1 $ do+    -- Plus the final number of with-arguments and the number of visible ones.+withFunctionType delta1 vtys delta2 b bndry = addContext delta1 $ do    reportSLn "tc.with.abstract" 20 $ "preparing for with-abstraction" @@ -160,37 +143,75 @@   -- of the pattern variables not mentioned in @vs : as@.   let dbg n s x = reportSDoc "tc.with.abstract" n $ nest 2 $ text (s ++ " =") <+> prettyTCM x -  let d2b = telePi_ delta2 b+  d2b <- telePiPath_ delta2 b bndry   dbg 30 "Δ₂ → B" d2b   d2b  <- normalise d2b   dbg 30 "normal Δ₂ → B" d2b   d2b  <- etaContract d2b   dbg 30 "eta-contracted Δ₂ → B" d2b -  vs <- etaContract =<< normalise vs-  as <- etaContract =<< normalise as  -- do we need this?+  vtys <- etaContract =<< normalise vtys -  let piAbstractVs []         b = return b-      piAbstractVs (va : vas) b = piAbstract va =<< piAbstractVs vas b-  -- wd2db = wtel → [vs : as] (Δ₂ → B)-  wd2b <- piAbstractVs (zip vs as) d2b+  -- wd2b = wtel → [vs : as] (Δ₂ → B)+  wd2b <- foldrM piAbstract d2b vtys   dbg 30 "wΓ → Δ₂ → B" wd2b -  return (telePi_ delta1 wd2b, countWithArgs as)+  let nwithargs = countWithArgs $ fmap (snd . unArg) vtys+  let nwithpats = countWithPats vtys -countWithArgs :: [EqualityView] -> Nat-countWithArgs = sum . map countArgs+  TelV wtel _ <- telViewUpTo nwithargs wd2b++  -- select the boundary for "Δ₁" abstracting over "wΓ.Δ₂"+  let bndry' = Boundary [(i - sd2,(lams u0, lams u1)) | (i,(u0,u1)) <- theBoundary bndry, i >= sd2]+        where sd2 = size delta2+              lams = teleNoAbs wtel . abstract delta2++  d1wd2b <- telePiPath_ delta1 wd2b bndry'++  dbg 30 "Δ₁ → wΓ → Δ₂ → B" d1wd2b++  return (d1wd2b, (nwithargs, nwithpats))++-- | Count the number of arguments introduced into the type of the with-function.+countWithArgs :: (Functor f, Foldable f) => f EqualityView -> Nat1+countWithArgs = sum . fmap countArgs   where     countArgs OtherType{}    = 1+    countArgs IdiomType{}    = 2     countArgs EqualityType{} = 2 +-- | Count the number of with-patterns in the with-clause+--   that need to be transformed to regular patterns+--   in the **current round** of with-abstraction+--   (important for nested with).+countWithPats :: (Functor f, Foldable f) => f (Arg (Term, EqualityView)) -> Nat1+countWithPats = sum . fmap \case+    -- Andreas, 2025-04-08, see issue #7788.+    Arg ai (_, OtherType   {}) -> if visible ai then 1 else 0+      -- A hidden @with@ (issue #500) does not have a with-pattern in the abstract syntax.+    Arg ai (_, IdiomType   {}) -> if visible ai then 2 else 1+      -- The hidden version of the inspect idiom has just one with-pattern in the abstract syntax.+    Arg ai (_, EqualityType{}) -> if visible ai then 2 else __IMPOSSIBLE__+      -- The desugaring of @rewrite@ produces two new with-patterns in the abstract syntax.+      -- They are always @NotHidden@.++ -- | From a list of @with@ and @rewrite@ expressions and their types, --   compute the list of final @with@ expressions (after expanding the @rewrite@s).-withArguments :: [Term] -> [EqualityView] -> [Term]-withArguments vs as = concat $ for (zip vs as) $ \case-  (v, OtherType a) -> [v]-  (prf, eqt@(EqualityType s _eq _l t v _v')) -> [unArg v, prf]-+withArguments :: List1 (Arg (Term, EqualityView)) ->+                 TCM (List1 (Arg Term))+withArguments vtys = do+  sconcat <$> do+    forM vtys $ \ (Arg info ts) -> do+      fmap (Arg info) <$> do+        case ts of+          (v, OtherType a) -> do+            return $ singleton v+          (prf, eqt@(EqualityType _r _s _eq _pars _t v _v')) -> do+            return $ unArg v :| prf : []+          (v, IdiomType t) -> do+            mkRefl <- getRefl+            return $ v :| mkRefl (defaultArg v) : []  -- | Compute the clauses for the with-function given the original patterns. buildWithFunction@@ -198,84 +219,112 @@   -> QName                -- ^ Name of the parent function.   -> QName                -- ^ Name of the with-function.   -> Type                 -- ^ Types of the parent function.+  -> Telescope            -- ^ Context of parent patterns.   -> [NamedArg DeBruijnPattern] -- ^ Parent patterns.   -> Nat                  -- ^ Number of module parameters in parent patterns   -> Substitution         -- ^ Substitution from parent lhs to with function lhs   -> Permutation          -- ^ Final permutation.   -> Nat                  -- ^ Number of needed vars.   -> Nat                  -- ^ Number of with expressions.-  -> [A.SpineClause]      -- ^ With-clauses.-  -> TCM [A.SpineClause]  -- ^ With-clauses flattened wrt. parent patterns.-buildWithFunction cxtNames f aux t qs npars withSub perm n1 n cs = mapM buildWithClause cs+  -> List1 A.SpineClause  -- ^ With-clauses.+  -> TCM (List1 A.SpineClause) -- ^ With-clauses flattened wrt. parent patterns.+buildWithFunction cxtNames f aux t delta qs npars withSub perm n1 n cs = mapM buildWithClause cs   where     -- Nested with-functions will iterate this function once for each parent clause.-    buildWithClause (A.Clause (A.SpineLHS i _ ps wps) inheritedDots rhs wh catchall) = do-      let (wps0, wps1) = genericSplitAt n wps-          ps0          = map defaultNamedArg wps0-      reportSDoc "tc.with" 50 $ text "inheritedDots:" <+> vcat [ prettyTCM x <+> text "=" <+> prettyTCM v <+> text ":" <+> prettyTCM a-                                                               | A.NamedDot x v a <- inheritedDots ]-      rhs <- buildRHS rhs-      (namedDots, ps') <- stripWithClausePatterns cxtNames f aux t qs npars perm ps-      let (ps1, ps2) = genericSplitAt n1 ps'-      let result = A.Clause (A.SpineLHS i aux (ps1 ++ ps0 ++ ps2) wps1) (inheritedDots ++ namedDots) rhs wh catchall+    buildWithClause (A.Clause lhs@(A.SpineLHS i _ allPs) inheritedPats rhs wh catchall) = do+      let (ps, wps)    = splitOffTrailingWithPatterns allPs+          (wps0, wps1) = splitAt n wps+          ps0          = map (updateNamedArg fromWithP) wps0+            where+            fromWithP (A.WithP _ p) = p+            fromWithP _ = __IMPOSSIBLE__++      reportSDoc "tc.with.split" 40 $ vcat+        [ "buildWithClause"+        , nest 2 $ "n    =" <+> prettyTCM n+        , nest 2 $ "wps  =" <+> prettyA wps+        , nest 2 $ "wps0 =" <+> prettyA wps0+        , nest 2 $ "wps1 =" <+> prettyA wps1+        ]++      -- Andreas, 2025-04-07, issue #7759+      -- Usually the following is impossible because the with-clause collection+      -- already looks for the correct number of with-patterns.+      -- However, if the lhs is just an ellipsis, we can slip through the cracks.+      -- Thus, we install another check here to enforce the correct number of with-patterns.+      when (length wps0 < n) $+        setCurrentRange lhs $ typeError TooFewPatternsInWithClause++      reportSDoc "tc.with" 50 $ "inheritedPats:" <+> vcat+        [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a+        | A.ProblemEq p v a <- inheritedPats+        ]+      (strippedPats, ps') <- stripWithClausePatterns cxtNames f aux t delta qs npars perm ps+      reportSDoc "tc.with" 50 $ hang "strippedPats:" 2 $+                                  vcat [ prettyA p <+> "==" <+> prettyTCM v <+> (":" <+> prettyTCM t)+                                       | A.ProblemEq p v t <- strippedPats ]+      rhs <- buildRHS strippedPats rhs+      let (ps1, ps2) = splitAt n1 ps'+      let result = A.Clause (A.SpineLHS i aux $ ps1 ++ ps0 ++ ps2 ++ wps1)+                     (inheritedPats ++ strippedPats)+                     rhs wh catchall       reportSDoc "tc.with" 20 $ vcat-        [ text "buildWithClause returns" <+> prettyA result+        [ "buildWithClause returns" <+> prettyA result         ]       return result -    buildRHS rhs@A.RHS{}                 = return rhs-    buildRHS rhs@A.AbsurdRHS             = return rhs-    buildRHS (A.WithRHS q es cs)         = A.WithRHS q es <$>+    buildRHS _ rhs@A.RHS{}                 = return rhs+    buildRHS _ rhs@A.AbsurdRHS             = return rhs+    buildRHS _ (A.WithRHS q es cs)         = A.WithRHS q es <$>       mapM ((A.spineToLhs . permuteNamedDots) <.> buildWithClause . A.lhsToSpine) cs-    buildRHS (A.RewriteRHS qes rhs wh) = flip (A.RewriteRHS qes) wh <$> buildRHS rhs+    buildRHS strippedPats1 (A.RewriteRHS qes strippedPats2 rhs wh) =+      flip (A.RewriteRHS qes (applySubst withSub $ strippedPats1 ++ strippedPats2)) wh <$> buildRHS [] rhs -    -- The named dot patterns computed by buildWithClause lives in the context+    -- The stripped patterns computed by buildWithClause lives in the context     -- of the top with-clause (of the current call to buildWithFunction). When-    -- we recurse we expect inherited named dot patterns to live in the context+    -- we recurse we expect inherited patterns to live in the context     -- of the innermost parent clause. Note that this makes them live in the     -- context of the with-function arguments before any pattern matching. We     -- need to update again once the with-clause patterns have been checked.     -- This happens in Rules.Def.checkClause before calling checkRHS.     permuteNamedDots :: A.SpineClause -> A.SpineClause-    permuteNamedDots (A.Clause lhs dots rhs wh catchall) =-      A.Clause lhs (applySubst withSub dots) rhs wh catchall+    permuteNamedDots (A.Clause lhs strippedPats rhs wh catchall) =+      A.Clause lhs (applySubst withSub strippedPats) rhs wh catchall -{-| @stripWithClausePatterns cxtNames parent f t qs np π ps = ps'@ -[@Δ@]   context bound by lhs of original function (not an argument).--[@f@]   name of @with@-function.--[@t@]   type of the original function.--[@qs@]  internal patterns for original function.--[@np@]  number of module parameters in @qs@--[@π@]   permutation taking @vars(qs)@ to @support(Δ)@.--[@ps@]  patterns in with clause (eliminating type @t@).+-- The arguments of @stripWithClausePatterns@ are documented+-- at its type signature.+-- The following is duplicate information, but may help reading the examples below.+--+-- [@Δ@]   context bound by lhs of original function.+-- [@f@]   name of @with@-function.+-- [@t@]   type of the original function.+-- [@qs@]  internal patterns for original function.+-- [@np@]  number of module parameters in @qs@+-- [@π@]   permutation taking @vars(qs)@ to @support(Δ)@.+-- [@ps@]  patterns in with clause (eliminating type @t@).+-- [@ps'@] patterns for with function (presumably of type @Δ@). -[@ps'@] patterns for with function (presumably of type @Δ@).+{-| @stripWithClausePatterns cxtNames parent f t Δ qs np π ps = ps'@  Example:  @-record Stream (A : Set) : Set where-  coinductive-  constructor delay-  field       force : A × Stream A+  record Stream (A : Set) : Set where+    coinductive+    constructor delay+    field       force : A × Stream A -record SEq (s t : Stream A) : Set where-  coinductive-  field-    ~force : let a , as = force s-                 b , bs = force t-             in  a ≡ b × SEq as bs+  record SEq (s t : Stream A) : Set where+    coinductive+    field+      ~force : let a , as = force s+                   b , bs = force t+               in  a ≡ b × SEq as bs -test : (s : Nat × Stream Nat) (t : Stream Nat) → SEq (delay s) t → SEq t (delay s)-~force (test (a     , as) t p) with force t-~force (test (suc n , as) t p) | b , bs = {!!}+  test : (s : Nat × Stream Nat) (t : Stream Nat) → SEq (delay s) t → SEq t (delay s)+  ~force (test (a     , as) t p) with force t+  ~force (test (suc n , as) t p) | b , bs = ? @  With function:@@ -297,97 +346,92 @@   f t (b , bs) (suc n) as t p @ -Note: stripWithClausePatterns factors @ps@ through @qs@, thus+Note: stripWithClausePatterns factors __@ps@__ through __@qs@__, thus  @   ps = qs[ps'] @  where @[..]@ is to be understood as substitution.-The projection patterns have vanished from @ps'@ (as they are already in @qs@).+The projection patterns have vanished from __@ps'@__ (as they are already in __@qs@__). -}  stripWithClausePatterns-  :: [Name]                   -- ^ Names of the module parameters of the parent function-  -> QName                    -- ^ Name of the parent function.-  -> QName                    -- ^ Name of with-function.+  :: [Name]                   -- ^ __@cxtNames@__ names of the module parameters of the parent function+  -> QName                    -- ^ __@parent@__ name of the parent function.+  -> QName                    -- ^ __@f@__   name of with-function.   -> Type                     -- ^ __@t@__   top-level type of the original function.+  -> Telescope                -- ^ __@Δ@__   context of patterns of parent function.   -> [NamedArg DeBruijnPattern] -- ^ __@qs@__  internal patterns for original function.-  -> Nat                      -- ^ __@npars@__ number of module parameters is @qs@.+  -> Nat                      -- ^ __@npars@__ number of module parameters in @qs@.   -> Permutation              -- ^ __@π@__   permutation taking @vars(qs)@ to @support(Δ)@.   -> [NamedArg A.Pattern]     -- ^ __@ps@__  patterns in with clause (eliminating type @t@).-  -> TCM ([A.NamedDotPattern], [NamedArg A.Pattern]) -- ^ __@ps'@__ patterns for with function (presumably of type @Δ@).-stripWithClausePatterns cxtNames parent f t qs npars perm ps = do+  -> TCM ([A.ProblemEq], [NamedArg A.Pattern]) -- ^ __@ps'@__ patterns for with function (presumably of type @Δ@).+stripWithClausePatterns cxtNames parent f t delta qs npars perm ps = do   -- Andreas, 2014-03-05 expand away pattern synoyms (issue 1074)   ps <- expandPatternSynonyms ps   -- Ulf, 2016-11-16 Issue 2303: We need the module parameter   -- instantiations from qs, so we make sure   -- that t is the top-level type of the parent function and add patterns for   -- the module parameters to ps before stripping.-  let paramPat i _ = A.VarP (cxtNames !! i)+  let paramPat i _ = A.VarP $ A.mkBindName $ indexWithDefault __IMPOSSIBLE__ cxtNames i       ps' = zipWith (fmap . fmap . paramPat) [0..] (take npars qs) ++ ps   psi <- insertImplicitPatternsT ExpandLast ps' t   reportSDoc "tc.with.strip" 10 $ vcat-    [ text "stripping patterns"-    , nest 2 $ text "t   = " <+> prettyTCM t-    , nest 2 $ text "ps  = " <+> fsep (punctuate comma $ map prettyA ps)-    , nest 2 $ text "ps' = " <+> fsep (punctuate comma $ map prettyA ps')-    , nest 2 $ text "psi = " <+> fsep (punctuate comma $ map prettyA psi)-    , nest 2 $ text "qs  = " <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs)-    , nest 2 $ text "perm= " <+> text (show perm)+    [ "stripping patterns"+    , nest 2 $ "t   = " <+> prettyTCM t+    , nest 2 $ "ps  = " <+> fsep (punctuate comma $ map prettyA ps)+    , nest 2 $ "ps' = " <+> fsep (punctuate comma $ map prettyA ps')+    , nest 2 $ "psi = " <+> fsep (punctuate comma $ map prettyA psi)+    , nest 2 $ addContext delta $+               "qs  = " <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs)+    , nest 2 $ "perm= " <+> text (show perm)     ]    -- Andreas, 2015-11-09 Issue 1710: self starts with parent-function, not with-function!-  (ps', namedDots) <- runWriterT $ strip (Def parent []) t psi qs-  reportSDoc "tc.with.strip" 50 $ nest 2 $-    text "namedDots:" <+> vcat [ prettyTCM x <+> text "=" <+> prettyTCM v <+> text ":" <+> prettyTCM a | A.NamedDot x v a <- namedDots ]+  (ps', strippedPats) <- runWriterT $ strip (Def parent []) t psi qs+  unless (null strippedPats) $ reportSDoc "tc.with.strip" 50 $ nest 2 $+    "strippedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a | A.ProblemEq p v a <- strippedPats ]   let psp = permute perm ps'   reportSDoc "tc.with.strip" 10 $ vcat-    [ nest 2 $ text "ps' = " <+> fsep (punctuate comma $ map prettyA ps')-    , nest 2 $ text "psp = " <+> fsep (punctuate comma $ map prettyA $ psp)+    [ nest 2 $ "ps' = " <+> fsep (punctuate comma $ map prettyA ps')+    , nest 2 $ "psp = " <+> fsep (punctuate comma $ map prettyA $ psp)     ]-  -- Andreas, 2014-03-05 Issue 142:-  -- In some cases, permute throws away some dot patterns of ps'-  -- which are then never checked.-  if True then return (namedDots, psp) else do-    -- Andreas, 2014-03-05 Disabled the fix for issue 142, the following is dead code:-    forM_ (permute (droppedP perm) ps') $ \ p -> setCurrentRange p $ do-      reportSDoc "tc.with.strip" 10 $ text "warning: dropped pattern " <+> prettyA p-      reportSDoc "tc.with.strip" 60 $ text $ show p-      case namedArg p of-        A.DotP info o e -> case unScope e of-          A.Underscore{} -> return ()-          e | o == UserWritten -> typeError $ GenericError $-            "This inaccessible pattern is never checked, so only _ allowed here"-          _ -> return ()-        _ -> return ()-    return (namedDots, psp)+  return (strippedPats, psp)   where +    -- We need to get the correct hiding from the lhs context. The unifier may have moved bindings+    -- sites around so we can't trust the hiding of the parent pattern variables. We should preserve+    -- the origin though.+    varArgInfo = \ x -> let n = dbPatVarIndex x in+                        if n < length infos then infos !! n else __IMPOSSIBLE__+      where infos = reverse $ map getArgInfo $ telToList delta++    setVarArgInfo x p = setOrigin (getOrigin p) $ setArgInfo (varArgInfo x) p+     strip-      :: Term                         -- ^ Self.-      -> Type                         -- ^ The type to be eliminated.-      -> [NamedArg A.Pattern]       -- ^ With-clause patterns.-      -> [NamedArg DeBruijnPattern] -- ^ Parent-clause patterns with de Bruijn indices relative to Δ.-      -> WriterT [A.NamedDotPattern] TCM [NamedArg A.Pattern]-            -- ^ With-clause patterns decomposed by parent-clause patterns.-            --   Also outputs named dot patterns from the parent clause that-            --   we need to add let-bindings for.+      :: Term                         -- Self.+      -> Type                         -- The type to be eliminated.+      -> [NamedArg A.Pattern]         -- With-clause patterns.+      -> [NamedArg DeBruijnPattern]   -- Parent-clause patterns with de Bruijn indices relative to Δ.+      -> WriterT [ProblemEq] TCM [NamedArg A.Pattern]+            -- With-clause patterns decomposed by parent-clause patterns.+            -- Also outputs named dot patterns from the parent clause that+            -- we need to add let-bindings for.      -- Case: out of with-clause patterns.     strip self t [] qs@(_ : _) = do       reportSDoc "tc.with.strip" 15 $ vcat-        [ text "strip (out of A.Patterns)"-        , nest 2 $ text "qs  =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs)-        , nest 2 $ text "self=" <+> prettyTCM self-        , nest 2 $ text "t   =" <+> prettyTCM t+        [ "strip (out of A.Patterns)"+        , nest 2 $ "qs  =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs)+        , nest 2 $ "self=" <+> prettyTCM self+        , nest 2 $ "t   =" <+> prettyTCM t         ]       -- Andreas, 2015-06-11, issue 1551:       -- As the type t develops, we need to insert more implicit patterns,       -- due to copatterns / flexible arity.       ps <- liftTCM $ insertImplicitPatternsT ExpandLast [] t-      if null ps then-        typeError $ GenericError $ "Too few arguments given in with-clause"+      if null ps then typeError TooFewPatternsInWithClause        else strip self t ps qs      -- Case: out of parent-clause patterns.@@ -395,10 +439,9 @@     -- are implicit patterns (we inserted too many).     strip _ _ ps      []      = do       let implicit (A.WildP{})     = True-          implicit (A.ConP ci _ _) = patOrigin ci == ConOSystem+          implicit (A.ConP ci _ _) = conPatOrigin ci == ConOSystem           implicit _               = False-      unless (all (implicit . namedArg) ps) $-        typeError $ GenericError $ "Too many arguments given in with-clause"+      unless (all (implicit . namedArg) ps) $ typeError TooManyPatternsInWithClause       return []      -- Case: both parent-clause pattern and with-clause pattern present.@@ -407,35 +450,32 @@       | A.AsP _ x p <- namedArg p0 = do         (a, _) <- mustBePi t         let v = patternToTerm (namedArg q)-        tell [A.NamedDot x v (unDom a)]+        tell [ProblemEq (A.VarP x) v a]         strip self t (fmap (p <$) p0 : ps) qs     strip self t ps0@(p0 : ps) qs0@(q : qs) = do-      p <- liftTCM $ expandLitPattern p0+      p <- (traverse . traverse) expandLitPattern p0       reportSDoc "tc.with.strip" 15 $ vcat-        [ text "strip"-        , nest 2 $ text "ps0 =" <+> fsep (punctuate comma $ map prettyA ps0)-        , nest 2 $ text "exp =" <+> prettyA p-        , nest 2 $ text "qs0 =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs0)-        , nest 2 $ text "self=" <+> prettyTCM self-        , nest 2 $ text "t   =" <+> prettyTCM t+        [ "strip"+        , nest 2 $ "ps0 =" <+> fsep (punctuate comma $ map prettyA ps0)+        , nest 2 $ "exp =" <+> prettyA p+        , nest 2 $ "qs0 =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs0)+        , nest 2 $ "self=" <+> prettyTCM self+        , nest 2 $ "t   =" <+> prettyTCM t         ]-      let failDotPat :: Monoid w => WriterT w TCM a-          failDotPat = do-            d <- liftTCM $ prettyA p-            typeError $ GenericError $-                "Inaccessible (dotted) patterns from the parent clause must " ++-                "also be inaccessible in the with clause, when checking the " ++-                "pattern " ++ show d ++ ","       case namedArg q of-        ProjP o d -> case A.maybePostfixProjP p of+        ProjP o d -> case A.isProjP p of           Just (o', AmbQ ds) -> do-            let d' = head ds-            when (length ds /= 1) __IMPOSSIBLE__-            d  <- liftTCM $ getOriginalProjection d-            d' <- liftTCM $ getOriginalProjection d'             -- We assume here that neither @o@ nor @o'@ can be @ProjSystem@.-            if o /= o' then liftTCM $ mismatchOrigin o o' else do-            if d /= d' then mismatch else do+            when (o /= o') $ setCurrentRange p0 $ addContext delta do+              reportSLn "tc.with.strip" 90 $ "p0 = " ++ show p0+              reportSLn "tc.with.strip" 80 $ "getRange p0 = " ++ prettyShow (getRange p0)+              warning $ WithClauseProjectionFixityMismatch p0 o' q o+            -- Andreas, 2016-12-28, issue #2360:+            -- We disambiguate the projection in the with clause+            -- to the projection in the parent clause.+            d  <- liftTCM $ getOriginalProjection d+            found <- existsM ds $ \ d' -> liftTCM $ (Just d ==) . fmap projOrig <$> isProjection d'+            if not found then mismatch else do               (self1, t1, ps) <- liftTCM $ do                 t <- reduce t                 (_, self1, t1) <- fromMaybe __IMPOSSIBLE__ <$> projectTyped self t o d@@ -447,87 +487,92 @@               strip self1 t1 ps qs           Nothing -> mismatch -        VarP x  -> do-          let v = var (dbPatVarIndex x)-          t  <- piApply1 t v-          ps <- strip (self `apply1` v) t ps qs-          return $ p : ps+        -- We can safely strip dots from variables. The unifier will put them back when required.+        VarP _ x | A.DotP _ u <- namedArg p+                 , A.Var y <- unScope u -> do+          (setVarArgInfo x (setNamedArg p $ A.VarP $ A.mkBindName y) :) <$>+            recurse (var (dbPatVarIndex x)) -        DotP v  -> case namedArg p of-          A.DotP r o _  -> ok p-          A.WildP _     -> ok p-          -- Ulf, 2016-05-30: dot patterns are no longer mandatory so a parent-          -- dot pattern can appear as a variable in the child clause. Indeed-          -- this happens if you use a variable in the parent and '...' in the-          -- child. In this case we need to remember the the binding, so we can-          -- insert a let for it.-          A.VarP x -> do-            (a, _) <- mustBePi t-            tell [A.NamedDot x v (unDom a)]-            ok p-          -- Andreas, 2013-03-21 in case the implicit A.pattern has already been eta-expanded-          -- we just fold it back.  This fixes issues 665 and 824.-          A.ConP ci _ _ | patOrigin ci == ConOSystem -> okFlex p-          -- Andreas, 2015-07-07 issue 1606: Same for flexible record patterns.-          -- Agda might have replaced a record of dot patterns (A.ConP) by a dot pattern (I.DotP).-          p'@A.ConP{} -> ifM (liftTCM $ isFlexiblePattern p') (okFlex p) {-else-} failDotPat+        VarP _ x  ->+          (setVarArgInfo x p :) <$> recurse (var (dbPatVarIndex x)) -          p@(A.PatternSynP pi' c' [ps']) -> do-             reportSDoc "impossible" 10 $-               text "stripWithClausePatterns: encountered pattern synonym " <+> prettyA p-             __IMPOSSIBLE__+        IApplyP _ _ _ x  ->+          (setVarArgInfo x p :) <$> recurse (var (dbPatVarIndex x)) -          _ -> failDotPat-          where-            okFlex = ok . makeImplicitP-            ok p = do-              t' <- piApply1 t v-              (p :) <$> strip (self `apply1` v) t' ps qs+        DefP{}  -> __IMPOSSIBLE__ +        DotP i v  -> do+          (a, _) <- mustBePi t+          tell [ProblemEq (namedArg p) v a]+          case v of+            Var x [] | PatOVar{} <- patOrigin i+               -> (p :) <$> recurse (var x)+            _  -> (makeWildP p :) <$> recurse v+         q'@(ConP c ci qs') -> do          reportSDoc "tc.with.strip" 60 $-           text "parent pattern is constructor " <+> prettyTCM c+           "parent pattern is constructor " <+> prettyTCM c          (a, b) <- mustBePi t          -- The type of the current pattern is a datatype.-         Def d es <- liftTCM $ ignoreSharing <$> normalise (unEl $ unDom a)+         Def d es <- liftTCM $ reduce (unEl $ unDom a)          let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es          -- Get the original constructor and field names.-         c <- (`withRangeOf` c) <$> do liftTCM $ getConForm $ conName c+         c <- either __IMPOSSIBLE__ (`withRangeOf` c) <$> do liftTCM $ getConForm $ conName c           case namedArg p of            -- Andreas, 2015-07-07 Issue 1606.           -- Agda sometimes changes a record of dot patterns into a dot pattern,           -- so the user should be allowed to do likewise.-          A.DotP{} -> ifNotM (liftTCM $ isFlexiblePattern q') mismatch $ {-else-} do-            maybe __IMPOSSIBLE__ (\ p -> strip self t (p : ps) qs0) =<< do-              liftTCM $ expandImplicitPattern' (unDom a) $ makeImplicitP p+          -- Jesper, 2017-11-16. This is now also allowed for data constructors.+          A.DotP r e -> do+            tell [ProblemEq (A.DotP r e) (patternToTerm q') a]+            ps' <-+              case appView e of+                -- If dot-pattern is an application of the constructor, try to preserve the+                -- arguments.+                Application (A.Con (A.AmbQ cs')) es -> do+                  cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'+                  unless (c `elem` cs') mismatch+                  return $ (map . fmap . fmap) (A.DotP r) es+                _  -> return $ map (unnamed (A.WildP empty) <$) qs'+            stripConP d us b c ConOCon qs' ps' -          -- Andreas, 2013-03-21 if we encounter an implicit pattern-          -- in the with-clause, we expand it and restart-          -- Andreas, 2015-07-07 Issue 1606 do this whenever the parent-          -- is a record pattern, regardless of whether it came from an implicit-          -- or not.  This allows to drop hidden flexible record patterns from-          -- the with clauses even when they were present in the parent clause.-          A.WildP{} | Just _ <- conPRecord ci -> do-            maybe __IMPOSSIBLE__ (\ p -> strip self t (p : ps) qs0) =<< do-              liftTCM $ expandImplicitPattern' (unDom a) p+          -- Andreas, 2016-12-29, issue #2363.+          -- Allow _ to stand for the corresponding parent pattern.+          A.WildP{} -> do+            -- Andreas, 2017-10-13, issue #2803:+            -- Delete the name, since it can confuse insertImplicitPattern.+            let ps' = map (unnamed (A.WildP empty) <$) qs'+            stripConP d us b c ConOCon qs' ps' +          -- Jesper, 2018-05-13, issue #2998.+          -- We also allow turning a constructor pattern into a variable.+          -- In general this is not type-safe since the types of some variables+          -- in the constructor pattern may have changed, so we have to+          -- re-check these solutions when checking the with clause (see LHS.hs)+          A.VarP x -> do+            tell [ProblemEq (A.VarP x) (patternToTerm q') a]+            let ps' = map (unnamed (A.WildP empty) <$) qs'+            stripConP d us b c ConOCon qs' ps'+           A.ConP _ (A.AmbQ cs') ps' -> do             -- Check whether the with-clause constructor can be (possibly trivially)             -- disambiguated to be equal to the parent-clause constructor.-            cs' <- liftTCM $ mapM getConForm cs'-            unless (elem c cs') mismatch+            -- Andreas, 2017-08-13, herein, ignore abstract constructors.+            cs' <- liftTCM $ List1.rights <$> mapM getConForm cs'+            unless (c `elem` cs') mismatch             -- Strip the subpatterns ps' and then continue.             stripConP d us b c ConOCon qs' ps' -          A.RecP _ fs -> caseMaybeM (liftTCM $ isRecord d) mismatch $ \ def -> do-            ps' <- liftTCM $ insertMissingFields d (const $ A.WildP empty) fs (recordFieldNames def)+          A.RecP _ _ fs -> caseMaybeM (liftTCM $ isRecord d) mismatch $ \ def -> do+            ps' <- liftTCM $ insertMissingFieldsFail d (const $ A.WildP empty) fs+                                                 (map argFromDom $ recordFieldNames def)             stripConP d us b c ConORec qs' ps'            p@(A.PatternSynP pi' c' ps') -> do              reportSDoc "impossible" 10 $-               text "stripWithClausePatterns: encountered pattern synonym " <+> prettyA p+               "stripWithClausePatterns: encountered pattern synonym " <+> prettyA p              __IMPOSSIBLE__            p -> do@@ -535,80 +580,70 @@              text $ "with clause pattern is  " ++ show p            mismatch -        LitP lit -> case namedArg p of-          A.LitP lit' | lit == lit' -> do-            (a, b) <- mustBePi t-            let v = Lit lit-            strip (self `apply1` v) (b `absApp` v) ps qs+        LitP _ lit -> case namedArg p of+          A.LitP _ lit' | lit == lit' -> recurse $ Lit lit+          A.WildP{}                   -> recurse $ Lit lit            p@(A.PatternSynP pi' c' [ps']) -> do              reportSDoc "impossible" 10 $-               text "stripWithClausePatterns: encountered pattern synonym " <+> prettyA p+               "stripWithClausePatterns: encountered pattern synonym " <+> prettyA p              __IMPOSSIBLE__            _ -> mismatch       where-        mismatch = typeError $-          WithClausePatternMismatch (namedArg p0) (dbPatVarName <$> namedArg q)-        mismatchOrigin o o' = typeError . GenericDocError =<< fsep-          [ text "With clause pattern"-          , prettyA p0-          , text "is not an instance of its parent pattern"-          , prettyTCM $ dbPatVarName <$> namedArg q-          , text $ "since the parent pattern is " ++ prettyProjOrigin o ++-                   " and the with clause pattern is " ++ prettyProjOrigin o'-          ]-        prettyProjOrigin ProjPrefix  = "a prefix projection"-        prettyProjOrigin ProjPostfix = "a postfix projection"-        prettyProjOrigin ProjSystem  = __IMPOSSIBLE__+        recurse v = do+          let piOrPathApplyM t v = do+                (TelV tel t', bs) <- telViewUpToPathBoundary' 1 t+                unless (size tel == 1) $ __IMPOSSIBLE__+                return (teleElims tel bs, subst 0 v t')+          (e, t') <- piOrPathApplyM t v+          strip (self `applyE` e) t' ps qs -        -- | Make an ImplicitP, keeping arg. info.-        makeImplicitP :: NamedArg A.Pattern -> NamedArg A.Pattern-        makeImplicitP = updateNamedArg $ const $ A.WildP patNoRange+        mismatch :: forall m a. (MonadAddContext m, MonadTCError m) => m a+        mismatch = addContext delta $ typeError $+          WithClausePatternMismatch (namedArg p0) q +        -- Make a WildP, keeping arg. info.+        makeWildP :: NamedArg A.Pattern -> NamedArg A.Pattern+        makeWildP = updateNamedArg $ const $ A.WildP patNoRange+         -- case I.ConP / A.ConP         stripConP-          :: QName-             -- ^ Data type name of this constructor pattern.-          -> [Arg Term]-             -- ^ Data type arguments of this constructor pattern.-          -> Abs Type-             -- ^ Type the remaining patterns eliminate.-          -> ConHead-             -- ^ Constructor of this pattern.-          -> ConInfo-             -- ^ Constructor info of this pattern (constructor/record).-          -> [NamedArg DeBruijnPattern]-             -- ^ Argument patterns (parent clause).-          -> [NamedArg A.Pattern]-             -- ^ Argument patterns (with clause).-          -> WriterT [A.NamedDotPattern] TCM [NamedArg A.Pattern]-             -- ^ Stripped patterns.+          :: QName       -- Data type name of this constructor pattern.+          -> [Arg Term]  -- Data type arguments of this constructor pattern.+          -> Abs Type    -- Type the remaining patterns eliminate.+          -> ConHead     -- Constructor of this pattern.+          -> ConInfo     -- Constructor info of this pattern (constructor/record).+          -> [NamedArg DeBruijnPattern]  -- Argument patterns (parent clause).+          -> [NamedArg A.Pattern]        -- Argument patterns (with clause).+          -> WriterT [ProblemEq] TCM [NamedArg A.Pattern]  -- Stripped patterns.         stripConP d us b c ci qs' ps' = do            -- Get the type and number of parameters of the constructor.           Defn {defType = ct, theDef = Constructor{conPars = np}}  <- getConInfo c           -- Compute the argument telescope for the constructor-          let ct' = ct `piApply` genericTake np us-          TelV tel' _ <- liftTCM $ telView ct'+          let ct' = ct `piApply` take np us+          TelV tel' _ <- liftTCM $ telViewPath ct'+          -- (TelV tel' _, _boundary) <- liftTCM $ telViewPathBoundary ct'            reportSDoc "tc.with.strip" 20 $-            vcat [ text "ct  = " <+> prettyTCM ct-                 , text "ct' = " <+> prettyTCM ct'-                 , text "np  = " <+> text (show np)-                 , text "us  = " <+> prettyList (map prettyTCM us)-                 , text "us' = " <+> prettyList (map prettyTCM $ genericTake np us)+            vcat [ "ct  = " <+> prettyTCM ct+                 , "ct' = " <+> prettyTCM ct'+                 , "np  = " <+> text (show np)+                 , "us  = " <+> prettyList (map prettyTCM us)+                 , "us' = " <+> prettyList (map prettyTCM $ take np us)                  ] +          -- TODO Andrea: preserve IApplyP patterns in v, see _boundary?           -- Compute the new type-          let v  = Con c ci [ Arg info (var i) | (i, Arg info _) <- zip (downFrom $ size qs') qs' ]+          let v  = Con c ci [ Apply $ Arg info (var i) | (i, Arg info _) <- zip (downFrom $ size qs') qs' ]               t' = tel' `abstract` absApp (raise (size tel') b) v               self' = tel' `abstract` apply1 (raise (size tel') self) v  -- Issue 1546            reportSDoc "tc.with.strip" 15 $ sep-            [ text "inserting implicit"+            [ "inserting implicit"             , nest 2 $ prettyList $ map prettyA (ps' ++ ps)-            , nest 2 $ text ":" <+> prettyTCM t'+            , nest 2 $ ":" <+> prettyTCM t'             ]            -- Insert implicit patterns (just for the constructor arguments)@@ -638,14 +673,22 @@ --     f (suc a) (suc b) | c --   @ withDisplayForm-  :: QName                -- ^ The name of parent function.-  -> QName                -- ^ The name of the @with@-function.-  -> Telescope            -- ^ __@Δ₁@__      The arguments of the @with@ function before the @with@ expressions.-  -> Telescope            -- ^ __@Δ₂@__      The arguments of the @with@ function after the @with@ expressions.-  -> Nat                  -- ^ __@n@__       The number of @with@ expressions.-  -> [NamedArg DeBruijnPattern]   -- ^ __@qs@__      The parent patterns.-  -> Permutation          -- ^ __@perm@__    Permutation to split into needed and unneeded vars.-  -> Permutation          -- ^ __@lhsPerm@__ Permutation reordering the variables in parent patterns.+  :: QName+       -- ^ The name of parent function.+  -> QName+       -- ^ The name of the @with@-function.+  -> Telescope+       -- ^ __@Δ₁@__     The arguments of the @with@ function before the @with@ expressions.+  -> Telescope+       -- ^ __@Δ₂@__     The arguments of the @with@ function after the @with@ expressions.+  -> Nat+       -- ^ __@n@__      The number of @with@ expressions.+  -> [NamedArg DeBruijnPattern]+      -- ^ __@qs@__      The parent patterns.+  -> Permutation+      -- ^ __@perm@__    Permutation to split into needed and unneeded vars.+  -> Permutation+      -- ^ __@lhsPerm@__ Permutation reordering the variables in parent patterns.   -> TCM DisplayForm withDisplayForm f aux delta1 delta2 n qs perm@(Perm m _) lhsPerm = do @@ -669,37 +712,38 @@       tqs        = applySubst rho tqs0       -- Build the arguments to the with function.       es         = map (Apply . fmap DTerm) topArgs ++ tqs-      withArgs   = map var $ take n $ downFrom $ size delta2 + n-      dt         = DWithApp (DDef f es) (map DTerm withArgs) []+      withArgs   = List1.fromListSafe __IMPOSSIBLE__ $  -- List is non-empty since n >= 1+                     map var $ take n $ downFrom $ size delta2 + n+      dt         = DWithApp (DDef f es) (fmap DTerm withArgs) []    -- Build the lhs of the display form and finish.   -- @var 0@ is the pattern variable (hole).-  let display = Display arity (replicate arity $ Apply $ defaultArg $ var 0) dt+  let display = Display arity [Apply $ defaultArg $ var i | i <- downFrom arity] dt    -- Debug printing.   let addFullCtx = addContext delta1                  . flip (foldr addContext) (for [1..n] $ \ i -> "w" ++ show i)                  . addContext delta2   reportSDoc "tc.with.display" 20 $ vcat-    [ text "withDisplayForm"+    [ "withDisplayForm"     , nest 2 $ vcat-      [ text "f      =" <+> text (show f)-      , text "aux    =" <+> text (show aux)-      , text "delta1 =" <+> prettyTCM delta1-      , text "delta2 =" <+> do addContext delta1 $ prettyTCM delta2-      , text "n      =" <+> text (show n)-      , text "perm   =" <+> text (show perm)-      , text "top    =" <+> do addFullCtx $ prettyTCM topArgs-      , text "qs     =" <+> sep (map (prettyTCM . namedArg) qs)-      , text "qsToTm =" <+> prettyTCM tqs0 -- ctx would be permuted form of delta1 ++ delta2-      , text "ys     =" <+> text (show ys)-      , text "rho    =" <+> text (prettyShow rho)-      , text "qs[rho]=" <+> do addFullCtx $ prettyTCM tqs-      , text "dt     =" <+> do addFullCtx $ prettyTCM dt+      [ "f      =" <+> text (prettyShow f)+      , "aux    =" <+> text (prettyShow aux)+      , "delta1 =" <+> prettyTCM delta1+      , "delta2 =" <+> do addContext delta1 $ prettyTCM delta2+      , "n      =" <+> text (show n)+      , "perm   =" <+> text (show perm)+      , "top    =" <+> do addFullCtx $ prettyTCM topArgs+      , "qs     =" <+> prettyList (map pretty qs)+      , "qsToTm =" <+> prettyTCM tqs0 -- ctx would be permuted form of delta1 ++ delta2+      , "ys     =" <+> text (show ys)+      , "rho    =" <+> text (prettyShow rho)+      , "qs[rho]=" <+> do addFullCtx $ prettyTCM tqs+      , "dt     =" <+> do addFullCtx $ prettyTCM dt       ]     ]   reportSDoc "tc.with.display" 70 $ nest 2 $ vcat-      [ text "raw    =" <+> text (show display)+      [ "raw    =" <+> text (show display)       ]    return display@@ -709,19 +753,7 @@     -- Andreas, 2015-10-28: Yes, but properly! (Issue 1407)     sub top ys wild = parallelS $ map term [0 .. m + top - 1]       where-        term i = maybe wild var $ findIndex (Just i ==) ys-    -- -- OLD-    -- sub top rho wild = parallelS $ map term [0 .. m - 1] ++ topTerms-    --   where-    --     -- Ulf, 2014-02-19: We need to rename the module parameters as well! (issue1035)-    --     newVars  = length qs-    --     topTerms = [ var (i + newVars) | i <- [0..top - 1] ]-    --     -- thinking required.. but ignored-    --     -- dropping the reverse seems to work better-    --     -- Andreas, 2010-09-09: I DISAGREE.-    --     -- Ulf, 2011-09-02: Thinking done. Neither was correct.-    --     -- We had the wrong permutation and we used it incorrectly. Should work now.-    --     term i = maybe wild var $ findIndex (Just i ==) rho+        term i = maybe wild var $ List.elemIndex (Just i) ys  -- Andreas, 2014-12-05 refactored using numberPatVars -- Andreas, 2013-02-28 modeled after Coverage/Match/buildMPatterns@@ -737,9 +769,29 @@     toTerms = map $ fmap $ toTerm . namedThing      toTerm :: DeBruijnPattern -> DisplayTerm-    toTerm p = case p of-      ProjP _ d   -> DDef d [] -- WRONG. TODO: convert spine to non-spine ... DDef d . defaultArg-      VarP x      -> DTerm  $ var $ dbPatVarIndex x-      DotP t      -> DDot   $ t-      ConP c cpi ps -> DCon c (fromConPatternInfo cpi) $ toTerms ps-      LitP l      -> DTerm  $ Lit l+    toTerm p = case patOrigin $ fromMaybe __IMPOSSIBLE__ $ patternInfo p of+      PatOSystem -> toDisplayPattern p+      PatOSplit  -> toDisplayPattern p+      PatOSplitArg{} -> toVarOrDot p+      PatOVar{}  -> toVarOrDot p+      PatODot    -> DDot $ patternToTerm p+      PatOWild   -> toVarOrDot p+      PatOCon    -> toDisplayPattern p+      PatORec    -> toDisplayPattern p+      PatOLit    -> toDisplayPattern p+      PatOAbsurd -> toDisplayPattern p -- see test/Succeed/Issue2849.agda++    toDisplayPattern :: DeBruijnPattern -> DisplayTerm+    toDisplayPattern = \case+      IApplyP _ _ _ x -> DTerm $ var $ dbPatVarIndex x -- TODO, should be an Elim' DisplayTerm ?+      ProjP _ d  -> __IMPOSSIBLE__+      VarP i x -> DTerm  $ var $ dbPatVarIndex x+      DotP i t -> DDot   $ t+      p@(ConP c cpi ps) -> DCon c (fromConPatternInfo cpi) $ toTerms ps+      LitP i l -> DTerm  $ Lit l+      DefP _ q ps -> DDef q $ map Apply $ toTerms ps++    toVarOrDot :: DeBruijnPattern -> DisplayTerm+    toVarOrDot p = case patternToTerm p of+      Var i [] -> DTerm $ var i+      t        -> DDot t
+ src/full/Agda/Utils/AffineHole.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Contexts with at most one hole.++module Agda.Utils.AffineHole where++++data AffineHole r a+  = ZeroHoles a+      -- ^ A constant term.+  | OneHole (r -> a) r+      -- ^ A term with one hole and the (old) contents.+  | ManyHoles+      -- ^ A term with many holes (error value).+  deriving (Functor)++instance Applicative (AffineHole r) where+  pure = ZeroHoles++  ZeroHoles f <*> ZeroHoles a = ZeroHoles $ f a+  ZeroHoles f <*> OneHole g y = OneHole (f . g) y+  OneHole h x <*> ZeroHoles a = OneHole (`h` a) x+  _ <*> _ = ManyHoles++-- NB: @AffineHole r@ is not a monad.+-- @+--   OneHole (h :: r -> a) >>= (k :: a -> AffineHole r b) = _ :: AffineHole r b+-- @+-- We are lacking an @r@ to make use of @h@.
+ src/full/Agda/Utils/Applicative.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Utils.Applicative+       ( (?*>)+       , (?$>)+       , foldA+       , foldMapA+       , forA+       , liftA4+       )+       where++import Control.Applicative+import Data.Monoid ( Alt(..) )+import Data.Traversable ( for )++liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftA4 f a b c d = liftA3 f a b c <*> d++-- | Better name for 'for'.+forA :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)+forA = for++-- | Guard: return the action @f@ only if the boolean is @True@+(?*>) :: Alternative f => Bool -> f a -> f a+b ?*> f = if b then f else empty++-- | Guard: return the value @a@ only if the boolean is @True@+(?$>) :: Alternative f => Bool -> a -> f a+b ?$> a = b ?*> pure a++-- | Branch over a 'Foldable' collection of values.+foldA :: (Alternative f, Foldable t) => t a -> f a+foldA = foldMapA pure++-- | Branch over a 'Foldable' collection of values using the supplied+--   action.+foldMapA :: (Alternative f, Foldable t) => (a -> f b) -> t a -> f b+foldMapA f = getAlt . foldMap (Alt . f)
src/full/Agda/Utils/AssocList.hs view
@@ -1,18 +1,21 @@-{-# LANGUAGE CPP           #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Additional functions for association lists. -module Agda.Utils.AssocList where+module Agda.Utils.AssocList+  ( module Agda.Utils.AssocList+  , lookup+  ) where  import Prelude hiding (lookup) -import Control.Applicative-+import Data.Function (on)+import Data.List (lookup) import qualified Data.List as List+import qualified Data.Map  as Map  import Agda.Utils.Tuple -#include "undefined.h" import Agda.Utils.Impossible  -- | A finite map, represented as a set of pairs.@@ -20,11 +23,21 @@ --   Invariant: at most one value per key. type AssocList k v = [(k,v)] --- | O(n).---   Reexport 'List.lookup'.-lookup :: Eq k => k -> AssocList k v -> Maybe v-lookup = List.lookup+-- Lookup, reexported from Data.List.+-- O(n).+-- lookup :: Eq k => k -> AssocList k v -> Maybe v +-- | Lookup keys in the same association list often.+--   Use partially applied to create partial function+--   @apply m :: k -> Maybe v@.+--+--   * First time: @O(n log n)@ in the worst case.+--   * Subsequently: @O(log n)@.+--+--   Specification: @apply m == (`lookup` m)@.+apply :: Ord k => AssocList k v -> k -> Maybe v+apply m = (`Map.lookup` Map.fromListWith (\ _new old -> old) m)+ -- | O(n). --   Get the domain (list of keys) of the finite map. keys :: AssocList k v -> [k]@@ -42,6 +55,13 @@ --   Otherwise, an internal error is raised. update :: Eq k => k -> v -> AssocList k v -> AssocList k v update k v = updateAt k $ const v++-- | O(n).+--   Delete a binding.+--   The key must be in the domain of the finite map.+--   Otherwise, an internal error is raised.+delete :: Eq k => k -> AssocList k v -> AssocList k v+delete k = List.deleteBy ((==) `on` fst) (k, __IMPOSSIBLE__)  -- | O(n). --   Update the value at a key with a certain function.
src/full/Agda/Utils/Bag.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | A simple overlay over Data.Map to manage unordered sets with duplicates. @@ -7,32 +6,31 @@  import Prelude hiding (null, map) -import Control.Applicative hiding (empty)-import Text.Show.Functions ()--import Data.Foldable (Foldable(foldMap))-import Data.Functor.Identity-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Semigroup-import qualified Data.Set as Set-import Data.Traversable+import           Text.Show.Functions    () -- instance only -import Agda.Utils.Functor+import qualified Data.List              as List+import           Data.List.NonEmpty     ( NonEmpty, pattern (:|) )+import qualified Data.List.NonEmpty     as List1+  -- NB: Not importing Agda.Utils.List1 to avoid import cycles.+import           Data.Map               ( Map )+import qualified Data.Map               as Map+import           Data.Semigroup -#include "undefined.h"-import Agda.Utils.Impossible+import           Agda.Utils.Functor  -- | A set with duplicates. --   Faithfully stores elements which are equal with regard to (==).-newtype Bag a = Bag { bag :: Map a [a] }+newtype Bag a = Bag+  { bag :: Map a (NonEmpty a)+      -- ^ The list contains all occurrences of @a@ (not just the duplicates!).+      --   Hence, the invariant: the list is never empty.+  }   deriving (Eq, Ord)   -- The list contains all occurrences of @a@ (not just the duplicates!).-  -- Hence the invariant: the list is never empty!+  -- Hence the invariant: the list is never empty.   --   -- This is slightly wasteful, but much easier to implement-  -- in terms of Map as the alternative, which is to store+  -- in terms of @Map@ as the alternative, which is to store   -- only the duplicates in the list.   -- See, e.g., implementation of 'union' which would be impossible   -- to do in the other representation.  We would need a@@ -44,23 +42,29 @@ -- * Query ------------------------------------------------------------------------ +-- | Is the bag empty? null :: Bag a -> Bool null = Map.null . bag +-- | Number of elements in the bag.  Duplicates count. O(n). size :: Bag a -> Int size = getSum . foldMap (Sum . length) . bag --- | @bag ! a@ finds all elements equal to @a@.+-- | @(bag ! a)@ finds all elements equal to @a@.  O(log n).+--   Total function, returns @[]@ if none are. (!) :: Ord a => Bag a -> a -> [a]-Bag b ! a = Map.findWithDefault [] a b+(!) (Bag b) a = maybe [] List1.toList $ Map.lookup a b+  -- Note: not defined infix because of BangPatterns. +-- | O(log n). member :: Ord a => a -> Bag a -> Bool member a = not . notMember a +-- | O(log n). notMember :: Ord a => a -> Bag a -> Bool notMember a b = List.null (b ! a) --- | Return the multiplicity of the given element.+-- | Return the multiplicity of the given element. O(log n + count _ _). count :: Ord a => a -> Bag a -> Int count a b = length (b ! a) @@ -68,43 +72,45 @@ -- * Construction ------------------------------------------------------------------------ +-- | O(1) empty :: Bag a empty = Bag $ Map.empty +-- | O(1) singleton :: a -> Bag a-singleton a = Bag $ Map.singleton a [a]+singleton a = Bag $ Map.singleton a (a :| [])  union :: Ord a => Bag a -> Bag a -> Bag a-union (Bag b) (Bag c) = Bag $ Map.unionWith (++) b c+union (Bag b) (Bag c) = Bag $ Map.unionWith (<>) b c  unions :: Ord a => [Bag a] -> Bag a-unions = Bag . Map.unionsWith (++)  . List.map bag+unions = Bag . Map.unionsWith (<>)  . List.map bag  -- | @insert a b = union b (singleton a)@ insert :: Ord a => a -> Bag a -> Bag a-insert a = Bag . Map.insertWith (++) a [a] . bag+insert a = Bag . Map.insertWith (<>) a (a :| []) . bag  -- | @fromList = unions . map singleton@ fromList :: Ord a => [a] -> Bag a-fromList = Bag . Map.fromListWith (++) . List.map (\ a -> (a,[a]))+fromList = Bag . Map.fromListWith (<>) . List.map (\ a -> (a, a :| []))  ------------------------------------------------------------------------ -- * Destruction ------------------------------------------------------------------------  -- | Returns the elements of the bag, grouped by equality (==).-groups :: Bag a -> [[a]]+groups :: Bag a -> [NonEmpty a] groups = Map.elems . bag  -- | Returns the bag, with duplicates. toList :: Bag a -> [a]-toList = concat . groups+toList = concatMap List1.toList . groups  -- | Returns the bag without duplicates. keys :: Bag a -> [a] keys = Map.keys . bag -- Works because of the invariant!--- keys = catMaybes . map headMaybe . Map.elems . bag+-- keys = catMaybes . map listToMaybe . Map.elems . bag --   -- Map.keys does not work, as zero copies @(a,[])@ --   -- should count as not present in the bag. @@ -119,26 +125,26 @@ -- * Traversal ------------------------------------------------------------------------ +-- | O(n). map :: Ord b => (a -> b) -> Bag a -> Bag b-map f = Bag . Map.fromListWith (++) . List.map ff . Map.elems . bag+map f = Bag . Map.fromListWith (<>) . List.map ff . Map.elems . bag   where-    ff (a : as) = (b, b : List.map f as) where b = f a-    ff []       = __IMPOSSIBLE__+    ff (a :| as) = (b, b :| List.map f as) where b = f a  traverse' :: forall a b m . (Applicative m, Ord b) =>              (a -> m b) -> Bag a -> m (Bag b)-traverse' f = (Bag . Map.fromListWith (++)) <.> traverse trav . Map.elems . bag+traverse' f = (Bag . Map.fromListWith (<>)) <.> traverse trav . Map.elems . bag   where-    trav :: [a] -> m (b, [b])-    trav (a : as) = (\ b bs -> (b, b:bs)) <$> f a <*> traverse f as-    trav []       = __IMPOSSIBLE__+    trav :: NonEmpty a -> m (b, NonEmpty b)+    trav (a :| as) = (\ b bs -> (b, b :| bs)) <$> f a <*> traverse f as + --------------------------------------------------------------------------- * Instances+-- Instances ------------------------------------------------------------------------  instance Show a => Show (Bag a) where-  showsPrec _ (Bag b) = ("Agda.Utils.Bag.Bag (" ++) . showsPrec 0 b . (')':)+  showsPrec _ (Bag b) = ("Agda.Utils.Bag.Bag (" ++) . shows b . (')':)  instance Ord a => Semigroup (Bag a) where   (<>) = union
src/full/Agda/Utils/Benchmark.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE UndecidableInstances      #-}  -- | Tools for benchmarking and accumulating results. --   Nothing Agda-specific in here.@@ -8,21 +6,29 @@  import Prelude hiding (null) +import Control.DeepSeq import qualified Control.Exception as E (evaluate)+import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.Writer import Control.Monad.State+import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Foldable (foldMap)-import Data.Functor++import Data.Function (on) import qualified Data.List as List import Data.Monoid+import Data.Maybe +import GHC.Generics (Generic)+ import qualified Text.PrettyPrint.Boxes as Boxes +import Agda.Utils.ListT import Agda.Utils.Null import Agda.Utils.Monad hiding (finally) import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Time import Agda.Utils.Trie (Trie) import qualified Agda.Utils.Trie as Trie@@ -38,28 +44,37 @@  type Timings        a = Trie a CPUTime +data BenchmarkOn a = BenchmarkOff | BenchmarkOn | BenchmarkSome (Account a -> Bool)+  deriving Generic++isBenchmarkOn :: Account a -> BenchmarkOn a -> Bool+isBenchmarkOn _ BenchmarkOff      = False+isBenchmarkOn _ BenchmarkOn       = True+isBenchmarkOn a (BenchmarkSome p) = p a+ -- | Benchmark structure is a trie, mapping accounts (phases and subphases) --   to CPU time spent on their performance. data Benchmark a = Benchmark-  { benchmarkOn    :: !Bool+  { benchmarkOn    :: !(BenchmarkOn a)     -- ^ Are we benchmarking at all?   , currentAccount :: !(CurrentAccount a)     -- ^ What are we billing to currently?   , timings        :: !(Timings a)     -- ^ The accounts and their accumulated timing bill.   }+  deriving Generic  -- | Initial benchmark structure (empty). instance Null (Benchmark a) where   empty = Benchmark-    { benchmarkOn = False+    { benchmarkOn = BenchmarkOff     , currentAccount = Strict.Nothing     , timings = empty     }   null = null . timings  -- | Semantic editor combinator.-mapBenchmarkOn :: (Bool -> Bool) -> Benchmark a -> Benchmark a+mapBenchmarkOn :: (BenchmarkOn a -> BenchmarkOn a) -> Benchmark a -> Benchmark a mapBenchmarkOn f b = b { benchmarkOn = f $ benchmarkOn b }  -- | Semantic editor combinator.@@ -80,17 +95,16 @@   pretty b = text $ Boxes.render table     where     trie = timings b-    (accounts, times) = unzip $ Trie.toList trie-    aggrTimes         = do-      a <- accounts-      let t = Trie.lookupTrie a trie-          hasChildren =-            case foldMap (:[]) t of-              _:_:_ -> True-              _     -> False-      return $ if not (null a) && hasChildren-               then Boxes.text $ "(" ++ prettyShow (getSum $ foldMap Sum t) ++ ")"-               else Boxes.text ""+    (accounts, times0) = unzip $ Trie.toListOrderedBy (flip compare `on` snd)+                               $ Trie.filter ((> fromMilliseconds 10) . snd)+                               $ Trie.mapSubTries (Just . aggr) trie+    times = map fst times0+    aggr t = (fromMaybe 0 $ Trie.lookup [] t, getSum $ foldMap Sum t)+    aggrTimes = do+      (a, (t, aggrT)) <- zip accounts times0+      return $ if t == aggrT || null a+               then ""+               else Boxes.text $ "(" ++ prettyShow aggrT ++ ")"      -- Generate a table.     table = Boxes.hsep 1 Boxes.left [col1, col2, col3]@@ -105,7 +119,7 @@            sum times : times     -- Thid column: Aggregate times.     col3 = Boxes.vcat Boxes.right $-           Boxes.text "" : aggrTimes+           "" : aggrTimes      showAccount [] = "Miscellaneous"     showAccount ks = List.intercalate "." $ map prettyShow ks@@ -115,16 +129,14 @@  -- | Monad with access to benchmarking data. -class (Ord a, Functor m, MonadIO m) => MonadBench a m | m -> a where-  getBenchmark :: m (Benchmark a)--  getsBenchmark :: (Benchmark a -> c) -> m c-  getsBenchmark f = f <$> getBenchmark+class (Ord (BenchPhase m), Functor m, MonadIO m) => MonadBench m where+  type BenchPhase m+  getBenchmark :: m (Benchmark (BenchPhase m)) -  putBenchmark :: Benchmark a -> m ()+  putBenchmark :: Benchmark (BenchPhase m) -> m ()   putBenchmark b = modifyBenchmark $ const b -  modifyBenchmark :: (Benchmark a -> Benchmark a) -> m ()+  modifyBenchmark :: (Benchmark (BenchPhase m) -> Benchmark (BenchPhase m)) -> m ()   modifyBenchmark f = do     b <- getBenchmark     putBenchmark $! f b@@ -132,33 +144,63 @@   -- | We need to be able to terminate benchmarking in case of an exception.   finally :: m b -> m c -> m b --- needs UndecidableInstances because of weakness of FunctionalDependencies-instance MonadBench a m => MonadBench a (ReaderT r m) where+  {-# MINIMAL getBenchmark , (putBenchmark | modifyBenchmark) , finally #-}++getsBenchmark :: MonadBench m => (Benchmark (BenchPhase m) -> c) -> m c+getsBenchmark f = f <$> getBenchmark++instance MonadBench m => MonadBench (ReaderT r m) where+  type BenchPhase (ReaderT r m) = BenchPhase m   getBenchmark    = lift $ getBenchmark   putBenchmark    = lift . putBenchmark   modifyBenchmark = lift . modifyBenchmark   finally m f = ReaderT $ \ r ->     finally (m `runReaderT` r) (f `runReaderT` r) -instance MonadBench a m => MonadBench a (StateT r m) where+instance (MonadBench m, Monoid w) => MonadBench (WriterT w m) where+  type BenchPhase (WriterT w m) = BenchPhase m   getBenchmark    = lift $ getBenchmark   putBenchmark    = lift . putBenchmark   modifyBenchmark = lift . modifyBenchmark+  finally m f = WriterT $ finally (runWriterT m) (runWriterT f)++instance MonadBench m => MonadBench (StateT r m) where+  type BenchPhase (StateT r m) = BenchPhase m++  getBenchmark    = lift $ getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark   finally m f = StateT $ \s ->     finally (m `runStateT` s) (f `runStateT` s) +instance MonadBench m => MonadBench (ExceptT e m) where+  type BenchPhase (ExceptT e m) = BenchPhase m++  getBenchmark    = lift $ getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark+  finally m f = ExceptT $ finally (runExceptT m) (runExceptT f)++instance MonadBench m => MonadBench (ListT m) where+  type BenchPhase (ListT m) = BenchPhase m++  getBenchmark    = lift getBenchmark+  putBenchmark    = lift . putBenchmark+  modifyBenchmark = lift . modifyBenchmark+  finally m f = ListT $ finally (runListT m) (runListT f)+ -- | Turn benchmarking on/off. -setBenchmarking :: MonadBench a m => Bool -> m ()+setBenchmarking :: MonadBench m => BenchmarkOn (BenchPhase m) -> m () setBenchmarking b = modifyBenchmark $ mapBenchmarkOn $ const b  -- | Bill current account with time up to now. --   Switch to new account. --   Return old account (if any). -switchBenchmarking :: MonadBench a m-  => Strict.Maybe (Account a)      -- ^ Maybe new account.-  -> m (Strict.Maybe (Account a))  -- ^ Maybe old account.+switchBenchmarking :: MonadBench m+  => Strict.Maybe (Account (BenchPhase m))      -- ^ Maybe new account.+  -> m (Strict.Maybe (Account (BenchPhase m)))  -- ^ Maybe old account. switchBenchmarking newAccount = do   now <- liftIO $ getCPUTime   -- Stop and bill current benchmarking.@@ -171,24 +213,25 @@  -- | Resets the account and the timing information. -reset :: MonadBench a m => m ()+reset :: MonadBench m => m () reset = modifyBenchmark $   mapCurrentAccount (const Strict.Nothing) .   mapTimings (const Trie.empty) +{-# INLINABLE billTo #-} -- | Bill a computation to a specific account. --   Works even if the computation is aborted by an exception. -billTo :: MonadBench a m => Account a -> m c -> m c-billTo account m = ifNotM (getsBenchmark benchmarkOn) m $ do+billTo :: MonadBench m => Account (BenchPhase m) -> m c -> m c+billTo account m = ifNotM (isBenchmarkOn account <$> getsBenchmark benchmarkOn) m $ do   -- Switch to new account.   old <- switchBenchmarking $ Strict.Just account   -- Compute and switch back to old account.   (liftIO . E.evaluate =<< m) `finally` switchBenchmarking old  -- | Bill a CPS function to an account. Can't handle exceptions.-billToCPS :: MonadBench a m => Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c-billToCPS account f k = ifNotM (getsBenchmark benchmarkOn) (f k) $ do+billToCPS :: MonadBench m => Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c+billToCPS account f k = ifNotM (isBenchmarkOn account <$> getsBenchmark benchmarkOn) (f k) $ do   -- Switch to new account.   old <- switchBenchmarking $ Strict.Just account   f $ \ x -> x `seq` do@@ -196,5 +239,10 @@     k x  -- | Bill a pure computation to a specific account.-billPureTo :: MonadBench a m  => Account a -> c -> m c+billPureTo :: MonadBench m  => Account (BenchPhase m) -> c -> m c billPureTo account = billTo account . return++-- NFData instances.++instance NFData a => NFData (BenchmarkOn a)+instance NFData a => NFData (Benchmark a)
src/full/Agda/Utils/BiMap.hs view
@@ -1,73 +1,451 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-} --- | Finite bijections (implemented as a pair of maps).+-- | Partly invertible finite maps.+--+-- Time complexities are given under the assumption that all relevant+-- instance functions, as well as arguments of function type, take+-- constant time, and "n" is the number of keys involved in the+-- operation.  module Agda.Utils.BiMap where -import Prelude hiding (lookup, unzip)+import Prelude hiding (null, lookup) -import Control.Applicative ((<*>))+import Control.Monad.Identity+import Control.Monad.State -import Data.Function-import Data.Functor+import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe+import Data.Ord import Data.Tuple-import Data.Typeable ( Typeable ) --- | Finite bijective map from @a@ to @b@.  There, and back again.-data BiMap a b = BiMap-  { biMapThere :: Map a b-  , biMapBack  :: Map b a+import GHC.Generics (Generic)++import Agda.Utils.List+import Agda.Utils.Null++-- | Partial injections from a type to some tag type.+--+-- The idea is that 'tag' should be injective on its domain: if+-- @'tag' x = 'tag' y = 'Just' i@, then @x = y@. However, this+-- property does not need to hold globally. The preconditions of the+-- 'BiMap' operations below specify for which sets of values 'tag'+-- must be injective.++class HasTag a where+  type Tag a+  tag :: a -> Maybe (Tag a)++-- | Checks if the function 'tag' is injective for the values in the+-- given list for which the function is defined.++tagInjectiveFor ::+  (Eq v, Eq (Tag v), HasTag v) =>+  [v] -> Bool+tagInjectiveFor vs = and+  [ v1 == v2+  | v1 <- vs+  , v2 <- vs+  , isJust (tag v1)+  , tag v1 == tag v2+  ]++-- | Finite maps from @k@ to @v@, with a way to quickly get from @v@+-- to @k@ for certain values of type @v@ (those for which 'tag' is+-- defined).+--+-- Every value of this type must satisfy 'biMapInvariant'.++data BiMap k v = BiMap+  { biMapThere :: !(Map k v)+  , biMapBack  :: !(Map (Tag v) k)   }-  deriving (Typeable)+  deriving Generic +-- | The invariant for 'BiMap'.++biMapInvariant ::+  (Eq k, Eq v, Ord (Tag v), HasTag v) =>+  BiMap k v -> Bool+biMapInvariant m@(BiMap t u) =+  u ==+  Map.fromList+    [ (k', k)+    | (k, v) <- Map.toList t+    , Just k' <- [tag v]+    ]+    &&+  tagInjectiveFor (map snd $ toList m)++instance Null (BiMap k v) where+  empty = BiMap Map.empty Map.empty+  null  = null . biMapThere++-- | Is the value a source key? O(log n).++source :: Ord k => k -> BiMap k v -> Bool+source k = Map.member k . biMapThere++-- | Is the value a target key? O(log n).++target :: Ord (Tag v) => Tag v -> BiMap k v -> Bool+target k = Map.member k . biMapBack+ -- | Lookup. O(log n).-lookup :: Ord a => a -> BiMap a b -> Maybe b++lookup :: Ord k => k -> BiMap k v -> Maybe v lookup a = Map.lookup a . biMapThere --- | Inverse lookup.  O(log n).-invLookup :: Ord b => b -> BiMap a b -> Maybe a-invLookup b = Map.lookup b . biMapBack+-- | Inverse lookup. O(log n). --- | Empty bimap. O(1).-empty :: BiMap a b-empty = BiMap Map.empty Map.empty+invLookup :: Ord (Tag v) => Tag v -> BiMap k v -> Maybe k+invLookup k = Map.lookup k . biMapBack --- | Singleton bimap. O(1).-singleton :: a -> b -> BiMap a b-singleton a b = BiMap (Map.singleton a b) (Map.singleton b a)+-- | Singleton map. O(1). --- | Insert.  Overwrites existing value if present.-insert :: (Ord a, Ord b) => a -> b -> BiMap a b -> BiMap a b-insert a b (BiMap t u) = BiMap (Map.insert a b t) (Map.insert b a u)+singleton :: HasTag v => k -> v -> BiMap k v+singleton k v =+  BiMap+    (Map.singleton k v)+    (case tag v of+       Nothing -> Map.empty+       Just k' -> Map.singleton k' k) --- | Left-biased Union. O(Map.union).-union :: (Ord a, Ord b) => BiMap a b -> BiMap a b -> BiMap a b-union (BiMap t1 b1) (BiMap t2 b2) = BiMap (Map.union t1 t2) (Map.union b1 b2)+-- | Insertion. Overwrites existing values. O(log n).+--+-- Precondition: See 'insertPrecondition'. --- | Construct from a list of pairs.+insert ::+  (Ord k, HasTag v, Ord (Tag v)) =>+  k -> v -> BiMap k v -> BiMap k v+insert k v (BiMap t b) =+  BiMap+    (Map.insert k v t)+    (case tag v of+       Nothing -> b'+       Just k' -> Map.insert k' k b')+  where+  b' = case tag =<< Map.lookup k t of+    Nothing -> b+    Just k' -> Map.delete k' b++-- | The precondition for @'insert' k v m@: If @v@ has a 'tag' (@'tag'+-- v ≠ 'Nothing'@), then @m@ must not contain any mapping @k' ↦ v'@+-- for which @k ≠ k'@ and @'tag' v = 'tag' v'@.++insertPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  k -> v -> BiMap k v -> Bool+insertPrecondition k v m =+  case tag v of+    Nothing -> True+    Just _  ->+      not $ any (\(k', v') -> k' /= k && tag v == tag v') $ toList m++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n). -----   Does not check for actual bijectivity of constructed finite map.-fromList :: (Ord a, Ord b) => [(a,b)] -> BiMap a b-fromList = List.foldl' (flip (uncurry insert)) empty+-- The precondition for @'alterM' f k m@ is that, if the value @v@ is+-- inserted into @m@, and @'tag' v@ is defined, then no key other than+-- @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@. --- | Turn into list, sorted ascendingly by first value.-toList :: BiMap a b -> [(a,b)]+alterM ::+  forall k v m. (Ord k, Ord (Tag v), HasTag v, Monad m) =>+  (Maybe v -> m (Maybe v)) -> k -> BiMap k v -> m (BiMap k v)+alterM f k m@(BiMap t b) = do+  (t', r) <- runStateT (Map.alterF f' k t) Nothing+  return $ case r of+    Nothing -> m+    Just r  -> BiMap t' (updateBack r b)+  where+  f' ::+    Maybe v ->+    StateT (Maybe (Maybe (Tag v), Maybe (Tag v))) m (Maybe v)+  f' v = do+    r <- lift (f v)+    put $ Just (tag =<< v, tag =<< r)+    return r++  updateBack (k'1, k'2) =+    if k'1 == k'2+    then id+    else maybe id (flip Map.insert k) k'2 .+         maybe id Map.delete k'1++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n).+--+-- Precondition: See 'alterPrecondition'.++alter ::+  forall k v. (Ord k, Ord (Tag v), HasTag v) =>+  (Maybe v -> Maybe v) -> k -> BiMap k v -> BiMap k v+alter f k m = runIdentity $ alterM (Identity . f) k m++-- | The precondition for @'alter' f k m@ is that, if the value @v@ is+-- inserted into @m@, and @'tag' v@ is defined, then no key other than+-- @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++alterPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (Maybe v -> Maybe v) -> k -> BiMap k v -> Bool+alterPrecondition f k m =+  case tag =<< f (lookup k m) of+    Nothing -> True+    Just k' -> and+      [ Just k' /= tag v+      | (k'', v) <- toList m+      , k'' /= k+      ]++-- | Modifies the value at the given position, if any. If the function+-- returns 'Nothing', then the value is removed. O(log n).+--+-- Precondition: See 'updatePrecondition'.++update ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (v -> Maybe v) -> k -> BiMap k v -> BiMap k v+update f = alter (f =<<)++-- | The precondition for @'update' f k m@ is that, if the value @v@+-- is inserted into @m@, and @'tag' v@ is defined, then no key other+-- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++updatePrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (v -> Maybe v) -> k -> BiMap k v -> Bool+updatePrecondition f = alterPrecondition (f =<<)++-- | Modifies the value at the given position, if any. O(log n).+--+-- Precondition: See 'adjustPrecondition'.++adjust ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (v -> v) -> k -> BiMap k v -> BiMap k v+adjust f = update (Just . f)++-- | The precondition for @'adjust' f k m@ is that, if the value @v@+-- is inserted into @m@, and @'tag' v@ is defined, then no key other+-- than @k@ may map to a value @v'@ for which @'tag' v' = 'tag' v@.++adjustPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (v -> v) -> k -> BiMap k v -> Bool+adjustPrecondition f = updatePrecondition (Just . f)++-- | Inserts a binding into the map. If a binding for the key already+-- exists, then the value obtained by applying the function to the+-- key, the new value and the old value is inserted, and the old value+-- is returned.+--+-- Precondition: See 'insertLookupWithKeyPrecondition'.++insertLookupWithKey ::+  forall k v. (Ord k, Ord (Tag v), HasTag v) =>+  (k -> v -> v -> v) -> k -> v -> BiMap k v -> (Maybe v, BiMap k v)+insertLookupWithKey f k v m = swap $ runState (alterM f' k m) Nothing+  where+  f' :: Maybe v -> State (Maybe v) (Maybe v)+  f' Nothing     = return $ Just v+  f' r@(Just v') = do+    put r+    return $ Just (f k v v')++-- | The precondition for @'insertLookupWithKey' f k v m@ is that, if+-- the value @v'@ is inserted into @m@, and @'tag' v'@ is defined,+-- then no key other than @k@ may map to a value @v''@ for which+-- @'tag' v'' = 'tag' v'@.++insertLookupWithKeyPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  (k -> v -> v -> v) -> k -> v -> BiMap k v -> Bool+insertLookupWithKeyPrecondition f k v =+  alterPrecondition (Just . maybe v (f k v)) k++-- | Changes all the values using the given function, which is also+-- given access to keys. O(n log n).+--+-- Precondition: See 'mapWithKeyPrecondition'.++mapWithKey ::+  (Ord k, Ord (Tag v), HasTag v) =>+  (k -> v -> v) -> BiMap k v -> BiMap k v+mapWithKey f = fromList . map (\(k, v) -> (k, f k v)) . toList++-- | The precondition for @'mapWithKey' f m@: For any two distinct+-- mappings @k₁ ↦ v₁@, @k₂ ↦ v₂@ in @m@ for which the tags of+-- @f k₁ v₁@ and @f k₂ v₂@ are defined the values of @f@ must be+-- distinct (@f k₁ v₁ ≠ f k₂ v₂@). Furthermore 'tag' must be injective+-- for @{ f k v | (k, v) ∈ m }@.++mapWithKeyPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  (k -> v -> v) -> BiMap k v -> Bool+mapWithKeyPrecondition f =+  fromListPrecondition . map (\(k, v) -> (k, f k v)) . toList++-- | Changes all the values using the given function, which is also+-- given access to keys. O(n).+--+-- Precondition: See 'mapWithKeyFixedTagsPrecondition'. Note that tags+-- must not change.++mapWithKeyFixedTags :: (k -> v -> v) -> BiMap k v -> BiMap k v+mapWithKeyFixedTags f (BiMap t b) = BiMap (Map.mapWithKey f t) b++-- | The precondition for @'mapWithKeyFixedTags' f m@ is that, if @m@+-- maps @k@ to @v@, then @'tag' (f k v) == 'tag' v@.++mapWithKeyFixedTagsPrecondition ::+  (Eq v, Eq (Tag v), HasTag v) =>+  (k -> v -> v) -> BiMap k v -> Bool+mapWithKeyFixedTagsPrecondition f m = and+  [ tag (f k v) == tag v+  | (k, v) <- toList m+  ]++-- | Left-biased union. For the time complexity, see 'Map.union'.+--+-- Precondition: See 'unionPrecondition'.++union :: (Ord k, Ord (Tag v)) => BiMap k v -> BiMap k v -> BiMap k v+union (BiMap t1 b1) (BiMap t2 b2) =+  BiMap (Map.union t1 t2) (Map.union b1 b2)++-- The precondition for @'union' m₁ m₂@: If @k@ is mapped to @v₁@ in+-- @m₁@ and @v₂@ in @m₂@, then @'tag' v₂ = 'Nothing'@ or @'tag' v₁ =+-- 'tag' v₂@. Furthermore, if @k₁@ is mapped to @v₁@ in @m₁@ and @k₂@+-- is mapped to @v₂@ in @m₂@, where @'tag' v₁ = 'tag' v₂ = 'Just' k@,+-- then @k₁ = k₂@. Finally 'tag' must be injective for+-- @{v₁ | (k₁, v₁) ∈ m₁} ∪ {v₂ | (k₂, v₂) ∈ m₂, k₂ ∉ m₁}@.++unionPrecondition ::+  (Ord k, Eq v, Eq (Tag v), HasTag v) =>+  BiMap k v -> BiMap k v -> Bool+unionPrecondition m1@(BiMap t1 _) m2@(BiMap t2 _) =+  and+    [ tag v2 == Nothing || tag v1 == tag v2+    | (v1, v2) <- Map.elems $ Map.intersectionWith (,) t1 t2+    ] &&+  and+    [ k1 == k2+    | (k1, v1) <- toList m1+    , (k2, v2) <- toList m2+    , tag v1 == tag v2+    , isJust (tag v1)+    ]+    &&+  tagInjectiveFor+    ([ v1+     | (_, v1) <- toList m1+     ] +++     [ v2+     | (k2, v2) <- toList m2+     , k2 `notElem` ks1+     ])+  where+  ks1 = map fst (toList m1)++-- | Conversion from lists of pairs. Later entries take precedence+-- over earlier ones. O(n log n).+--+-- Precondition: See 'fromListPrecondition'.++fromList ::+  (Ord k, Ord (Tag v), HasTag v) =>+  [(k, v)] -> BiMap k v+fromList = List.foldr (uncurry insert) empty++-- The precondition for @'fromList' kvs@: For all pairs @(k₁, v₁)@,+-- @(k₂, v₂)@ in @kvs@ for which the tags of @v₁@ and @v₂@ are+-- defined, if @v₁ = v₂@ then @k₁ = k₂@. Furthermore 'tag' must be+-- injective for the values in the list.++fromListPrecondition ::+  (Eq k, Eq v, Eq (Tag v), HasTag v) =>+  [(k, v)] -> Bool+fromListPrecondition kvs =+  and+    [ k1 == k2+    | (k1, v1) <- kvs+    , (k2, v2) <- kvs+    , isJust (tag v1)+    , isJust (tag v2)+    , v1 == v2+    ]+    &&+  tagInjectiveFor (map snd kvs)++-- | Conversion to lists of pairs, with the keys in ascending order.+-- O(n).++toList :: BiMap k v -> [(k, v)] toList = Map.toAscList . biMapThere +-- | The keys, in ascending order. O(n).++keys :: BiMap k v -> [k]+keys = Map.keys . biMapThere++-- | The values, ordered according to the corresponding keys. O(n).++elems :: BiMap k v -> [v]+elems = Map.elems . biMapThere++-- | Conversion from two lists that contain distinct keys/tags, with+-- the keys/tags in ascending order. O(n).+--+-- Precondition: See 'fromDistinctAscendingListsPrecondition'.++fromDistinctAscendingLists ::+  ([(k, v)], [(Tag v, k)]) -> BiMap k v+fromDistinctAscendingLists (t, b) =+  BiMap (Map.fromDistinctAscList t) (Map.fromDistinctAscList b)++-- The precondition for @'fromDistinctAscendingLists' (kvs, kks)@: The+-- lists must contain distinct keys/tags, and must be sorted according+-- to the keys/tags. Furthermore, for every pair @(k, v)@ in the first+-- list for which @'tag' v = 'Just' k'@ there must be a pair @(k', k)@+-- in the second list, and there must not be any other pairs in that+-- list. Finally 'tag' must be injective for @{v | (_, v) ∈ kvs }@.++fromDistinctAscendingListsPrecondition ::+  (Ord k, Eq v, Ord (Tag v), HasTag v) =>+  ([(k, v)], [(Tag v, k)]) -> Bool+fromDistinctAscendingListsPrecondition (kvs, kks) =+  fastDistinct (map fst kvs) && sorted (map fst kvs)+    &&+  fastDistinct (map fst kks) && sorted (map fst kks)+    &&+  kks ==+  List.sortBy (comparing fst)+    [ (k', k)+    | (k, v) <- kvs+    , Just k' <- [tag v]+    ]+    &&+  tagInjectiveFor [ v | (_, v) <- kvs ]++-- | Generates input suitable for 'fromDistinctAscendingLists'. O(n).++toDistinctAscendingLists :: BiMap k v -> ([(k, v)], [(Tag v, k)])+toDistinctAscendingLists (BiMap t b) =+  (Map.toAscList t, Map.toAscList b)+ --------------------------------------------------------------------------- * Instances+-- Instances ------------------------------------------------------------------------ -instance (Ord a, Ord b) => Eq (BiMap a b) where+instance (Eq k, Eq v) => Eq (BiMap k v) where   (==) = (==) `on` biMapThere -instance (Ord a, Ord b) => Ord (BiMap a b) where+instance (Ord k, Ord v) => Ord (BiMap k v) where   compare = compare `on` biMapThere -instance (Show a, Show b) => Show (BiMap a b) where+instance (Show k, Show v) => Show (BiMap k v) where   show bimap = "Agda.Utils.BiMap.fromList " ++ show (toList bimap)-
+ src/full/Agda/Utils/BoolSet.hs view
@@ -0,0 +1,184 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Representation of @'Set' 'Bool'@ as a 4-element enum type.+--+-- All operations in constant time and space.+--+-- Mimics the interface of 'Data.Set'.+--+-- Import as:+-- @+--    import qualified Agda.Utils.BoolSet as BoolSet+--    import Agda.Utils.BoolSet (BoolSet)+-- @++module Agda.Utils.BoolSet+  ( BoolSet+  , (\\)+  , complement+  , delete+  , difference+  , elems+  , empty+  , fromList, fromAscList, fromDistinctAscList+  , insert+  , intersection+  , isSubsetOf+  , lookupMin+  , member+  , notMember+  , null+  , singleton+  , size+  , toList, toAscList+  , toSingleton+  , total+  , union+  ) where++import Prelude hiding (null)++import Agda.Utils.Impossible++-- | Isomorphic to @'Set' 'Bool'@.+data BoolSet = SetEmpty | SetTrue | SetFalse | SetBoth+  deriving (Eq, Ord, Show, Enum, Bounded)++-- * Query++null :: BoolSet -> Bool+null = (SetEmpty ==)++size :: BoolSet -> Int+size = \case+  SetEmpty -> 0+  SetTrue  -> 1+  SetFalse -> 1+  SetBoth  -> 2++member :: Bool -> BoolSet -> Bool+member b = \case+  SetEmpty -> False+  SetBoth  -> True+  SetTrue  -> b+  SetFalse -> not b++-- | @not . member b@.+notMember :: Bool -> BoolSet -> Bool+notMember b = not . member b++isSubsetOf ::  BoolSet -> BoolSet -> Bool+isSubsetOf = curry $ \case+  (SetEmpty , _        ) -> True+  (_        , SetBoth  ) -> True+  (SetTrue  , SetTrue  ) -> True+  (SetFalse , SetFalse ) -> True+  _                      -> False++lookupMin :: BoolSet -> Maybe Bool+lookupMin = \case+  SetEmpty -> Nothing+  SetTrue  -> Just True+  _        -> Just False++-- | @toSingleton s == Just b@ iff @s == singleton b@.+toSingleton :: BoolSet -> Maybe Bool+toSingleton  = \case+  SetTrue  -> Just True+  SetFalse -> Just False+  _        -> Nothing++-- * Construction++-- | The empty set.+empty :: BoolSet+empty = SetEmpty++-- | The full set.+total :: BoolSet+total = SetBoth++-- | A singleton set.+singleton :: Bool -> BoolSet+singleton = \case+  True  -> SetTrue+  False -> SetFalse++insert :: Bool -> BoolSet -> BoolSet+insert b = \case+  SetBoth  -> SetBoth+  SetEmpty -> singleton b+  SetTrue  -> if b then SetTrue else SetBoth+  SetFalse -> if b then SetBoth else SetFalse++delete :: Bool -> BoolSet -> BoolSet+delete b = \case+  SetEmpty -> SetEmpty+  SetTrue  -> if b then SetEmpty else SetTrue+  SetFalse -> if b then SetFalse else SetEmpty+  SetBoth  -> if b then SetFalse else SetTrue++-- * Combine++complement :: BoolSet -> BoolSet+complement = \case+  SetEmpty -> SetBoth+  SetBoth  -> SetEmpty+  SetTrue  -> SetFalse+  SetFalse -> SetTrue++difference, (\\) :: BoolSet -> BoolSet -> BoolSet+difference = curry $ \case+  (SetEmpty , _        ) -> SetEmpty+  (_        , SetBoth  ) -> SetEmpty+  (s        , SetEmpty ) -> s+  (SetBoth  , SetTrue  ) -> SetFalse+  (SetBoth  , SetFalse ) -> SetTrue+  (SetTrue  , SetTrue  ) -> SetEmpty+  (SetTrue  , SetFalse ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetFalse+  (SetFalse , SetFalse ) -> SetEmpty+(\\)       = difference++intersection ::  BoolSet -> BoolSet -> BoolSet+intersection = curry $ \case+  (SetEmpty , _        ) -> SetEmpty+  (_        , SetEmpty ) -> SetEmpty+  (SetBoth  , s        ) -> s+  (s        , SetBoth  ) -> s+  (SetTrue  , SetTrue  ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetEmpty+  (SetTrue  , SetFalse ) -> SetEmpty+  (SetFalse , SetFalse ) -> SetFalse++union ::  BoolSet -> BoolSet -> BoolSet+union = curry $ \case+  (SetBoth  , _        ) -> SetBoth+  (_        , SetBoth  ) -> SetBoth+  (SetEmpty , s        ) -> s+  (s        , SetEmpty ) -> s+  (SetTrue  , SetTrue  ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetBoth+  (SetTrue  , SetFalse ) -> SetBoth+  (SetFalse , SetFalse ) -> SetFalse++-- * Conversion++elems, toList, toAscList :: BoolSet -> [Bool]+elems     = \case+  SetEmpty -> []+  SetTrue  -> [True]+  SetFalse -> [False]+  SetBoth  -> [False, True]+toList    = elems+toAscList = elems++fromList, fromAscList, fromDistinctAscList :: [Bool] -> BoolSet+fromList            = foldr insert SetEmpty+fromAscList         = fromList+fromDistinctAscList = \case+  []            -> SetEmpty+  [False]       -> SetFalse+  [True]        -> SetTrue+  [False, True] -> SetBoth+  _             -> __IMPOSSIBLE__
+ src/full/Agda/Utils/Boolean.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Boolean algebras and types isomorphic to 'Bool'.+--+-- There are already solutions for 'Boolean' algebras in the Haskell ecosystem,+-- but they do not offer easy instantiations for types isomorphic to 'Bool'.+-- In particular, if type @a@ is isomorphic to 'Bool', so it satisfies `IsBool a`,+-- we would like to instantiate 'Boolean a' by just giving 'true' and 'false'.+-- To facilitate this within the limits of the Haskell class system,+-- we define the class 'Boolean' mutually with class 'IsBool',+-- so that operations 'not', '(&&)', and '(||)' can get default implementations.+--+-- Usage:+-- @+--    import Prelude hiding ( not, (&&), (||) )+--    import Agda.Utils.Boolean+-- @++module Agda.Utils.Boolean where++import Prelude ( Bool(True,False), Eq, ($), (.), const, id )+import qualified Prelude as P++infixr 3 &&+infixr 2 ||++-- | Boolean algebras.+--+class Boolean a where+  fromBool :: Bool -> a++  true :: a+  true = fromBool True++  false :: a+  false = fromBool False++  not :: a -> a++  (&&) :: a -> a -> a++  (||) :: a -> a -> a++  implies :: a -> a -> a+  implies a b = b || not a++  -- | Set difference, dual to 'implies'.+  butNot :: a -> a -> a+  butNot a b = a && not b++  default not :: IsBool a => a -> a+  not = fromBool1 P.not++  default (&&) :: IsBool a => a -> a -> a+  (&&) = fromBool2 (P.&&)++  default (||) :: IsBool a => a -> a -> a+  (||) = fromBool2 (P.||)++-- | Types isomorphic to 'Bool'.+--+class (Boolean a, Eq a) => IsBool a where+  toBool :: a -> Bool++  ifThenElse :: a -> b -> b -> b+  ifThenElse c t e = if toBool c then t else e++  fromBool1 :: (Bool -> Bool) -> (a -> a)+  fromBool1 f = fromBool . f . toBool++  fromBool2 :: (Bool -> Bool -> Bool) -> (a -> a -> a)+  fromBool2 f a b = fromBool $ f (toBool a) (toBool b)++  {-# MINIMAL toBool #-}++instance Boolean Bool where+  fromBool = id++instance IsBool Bool where+  toBool = id+  -- optional+  fromBool1 = id+  fromBool2 = id++instance Boolean b => Boolean (a -> b) where+  fromBool   = const . fromBool+  not f      = not . f+  (f && g) a = f a && g a+  (f || g) a = f a || g a
+ src/full/Agda/Utils/CallStack.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Utils.CallStack (module Exports) where+import Agda.Utils.CallStack.Base as Exports+import Agda.Utils.CallStack.Pretty as Exports ()
+ src/full/Agda/Utils/CallStack/Base.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Utils.CallStack.Base (+  -- * Simple type aliases+    SrcLocPackage+  , SrcLocModule+  , SrcFun+  , SrcLocFile+  , SrcLocLine+  , SrcLocCol+  , CallSite(..)+  , CallSiteFilter++  -- * String-based "pretty" representations+  , prettySrcLoc+  , prettyCallSite+  , prettyCallStack++  -- * Generic utilities over CallStack and CallSite+  , filterCallStack+  , headCallSite+  , overCallSites+  , popnCallStack+  , truncatedCallStack+  , withCallerCallStack+  , withCurrentCallStack+  , withNBackCallStack++  -- * Re-exported stuff+  , CallStack+  , callStack+  , fromCallSiteList+  , getCallStack+  , HasCallStack+  , SrcLoc(..)+  )+  where++import Data.List ( intercalate )+import Data.Maybe ( listToMaybe )+import GHC.Stack+  ( callStack+  , CallStack+  , emptyCallStack+  , fromCallSiteList+  , getCallStack+  , HasCallStack+  , popCallStack+  , prettySrcLoc+  , SrcLoc(..)+  )++-- * Type aliases++-- | Type of the package name of a @SrcLoc@+-- | e.g. `Agda-2.…`+type SrcLocPackage = String++-- | Type of the module name of a @SrcLoc@+-- | e.g. `Agda.Utils.Foo`+type SrcLocModule = String++-- | Type of the name of a function in a @CallSite@+-- | e.g. `proveEverything`+type SrcFun = String++-- | Type of a filename of a @SrcLoc@+-- | e.g. `src/full/Agda/Utils/Foo.hs`+type SrcLocFile = String++-- | Type of a line number of a @SrcLoc@+type SrcLocLine = Int++-- | Type of a column of a @SrcLoc@+type SrcLocCol = Int++-- | Type of an entry in  a @CallStack@+newtype CallSite = CallSite { unCallSite :: (SrcFun, SrcLoc) }++-- | Type of a filter for @CallSite@+type CallSiteFilter = CallSite -> Bool++-- * Simple String representations+-- Note that there are @Agda.Syntax.Common.Pretty@ instances defined in @Agda.Utils.CallStack.Pretty@++-- | The same as the un-exported internal function in @GHC.Exceptions (prettyCallStackLines)@+--  Prints like: @doFoo, called at foo.hs:190:24 in main:Main@+prettyCallSite :: CallSite -> String+prettyCallSite (CallSite (fun, loc)) = fun ++ ", called at " ++ prettySrcLoc loc++-- | Pretty-print a @CallStack@. This has a few differences from @GHC.Stack.prettyCallStackLines@.+-- We omit the "CallStack (from GetCallStack)" header line for brevity.+-- If there is only one entry (which is common, due to the manual nature of the @HasCallStack@ constraint),+-- shows the entry on one line. If there are multiple, then the following lines are indented.+prettyCallStack :: CallStack -> String+prettyCallStack cs = case map (prettyCallSite . CallSite) (getCallStack cs) of+  []                  -> "(empty CallStack)"+  firstLoc : restLocs -> intercalate "\n" (firstLoc : (map ("  " ++) restLocs))++-- * Generic utilities over CallStack and CallSite++-- | Get the most recent @CallSite@ in a @CallStack@, if there is one.+headCallSite :: CallStack -> Maybe CallSite+headCallSite = fmap CallSite . listToMaybe . getCallStack++-- | @CallStack@ comprising only the most recent @CallSite@+truncatedCallStack :: CallStack -> CallStack+truncatedCallStack cs = maybe emptyCallStack (fromCallSiteList . pure) (fmap unCallSite $ headCallSite cs)++-- | Transform a @CallStack@ by transforming its list of @CallSite@+overCallSites :: ([CallSite] -> [CallSite]) -> CallStack -> CallStack+overCallSites f = fromCallSiteList . (map unCallSite . f . map CallSite) . getCallStack++-- | Transform a @CallStack@ by filtering each @CallSite@+filterCallStack :: CallSiteFilter -> CallStack -> CallStack+filterCallStack = overCallSites . filter++-- | Pops n entries off a @CallStack@ using @popCallStack@.+-- Note that frozen callstacks are unaffected.+popnCallStack :: Word -> CallStack -> CallStack+popnCallStack 0 = id+popnCallStack n = (popnCallStack (n - 1)) . popCallStack++withNBackCallStack :: HasCallStack => Word -> (CallStack -> b) -> b+withNBackCallStack n f = f (popnCallStack n from)+  where+    -- This very line (always dropped):+    here = callStack+    -- The invoker (n = 0):+    from = popCallStack here++withCurrentCallStack :: HasCallStack => (CallStack -> b) -> b+withCurrentCallStack = withNBackCallStack 0+  -- 0 => this line in this utility function.+  -- 1 => the invocation of this utility function.++withCallerCallStack :: HasCallStack => (CallStack -> b) -> b+withCallerCallStack = withNBackCallStack 1+  -- 0 => this line in this utility function.+  -- 1 => our caller.+  -- 2 => their caller.
+ src/full/Agda/Utils/CallStack/Pretty.hs view
@@ -0,0 +1,32 @@+module Agda.Utils.CallStack.Pretty+  ( -- This module only exports instances.+  ) where++import Agda.Utils.CallStack.Base+  ( CallSite(..)+  , CallStack+  , SrcLoc(..)+  , getCallStack+  )+import Agda.Syntax.Common.Pretty+  ( (<+>), ($+$), (<>)+  , pshow, text+  , colon, comma+  , nest, parens+  , hcat, hsep, vcat+  , Pretty(pretty)+  )++instance Pretty SrcLoc where+  pretty SrcLoc {..} = hsep [physicalLoc, "in", logicalLoc]+      where+        physicalLoc = hcat [text srcLocFile, colon, pshow srcLocStartLine, colon, pshow srcLocStartCol]+        logicalLoc = hcat [text srcLocPackage, colon, text srcLocModule]++instance Pretty CallSite where+  pretty (CallSite (fun, loc)) = hsep [text fun <> comma, "called at", pretty loc]++instance Pretty CallStack where+  pretty cs = case fmap pretty (getCallStack cs) of+    []                  -> parens "empty CallStack"+    firstLoc : restLocs -> firstLoc $+$ nest 2 (vcat restLocs)
src/full/Agda/Utils/Char.hs view
@@ -1,54 +1,37 @@-module Agda.Utils.Char where--import Data.Char---- | Convert a character in @'0'..'9'@ into the corresponding digit @0..9@.--decDigit :: Char -> Int-decDigit c = ord c - ord '0'---- | Convert a character in @'0'..'9','A'..'F','a'..'f'@---   into the corresponding digit @0..15@.+{-# OPTIONS_GHC -Wunused-imports #-} -hexDigit :: Char -> Int-hexDigit c | isDigit c  = decDigit c-           | otherwise  = ord (toLower c) - ord 'a' + 10+-- |+-- Agda strings uses Data.Text [1], which can only represent unicode scalar values [2], excluding+-- the surrogate code points [3] (@U+D800..U+DFFF@). To allow @primStringFromList@ to be injective+-- we make sure character values also exclude surrogate code points, mapping them to the replacement+-- character @U+FFFD@.+--+-- See #4999 for more information.+--+-- [1] https://hackage.haskell.org/package/text-1.2.4.0/docs/Data-Text.html#g:2+-- [2] https://www.unicode.org/glossary/#unicode_scalar_value+-- [3] https://www.unicode.org/glossary/#surrogate_code_point --- | Convert a character in @'0'..'7'@ into the corresponding digit @0..7@.+module Agda.Utils.Char where -octDigit :: Char -> Int-octDigit = decDigit+import Data.Char ---------------------------------------------------------------------------- * Unicode exploration-------------------------------------------------------------------------+-- | The unicode replacement character � .+replacementChar :: Char+replacementChar = '\xFFFD' --- | Unicode characters are divided into letters, numbers, marks,--- punctuation, symbols, separators (including spaces) and others--- (including control characters).------ These are the tests that 'Data.Char' offers-data UnicodeTest-  = IsControl | IsSpace-  | IsLower | IsUpper | IsAlpha | IsAlphaNum | IsPrint-  | IsDigit | IsOctDigit | IsHexDigit-  | IsLetter | IsMark | IsNumber | IsPunctuation | IsSymbol | IsSeparator-  deriving (Eq, Ord, Show)+-- | Is a character a surrogate code point.+isSurrogateCodePoint :: Char -> Bool+isSurrogateCodePoint c = generalCategory c == Surrogate --- | Test names paired with their implementation.-unicodeTests :: [(UnicodeTest, Char -> Bool)]-unicodeTests =-  [ (IsControl, isControl), (IsSpace, isSpace)-  , (IsLower, isLower), (IsUpper, isUpper), (IsAlpha, isAlpha)-  , (IsAlphaNum, isAlphaNum)-  , (IsPrint, isPrint)-  , (IsDigit, isDigit), (IsOctDigit, isOctDigit), (IsHexDigit, isHexDigit)-  , (IsLetter, isLetter), (IsMark, isMark)-  , (IsNumber, isNumber), (IsPunctuation, isPunctuation), (IsSymbol, isSymbol)-  , (IsSeparator, isSeparator)-  ]+-- | Map surrogate code points to the unicode replacement character.+replaceSurrogateCodePoint :: Char -> Char+replaceSurrogateCodePoint c+  | isSurrogateCodePoint c = replacementChar+  | otherwise              = c --- | Find out which tests a character satisfies.-testChar :: Char -> [UnicodeTest]-testChar c = map fst $ filter (($ c) . snd) unicodeTests+-- | Total function to convert an integer to a character. Maps surrogate code points+--   to the replacement character @U+FFFD@.+integerToChar :: Integer -> Char+integerToChar = replaceSurrogateCodePoint . toEnum . fromIntegral . (`mod` 0x110000) 
src/full/Agda/Utils/Cluster.hs view
@@ -1,43 +1,69 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Create clusters of non-overlapping things.  module Agda.Utils.Cluster-  ( C-  , cluster+  ( cluster   , cluster'+  , cluster1+  , cluster1'   ) where  import Control.Monad  -- An imperative union-find library:-import Data.Equivalence.Monad+import Data.Equivalence.Monad ( runEquivM, equateAll, classDesc ) -import Data.Char-import Data.Functor-import qualified Data.IntMap as IntMap-import Data.List+-- NB: We keep this module independent of Agda.Utils.List1+import Data.List.NonEmpty     ( NonEmpty(..), nonEmpty, toList )+import Data.Maybe             ( fromMaybe ) --- | Characteristic identifiers.-type C = Int+import qualified Data.Map.Strict as MapS --- | Given a function @f :: a -> (C,[C])@ which returns a non-empty list of---   characteristics @C@ of @a@, partition a list of @a@s into groups---   such that each element in a group shares at least one characteristic+import Agda.Utils.Functor+import Agda.Utils.Singleton++-- | Given a function @f :: a -> NonEmpty c@ which returns a non-empty list of+--   characteristics of @a@, partition a list of @a@s into groups such+--   that each element in a group shares at least one characteristic --   with at least one other element of the group.-cluster :: (a -> (C,[C])) -> [a] -> [[a]]-cluster f as = cluster' $ map (\ a -> (a, f a)) as+cluster :: Ord c => (a -> NonEmpty c) -> [a] -> [NonEmpty a]+cluster = liftList1 . cluster1  -- | Partition a list of @a@s paired with a non-empty list of---   characteristics $C$ into groups---   such that each element in a group shares at least one characteristic+--   characteristics into groups such that each element in a group+--   shares at least one characteristic with at least one other+--   element of the group.+cluster' :: Ord c => [(a, NonEmpty c)] -> [NonEmpty a]+cluster' = liftList1 cluster1'++-- | Lift a function on non-empty lists to a function on lists.+--+-- Duplicate of 'Agda.Utils.List1.liftList1'.+liftList1 :: (NonEmpty a -> NonEmpty b) -> [a] -> [b]+liftList1 f = \case+  []     -> []+  a : as -> toList $ f $ a :| as++-- | Given a function @f :: a -> NonEmpty c@ which returns a non-empty list of+--   characteristics of @a@, partition a non-empty list of @a@s into groups such+--   that each element in a group shares at least one characteristic --   with at least one other element of the group.-cluster' :: [(a,(C,[C]))] -> [[a]]-cluster' acs = runEquivM id const $ do+cluster1 :: Ord c => (a -> NonEmpty c) -> NonEmpty a -> NonEmpty (NonEmpty a)+cluster1 f as = cluster1' $ fmap (\ a -> (a, f a)) as++-- | Partition a non-empty list of @a@s paired with a non-empty list of+--   characteristics into groups such that each element in a group+--   shares at least one characteristic with at least one other+--   element of the group.+cluster1' :: Ord c => NonEmpty (a, NonEmpty c) -> NonEmpty (NonEmpty a)+cluster1' acs = runEquivM id const $ do   -- Construct the equivalence classes of characteristics.-  forM_ acs $ \ (_,(c,cs)) -> equateAll $ c:cs+  forM_ acs $ \ (_, c :| cs) -> equateAll $ c:cs   -- Pair each element with its class.-  cas <- forM acs $ \ (a,(c,_)) -> (`IntMap.singleton` [a]) <$> classDesc c+  cas <- forM acs $ \ (a, c :| _) -> classDesc c <&> \ k -> MapS.singleton k (singleton a)   -- Create a map from class to elements.-  let m = IntMap.unionsWith (++) cas+  let m = MapS.unionsWith (<>) cas   -- Return the values of the map-  return $ IntMap.elems m+  return $ fromMaybe (error "impossibility at Agda.Utils.Cluster.cluster'") $ nonEmpty $+    MapS.elems m
src/full/Agda/Utils/Either.hs view
@@ -1,18 +1,36 @@ --------------------------------------------------------------------------- | Utilities for the 'Either' type+-- | Utilities for the 'Either' type. ------------------------------------------------------------------------  module Agda.Utils.Either-  ( whileLeft, caseEitherM-  , mapEither, mapLeft, mapRight+  ( whileLeft+  , caseEitherM+  , mapLeft+  , mapRight   , traverseEither-  , isLeft, isRight-  , fromLeft, fromRight-  , maybeLeft, maybeRight-  , allLeft, allRight+  , isLeft+  , isRight+  , fromLeft+  , fromRight+  , fromLeftM+  , fromRightM+  , maybeLeft+  , maybeRight+  , allLeft+  , allRight+  , groupByEither   , maybeToEither+  , swapEither   ) where +import Data.Bifunctor+import Data.Either (isLeft, isRight)+import Data.List   (unfoldr)++import Agda.Utils.List ( spanJust )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+ -- | Loop while we have an exception.  whileLeft :: Monad m => (a -> Either b c) -> (a -> b -> m a) -> (a -> c -> m d) -> a -> m d@@ -27,68 +45,59 @@ caseEitherM :: Monad m => m (Either a b) -> (a -> m c) -> (b -> m c) -> m c caseEitherM mm f g = either f g =<< mm --- | 'Either' is a bifunctor.--mapEither :: (a -> c) -> (b -> d) -> Either a b -> Either c d-mapEither f g = either (Left . f) (Right . g)- -- | 'Either _ b' is a functor.  mapLeft :: (a -> c) -> Either a b -> Either c b-mapLeft f = mapEither f id+mapLeft = first  -- | 'Either a' is a functor.  mapRight :: (b -> d) -> Either a b -> Either a d-mapRight = mapEither id+mapRight = second  -- | 'Either' is bitraversable.-+-- Note: From @base >= 4.10.0.0@ already present in `Data.Bitraversable`. traverseEither :: Functor f => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) traverseEither f g = either (fmap Left . f) (fmap Right . g) --- | Returns 'True' iff the argument is @'Right' x@ for some @x@.---   Note: from @base >= 4.7.0.0@ already present in @Data.Either@.-isRight :: Either a b -> Bool-isRight (Right _) = True-isRight (Left  _) = False---- | Returns 'True' iff the argument is @'Left' x@ for some @x@.---   Note: from @base >= 4.7.0.0@ already present in @Data.Either@.-isLeft :: Either a b -> Bool-isLeft (Right _) = False-isLeft (Left _)  = True- -- | Analogue of 'Data.Maybe.fromMaybe'. fromLeft :: (b -> a) -> Either a b -> a-fromLeft = either id+fromLeft = (id `either`)  -- | Analogue of 'Data.Maybe.fromMaybe'. fromRight :: (a -> b) -> Either a b -> b-fromRight f = either f id+fromRight = (`either` id) +-- | Analogue of 'Agda.Utils.Maybe.fromMaybeM'.+fromLeftM :: Monad m => (b -> m a) -> m (Either a b) -> m a+fromLeftM f m = either return f =<< m++-- | Analogue of 'Agda.Utils.Maybe.fromMaybeM'.+fromRightM :: Monad m => (a -> m b) -> m (Either a b) -> m b+fromRightM f m = either f return =<< m+ -- | Safe projection from 'Left'.---   @---     maybeLeft (Left a) = Just a---     maybeLeft Right{}  = Nothing---   @+--+--   > maybeLeft (Left a) = Just a+--   > maybeLeft Right{}  = Nothing+-- maybeLeft :: Either a b -> Maybe a maybeLeft = either Just (const Nothing)  -- | Safe projection from 'Right'.---   @---     maybeRight (Right b) = Just b---     maybeRight Left{}    = Nothing---   @+--+--   > maybeRight (Right b) = Just b+--   > maybeRight Left{}    = Nothing+-- maybeRight :: Either a b -> Maybe b maybeRight = either (const Nothing) Just --- | Returns @'Just' <input with tags stripped>@ if all elements are+-- | Returns @'Just' input_with_tags_stripped@ if all elements are -- to the 'Left', and otherwise 'Nothing'. allLeft :: [Either a b] -> Maybe [a] allLeft = mapM maybeLeft --- | Returns @'Just' <input with tags stripped>@ if all elements are+-- | Returns @'Just' input_with_tags_stripped@ if all elements are -- to the right, and otherwise 'Nothing'. -- -- @@@ -102,6 +111,19 @@ allRight :: [Either a b] -> Maybe [b] allRight = mapM maybeRight --- | Convert 'Maybe' to @'Either' ()'@-maybeToEither :: Maybe a -> Either () a-maybeToEither = maybe (Left ()) Right+-- | Groups a list into alternating chunks of 'Left' and 'Right' values+groupByEither :: forall a b. [Either a b] -> [Either (List1 a) (List1 b)]+groupByEither = unfoldr c+  where+  c :: [Either a b] -> Maybe (Either (List1 a) (List1 b), [Either a b])+  c []             = Nothing+  c (Left  a : xs) = Just $ first (Left  . (a :|)) $ spanJust maybeLeft  xs+  c (Right b : xs) = Just $ first (Right . (b :|)) $ spanJust maybeRight xs++-- | Convert 'Maybe' to @'Either' e@, given an error @e@ for the 'Nothing' case.+maybeToEither :: e -> Maybe a -> Either e a+maybeToEither e = maybe (Left e) Right++-- | Swap tags 'Left' and 'Right'.+swapEither :: Either a b -> Either b a+swapEither = either Right Left
src/full/Agda/Utils/Empty.hs view
@@ -1,14 +1,22 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | An empty type with some useful instances. module Agda.Utils.Empty where +import Control.DeepSeq+import Control.Exception (evaluate)+ import Agda.Utils.Impossible -#include "undefined.h"  data Empty +-- | Values of type 'Empty' are not forced, because 'Empty' is used as+-- a constructor argument in 'Agda.Syntax.Internal.Substitution''.++instance NFData Empty where+  rnf _ = ()+ instance Eq Empty where   _ == _ = True @@ -21,3 +29,17 @@ absurd :: Empty -> a absurd e = seq e __IMPOSSIBLE__ ++-- | @toImpossible e@ extracts the @Impossible@ value raised via+--   @__IMPOSSIBLE__@ to create the element @e@ of type @Empty@.+--   It proceeds by evaluating @e@ to weak head normal form and+--   catching the exception.+--   We are forced to wrap things in a @Maybe@ because of+--   @catchImpossible@'s type.++toImpossible :: Empty -> IO Impossible+toImpossible e = do+  s <- catchImpossible (Nothing <$ evaluate e) (return . Just)+  case s of+    Just i  -> return i+    Nothing -> absurd e -- this should never happen
src/full/Agda/Utils/Environment.hs view
@@ -1,6 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Expand environment variables in strings-module Agda.Utils.Environment ( expandEnvironmentVariables ) where+module Agda.Utils.Environment+  ( EnvVars+  , expandEnvironmentVariables+  , expandEnvVarTelescope+  ) where  import Data.Char import Data.Maybe@@ -9,38 +14,57 @@  expandEnvironmentVariables :: String -> IO String expandEnvironmentVariables s = do-  env <- getEnvironment+  env  <- getEnvironment   home <- getHomeDirectory   return $ expandVars home env s -expandVars :: String -> [(String, String)] -> String -> String+expandVars+  :: String              -- ^ Home directory.+  -> EnvVars             -- ^ Environment variable substitution map.+  -> String              -- ^ Input.+  -> String              -- ^ Output with variables and @~@ (home) substituted. expandVars home env s = concatMap repl $ tokens s   where-    repl Home = home ++ "/"+    repl Home    = home ++ "/"     repl (Var x) = fromMaybe "" $ lookup x env     repl (Str s) = s -data Token = Home | Var String | Str String+-- | List of environment variable bindings.+type EnvVars = [(String, String)]++-- | Expand a telescope of environment variables+--   (each value may refer to variables earlier in the list).+expandEnvVarTelescope :: String -> EnvVars -> EnvVars+expandEnvVarTelescope home = reverse . foldl  -- foldl reverses, so re-reverse afterwards+  (\ acc (var, val) -> (var, expandVars home acc val) : acc) []++-- | Tokenization for environment variable substitution.+data Token+  = Home        -- ^ @~@.+  | Var String  -- ^ @$VARIABLE@ or @${VARIABLE}@.+  | Str String  -- ^ Ordinary characters.   deriving (Eq, Show) +-- | Tokenize a string.+--   The @~@ is recognized as @$HOME@ only at the beginning of the string. tokens :: String -> [Token]-tokens s = case s of-  '~' : '/' : s -> Home : tokens' s+tokens = \case+  '~'  : '/' : s -> Home : tokens' s   '\\' : '~' : s -> cons '~' $ tokens' s-  _ -> tokens' s+  s -> tokens' s   where     tokens' :: String -> [Token]-    tokens' s =-      case s of+    tokens' = \case         '$' : '$' : s -> cons '$' $ tokens' s         '$' : s@(c : _) | c == '_' || isAlpha c -> Var x : tokens' s'-          where (x, s') = span (\ c -> c == '_' || isAlphaNum c) s+          where+          (x, s') = span (\ c -> c == '_' || isAlphaNum c) s         '$' : '{' : s ->           case break (== '}') s of             (x, '}' : s) -> Var x : tokens' s             _            -> [Str $ "${" ++ s] -- abort on unterminated '{'         c : s -> cons c $ tokens' s         ""    -> []+    cons :: Char -> [Token] -> [Token]     cons c (Str s : ts) = Str (c : s) : ts     cons c ts           = Str [c] : ts-
− src/full/Agda/Utils/Except.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}--#if !(MIN_VERSION_mtl(2,2,1))-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif----------------------------------------------------------------------------------- | Wrapper for Control.Monad.Except from the mtl package---------------------------------------------------------------------------------module Agda.Utils.Except-  ( Error(noMsg, strMsg)-  , ExceptT-  , mkExceptT-  , MonadError(catchError, throwError)-  , runExceptT-  , mapExceptT-  ) where--#include "undefined.h"-import Agda.Utils.Impossible---------------------------------------------------------------------------#if MIN_VERSION_mtl(2,2,1)--- New mtl, reexport ExceptT, define class Error for backward compat.---------------------------------------------------------------------------import Control.Monad.Except---- | We cannot define data constructors synonymous, so we define the--- @mkExceptT@ function to be used instead of the data constructor--- @ExceptT@.-mkExceptT :: m (Either e a) -> ExceptT e m a-mkExceptT = ExceptT---- From Control.Monad.Trans.Error of transformers 0.3.0.0.--class Error a where-  noMsg  :: a-  strMsg :: String -> a--  noMsg    = strMsg ""-  strMsg _ = noMsg---- | A string can be thrown as an error.-instance Error String where-  strMsg = id---------------------------------------------------------------------------#else--- Old mtl, need to define ExceptT from ErrorT---------------------------------------------------------------------------import Control.Monad.Error-import Text.PrettyPrint--type ExceptT = ErrorT---- | We cannot define data constructors synonymous, so we define the--- @mkExceptT@ function to be used instead of the data constructor--- @ErrorT@.-mkExceptT :: m (Either e a) -> ExceptT e m a-mkExceptT = ErrorT---- | 'runExcept' function using mtl 2.1.*.-runExceptT ::  ExceptT e m a -> m (Either e a)-runExceptT = runErrorT--mapExceptT :: (m (Either e a) -> m' (Either e' a')) -> ExceptT e m a -> ExceptT e' m' a'-mapExceptT = mapErrorT--instance Error Doc where-  noMsg  = empty-  strMsg = text---- | To simulate @MaybeT@ by @ExceptT@.-instance Error () where-  noMsg = ()---- Stupid ErrorT!-instance Error (a, b, c) where-  noMsg = __IMPOSSIBLE__--#endif
+ src/full/Agda/Utils/Fail.hs view
@@ -0,0 +1,11 @@+-- | A pure MonadFail.+module Agda.Utils.Fail where++newtype Fail a = Fail { runFail :: Either String a }+  deriving (Functor, Applicative, Monad)++instance MonadFail Fail where+  fail = Fail . Left++runFail_ :: Fail a -> a+runFail_ = either error id . runFail
src/full/Agda/Utils/Favorites.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Maintaining a list of favorites of some partially ordered type. --   Only the best elements are kept.@@ -13,9 +13,6 @@  import Prelude hiding ( null ) -import Data.Foldable (Foldable)-import Data.Functor-import Data.Semigroup import qualified Data.List as List import qualified Data.Set as Set 
+ src/full/Agda/Utils/FileId.hs view
@@ -0,0 +1,140 @@+-- | Translating between file paths and ids.+--+-- This module allows you to build a dictionary from file paths to some unique identifier+-- and to look up both file paths and identifiers in that dictionary.++module Agda.Utils.FileId where++import           Prelude               hiding (null)++import           Control.DeepSeq       (NFData)+import           Control.Monad.Except  (ExceptT)+import           Control.Monad.Reader  (ReaderT)+import           Control.Monad.State   (StateT)+import           Control.Monad.Trans   (MonadTrans, lift)++import           Data.Bifunctor        (second)+import           Data.EnumMap          (EnumMap)+import qualified Data.EnumMap          as EnumMap+import           Data.Map              (Map)+import qualified Data.Map              as Map+import           Data.Maybe            (fromMaybe)+import           Data.Word             (Word32)++import           GHC.Generics          (Generic)++import           Agda.Utils.CallStack  (HasCallStack)+import           Agda.Utils.FileName   (AbsolutePath)+import           Agda.Utils.Null       (Null(..))++import Agda.Utils.Impossible (__IMPOSSIBLE__)++type File = AbsolutePath++-- | Unique identifier of a file.+newtype FileId = FileId { theFileId :: Word32 }+  deriving (Eq, Ord, Show, Generic, Enum, Num)++-- * Mapping between files and their unique identifiers.++type FileToId = Map File FileId+type IdToFile = EnumMap FileId File++data FileDict = FileDict+  { fileToId :: FileToId+  , idToFile :: IdToFile+  } deriving (Generic)++-- | Translate a file to an ID; mapping must exist.+class GetFileId a where+  getFileId :: HasCallStack => a -> File -> FileId++-- | Translate a ID to a file; mapping must exist.+class GetIdFile a where+  getIdFile :: a -> FileId -> File++-- * Constructing a mapping between files and their unique identifiers.++data FileDictBuilder = FileDictBuilder+  { nextFileId :: FileId+  , fileDict   :: FileDict+  } deriving (Generic)++-- | Register a new file identifier or retrieve an existing one.+registerFileId :: File -> FileDictBuilder -> (FileId, FileDictBuilder)+registerFileId f d = second (fromMaybe d) $ registerFileId'' f d++-- | Register a new file identifier ('True') or retrieve an existing one ('False').+registerFileId' :: File -> FileDictBuilder -> ((FileId, Bool), FileDictBuilder)+registerFileId' f d =+  case registerFileId'' f d of+    (i, Nothing) -> ((i, False), d)+    (i, Just d') -> ((i, True), d')++-- | Register a new file identifier or retrieve an existing one.+--+--   If 'Nothing' is returned, the file was already registered.+registerFileId'' :: File -> FileDictBuilder -> (FileId, Maybe FileDictBuilder)+registerFileId''  f d@(FileDictBuilder n (FileDict fileToId idToFile)) =+  case Map.lookup f fileToId of+    Just i  -> (i, Nothing)+    Nothing -> (n, Just $ FileDictBuilder (n + 1) (FileDict fileToId' idToFile'))+  where+    fileToId' = Map.insert f n fileToId+    idToFile' = EnumMap.insert n f idToFile++-- * Monadic interface++class Monad m => MonadFileId m where+  fileFromId :: FileId -> m File+  idFromFile :: File -> m FileId++  default fileFromId :: (MonadTrans t, MonadFileId n, m ~ t n) => FileId -> m File+  fileFromId = lift . fileFromId++  default idFromFile :: (MonadTrans t, MonadFileId n, m ~ t n) => File -> m FileId+  idFromFile = lift . idFromFile++instance MonadFileId m => MonadFileId (ExceptT e m)+instance MonadFileId m => MonadFileId (ReaderT r m)+instance MonadFileId m => MonadFileId (StateT s m)++-- Instances for GetFileId++instance GetFileId FileToId where+  getFileId :: FileToId -> File -> FileId+  getFileId m f = Map.findWithDefault __IMPOSSIBLE__ f m++instance GetFileId FileDict where+  getFileId = getFileId . fileToId++instance GetFileId FileDictBuilder where+  getFileId = getFileId . fileDict++-- Instances for GetIdFile++instance GetIdFile IdToFile where+  getIdFile :: IdToFile -> FileId -> File+  getIdFile m i = EnumMap.findWithDefault __IMPOSSIBLE__ i m++instance GetIdFile FileDict where+  getIdFile = getIdFile . idToFile++instance GetIdFile FileDictBuilder where+  getIdFile = getIdFile . fileDict++-- Instances for Null++instance Null FileDict where+  empty = FileDict empty empty+  null (FileDict to fro) = null to && null fro++instance Null FileDictBuilder where+  empty = FileDictBuilder 1 empty+  null (FileDictBuilder _ d) = null d++-- Instances for NFData++instance NFData FileId+instance NFData FileDict+instance NFData FileDictBuilder
src/full/Agda/Utils/FileName.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-| Operations on file names. -} module Agda.Utils.FileName@@ -8,30 +6,33 @@   , filePath   , mkAbsolute   , absolute-  , (===)+  , canonicalizeAbsolutePath+  , sameFile   , doesFileExistCaseSensitive-  , rootPath+  , isNewerThan+  , relativizeAbsolutePath+  , makeRelativeCanonical+  , stripAnyOfExtensions   ) where -import Control.Applicative-import System.Directory-import System.FilePath--#if mingw32_HOST_OS-import Control.Exception (bracket)-import System.Win32 (findFirstFile, findClose, getFindDataFileName)+import Control.Applicative ( liftA2 )+import Control.DeepSeq+#ifdef mingw32_HOST_OS+import Control.Exception   ( bracket )+import System.Win32        ( findFirstFile, findClose, getFindDataFileName ) #endif -import Data.Text (Text)+import Data.Function (on)+import Data.Hashable       ( Hashable )+import Data.Maybe          ( catMaybes, listToMaybe )+import Data.Text           ( Text ) import qualified Data.Text as Text-import Data.Function-import Data.Hashable-import Data.Typeable (Typeable) +import System.Directory+import System.FilePath+ import Agda.Utils.Monad-import Agda.Utils.Pretty -#include "undefined.h" import Agda.Utils.Impossible  -- | Paths which are known to be absolute.@@ -39,22 +40,12 @@ -- Note that the 'Eq' and 'Ord' instances do not check if different -- paths point to the same files or directories. -newtype AbsolutePath = AbsolutePath { byteStringPath :: Text }-  deriving (Eq, Ord, Typeable, Hashable)+newtype AbsolutePath = AbsolutePath { textPath :: Text }+  deriving (Show, Eq, Ord, Hashable, NFData)  -- | Extract the 'AbsolutePath' to be used as 'FilePath'. filePath :: AbsolutePath -> FilePath-filePath = Text.unpack . byteStringPath---- TODO: 'Show' should output Haskell-parseable representations.--- The following instance is deprecated, and Pretty should be used--- instead.  Later, simply derive Show for this type.--instance Show AbsolutePath where-  show = filePath--instance Pretty AbsolutePath where-  pretty = text . filePath+filePath = Text.unpack . textPath  -- | Constructs 'AbsolutePath's. --@@ -64,18 +55,13 @@ mkAbsolute f   | isAbsolute f =       AbsolutePath $ Text.pack $ dropTrailingPathSeparator $ normalise f+        -- normalize does not resolve symlinks   | otherwise    = __IMPOSSIBLE__ -rootPath :: FilePath-#if mingw32_HOST_OS-rootPath = joinDrive "C:" [pathSeparator]-#else-rootPath = [pathSeparator]-#endif---- | maps @/bla/bla/bla/foo.bar.xxx@ to @foo.bar@.-rootName :: AbsolutePath -> String-rootName = dropExtension . snd . splitFileName . filePath+-- UNUSED Liang-Ting Chen 2019-07-16+---- | maps @/bla/bla/bla/foo.bar.xxx@ to @foo.bar@.+--rootName :: AbsolutePath -> String+--rootName = dropExtension . snd . splitFileName . filePath  -- | Makes the path absolute. --@@ -86,25 +72,29 @@ absolute f = mkAbsolute <$> do   -- canonicalizePath sometimes truncates paths pointing to   -- non-existing files/directories.-  ex <- doesFileExist f .||. doesDirectoryExist f-  if ex then-    canonicalizePath f+  ex <- doesFileExist f `or2M` doesDirectoryExist f+  if ex then do+    -- Andreas, 2020-08-11, issue #4828+    -- Do not use @canonicalizePath@ on the full path as it resolves symlinks,+    -- which leads to wrong placement of the .agdai file.+    dir <- canonicalizePath (takeDirectory f)+    return (dir </> takeFileName f)    else do     cwd <- getCurrentDirectory     return (cwd </> f)-  where-  m1 .||. m2 = do-    b1 <- m1-    if b1 then return True else m2 --- | Tries to establish if the two file paths point to the same file--- (or directory).+-- | Resolve symlinks etc.  Preserves 'sameFile'. -infix 4 ===+canonicalizeAbsolutePath :: AbsolutePath -> IO AbsolutePath+canonicalizeAbsolutePath (AbsolutePath f) =+  AbsolutePath . Text.pack <$> canonicalizePath (Text.unpack f) -(===) :: AbsolutePath -> AbsolutePath -> Bool-(===) = equalFilePath `on` filePath+-- | Tries to establish if the two file paths point to the same file+-- (or directory). False negatives may be returned. +sameFile :: AbsolutePath -> AbsolutePath -> IO Bool+sameFile = liftA2 equalFilePath `on` (canonicalizePath . filePath)+ -- | Case-sensitive 'doesFileExist' for Windows. -- -- This is case-sensitive only on the file name part, not on the directory part.@@ -113,11 +103,67 @@ --  case insensitively.)  doesFileExistCaseSensitive :: FilePath -> IO Bool-#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS doesFileExistCaseSensitive f = do   doesFileExist f `and2M` do     bracket (findFirstFile f) (findClose . fst) $       fmap (takeFileName f ==) . getFindDataFileName . snd #else-doesFileExistCaseSensitive f = doesFileExist f+doesFileExistCaseSensitive = doesFileExist #endif++-- | True if the first file is newer than the second file. If a file doesn't+-- exist it is considered to be infinitely old.+isNewerThan :: FilePath -> FilePath -> IO Bool+isNewerThan new old = do+    newExist <- doesFileExist new+    oldExist <- doesFileExist old+    if not (newExist && oldExist)+        then return newExist+        else do+            newT <- getModificationTime new+            oldT <- getModificationTime old+            return $ newT >= oldT++-- | A partial version of 'System.FilePath.makeRelative' with flipped arguments,+--   returning 'Nothing' if the given path cannot be relativized to the given @root@.+relativizeAbsolutePath ::+     AbsolutePath+       -- ^ The absolute path we seek to relativize.+  -> AbsolutePath+       -- ^ The root for relativization.+  -> Maybe FilePath+       -- ^ The relative path, if any.+relativizeAbsolutePath apath aroot+  | rest /= path = Just rest+  | otherwise    = Nothing+  where+  path = filePath apath+  root = filePath aroot+  rest = makeRelative root path+    -- Andreas, 2022-10-10+    -- See https://gitlab.haskell.org/haskell/filepath/-/issues/130.+    -- 'System.FilePath.makeRelative' is strangely enough a total function,+    -- and it returns the original @path@ if it could not be relativized to+    -- the @root@, or if the @root@ was ".".+    -- In our case, the @root@ is absolute, so we should expect @rest@ to+    -- always be different from @path@ if @path@ is relative to @root@.+    -- In the extreme case, @root = "/"@ and @path == "/" ++ rest@.++-- -- Andreas, 2024-11-10, extracted from 'stripPrimitiveLibDir':+-- -- This is a simple implementation of 'relativizeAbsolutePath' using 'splitDirectories'.+-- stripDir :: AbsolutePath -> AbsolutePath -> Maybe FilePath+-- stripDir dir file =+--   joinPath <$> List.stripPrefix (split dir) (split file)+--   where+--     split = splitDirectories . filePath++-- | Makes a path relative to a root without assuming that either path is+-- canonical.++makeRelativeCanonical :: FilePath -> FilePath -> IO FilePath+makeRelativeCanonical = liftA2 makeRelative `on` canonicalizePath++-- | Generalizes 'stripExtension'.+stripAnyOfExtensions :: [String] -> FilePath -> Maybe FilePath+stripAnyOfExtensions exts p = listToMaybe $ catMaybes $ map (`stripExtension` p) exts
+ src/full/Agda/Utils/Float.hs view
@@ -0,0 +1,311 @@++-- | Logically consistent comparison of floating point numbers.++module Agda.Utils.Float+  ( asFinite+  , isPosInf+  , isNegInf+  , isPosZero+  , isNegZero+  , isSafeInteger+  , doubleEq+  , doubleLe+  , doubleLt+  , intToDouble+  , doublePlus+  , doubleMinus+  , doubleTimes+  , doubleNegate+  , doubleDiv+  , doublePow+  , doubleSqrt+  , doubleExp+  , doubleLog+  , doubleSin+  , doubleCos+  , doubleTan+  , doubleASin+  , doubleACos+  , doubleATan+  , doubleATan2+  , doubleSinh+  , doubleCosh+  , doubleTanh+  , doubleASinh+  , doubleACosh+  , doubleATanh+  , doubleRound+  , doubleFloor+  , doubleCeiling+  , doubleDenotEq+  , doubleDenotOrd+  , doubleToWord64+  , doubleToRatio+  , ratioToDouble+  , doubleDecode+  , doubleEncode+  , toStringWithoutDotZero+  ) where++import Data.Bifunctor   ( second )+import Data.Function    ( on )+import Data.Maybe       ( fromMaybe )+import Data.Ratio       ( (%), numerator, denominator )+import Data.Word        ( Word64 )++import Agda.Utils.List  ( stripSuffix )++import GHC.Float (castDoubleToWord64, castWord64ToDouble)+++{-# INLINE doubleEq #-}+doubleEq :: Double -> Double -> Bool+doubleEq = (==)++{-# INLINE doubleLe #-}+doubleLe :: Double -> Double -> Bool+doubleLe = (<=)++{-# INLINE doubleLt #-}+doubleLt :: Double -> Double -> Bool+doubleLt = (<)++truncateDouble :: Double -> Double+truncateDouble = castWord64ToDouble . castDoubleToWord64++{-# INLINE intToDouble #-}+intToDouble :: Integral a => a -> Double+intToDouble = truncateDouble . fromIntegral++{-# INLINE doublePlus #-}+doublePlus :: Double -> Double -> Double+doublePlus x y = truncateDouble (x + y)++{-# INLINE doubleMinus #-}+doubleMinus :: Double -> Double -> Double+doubleMinus x y = truncateDouble (x - y)++{-# INLINE doubleTimes #-}+doubleTimes :: Double -> Double -> Double+doubleTimes x y = truncateDouble (x * y)++{-# INLINE doubleNegate #-}+doubleNegate :: Double -> Double+doubleNegate = negate -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleDiv #-}+doubleDiv :: Double -> Double -> Double+doubleDiv = (/) -- NOTE: doesn't cause underflow/overflow++{-# INLINE doublePow #-}+doublePow :: Double -> Double -> Double+doublePow x y = truncateDouble (x ** y)++{-# INLINE doubleSqrt #-}+doubleSqrt :: Double -> Double+doubleSqrt = sqrt -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleExp #-}+doubleExp :: Double -> Double+doubleExp x = truncateDouble (exp x)++{-# INLINE doubleLog #-}+doubleLog :: Double -> Double+doubleLog = log -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSin #-}+doubleSin :: Double -> Double+doubleSin = sin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCos #-}+doubleCos :: Double -> Double+doubleCos = cos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTan #-}+doubleTan :: Double -> Double+doubleTan = tan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASin #-}+doubleASin :: Double -> Double+doubleASin = asin -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACos #-}+doubleACos :: Double -> Double+doubleACos = acos -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan #-}+doubleATan :: Double -> Double+doubleATan = atan -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATan2 #-}+doubleATan2 :: Double -> Double -> Double+doubleATan2 = atan2 -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleSinh #-}+doubleSinh :: Double -> Double+doubleSinh = sinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleCosh #-}+doubleCosh :: Double -> Double+doubleCosh = cosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleTanh #-}+doubleTanh :: Double -> Double+doubleTanh = tanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleASinh #-}+doubleASinh :: Double -> Double+doubleASinh = asinh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleACosh #-}+doubleACosh :: Double -> Double+doubleACosh = acosh -- NOTE: doesn't cause underflow/overflow++{-# INLINE doubleATanh #-}+doubleATanh :: Double -> Double+doubleATanh = atanh -- NOTE: doesn't cause underflow/overflow++{-# INLINE negativeZero #-}+negativeZero :: Double+negativeZero = -0.0++positiveInfinity :: Double+positiveInfinity = 1.0 / 0.0++negativeInfinity :: Double+negativeInfinity = -positiveInfinity++nan :: Double+nan = 0.0 / 0.0++isPosInf :: Double -> Bool+isPosInf x = x > 0.0 && isInfinite x++isNegInf :: Double -> Bool+isNegInf x = x < 0.0 && isInfinite x++isPosZero :: Double -> Bool+isPosZero x = doubleDenotEq x 0.0++isNegZero :: Double -> Bool+isNegZero x = doubleDenotEq x (-0.0)++doubleRound :: Double -> Maybe Integer+doubleRound = fmap round . asFinite++doubleFloor :: Double -> Maybe Integer+doubleFloor = fmap floor . asFinite++doubleCeiling :: Double -> Maybe Integer+doubleCeiling = fmap ceiling . asFinite++normaliseNaN :: Double -> Double+normaliseNaN x+  | isNaN x   = nan+  | otherwise = x++doubleToWord64 :: Double -> Maybe Word64+doubleToWord64 x+  | isNaN x   = Nothing+  | otherwise = Just (castDoubleToWord64 x)++-- |Denotational equality for floating point numbers, checks bitwise equality.+--+--  NOTE: Denotational equality distinguishes NaNs, so its results may vary+--        depending on the architecture and compilation flags. Unfortunately,+--        this is a problem with floating-point numbers in general.+--+doubleDenotEq :: Double -> Double -> Bool+doubleDenotEq = (==) `on` doubleToWord64++-- |I guess "denotational orderings" are now a thing? The point is that we need+--  an Ord instance which provides a total ordering, and is consistent with the+--  denotational equality.+--+--  NOTE: The ordering induced via `doubleToWord64` is total, and is consistent+--        with `doubleDenotEq`. However, it is *deeply* unintuitive. For one, it+--        considers all negative numbers to be larger than positive numbers.+--+doubleDenotOrd :: Double -> Double -> Ordering+doubleDenotOrd = compare `on` doubleToWord64++-- |Return Just x if it's a finite number, otherwise return Nothing.+asFinite :: Double -> Maybe Double+asFinite x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just x++-- |Remove suffix @.0@ from printed floating point number.+toStringWithoutDotZero :: Double -> String+toStringWithoutDotZero d = fromMaybe s $ stripSuffix ".0" s+  where s = show d++-- |Decode a Double to an integer ratio.+doubleToRatio :: Double -> (Integer, Integer)+doubleToRatio x+  | isNaN      x = (0, 0)+  | isInfinite x = (signum (floor x), 0)+  | otherwise    = let r = toRational x in (numerator r, denominator r)++-- |Encode an integer ratio as a double.+ratioToDouble :: Integer -> Integer -> Double+ratioToDouble n d+  | d == 0 = case compare n 0 of+      LT -> negativeInfinity+      EQ -> nan+      GT -> positiveInfinity+  | otherwise = fromRational (n % d)++-- |Decode a Double to its mantissa and its exponent, normalised such that the+--  mantissa is the smallest possible number without loss of accuracy.+doubleDecode :: Double -> Maybe (Integer, Integer)+doubleDecode x+  | isNaN      x = Nothing+  | isInfinite x = Nothing+  | otherwise    = Just (uncurry normalise (second toInteger (decodeFloat x)))+  where+    normalise :: Integer -> Integer -> (Integer, Integer)+    normalise mantissa exponent+      | even mantissa = normalise (mantissa `div` 2) (exponent + 1)+      | otherwise = (mantissa, exponent)++-- |Checks whether or not the Double is within a safe range of operation.+isSafeInteger :: Double -> Bool+isSafeInteger x = case properFraction x of+  (n, f) -> f == 0.0 && minMantissa <= n && n <= maxMantissa++doubleRadix :: Integer+doubleRadix = floatRadix (undefined :: Double)++doubleDigits :: Int+doubleDigits = floatDigits (undefined :: Double)++doubleRange :: (Int, Int)+doubleRange = floatRange (undefined :: Double)++-- |The smallest representable mantissa. Simultaneously, the smallest integer which can be+--  represented as a Double without loss of precision.+minMantissa :: Integer+minMantissa = - maxMantissa++-- |The largest representable mantissa. Simultaneously, the largest integer which can be+--  represented as a Double without loss of precision.+maxMantissa :: Integer+maxMantissa = (doubleRadix ^ toInteger doubleDigits) - 1++-- |The largest representable exponent.+minExponent :: Integer+minExponent = toInteger $ (fst doubleRange - doubleDigits) - 1++-- |The smallest representable exponent.+maxExponent :: Integer+maxExponent = toInteger $ snd doubleRange - doubleDigits++-- |Encode a mantissa and an exponent as a Double.+doubleEncode :: Integer -> Integer -> Maybe Double+doubleEncode mantissa exponent+  = if minMantissa <= mantissa && mantissa <= maxMantissa &&+       minExponent <= exponent && exponent <= maxExponent+    then Just (encodeFloat mantissa (fromInteger exponent))+    else Nothing
src/full/Agda/Utils/Function.hs view
@@ -1,6 +1,19 @@+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Utils.Function where+{-# LANGUAGE RebindableSyntax #-} +module Agda.Utils.Function+  ( module Agda.Utils.Function+  , module Data.Function+  ) where++import Prelude hiding ( not, (&&), (||) )++import Data.Function  ( on )+import Data.String    ( fromString )       -- for RebindableSyntax, somehow not covered by Prelude++import Agda.Utils.Boolean+ -- | Repeat a state transition @f :: a -> (b, a)@ with output @b@ --   while condition @cond@ on the output is true. --   Return all intermediate results and the final result@@ -96,24 +109,58 @@ -- The applications are calculated strictly.  iterate' :: Integral i => i -> (a -> a) -> a -> a-iterate' 0 f x             = x+iterate' 0 _ x             = x iterate' n f x | n > 0     = iterate' (n - 1) f $! f x                | otherwise = error "iterate': Negative input."  -- * Iteration over Booleans.  -- | @applyWhen b f a@ applies @f@ to @a@ when @b@.-applyWhen :: Bool -> (a -> a) -> a -> a+{-# SPECIALIZE applyWhen :: Bool -> (a -> a) -> (a -> a) #-}+{-# INLINE applyWhen #-}+applyWhen :: IsBool b => b -> (a -> a) -> a -> a applyWhen b f = if b then f else id+  -- Note: RebindableSyntax translates this if-then-else to ifThenElse of IsBool.  -- | @applyUnless b f a@ applies @f@ to @a@ unless @b@.-applyUnless :: Bool -> (a -> a) -> a -> a+{-# SPECIALIZE applyUnless :: Bool -> (a -> a) -> (a -> a) #-}+{-# INLINE applyUnless #-}+applyUnless :: IsBool b => b -> (a -> a) -> a -> a applyUnless b f = if b then id else f+  -- Note: RebindableSyntax translates this if-then-else to ifThenElse of IsBool. +-- | @applyWhenIts p f a@ applies @f@ to @a@ when @p a@.+{-# SPECIALIZE applyWhenIts :: (a -> Bool) -> (a -> a) -> (a -> a) #-}+{-# INLINE applyWhenIts #-}+applyWhenIts :: IsBool b => (a -> b) -> (a -> a) -> a -> a+applyWhenIts p f a = if p a then f a else a+  -- Note: RebindableSyntax translates this if-then-else to ifThenElse of IsBool.++-- | @applyUnlessIts p f a@ applies @f@ to @a@ unless @p a@.+{-# SPECIALIZE applyUnlessIts :: (a -> Bool) -> (a -> a) -> (a -> a) #-}+{-# INLINE applyUnlessIts #-}+applyUnlessIts :: IsBool b => (a -> b) -> (a -> a) -> a -> a+applyUnlessIts p f a = if p a then a else f a+  -- Note: RebindableSyntax translates this if-then-else to ifThenElse of IsBool.+ -- | Monadic version of @applyWhen@-applyWhenM :: (Monad m) => m Bool -> (m a -> m a) -> m a -> m a+{-# SPECIALIZE applyWhenM :: Monad m => m Bool -> (m a -> m a) -> m a -> m a #-}+{-# INLINE applyWhenM #-}+applyWhenM :: (IsBool b, Monad m) => m b -> (m a -> m a) -> m a -> m a applyWhenM mb f x = mb >>= \ b -> applyWhen b f x  -- | Monadic version of @applyUnless@-applyUnlessM :: (Monad m) => m Bool -> (m a -> m a) -> m a -> m a+{-# SPECIALIZE applyUnlessM :: Monad m => m Bool -> (m a -> m a) -> m a -> m a #-}+{-# INLINE applyUnlessM #-}+applyUnlessM :: (IsBool b, Monad m) => m b -> (m a -> m a) -> m a -> m a applyUnlessM mb f x = mb >>= \ b -> applyUnless b f x++-- | 'Maybe' version of 'applyWhen'.+{-# INLINE applyWhenJust #-}+applyWhenJust :: Maybe b -> (b -> a -> a) -> a -> a+applyWhenJust m f = maybe id f m++-- | 'Maybe' version of 'applyUnless'.+{-# INLINE applyWhenNothing #-}+applyWhenNothing :: Maybe b -> (a -> a) -> a -> a+applyWhenNothing m f = maybe f (const id) m
src/full/Agda/Utils/Functor.hs view
@@ -1,33 +1,27 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Utilities for functors.  module Agda.Utils.Functor-  ( module Agda.Utils.Functor-  , (<$>) -- from Data.Functor+  ( (<.>)+  , for+  , Decoration(traverseF, distributeF)+  , dmap+  , dget+  -- From Data.Functor:+  , (<$>)+  , ($>)+  , (<&>)   )   where  import Control.Applicative ( Const(Const), getConst ) -import Data.Functor+import Data.Functor (($>), (<&>)) import Data.Functor.Identity import Data.Functor.Compose-import Data.Functor.Classes --- Andreas, 2015-05-06, see issue 1501.--- This instance can be obtained from transformers-compat.--- -- ASR (15 October 2014): See issue 1304.--- #if !MIN_VERSION_transformers(0,4,1)--- instance Eq a => Eq (Identity a) where---   Identity x == Identity x' = x == x'--- #endif -infixr 4 $>--($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)- infixr 9 <.>  -- | Composition: pure function after functorial (monadic) function.@@ -37,13 +31,8 @@ -- | The true pure @for@ loop. --   'Data.Traversable.for' is a misnomer, it should be @forA@. for :: Functor m => m a -> (a -> b) -> m b-for = flip fmap--infix 4 <&>---- | Infix version of 'for'.-(<&>) :: Functor m => m a -> (a -> b) -> m b-(<&>) = for+for a b = fmap b a+{-# INLINE for #-}  -- | A decoration is a functor that is traversable into any functor. --@@ -61,6 +50,8 @@   -- | Decorations commute into any functor.   distributeF :: (Functor m) => t (m a) -> m (t a)   distributeF = traverseF id++  {-# MINIMAL traverseF | distributeF #-}  -- | Any decoration is traversable with @traverse = traverseF@. --   Just like any 'Traversable' is a functor, so is
− src/full/Agda/Utils/Geniplate.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Utilities related to Geniplate.--module Agda.Utils.Geniplate-  ( instanceUniverseBiT'-  , instanceTransformBiMT'-  , dontDescendInto-  ) where--import Data.Generics.Geniplate-import Data.Map (Map)--import qualified Language.Haskell.TH as TH--import qualified Agda.Syntax.Abstract.Name as A-import qualified Agda.Syntax.Concrete.Name as C-import qualified Agda.Syntax.Position as P-import qualified Agda.Syntax.Scope.Base as S-import qualified Agda.Utils.FileName as F-import qualified Agda.Utils.Maybe.Strict as MS---- | Types which Geniplate should not descend into.--dontDescendInto :: [TH.TypeQ]-dontDescendInto =-  [ [t| String |]-  , [t| A.QName |]-  , [t| A.Name |]-  , [t| C.Name |]-  , [t| S.ScopeInfo |]-  , [t| Map A.QName A.QName |]-  , [t| Map A.ModuleName A.ModuleName |]-  , [t| [(A.QName, A.QName)] |]-  , [t| [(A.ModuleName, A.ModuleName)] |]-  , [t| A.AmbiguousQName |]-  , [t| P.Range' (MS.Maybe F.AbsolutePath) |]-  ]---- | A localised instance of 'instanceUniverseBiT'. The generated--- 'universeBi' functions neither descend into the types in--- 'dontDescendInto', nor into the types in the list argument.--instanceUniverseBiT' :: [TH.TypeQ] -> TH.TypeQ -> TH.Q [TH.Dec]-instanceUniverseBiT' ts p =-  instanceUniverseBiT (ts ++ dontDescendInto) p---- | A localised instance of 'instanceTransformBiMT'. The generated--- 'transformBiM' functions neither descend into the types in--- 'dontDescendInto', nor into the types in the list argument.--instanceTransformBiMT' :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ -> TH.Q [TH.Dec]-instanceTransformBiMT' ts p =-  instanceTransformBiMT (ts ++ dontDescendInto) p
+ src/full/Agda/Utils/GetOpt.hs view
@@ -0,0 +1,229 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Agda.Utils.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2005+-- License     :  BSD-style+--+-- This module provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU+-- @getopt@ library.+--+-- It is a fork of "System.Console.GetOpt" from the base package of GHC,+-- written by Sven Panne.+--+-- We modify it to remove the "allow prefixes of long options" behavior.+-----------------------------------------------------------------------------++module Agda.Utils.GetOpt (+   -- * GetOpt+   getOpt, getOpt',+   usageInfo,+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),+) where++import Prelude+import Data.List (find)++-- | What to do with options following non-options.+data ArgOrder a+  = RequireOrder                -- ^ no option processing after first non-option+  | Permute                     -- ^ freely intersperse options and non-options+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a =+  Option               -- ^ description of a single options:+    [Char]             -- ^ list of short option characters+    [String]           -- ^ list of long option strings (without "--")+    (ArgDescr a)       -- ^ argument descriptor+    String             -- ^ explanation of option for user++-- | Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+  = NoArg                   a          -- ^ no argument expected+  | ReqArg (String       -> a) String  -- ^ option requires argument+  | OptArg (Maybe String -> a) String  -- ^ optional argument++instance Functor ArgOrder where+  fmap _ RequireOrder      = RequireOrder+  fmap _ Permute           = Permute+  fmap f (ReturnInOrder g) = ReturnInOrder (f . g)++instance Functor OptDescr where+  fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c++instance Functor ArgDescr where+  fmap f (NoArg a)    = NoArg (f a)+  fmap f (ReqArg g s) = ReqArg (f . g) s+  fmap f (OptArg g s) = OptArg (f . g) s++-- | Kind of command line argument (internal use only):+data OptKind a+  = Opt       a        -- ^  an option+  | UnreqOpt  String   -- ^  an un-recognized option+  | NonOpt    String   -- ^  a non-option+  | EndOfOpts          -- ^  end-of-options marker (i.e. "--")+  | OptErr    String   -- ^  something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the+-- second argument.+usageInfo ::+     String            -- ^ header+  -> [OptDescr a]      -- ^ option descriptors+  -> String            -- ^ nicely formatted description of options+usageInfo header optDescr = unlines (header:table)+   where+     (ss, ls, ds)   = unzip3 $ concatMap fmtOpt optDescr+     table          = zipWith3 paste (sameLen ss) (sameLen ls) ds+     paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+     sameLen xs     = flushLeft ((maximum . map length) xs) xs+     flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> [(String, String, String)]+fmtOpt (Option sos los ad descr) =+   case lines descr of+     []     -> [(sosFmt, losFmt, "")]+     (d:ds) ->  (sosFmt, losFmt, d) : [ ("", "", d') | d' <- ds ]+   where+     sepBy _  []     = ""+     sepBy _  [x]    = x+     sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs+     sosFmt = sepBy ',' (map (fmtShort ad) sos)+     losFmt = sepBy ',' (map (fmtLong  ad) los)++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from+  'GHC.Internal.System.Environment.getArgs').++'getOpt' returns a triple consisting of the option arguments, a list+of non-options, and a list of error messages.+-}+getOpt :: ArgOrder a                   -- ^ non-option handling+       -> [OptDescr a]                 -- ^ option descriptors+       -> [String]                     -- ^ the command-line arguments+       -> ([a], [String], [String])    -- ^ @(options, non-options, error messages)@+getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)+  where+    (os, xs, us, es) = getOpt' ordering optDescr args++{-|+This is almost the same as 'getOpt', but returns a quadruple+consisting of the option arguments, a list of non-options, a list of+unrecognized options, and a list of error messages.+-}+getOpt' :: ArgOrder a                           -- ^ non-option handling+        -> [OptDescr a]                         -- ^ option descriptors+        -> [String]                             -- ^ the command-line arguments+        -> ([a], [String], [String], [String])  -- ^ @(options, non-options, unrecognized, error messages)@+getOpt' _        _        []         =  ([], [], [], [])+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering+   where+     procNextOpt (Opt o)      _                 = (o:os, xs, us, es)+     procNextOpt (UnreqOpt u) _                 = (os, xs, u:us, es)+     procNextOpt (NonOpt x)   RequireOrder      = ([], x:rest, [], [])+     procNextOpt (NonOpt x)   Permute           = (os, x:xs, us, es)+     procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs, us, es)+     procNextOpt EndOfOpts    RequireOrder      = ([], rest, [], [])+     procNextOpt EndOfOpts    Permute           = ([], rest, [], [])+     procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest, [], [], [])+     procNextOpt (OptErr e)   _                 = (os, xs, us, e:es)++     (opt, rest) = getNext arg args optDescr+     (os, xs, us, es) = getOpt' ordering optDescr rest++-- | Take a look at the next cmd line arg and decide what to do with it.+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+getNext ('-':'-':[]) rest _        = (EndOfOpts, rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a, rest)++-- | Handle long option.+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])+longOpt ls rs optDescr = long ads arg rs+   where+     (opt, arg) = break (== '=') ls+     getWith p = [ o | o@(Option _ xs _ _) <- optDescr+                     , find (p opt) xs /= Nothing ]+     options    = getWith (==)+     -- Diff to System.Console.GetOpt here: do not allow prefixes+     ads       = [ ad | Option _ _ ad _ <- options ]+     optStr    = ("--" ++ opt)++     long (_:_:_)      _        rest     = (errAmbig options optStr, rest)+     long [NoArg  a  ] []       rest     = (Opt a, rest)+     long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr, rest)+     long [ReqArg _ d] []       []       = (errReq d optStr, [])+     long [ReqArg f _] []       (r:rest) = (Opt (f r), rest)+     long [ReqArg f _] ('=':xs) rest     = (Opt (f xs), rest)+     long [OptArg f _] []       rest     = (Opt (f Nothing), rest)+     long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)), rest)+     long _            _        rest     = (UnreqOpt ("--" ++ ls), rest)++-- | Handle short option.+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])+shortOpt y ys rs optDescr = short ads ys rs+  where+    options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]+    ads     = [ ad | Option _ _ ad _ <- options ]+    optStr  = '-':[y]++    short (_:_:_)        _  rest     = (errAmbig options optStr, rest)+    short (NoArg  a  :_) [] rest     = (Opt a, rest)+    short (NoArg  a  :_) xs rest     = (Opt a, ('-':xs):rest)+    short (ReqArg _ d:_) [] []       = (errReq d optStr, [])+    short (ReqArg f _:_) [] (r:rest) = (Opt (f r), rest)+    short (ReqArg f _:_) xs rest     = (Opt (f xs), rest)+    short (OptArg f _:_) [] rest     = (Opt (f Nothing), rest)+    short (OptArg f _:_) xs rest     = (Opt (f (Just xs)), rest)+    short []             [] rest     = (UnreqOpt optStr, rest)+    short []             xs rest     = (UnreqOpt optStr, ('-':xs):rest)++-- * Miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where+     header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> String+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs view
@@ -1,50 +1,57 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Directed graphs (can of course simulate undirected graphs). -- --   Represented as adjacency maps in direction from source to target. -----   Each source node maps to a adjacency map of outgoing edges,+--   Each source node maps to an adjacency map of outgoing edges, --   which is a map from target nodes to edges. -----   This allows to get outgoing edges in O(log n) time where---   @n@ is the number of nodes in the graph.------   However, the set of incoming edges can only be obtained in---   @O(n log n)@ or @O(e)@ where @e@ is the total number of edges.+--   Listed time complexities are for the worst case (and possibly+--   amortised), with /n/ standing for the number of nodes in the+--   graph and /e/ standing for the number of edges. Comparisons,+--   predicates etc. are assumed to take constant time (unless+--   otherwise stated).  module Agda.Utils.Graph.AdjacencyMap.Unidirectional-  ( Graph(..)+  ( -- * Graphs and edges+    Graph(..)+  , invariant   , Edge(..)-  , transposeEdge+    -- * Queries+  , lookup   , edges+  , neighbours, neighboursMap   , edgesFrom   , edgesTo   , diagonal-  , lookup-  , neighbours, neighboursMap-  , sourceNodes, targetNodes-  , Nodes(..)-  , computeNodes, nodes-  , fromNodes-  , fromList, fromListWith-  , toList+  , nodes, sourceNodes, targetNodes, isolatedNodes+  , Nodes(..), computeNodes   , discrete-  , clean+  , acyclic+    -- * Construction+  , fromNodes, fromNodeSet+  , fromEdges, fromEdgesWith   , empty   , singleton   , insert, insertWith   , insertEdge, insertEdgeWith-  , union , unionWith+  , union, unionWith   , unions, unionsWith-  , removeNode+    -- * Transformation+  , mapWithEdge+  , transposeEdge, transpose+  , clean+  , removeNode, removeNodes   , removeEdge+  , filterNodes   , filterEdges+  , filterNodesKeepingEdges+  , renameNodes, renameNodesMonotonic+  , WithUniqueInt(..), addUniqueInts   , unzip-  , mapWithEdge+  , composeWith+    -- * Strongly connected components   , sccs'   , sccs   , DAG(..)@@ -53,25 +60,24 @@   , reachable   , sccDAG'   , sccDAG-  , acyclic-  , reachableFrom+    -- * Reachability+  , reachableFrom, reachableFromSet   , walkSatisfying-  , composeWith-  , complete-  , gaussJordanFloydWarshallMcNaughtonYamadaReference+  , longestPaths+    -- * Transitive closure   , gaussJordanFloydWarshallMcNaughtonYamada+  , gaussJordanFloydWarshallMcNaughtonYamadaReference+  , transitiveClosure+  , transitiveReduction+  , complete, completeIter   )   where -import Prelude hiding (lookup, unzip, null)--import Control.Applicative hiding (empty)-import Control.Monad+import Prelude hiding ( lookup, null, unzip )  import qualified Data.Array.IArray as Array-import qualified Data.Edison.Seq.BankersQueue as BQ-import qualified Data.Edison.Seq.SimpleQueue as SQ-import Data.Function+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap@@ -79,73 +85,128 @@ import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Map.Strict (Map)-import qualified Data.Maybe as Maybe-import Data.Maybe (maybeToList, fromMaybe, catMaybes)+import Data.Foldable (toList)++import Data.Maybe (maybeToList, fromMaybe) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Tree as Tree  import Agda.Utils.Function-import Agda.Utils.Functor-import Agda.Utils.List (headMaybe)+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null (Null(null)) import qualified Agda.Utils.Null as Null+import Agda.Syntax.Common.Pretty import Agda.Utils.SemiRing-import Agda.Utils.Singleton (Singleton)-import qualified Agda.Utils.Singleton as Singleton import Agda.Utils.Tuple -#include "undefined.h" import Agda.Utils.Impossible+import Agda.Utils.Functor --- | @Graph s t e@ is a directed graph with---   source nodes in @s@---   target nodes in @t@---   and edges in @e@.+------------------------------------------------------------------------+-- Graphs and edges++-- | @Graph n e@ is a type of directed graphs with nodes in @n@ and+--   edges in @e@. -----   Admits at most one edge between any two nodes.---   Several edges can be modeled by using a collection type for @e@.+--   At most one edge is allowed between any two nodes. Multigraphs+--   can be simulated by letting the edge type @e@ be a collection+--   type. -----   Represented as "adjacency list", or rather, adjacency map.---   This allows to get all outgoing edges for a node---   in @O(log n)@ time where @n@ is the number of nodes of the graph.+--   The graphs are represented as adjacency maps (adjacency lists,+--   but using finite maps instead of arrays and lists). This makes it+--   possible to compute a node's outgoing edges in logarithmic time+--   (/O(log n)/). However, computing the incoming edges may be more+--   expensive. -----   Incoming edges can only be computed in @O(n + e)@ time where---   @e@ is the number of edges.+--   Note that neither the number of nodes nor the number of edges may+--   exceed @'maxBound' :: 'Int'@. -newtype Graph s t e = Graph-  { graph :: Map s (Map t e) -- ^ Forward edges.+newtype Graph n e = Graph+  { graph :: Map n (Map n e) -- ^ Forward edges.   }-  deriving (Eq, Functor, Show)+  deriving Eq -data Edge s t e = Edge-  { source :: s  -- ^ Outgoing node.-  , target :: t  -- ^ Incoming node.+-- The Functor instance for strict maps is the one for lazy maps, so a+-- custom Functor instance using strict map functions is used here.++instance Functor (Graph n) where+  fmap f = Graph . Map.map (Map.map f) . graph++-- | Internal invariant.++invariant :: Ord n => Graph n e -> Bool+invariant g =+  -- Every target node must be present in the graph as a source node,+  -- possibly without outgoing edges.+  Set.isSubsetOf (targetNodes g) (nodes g)++instance (Ord n, Pretty n, Pretty e) => Pretty (Graph n e) where+  pretty g = vcat (concatMap pretty' (Set.toAscList (nodes g)))+    where+    pretty' n = case edgesFrom g [n] of+      [] -> [pretty n]+      es -> map pretty es++instance (Ord n, Show n, Show e) => Show (Graph n e) where+  showsPrec _ g =+    showString "union (fromEdges " .+    shows (edges g) .+    showString ") (fromNodes " .+    shows (Set.toList (isolatedNodes g)) .+    showString ")"++-- | Edges.++data Edge n e = Edge+  { source :: n  -- ^ Outgoing node.+  , target :: n  -- ^ Incoming node.   , label  :: e  -- ^ Edge label (weight).   } deriving (Eq, Ord, Functor, Show) --- | Reverse an edge.+instance (Pretty n, Pretty e) => Pretty (Edge n e) where+  pretty (Edge s t e) =+    pretty s <+> ("--(" <> pretty e <> ")-->") <+> pretty t -transposeEdge :: Edge s t e -> Edge t s e-transposeEdge (Edge s t e) = Edge t s e+------------------------------------------------------------------------+-- Queries --- * Edge queries+-- | If there is an edge from @s@ to @t@, then @lookup s t g@ is+-- @'Just' e@, where @e@ is the edge's label. /O(log n)/. --- | Turn a graph into a list of edges.  @O(n + e)@+lookup :: Ord n => n -> n -> Graph n e -> Maybe e+lookup s t (Graph g) = Map.lookup t =<< Map.lookup s g -edges :: Graph s t e -> [Edge s t e]+-- | The graph's edges. /O(n + e)/.++edges :: Graph n e -> [Edge n e] edges (Graph g) =   [ Edge s t e   | (s, tes) <- Map.assocs g   , (t, e)   <- Map.assocs tes   ] --- | All edges originating in the given nodes.---   (I.e., all outgoing edges for the given nodes.)------   Roughly linear in the length of the result list @O(result)@.+-- | @neighbours u g@ consists of all nodes @v@ for which there is an+-- edge from @u@ to @v@ in @g@, along with the corresponding edge+-- labels. /O(log n + |@neighbours u g@|)/. -edgesFrom :: Ord s => Graph s t e -> [s] -> [Edge s t e]+neighbours :: Ord n => n -> Graph n e -> [(n, e)]+neighbours s = Map.toList . neighboursMap s++-- | @neighboursMap u g@ consists of all nodes @v@ for which there is+-- an edge from @u@ to @v@ in @g@, along with the corresponding edge+-- labels. /O(log n)/.++neighboursMap :: Ord n => n -> Graph n e -> Map n e+neighboursMap s (Graph g) = fromMaybe Map.empty $ Map.lookup s g++-- | @edgesFrom g ns@ is a list containing all edges originating in+-- the given nodes (i.e., all outgoing edges for the given nodes). If+-- @ns@ does not contain duplicates, then the resulting list does not+-- contain duplicates. /O(|@ns@| log |@n@| + |@edgesFrom g ns@|)/.++edgesFrom :: Ord n => Graph n e -> [n] -> [Edge n e] edgesFrom (Graph g) ss =   [ Edge s t e   | s <- ss@@ -153,13 +214,12 @@   , (t, e) <- Map.assocs m   ] ---- | All edges ending in the given nodes.---   (I.e., all incoming edges for the given nodes.)------   Expensive: @O(n * |ts| * log n)@.+-- | @edgesTo g ns@ is a list containing all edges ending in the given+-- nodes (i.e., all incoming edges for the given nodes). If @ns@ does+-- not contain duplicates, then the resulting list does not contain+-- duplicates. /O(|@ns@| n log n)/. -edgesTo :: Ord t => Graph s t e -> [t] -> [Edge s t e]+edgesTo :: Ord n => Graph n e -> [n] -> [Edge n e] edgesTo (Graph g) ts =   [ Edge s t e   | (s, m) <- Map.assocs g@@ -167,231 +227,451 @@   , e <- maybeToList $ Map.lookup t m   ] --- | Get all self-loops.+-- | All self-loops. /O(n log n)/. -diagonal :: (Ord n) => Graph n n e -> [Edge n n e]+diagonal :: Ord n => Graph n e -> [Edge n e] diagonal (Graph g) =   [ Edge s s e   | (s, m) <- Map.assocs g   , e      <- maybeToList $ Map.lookup s m   ] --- | Lookup label of an edge.--lookup :: (Ord s, Ord t) => s -> t -> Graph s t e -> Maybe e-lookup s t (Graph g) = Map.lookup t =<< Map.lookup s g---- | Get a list of outgoing edges with target.--neighbours :: Ord s => s -> Graph s t e -> [(t, e)]-neighbours s (Graph g) = maybe [] Map.assocs $ Map.lookup s g---- | Get a list of outgoing edges with target.--neighboursMap :: Ord s => s -> Graph s t e -> Map t e-neighboursMap s (Graph g) = fromMaybe Map.empty $ Map.lookup s g+-- | All nodes. /O(n)/. --- * Node queries+nodes :: Graph n e -> Set n+nodes = Map.keysSet . graph --- | Returns all the nodes with outgoing edges.  @O(n)@.+-- | Nodes with outgoing edges. /O(n)/. -sourceNodes :: Graph s t e -> Set s-sourceNodes = Map.keysSet . graph+sourceNodes :: Graph n e -> Set n+sourceNodes = Map.keysSet . Map.filter (not . Map.null) . graph --- | Returns all the nodes with incoming edges.  Expensive! @O(e)@.+-- | Nodes with incoming edges. /O(n + e log n)/. -targetNodes :: Ord t => Graph s t e -> Set t+targetNodes :: Ord n => Graph n e -> Set n targetNodes = Set.fromList . map target . edges --- | For homogeneous graphs, @(s = t)@ we can compute a set---   of all nodes.------   Structure @Nodes@ is for computing all nodes but also---   remembering which were incoming and which outgoing.---   This is mostly for efficiency reasons, to avoid recomputation---   when all three sets are needed.+-- | Various kinds of nodes.  data Nodes n = Nodes   { srcNodes :: Set n+    -- ^ Nodes with outgoing edges.   , tgtNodes :: Set n+    -- ^ Nodes with incoming edges.   , allNodes :: Set n+    -- ^ All nodes, with or without edges.   } -computeNodes :: (Ord n) => Graph n n e -> Nodes n-computeNodes g = Nodes srcs tgts (srcs `Set.union` tgts)-  where srcs = sourceNodes g-        tgts = targetNodes g+-- | Constructs a 'Nodes' structure. /O(n + e log n)/. --- | The set of all nodes (outgoing and incoming).+computeNodes :: Ord n => Graph n e -> Nodes n+computeNodes g =+  Nodes { srcNodes = Set.filter (not . null . flip neighbours g) ns+        , tgtNodes = targetNodes g+        , allNodes = ns+        }+  where+  ns = nodes g -nodes :: (Ord n) => Graph n n e -> Set n-nodes = allNodes . computeNodes+-- | Nodes without incoming or outgoing edges. /O(n + e log n)/. --- * Graph construction.+isolatedNodes :: Ord n => Graph n e -> Set n+isolatedNodes g =+  Set.difference (allNodes ns) (Set.union (srcNodes ns) (tgtNodes ns))+  where+  ns = computeNodes g --- | Constructs a completely disconnected graph containing the given---   nodes. @O(n)@.+-- | Checks whether the graph is discrete (containing no edges other+-- than 'null' edges). /O(n + e)/. -fromNodes :: Ord n => [n] -> Graph n n e-fromNodes ns = Graph $ Map.fromList $ map (, Map.empty) ns+discrete :: Null e => Graph n e -> Bool+discrete = all' (all' null) . graph+  where all' p = List.all p . Map.elems --- | Constructs a graph from a list of edges.  O(e log n)------   Later edges overwrite earlier edges.+-- | Returns @True@ iff the graph is acyclic. -fromList :: (Ord s, Ord t) => [Edge s t e] -> Graph s t e-fromList = fromListWith $ \ new old -> new+acyclic :: Ord n => Graph n e -> Bool+acyclic = all isAcyclic . sccs'+  where+  isAcyclic Graph.AcyclicSCC{} = True+  isAcyclic Graph.CyclicSCC{}  = False --- | Constructs a graph from a list of edges.  O(e log n)------   Later edges are combined with earlier edges using the supplied function.+------------------------------------------------------------------------+-- Construction -fromListWith :: (Ord s, Ord t) => (e -> e -> e) -> [Edge s t e] -> Graph s t e-fromListWith f = List.foldl' (flip (insertEdgeWith f)) empty+-- | Constructs a completely disconnected graph containing the given+--   nodes. /O(n log n)/. --- | Convert a graph into a list of edges. O(e)+fromNodes :: Ord n => [n] -> Graph n e+fromNodes ns = Graph $ Map.fromList $ map (, Map.empty) ns -toList :: Graph s t e -> [Edge s t e]-toList (Graph g) = [ Edge s t a | (s,m) <- Map.assocs g, (t,a) <- Map.assocs m ]+-- | Constructs a completely disconnected graph containing the given+--   nodes. /O(n)/. --- | Check whether the graph is discrete (no edges).---   This could be seen as an empty graph.---   Worst-case (is discrete): @O(e)@.-discrete :: Null e => Graph s t e -> Bool-discrete = all' (all' null) . graph-  where all' p = List.all p . Map.elems+fromNodeSet :: Ord n => Set n -> Graph n e+fromNodeSet ns = Graph $ Map.fromSet (\_ -> Map.empty) ns --- | Removes 'Null' edges (and empty 'Map's).-clean :: Null e => Graph s t e -> Graph s t e-clean = Graph . filt . fmap filt . graph-  where-    filt :: Null a => Map k a -> Map k a-    filt = Map.filter (not . null)+-- | @fromEdges es@ is a graph containing the edges in @es@, with the+-- caveat that later edges overwrite earlier edges. /O(|@es@| log n)/. --- | Empty graph (no nodes, no edges).+fromEdges :: Ord n => [Edge n e] -> Graph n e+fromEdges = fromEdgesWith $ \ new old -> new -empty :: Graph s t e+-- | @fromEdgesWith f es@ is a graph containing the edges in @es@.+-- Later edges are combined with earlier edges using the supplied+-- function. /O(|@es@| log n)/.++fromEdgesWith :: Ord n => (e -> e -> e) -> [Edge n e] -> Graph n e+fromEdgesWith f = List.foldl' (flip (insertEdgeWith f)) empty++-- | Empty graph (no nodes, no edges). /O(1)/.++empty :: Graph n e empty = Graph Map.empty --- | A graph with two nodes and a single connecting edge.+-- | A graph with two nodes and a single connecting edge. /O(1)/. -singleton :: s -> t -> e -> Graph s t e-singleton s t e = Graph $ Map.singleton s (Map.singleton t e)+singleton :: Ord n => n -> n -> e -> Graph n e+singleton s t e = insert s t e empty --- | Insert an edge into the graph.+-- | Inserts an edge into the graph. /O(log n)/. -insert :: (Ord s, Ord t) => s -> t -> e -> Graph s t e -> Graph s t e+insert :: Ord n => n -> n -> e -> Graph n e -> Graph n e insert = insertWith $ \ new old -> new -insertEdge :: (Ord s, Ord t) => Edge s t e -> Graph s t e -> Graph s t e+-- | Inserts an edge into the graph. /O(log n)/.++insertEdge :: Ord n => Edge n e -> Graph n e -> Graph n e insertEdge (Edge s t e) = insert s t e --- | Insert an edge, possibly combining @old@ edge weight with @new@ weight by---   given function @f@ into @f new old@.+-- | @insertWith f s t new@ inserts an edge from @s@ to @t@ into the+-- graph. If there is already an edge from @s@ to @t@ with label @old@,+-- then this edge gets replaced by an edge with label @f new old@, and+-- otherwise the edge's label is @new@. /O(log n)/. -insertWith :: (Ord s, Ord t) =>-              (e -> e -> e) -> s -> t -> e -> Graph s t e -> Graph s t e-insertWith f s t e (Graph g) = Graph (Map.alter (Just . ins) s g)-  where ins Nothing  = Map.singleton t e-        ins (Just m) = Map.insertWith f t e m+insertWith ::+  Ord n => (e -> e -> e) -> n -> n -> e -> Graph n e -> Graph n e+insertWith f s t e (Graph g) =+  Graph (Map.alter (Just . insNode) t $ Map.alter (Just . insEdge) s g)+  where+  insEdge Nothing  = Map.singleton t e+  insEdge (Just m) = Map.insertWith f t e m -insertEdgeWith :: (Ord s, Ord t) =>-                  (e -> e -> e) -> Edge s t e -> Graph s t e -> Graph s t e+  insNode Nothing  = Map.empty+  insNode (Just m) = m++-- | A variant of 'insertWith'. /O(log n)/.++insertEdgeWith ::+  Ord n => (e -> e -> e) -> Edge n e -> Graph n e -> Graph n e insertEdgeWith f (Edge s t e) = insertWith f s t e  -- | Left-biased union.+--+-- Time complexity: See 'unionWith'. -union :: (Ord s, Ord t) => Graph s t e -> Graph s t e -> Graph s t e+union :: Ord n => Graph n e -> Graph n e -> Graph n e union = unionWith $ \ left right -> left -unionWith :: (Ord s, Ord t) =>-             (e -> e -> e) -> Graph s t e -> Graph s t e -> Graph s t e-unionWith f (Graph g) (Graph g') = Graph $ Map.unionWith (Map.unionWith f) g g'+-- | Union. The function is used to combine edge labels for edges that+-- occur in both graphs (labels from the first graph are given as the+-- first argument to the function).+--+-- Time complexity: /O(n₁ log (n₂/n₁ + 1) + e₁ log e₂)/, where /n₁/ is+-- the number of nodes in the graph with the smallest number of nodes+-- and /n₂/ is the number of nodes in the other graph, and /e₁/ is the+-- number of edges in the graph with the smallest number of edges and+-- /e₂/ is the number of edges in the other graph.+--+-- Less complicated time complexity: /O((n + e) log n/ (where /n/ and+-- /e/ refer to the resulting graph). -unions ::(Ord s, Ord t) => [Graph s t e] -> Graph s t e+unionWith ::+  Ord n => (e -> e -> e) -> Graph n e -> Graph n e -> Graph n e+unionWith f (Graph g) (Graph g') =+  Graph $ Map.unionWith (Map.unionWith f) g g'++-- | Union. /O((n + e) log n/ (where /n/ and /e/ refer to the+-- resulting graph).++unions :: Ord n => [Graph n e] -> Graph n e unions = unionsWith $ \ left right -> left -unionsWith :: (Ord s, Ord t) => (e -> e -> e) -> [Graph s t e] -> Graph s t e+-- | Union. The function is used to combine edge labels for edges that+-- occur in several graphs. /O((n + e) log n/ (where /n/ and /e/ refer+-- to the resulting graph).++unionsWith :: Ord n => (e -> e -> e) -> [Graph n e] -> Graph n e unionsWith f = List.foldl' (unionWith f) empty --- * Graph reversal+------------------------------------------------------------------------+-- Transformation --- | The opposite graph (with all edges reversed).+-- | A variant of 'fmap' that provides extra information to the+-- function argument. /O(n + e)/. -transpose :: (Ord s, Ord t) => Graph s t e -> Graph t s e-transpose = fromList . map transposeEdge . edges+mapWithEdge :: (Edge n e -> e') -> Graph n e -> Graph n e'+mapWithEdge f (Graph g) = Graph $ flip Map.mapWithKey g $ \ s m ->+  flip Map.mapWithKey m $ \ t e -> f (Edge s t e) --- * Graph deconstruction.+-- | Reverses an edge. /O(1)/. --- | Auxiliary function to turn empty map into @Nothing@.+transposeEdge :: Edge n e -> Edge n e+transposeEdge (Edge s t e) = Edge t s e -discardEmpty :: Map k v -> Maybe (Map k v)-discardEmpty m = if Map.null m then Nothing else Just m+-- | The opposite graph (with all edges reversed). /O((n + e) log n)/. --- | Removes the given source node, and all corresponding edges, from the graph.+transpose :: Ord n => Graph n e -> Graph n e+transpose g =+  fromEdges (map transposeEdge (edges g))+    `union`+  fromNodeSet (isolatedNodes g)++-- | Removes 'null' edges. /O(n + e)/.++clean :: Null e => Graph n e -> Graph n e+clean = Graph . Map.map (Map.filter (not . null)) . graph++-- | The graph @filterNodes p g@ contains exactly those nodes from @g@+-- that satisfy the predicate @p@. Edges to or from nodes that are+-- removed are also removed. /O(n + e)/.++filterNodes :: Ord n => (n -> Bool) -> Graph n e -> Graph n e+filterNodes p (Graph g) = Graph (Map.mapMaybeWithKey remSrc g)+  where+  remSrc s m+    | p s       = Just (Map.filterWithKey (\t _ -> p t) m)+    | otherwise = Nothing++-- | @removeNodes ns g@ removes the nodes in @ns@ (and all+-- corresponding edges) from @g@. /O((n + e) log |@ns@|)/.++removeNodes :: Ord n => Set n -> Graph n e -> Graph n e+removeNodes ns = filterNodes (\n -> not (Set.member n ns))++-- | @removeNode n g@ removes the node @n@ (and all corresponding+-- edges) from @g@. /O(n + e)/.++removeNode :: Ord n => n -> Graph n e -> Graph n e+removeNode = removeNodes . Set.singleton++-- | @removeEdge s t g@ removes the edge going from @s@ to @t@, if any.+--   /O(log n)/.++removeEdge :: Ord n => n -> n -> Graph n e -> Graph n e+removeEdge s t (Graph g) = Graph $ Map.adjust (Map.delete t) s g++-- | Keep only the edges that satisfy the predicate. /O(n + e)/.++filterEdges :: (Edge n e -> Bool) -> Graph n e -> Graph n e+filterEdges f =+  Graph .+  Map.mapWithKey (\s ->+    Map.filterWithKey (\t l ->+      f (Edge { source = s, target = t, label = l }))) .+  graph++-- | Removes the nodes that do not satisfy the predicate from the+-- graph, but keeps the edges: if there is a path in the original+-- graph between two nodes that are retained, then there is a path+-- between these two nodes also in the resulting graph. -----   O(log n).-removeSourceNode :: Ord s => s -> Graph s t e -> Graph s t e-removeSourceNode s (Graph g) = Graph $ Map.delete s g+-- Precondition: The graph must be acyclic.+--+-- Worst-case time complexity: /O(e n log n)/ (this has not been+-- verified carefully). --- | Removes the given target node, and all corresponding edges, from the graph.+filterNodesKeepingEdges ::+  forall n e. (Ord n, SemiRing e) =>+  (n -> Bool) -> Graph n e -> Graph n e+filterNodesKeepingEdges p g =+  foldr (insertEdgeWith oplus) (filterNodes p g)+    (fst edgesToAddAndRemove)+  where+  -- The new edges that should be added, and a map from nodes that+  -- should be removed to edges that should potentially be added+  -- (after being combined with paths into the nodes that should be+  -- removed).+  edgesToAddAndRemove :: ([Edge n e], Map n (Map n e))+  edgesToAddAndRemove =+    List.foldl' edgesToAddAndRemoveForSCC ([], Map.empty) (sccs' g)++  edgesToAddAndRemoveForSCC (add, !remove) (Graph.AcyclicSCC n)+    | p n =+      ( (do (n', e) <- neighbours n g+            case Map.lookup n' remove of+              Nothing -> []+              Just es ->+                for (Map.toList es) $ \(n', e') -> Edge+                  { source = n+                  , target = n'+                  , label  = e `otimes` e'+                  })+          +++        add+      , remove+      )+    | otherwise =+      ( add+      , Map.insert+          n+          (Map.unionsWith oplus $+           for (neighbours n g) $ \(n', e) ->+             case Map.lookup n' remove of+               Nothing -> Map.singleton n' e+               Just es -> fmap (e `otimes`) es)+          remove+      )+  edgesToAddAndRemoveForSCC _ (Graph.CyclicSCC{}) = __IMPOSSIBLE__++-- | Renames the nodes. -----   Expensive!  @O(n log n)@.+-- Precondition: The renaming function must be injective.+--+-- Time complexity: /O((n + e) log n)/. -removeTargetNode :: Ord t => t -> Graph s t e -> Graph s t e-removeTargetNode t (Graph g) = Graph $ Map.mapMaybe rem g-  where rem = discardEmpty . Map.delete t+renameNodes :: Ord n2 => (n1 -> n2) -> Graph n1 e -> Graph n2 e+renameNodes ren =+  Graph .+  fmap (Map.mapKeys ren) .+  Map.mapKeys ren .+  graph --- | Removes the given node, be it source or target,---   and all corresponding edges, from the graph.+-- | Renames the nodes. -----   Expensive!  @O(n log n)@.+-- Precondition: The renaming function @ren@ must be strictly+-- increasing (if @x '<' y@ then @ren x '<' ren y@).+--+-- Time complexity: /O(n + e)/. -removeNode :: Ord n => n -> Graph n n e -> Graph n n e-removeNode n = removeTargetNode n . removeSourceNode n+renameNodesMonotonic ::+  (Ord n1, Ord n2) => (n1 -> n2) -> Graph n1 e -> Graph n2 e+renameNodesMonotonic ren =+  Graph .+  fmap (Map.mapKeysMonotonic ren) .+  Map.mapKeysMonotonic ren .+  graph --- | @removeEdge s t g@ removes the edge going from @s@ to @t@, if any.+-- | @WithUniqueInt n@ consists of pairs of (unique) 'Int's and values+-- of type @n@. -----   @O((log n)^2)@.+-- Values of this type are compared by comparing the 'Int's. -removeEdge :: (Ord s, Ord t) => s -> t -> Graph s t e -> Graph s t e-removeEdge s t (Graph g) = Graph $ Map.adjust (Map.delete t) s g+data WithUniqueInt n = WithUniqueInt+  { uniqueInt  :: !Int+  , otherValue :: !n+  }+  deriving (Show, Functor) --- | Keep only the edges that satisfy the predicate.  @O(e).@+instance Eq (WithUniqueInt n) where+  WithUniqueInt i1 _ == WithUniqueInt i2 _ = i1 == i2 -filterEdges :: (e -> Bool) -> Graph s t e -> Graph s t e-filterEdges f (Graph g) = Graph $ Map.mapMaybe (discardEmpty . Map.filter f) g+instance Ord (WithUniqueInt n) where+  compare (WithUniqueInt i1 _) (WithUniqueInt i2 _) = compare i1 i2 --- | Unzipping a graph (naive implementation using fmap).+instance Pretty n => Pretty (WithUniqueInt n) where+  pretty (WithUniqueInt i n) =+    parens ((pretty i <> comma) <+> pretty n) -unzip :: Graph s t (e, e') -> (Graph s t e, Graph s t e')+-- | Combines each node label with a unique 'Int'.+--+-- Precondition: The number of nodes in the graph must not be larger+-- than @'maxBound' :: 'Int'@.+--+-- Time complexity: /O(n + e log n)/.++addUniqueInts ::+  forall n e. Ord n => Graph n e -> Graph (WithUniqueInt n) e+addUniqueInts g =+  Graph $+  Map.fromDistinctAscList $+  map (\(i, (n, m)) ->+        (WithUniqueInt i n, Map.mapKeysMonotonic ren m)) $+  zip [0..] $+  Map.toAscList $+  graph g+  where+  renaming :: Map n Int+  renaming = snd $ Map.mapAccum (\i _ -> (succ i, i)) 0 (graph g)++  ren :: n -> WithUniqueInt n+  ren n = case Map.lookup n renaming of+    Just i  -> WithUniqueInt i n+    Nothing -> __IMPOSSIBLE__++-- | Unzips the graph. /O(n + e)/.++-- This is a naive implementation that uses fmap.++unzip :: Graph n (e, e') -> (Graph n e, Graph n e') unzip g = (fst <$> g, snd <$> g) --- | Maps over a graph under availability of positional information,---   like 'Map.mapWithKey'.+-- | @composeWith times plus g g'@ finds all edges+--   @s --c_i--> t_i --d_i--> u@ and constructs the+--   result graph from @edge(s,u) = sum_i (c_i times d_i)@.+--+--   Complexity:  For each edge @s --> t@ in @g@ we look up+--   all edges starting with @t@ in @g'@.+--+--   Precondition: The two graphs must have exactly the same nodes. -mapWithEdge :: (Edge s t e -> e') -> Graph s t e -> Graph s t e'-mapWithEdge f (Graph g) = Graph $ flip Map.mapWithKey g $ \ s m ->-  flip Map.mapWithKey m $ \ t e -> f (Edge s t e)+composeWith ::+  Ord n =>+  (c -> d -> e) -> (e -> e -> e) ->+  Graph n c -> Graph n d -> Graph n e+composeWith times plus (Graph g) (Graph g') = Graph (Map.map comp g)+  where+  comp m = Map.fromListWith plus+    [ (u, c `times` d)+    | (t, c) <- Map.assocs m+    , m'     <- maybeToList (Map.lookup t g')+    , (u, d) <- Map.assocs m'+    ] --- * Strongly connected components.+------------------------------------------------------------------------+-- Strongly connected components  -- | The graph's strongly connected components, in reverse topological -- order.+--+-- The time complexity is likely /O(n + e log n)/ (but this depends on+-- the, at the time of writing undocumented, time complexity of+-- 'Graph.stronglyConnComp'). -sccs' :: Ord n => Graph n n e -> [Graph.SCC n]+sccs' :: Ord n => Graph n e -> [Graph.SCC n] sccs' g =   Graph.stronglyConnComp-    [ (n, n, map target (edgesFrom g [n]))-    | n <- Set.toList (nodes g)+    [ (n, n, Map.keys es)+    | (n, es) <- Map.toAscList (graph g)     ]+    -- Graph.stronglyConnComp sorts this list, and the sorting+    -- algorithm that is used is adaptive, so it may make sense to+    -- generate a sorted list. (These comments apply to one specific+    -- version of the code in Graph, compiled in a specific way.)  -- | The graph's strongly connected components, in reverse topological -- order.+--+-- The time complexity is likely /O(n + e log n)/ (but this depends on+-- the, at the time of writing undocumented, time complexity of+-- 'Graph.stronglyConnComp'). -sccs :: Ord n => Graph n n e -> [[n]]-sccs = map Graph.flattenSCC . sccs'+sccs :: Ord n => Graph n e -> [List1 n]+sccs = map flattenSCC . sccs' +-- | 'Data.Graph.flattenSCC' with a more precise type.++flattenSCC :: Graph.SCC n -> List1 n+flattenSCC = List1.fromList . Graph.flattenSCC+-- Andreas, 2024-01-31+-- Really, upstream should give flattenSCC a more precise type:+-- See https://github.com/haskell/containers/issues/985+-- The following more direct definition only works with containers >= 0.7,+-- but the time is not yet ripe for this:+--   \case+--     Graph.AcyclicSCC n   -> List1.singleton n+--     Graph.NECyclicSCC ns -> ns+ -- | SCC DAGs. -- -- The maps map SCC indices to and from SCCs/nodes.@@ -431,7 +711,7 @@     &&   all isAcyclic (Graph.scc (dagGraph g))   where-  isAcyclic (Tree.Node r []) = not (r `elem` (dagGraph g Array.! r))+  isAcyclic (Tree.Node r []) = r `notElem` (dagGraph g Array.! r)   isAcyclic _                = False  -- | The opposite DAG.@@ -447,13 +727,9 @@   Graph.CyclicSCC (n : _) -> reachable' n   Graph.CyclicSCC []      -> __IMPOSSIBLE__   where-  lookup' g k = case IntMap.lookup k g of-    Nothing -> __IMPOSSIBLE__-    Just x  -> x+  lookup' g k = fromMaybe __IMPOSSIBLE__ (IntMap.lookup k g) -  lookup'' g k = case Map.lookup k g of-    Nothing -> __IMPOSSIBLE__-    Just x  -> x+  lookup'' g k = fromMaybe __IMPOSSIBLE__ (Map.lookup k g)    reachable' n =     concatMap (Graph.flattenSCC . lookup' (dagComponentMap g)) $@@ -464,7 +740,7 @@  sccDAG' ::   forall n e. Ord n-  => Graph n n e+  => Graph n e   -> [Graph.SCC n]      -- ^ The graph's strongly connected components.   -> DAG n@@ -485,9 +761,7 @@     IntSet.toList $ IntSet.fromList       [ j       | e <- edgesFrom g ns-      , let j = case Map.lookup (target e) firstNodeMap of-                  Nothing -> __IMPOSSIBLE__-                  Just j  -> j+      , let j = fromMaybe __IMPOSSIBLE__ (Map.lookup (target e) firstNodeMap)       , j /= i       ] @@ -498,29 +772,22 @@       ]    convertInt :: Int -> Graph.Vertex-  convertInt i = case toVertex i of-    Nothing -> __IMPOSSIBLE__-    Just i  -> i+  convertInt i = fromMaybe __IMPOSSIBLE__ (toVertex i)    componentMap :: IntMap (Graph.SCC n)   componentMap = IntMap.fromList (map (mapFst convertInt) components)    secondNodeMap :: Map n Int-  secondNodeMap = fmap convertInt firstNodeMap+  secondNodeMap = Map.map convertInt firstNodeMap  -- | Constructs a DAG containing the graph's strongly connected -- components. -sccDAG :: Ord n => Graph n n e -> DAG n+sccDAG :: Ord n => Graph n e -> DAG n sccDAG g = sccDAG' g (sccs' g) --- | Returns @True@ iff the graph is acyclic.--acyclic :: Ord n => Graph n n e -> Bool-acyclic = all isAcyclic . sccs'-  where-  isAcyclic Graph.AcyclicSCC{} = True-  isAcyclic Graph.CyclicSCC{}  = False+------------------------------------------------------------------------+-- Reachability  -- | @reachableFrom g n@ is a map containing all nodes reachable from -- @n@ in @g@. For each node a simple path to the node is given, along@@ -534,20 +801,40 @@ -- time): /O(e log n)/, if the lists are not inspected. Inspection of -- a prefix of a list is linear in the length of the prefix. -reachableFrom :: Ord n => Graph n n e -> n -> Map n (Int, [Edge n n e])-reachableFrom g n = bfs (SQ.singleton (n, BQ.empty)) Map.empty+reachableFrom :: Ord n => Graph n e -> n -> Map n (Int, [Edge n e])+reachableFrom g n = reachableFromInternal g (Set.singleton n)++-- | @reachableFromSet g ns@ is a set containing all nodes reachable+-- from @ns@ in @g@.+--+-- Precondition: Every node in @ns@ must be a node in @g@. The number+-- of nodes in the graph must not be larger than @'maxBound' ::+-- 'Int'@.+--+-- Amortised time complexity (assuming that comparisons take constant+-- time): /O((|@ns@| + e) log n)/.++reachableFromSet :: Ord n => Graph n e -> Set n -> Set n+reachableFromSet g ns = Map.keysSet (reachableFromInternal g ns)++-- | Used to implement 'reachableFrom' and 'reachableFromSet'.++reachableFromInternal ::+  Ord n => Graph n e -> Set n -> Map n (Int, [Edge n e])+reachableFromInternal g ns =+  bfs (Seq.fromList (map (, Seq.empty) (toList ns))) Map.empty   where-  bfs !q !map = case SQ.lview q of-    Nothing          -> map-    Just ((u, p), q) ->+  bfs !q !map = case Seq.viewl q of+    Seq.EmptyL -> map+    (u, p) Seq.:< q ->       if u `Map.member` map       then bfs q map-      else bfs (foldr SQ.rcons q-                      [ (v, BQ.rcons (Edge u v e) p)+      else bfs (foldr (flip (Seq.|>)) q+                      [ (v, p Seq.|> Edge u v e)                       | (v, e) <- neighbours u g                       ])-               (let n = BQ.size p in-                n `seq` Map.insert u (n, BQ.toList p) map)+               (let n = Seq.length p in+                n `seq` Map.insert u (n, toList p) map)  -- | @walkSatisfying every some g from to@ determines if there is a -- walk from @from@ to @to@ in @g@, in which every edge satisfies the@@ -559,55 +846,89 @@ -- nodes in the graph must not be larger than @'maxBound' :: 'Int'@. -- -- Amortised time complexity (assuming that comparisons and the--- predicates take constant time to compute): /O(e log n)/.+-- predicates take constant time to compute): /O(n + e log n)/.  walkSatisfying ::   Ord n =>-  (e -> Bool) -> (e -> Bool) ->-  Graph n n e -> n -> n -> Maybe [Edge n n e]+  (Edge n e -> Bool) -> (Edge n e -> Bool) ->+  Graph n e -> n -> n -> Maybe [Edge n e] walkSatisfying every some g from to =   case     [ (l1 + l2, p1 ++ [e] ++ map transposeEdge (reverse p2))     | e <- everyEdges-    , some (label e)+    , some e     , (l1, p1) <- maybeToList (Map.lookup (source e) fromReaches)     , (l2, p2) <- maybeToList (Map.lookup (target e) reachesTo)     ] of     []  -> Nothing     ess -> Just $ snd $ List.minimumBy (compare `on` fst) ess   where-  everyEdges = [ e | e <- toList g, every (label e) ]+  everyEdges = [ e | e <- edges g, every e ] -  fromReaches = reachableFrom (fromList everyEdges) from+  fromReaches = reachableFrom (fromEdges everyEdges) from    reachesTo =-    reachableFrom (fromList (map transposeEdge everyEdges)) to---- * Graph composition+    reachableFrom (fromEdges (map transposeEdge everyEdges)) to --- | @composeWith times plus g g'@ finds all edges---   @s --c_i--> t_i --d_i--> u@ and constructs the---   result graph from @edge(s,u) = sum_i (c_i times d_i)@.+-- | Constructs a graph @g'@ with the same nodes as the original graph+-- @g@. In @g'@ there is an edge from @n1@ to @n2@ if and only if+-- there is a (possibly empty) simple path from @n1@ to @n2@ in @g@.+-- In that case the edge is labelled with all of the longest (in terms+-- of numbers of edges) simple paths from @n1@ to @n2@ in @g@, as well+-- as the lengths of these paths. -----   Complexity:  for each edge @s --> t@ in @g@ we lookup up---   all edges starting in with @t@ in @g'@.+-- Precondition: The graph must be acyclic. The number of nodes in the+-- graph must not be larger than @'maxBound' :: 'Int'@. ---composeWith :: (Ord t, Ord u) => (c -> d -> e) -> (e -> e -> e) ->-  Graph s t c -> Graph t u d -> Graph s u e-composeWith times plus (Graph g) (Graph g') = Graph $-  Map.mapMaybe (discardEmpty . comp) g where-    comp m = Map.fromListWith plus-      [ (u, c `times` d)-      | (t, c) <- Map.assocs m-      , m'     <- maybeToList (Map.lookup t g')-      , (u, d) <- Map.assocs m'-      ]+-- Worst-case time complexity (if the paths are not inspected):+-- /O(e n log n)/ (this has not been verified carefully).+--+-- The algorithm is based on one found on Wikipedia. +longestPaths ::+  forall n e. Ord n => Graph n e -> Graph n (Int, [[Edge n e]])+longestPaths g =+  Graph $+  fmap (fmap (mapSnd toList)) $+  List.foldl' (flip addLongestFrom) Map.empty $+  sccs' g+  where+  addLongestFrom ::+    Graph.SCC n ->+    Map n (Map n (Int, Seq [Edge n e])) ->+    Map n (Map n (Int, Seq [Edge n e]))+  addLongestFrom Graph.CyclicSCC{}    !_  = __IMPOSSIBLE__+  addLongestFrom (Graph.AcyclicSCC n) pss =+    Map.insert n+      (Map.insert n (0, Seq.singleton []) $+       Map.unionsWith longest candidates)+      pss+    where+    longest p1@(n1, ps1) p2@(n2, ps2) = case compare n1 n2 of+      GT -> p1+      LT -> p2+      EQ -> (n1, ps1 Seq.>< ps2)++    candidates :: [Map n (Int, Seq [Edge n e])]+    candidates =+      for (neighbours n g) $ \(n', e) ->+      let edge = Edge+            { source = n+            , target = n'+            , label  = e+            }+      in case Map.lookup n' pss of+        Nothing -> Map.empty+        Just ps -> fmap (succ -*- fmap (edge :)) ps++------------------------------------------------------------------------+-- Transitive closure+ -- | Transitive closure ported from "Agda.Termination.CallGraph". -- --   Relatively efficient, see Issue 1560. -complete :: (Eq e, Null e, SemiRing e, Ord n) => Graph n n e -> Graph n n e+complete :: (Eq e, Null e, SemiRing e, Ord n) => Graph n e -> Graph n e complete g = repeatWhile (mapFst (not . discrete) . combineNewOld' g) g   where     combineNewOld' new old = unzip $ unionWith comb new' old'@@ -631,7 +952,7 @@ -- --   @complete g = snd $ last $ completeIter g@ -completeIter :: (Eq e, Null e, SemiRing e, Ord n) => Graph n n e -> [(Graph n n e, Graph n n e)]+completeIter :: (Eq e, Null e, SemiRing e, Ord n) => Graph n e -> [(Graph n e, Graph n e)] completeIter g = iterWhile (not . discrete) (combineNewOld' g) g   where     combineNewOld' new old = unzip $ unionWith comb new' old'@@ -664,7 +985,7 @@  gaussJordanFloydWarshallMcNaughtonYamadaReference ::   forall n e. (Ord n, Eq e, StarSemiRing e) =>-  Graph n n e -> Graph n n e+  Graph n e -> Graph n e gaussJordanFloydWarshallMcNaughtonYamadaReference g =   toGraph (foldr step initialMatrix nodeIndices)   where@@ -700,10 +1021,12 @@       ]    toGraph m =-    fromList [ Edge (indexMap Map.! i) (indexMap Map.! j) e-             | ((i, j), e) <- Array.assocs m-             , e /= ozero-             ]+    fromEdges [ Edge (indexMap Map.! i) (indexMap Map.! j) e+              | ((i, j), e) <- Array.assocs m+              , e /= ozero+              ]+      `union`+    fromNodeSet (nodes g)  -- | Computes the transitive closure of the graph. --@@ -724,7 +1047,7 @@  gaussJordanFloydWarshallMcNaughtonYamada ::   forall n e. (Ord n, Eq e, StarSemiRing e) =>-  Graph n n e -> (Graph n n e, [Graph.SCC n])+  Graph n e -> (Graph n e, [Graph.SCC n]) gaussJordanFloydWarshallMcNaughtonYamada g =   (loop components g, components)   where@@ -732,7 +1055,7 @@   forwardDAG = sccDAG' g components   reverseDAG = oppositeDAG forwardDAG -  loop :: [Graph.SCC n] -> Graph n n e -> Graph n n e+  loop :: [Graph.SCC n] -> Graph n e -> Graph n e   loop []           !g = g   loop (scc : sccs)  g =     loop sccs (foldr step g (Graph.flattenSCC scc))@@ -742,7 +1065,7 @@     -- All nodes that can reach the SCC.     canReach     = reachable reverseDAG scc -    step :: n -> Graph n n e -> Graph n n e+    step :: n -> Graph n e -> Graph n e     step k !g =       foldr (insertEdgeWith oplus) g         [ Edge i j e@@ -754,6 +1077,28 @@       where       starTimes = otimes (ostar (lookup' k k)) -      lookup' s t = case lookup s t g of-        Nothing -> ozero-        Just e  -> e+      lookup' s t = fromMaybe ozero (lookup s t g)++-- | The transitive closure. Using 'gaussJordanFloydWarshallMcNaughtonYamada'.+--   NOTE: DO NOT USE () AS EDGE LABEL SINCE THIS MEANS EVERY EDGE IS CONSIDERED A ZERO EDGE AND NO+--         NEW EDGES WILL BE ADDED! Use 'Maybe ()' instead.+transitiveClosure :: (Ord n, Eq e, StarSemiRing e) => Graph n e -> Graph n e+transitiveClosure = fst . gaussJordanFloydWarshallMcNaughtonYamada++-- | The transitive reduction of the graph: a graph with the same+-- reachability relation as the graph, but with as few edges as+-- possible.+--+-- Precondition: The graph must be acyclic. The number of nodes in the+-- graph must not be larger than @'maxBound' :: 'Int'@.+--+-- Worst-case time complexity: /O(e n log n)/ (this has not been+-- verified carefully).+--+-- The algorithm is based on one found on Wikipedia.++transitiveReduction :: Ord n => Graph n e -> Graph n ()+transitiveReduction g =+  fmap (const ()) $+  filterEdges ((== 1) . fst . label) $+  longestPaths g
+ src/full/Agda/Utils/Graph/TopSort.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Utils.Graph.TopSort+    ( topSort+    ) where++import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G++-- NB:: Defined but not used+mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]+mergeBy _ [] xs = xs+mergeBy _ xs [] = xs+mergeBy f (x:xs) (y:ys)+    | f x y = x: mergeBy f xs (y:ys)+    | otherwise = y: mergeBy f (x:xs) ys++-- | topoligical sort with smallest-numbered available vertex first+-- | input: nodes, edges+-- | output is Nothing if the graph is not a DAG+--   Note: should be stable to preserve order of generalizable variables. Algorithm due to Richard+--   Eisenberg, and works by walking over the list left-to-right and moving each node the minimum+--   distance left to guarantee topological ordering.+topSort :: Ord n => Set n -> [(n, n)] -> Maybe [n]+topSort nodes edges = go [] (Set.toList nodes)+  where+    -- #4253: The input edges do not necessarily include transitive dependencies, so take transitive+    --        closure before sorting.+    w      = Just () -- () is not a good edge label since it counts as a "zero" edge and will be ignored+    g      = G.transitiveClosure $+               G.fromNodeSet nodes `G.union`+               G.fromEdges [G.Edge a b w | (a, b) <- edges]+    -- Only the keys of these maps are used.+    deps a = G.graph g Map.! a++    -- acc: Already sorted nodes in reverse order paired with accumulated set of nodes that must+    -- come before it+    go acc [] = Just $ reverse $ map fst acc+    go acc (n : ns) = (`go` ns) =<< insert n acc++    insert a [] = Just [(a, deps a)]+    insert a bs0@((b, before_b) : bs)+      | before && after = Nothing+      | before          = ((b, Map.union before_a before_b) :) <$> insert a bs  -- a must come before b+      | otherwise       = Just $ (a, Map.union before_a before_b) : bs0+      where+        before_a = deps a+        before = Map.member a before_b+        after  = Map.member b before_a
src/full/Agda/Utils/Hash.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-| Instead of checking time-stamps we compute a hash of the module source and     store it in the interface file. This module contains the functions to do@@ -9,23 +10,29 @@ import qualified Data.Hash as H import qualified Data.List as L import Data.Digest.Murmur64+import qualified Data.Text.Encoding as T+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T  import Agda.Utils.FileName+import Agda.Utils.IO.UTF8 (readTextFile)  type Hash = Word64  hashByteString :: ByteString -> Hash hashByteString = H.asWord64 . B.foldl' (\h b -> H.combine h (H.hashWord8 b)) (H.hashWord8 0) -hashFile :: AbsolutePath -> IO Hash-hashFile file = do-  s <- B.readFile (filePath file)-  return $ hashByteString s+hashTextFile :: AbsolutePath -> IO Hash+hashTextFile file = hashText <$> readTextFile (filePath file) +-- | Hashes a piece of 'Text'.++hashText :: Text -> Hash+hashText = hashByteString . T.encodeUtf8 . T.toStrict+ combineHashes :: [Hash] -> Hash combineHashes hs = H.asWord64 $ L.foldl' H.combine (H.hashWord8 0) $ L.map H.hash hs  -- | Hashing a module name for unique identifiers. hashString :: String -> Word64 hashString = asWord64 . hash64-
− src/full/Agda/Utils/HashMap.hs 
@@ -1,14 +0,0 @@-module Agda.Utils.HashMap-  ( module HashMap-  ) where--import Data.HashMap.Strict as HashMap---- ASR (20 January 2016) Issue 1779: I removed the @mapMaybe@ and--- @alter@ functions because them currently aren't used and--- them were added in unordered-containers 0.2.6.0.---- mapMaybe :: (a -> Maybe b) -> HashMap k a -> HashMap k b---- alter :: (Eq k, Hashable k) =>---          (Maybe a -> Maybe a) -> k -> HashMap k a -> HashMap k a
+ src/full/Agda/Utils/HashTable.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -Wunused-imports #-}++------------------------------------------------------------------------+-- | Hash tables.+------------------------------------------------------------------------++module Agda.Utils.HashTable+  ( HashTable+  , empty+  , insert+  , lookup+  , toList+  , keySet+  ) where++import Prelude hiding (lookup)++import Data.Hashable+import qualified Data.Vector.Hashtables as H+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector as V+import Data.Set (Set)+import qualified Data.Set as Set++-- | Hash tables.++-- A very limited amount of (possibly outdated) testing indicates+-- that, for the use in Agda's serialiser/deserialiser,+-- Data.HashTable.IO.CuckooHashTable is somewhat slower than+-- Data.HashTable.IO.BasicHashTable, and that+-- Data.HashTable.IO.LinearHashTable and the hashtables from+-- Data.Hashtable are much slower. However, other (also possibly+-- outdated) testing suggests that Data.HashTable.IO.CuckooHashTable+-- is quite a bit faster than Data.HashTable.IO.BasicHashTable for+-- 64-bit Windows. Some more recent, also limited, testing suggests+-- that the following hash table implementation from+-- Data.Vector.Hashtables is quite a bit faster than+-- Data.HashTable.IO.BasicHashTable (see issue #5966).++newtype HashTable k v =+  HashTable (H.Dictionary (H.PrimState IO) VM.MVector k VM.MVector v)++-- | An empty hash table.++empty :: IO (HashTable k v)+empty = HashTable <$> H.initialize 0++-- | Inserts the key and the corresponding value into the hash table.++insert :: (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()+insert (HashTable h) = H.insert h+{-# INLINABLE insert #-}++-- | Tries to find a value corresponding to the key in the hash table.++lookup :: (Eq k, Hashable k) => HashTable k v -> k -> IO (Maybe v)+lookup (HashTable h) = H.lookup h+{-# INLINABLE lookup #-}++-- | Converts the hash table to a list.+--+-- The order of the elements in the list is unspecified.++toList :: (Eq k, Hashable k) => HashTable k v -> IO [(k, v)]+toList (HashTable h) = H.toList h+{-# INLINABLE toList #-}++keySet :: forall k v. Ord k => HashTable k v -> IO (Set k)+keySet (HashTable h) = do+  (ks :: V.Vector k) <- H.keys h+  pure $! V.foldl' (flip Set.insert) mempty ks+{-# INLINABLE keySet #-}
src/full/Agda/Utils/Haskell/Syntax.hs view
@@ -1,34 +1,50 @@+{-# OPTIONS_GHC -Wunused-imports #-} +-- | ASTs for subset of GHC Haskell syntax.+ module Agda.Utils.Haskell.Syntax where --- Modules --+import Data.Text (Text) +-- * Modules+ data Module = Module ModuleName [ModulePragma] [ImportDecl] [Decl] -data ModulePragma = LanguagePragma [Name]+data ModulePragma+  = LanguagePragma [Name]+  | OtherPragma String  -- ^ Unstructured pragma (Andreas, 2017-08-23, issue #2712).  data ImportDecl = ImportDecl-      { importModule    :: ModuleName-      , importQualified :: Bool-      , importSpecs     :: Maybe (Bool, [ImportSpec]) }+  { importModule    :: ModuleName+  , importQualified :: Bool+  , importSpecs     :: Maybe (Bool, [ImportSpec])+  }  data ImportSpec = IVar Name --- Declarations --+-- * Declarations  data Decl = TypeDecl Name [TyVarBind] Type           | DataDecl DataOrNew Name [TyVarBind] [ConDecl] [Deriving]           | TypeSig [Name] Type           | FunBind [Match]+            -- ^ Should not be used when 'LocalBind' could be used.+          | LocalBind Strictness Name Rhs+            -- ^ Should only be used in @let@ or @where@.+          | PatSyn Pat Pat           | FakeDecl String+          | Comment String   deriving (Eq)  data DataOrNew = DataType | NewType   deriving (Eq) -data ConDecl = ConDecl Name [Type]+data ConDecl = ConDecl Name [(Maybe Strictness, Type)]   deriving (Eq) +data Strictness = Lazy | Strict+  deriving (Eq)+ type Deriving = (QName, [Type])  data Binds = BDecls [Decl]@@ -44,7 +60,7 @@ data Match = Match Name [Pat] Rhs (Maybe Binds)   deriving (Eq) --- Expressions --+-- * Expressions  data Type = TyForall [TyVarBind] Type           | TyFun Type Type@@ -73,6 +89,7 @@          | Con QName          | Lit Literal          | InfixApp Exp QOp Exp+         | Ann Exp Type          | App Exp Exp          | Lambda [Pat] Exp          | Let Binds Exp@@ -86,10 +103,10 @@ data Alt = Alt Pat Rhs (Maybe Binds)   deriving (Eq) -data Literal = Int Integer | Frac Rational | Char Char | String String+data Literal = Int Integer | Frac Rational | Char Char | String Text   deriving (Eq) --- Names --+-- * Names  data ModuleName = ModuleName String   deriving (Eq, Ord)
+ src/full/Agda/Utils/IArray.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- don't complain about empty exports for Agda.Utils.IArray++-- | Array utilities.++module Agda.Utils.IArray (module Agda.Utils.IArray, module Data.Array.IArray) where++import Data.Array.IArray+import Data.Array.Base   ( IArray(..) )+import Data.Ix           ( inRange )++#if MIN_VERSION_base(4,14,0)+import GHC.Ix            ( unsafeIndex )+#endif++-- Backported from array-0.5.6:++#if !MIN_VERSION_array(0,5,6)++{-# INLINE (!?) #-}+-- | Returns 'Just' the element of an immutable array at the specified index,+-- or 'Nothing' if the index is out of bounds.+--+(!?) :: (IArray a e, Ix i) => a i e -> i -> Maybe e+(!?) arr i+  | inRange b i = Just $ unsafeAt arr $+#if MIN_VERSION_base(4,14,0)+    unsafeIndex b i+#else+    index b i+#endif+  | otherwise   = Nothing+  where b = bounds arr++#endif
+ src/full/Agda/Utils/IO.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}++-- | Auxiliary functions for the IO monad.++module Agda.Utils.IO where++import Control.Exception+import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Writer++import Agda.Utils.List (dropFrom)+import Agda.Utils.String (rtrim)++-- | Catch 'Exception's in an extension of the 'IO' monad.+--+class CatchIO m where+  catchIO :: Exception e => m a -> (e -> m a) -> m a++-- | Alias of 'catch' for the IO monad.+--+instance CatchIO IO where+  catchIO = catch++-- | Upon exception, the error is lost.++instance CatchIO m => CatchIO (ExceptT e m) where+  catchIO m h = ExceptT $ runExceptT m `catchIO` \ e -> runExceptT (h e)++-- | Upon exception, the written output is lost.+--+instance CatchIO m => CatchIO (WriterT w m) where+  catchIO m h = WriterT $ runWriterT m `catchIO` \ e -> runWriterT (h e)++-- | Upon exception, the state is reset.+--+instance CatchIO m => CatchIO (StateT s m) where+  catchIO m h = StateT $ \s -> runStateT m s `catchIO` \ e -> runStateT (h e) s++-- | Print an 'IOException' without the call stack.+--+showIOException :: Exception e => e -> String+showIOException =+  rtrim+#if MIN_VERSION_base(4,20,0)+  -- Andreas, 2024-07-05, issue #7299.+  -- Ugly hack to drop call stack (introduced in GHC 9.10) from IOException.+  -- If you have a better solution, please update this.+  . dropFrom "HasCallStack"+#endif+  . displayException
src/full/Agda/Utils/IO/Binary.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Binary IO.  module Agda.Utils.IO.Binary
src/full/Agda/Utils/IO/Directory.hs view
@@ -1,27 +1,85 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Utils.IO.Directory   ( copyDirContent+  , copyIfChanged+  , findWithInfo   ) where  import Control.Monad+import Control.Monad.Writer ( WriterT, execWriterT, tell )+import Control.Monad.Trans  ( lift )++import Data.ByteString      as BS+import Data.Monoid          ( Endo(Endo, appEndo) )+ import System.Directory import System.FilePath-import Data.ByteString as BS+import qualified System.FilePath.Find as Find -import Paths_Agda +-- | Search a directory recursively, with recursion controlled by a+--   'RecursionPredicate'.  Lazily return a unsorted list of all files+--   matching the given 'FilterPredicate'.  Any errors that occur are+--   ignored, with warnings printed to 'stderr'.+findWithInfo+  :: Find.RecursionPredicate  -- ^ Control recursion into subdirectories.+  -> Find.FilterPredicate     -- ^ Decide whether a file appears in the result.+  -> FilePath                 -- ^ Directory to start searching.+  -> IO [Find.FileInfo]       -- ^ Files that matched the 'FilterPredicate'.+findWithInfo recurse filt dir = Find.fold recurse act [] dir+  where+  -- Add file to list front when it matches the filter+  act :: [Find.FileInfo] -> Find.FileInfo -> [Find.FileInfo]+  act fs f = if Find.evalClause filt f then f : fs else fs+++-- | @copyDirContent src dest@ recursively copies directory @src@ onto @dest@.+--+--   First, a to-do list of copy actions is created.+--   Then, the to-do list is carried out.+--+--   This avoids copying files we have just created again, which can happen+--   if @src@ and @dest@ are not disjoint.+--   (See issue #2705.)+-- copyDirContent :: FilePath -> FilePath -> IO ()-copyDirContent src dest = do-  createDirectoryIfMissing True dest-  chlds <- getDirectoryContents src-  mapM_ (\x -> do-    isDir <- doesDirectoryExist (src </> x)+copyDirContent src dest = mapM_ performAction =<< do+  (`appEndo` []) <$> execWriterT (copyDirContentDryRun src dest)++-- | Action to be carried out for copying a directory recursively.+--+data CopyDirAction+  = MkDir    FilePath+      -- ^ Create directory if missing.+  | CopyFile FilePath FilePath+      -- ^ Copy file if changed.++-- | Perform scheduled 'CopyDirAction'.+--+performAction :: CopyDirAction -> IO ()+performAction = \case+  MkDir d           -> createDirectoryIfMissing True d+  CopyFile src dest -> copyIfChanged src dest++-- | @copyDirContentDryRun src dest@ creates a to-do list+--   for recursively copying directory @src@ onto @dest@.+--+copyDirContentDryRun :: FilePath -> FilePath -> WriterT (Endo [CopyDirAction]) IO ()+copyDirContentDryRun src dest = do+  tell $ Endo (MkDir dest :)+  chlds <- lift $ getDirectoryContents src+  forM_ chlds $ \ x -> do+    isDir <- lift $ doesDirectoryExist (src </> x)     case isDir of       _ | x == "." || x == ".." -> return ()-      True  -> copyDirContent (src </> x) (dest </> x)-      False -> copyIfChanged (src </> x) (dest </> x)-    ) chlds+      True  -> copyDirContentDryRun (src </> x) (dest </> x)+      False -> tell $ Endo (CopyFile (src </> x) (dest </> x) :) +-- | @copyIfChanged src dst@ makes sure that @dst@ exists+--   and has the same content as @dst@.+-- copyIfChanged :: FilePath -> FilePath -> IO () copyIfChanged src dst = do   exist <- doesFileExist dst@@ -29,4 +87,3 @@     new <- BS.readFile src     old <- BS.readFile dst     unless (old == new) $ copyFile src dst-
+ src/full/Agda/Utils/IO/TempFile.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Common syntax highlighting functions for Emacs and JSON++module Agda.Utils.IO.TempFile+  ( writeToTempFile+  ) where++import qualified Control.Exception as E+import qualified System.Directory as D+import qualified System.IO as IO++-- | Creates a temporary file, writes some stuff, and returns the filepath+writeToTempFile :: String -> IO FilePath+writeToTempFile content = do+  dir      <- D.getTemporaryDirectory+  E.bracket (IO.openTempFile dir "agda2-mode") (IO.hClose . snd) $ \ (filepath, handle) -> do+    IO.hSetEncoding handle IO.utf8+    IO.hPutStr handle content+    return filepath
src/full/Agda/Utils/IO/UTF8.hs view
@@ -1,56 +1,102 @@+{-# LANGUAGE CPP #-}+ -- | Text IO using the UTF8 character encoding.  module Agda.Utils.IO.UTF8-  ( readTextFile-  , Agda.Utils.IO.UTF8.hPutStr+  ( ReadException+  , readTextFile+  , Agda.Utils.IO.UTF8.readFile   , Agda.Utils.IO.UTF8.writeFile+  , writeTextToFile   ) where +import Control.Exception+import Data.Maybe (fromMaybe)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.Text.Lazy.IO as T+import qualified Data.ByteString.Lazy as BS import qualified System.IO as IO-import Control.Applicative  -- | Converts many character sequences which may be interpreted as -- line or paragraph separators into '\n'. -convertLineEndings :: String -> String--- ASCII:-convertLineEndings ('\x000D' : '\x000A' : s) = '\n' : convertLineEndings s  -- CR LF-convertLineEndings ('\x000A'            : s) = '\n' : convertLineEndings s  -- LF  (Line feed)-convertLineEndings ('\x000D'            : s) = '\n' : convertLineEndings s  -- CR  (Carriage return)-convertLineEndings ('\x000C'            : s) = '\n' : convertLineEndings s  -- FF  (Form feed)--- Unicode:-convertLineEndings ('\x0085'            : s) = '\n' : convertLineEndings s  -- NEXT LINE-convertLineEndings ('\x2028'            : s) = '\n' : convertLineEndings s  -- LINE SEPARATOR-convertLineEndings ('\x2029'            : s) = '\n' : convertLineEndings s  -- PARAGRAPH SEPARATOR--- Not a line ending:-convertLineEndings (c                   : s) = c    : convertLineEndings s-convertLineEndings ""                        = ""+convertLineEndings :: Text -> Text+convertLineEndings = T.map convert . convertCRLF+  where+  -- Replaces CR LF with LF.+  convertCRLF = T.replace "\x000D\n" "\n" --- | Reads a UTF8-encoded text file and converts all Unicode line--- endings into '\n'.+  -- ASCII:+  convert '\x000D' = '\n'  -- CR  (Carriage return)+  convert '\x000C' = '\n'  -- FF  (Form feed)+  -- Unicode:+  convert '\x0085' = '\n'  -- NEXT LINE+  convert '\x2028' = '\n'  -- LINE SEPARATOR+  convert '\x2029' = '\n'  -- PARAGRAPH SEPARATOR+  -- Not a line ending (or '\x000A'):+  convert c        = c -readTextFile :: FilePath -> IO String-readTextFile file = convertLineEndings <$> do-  h <- IO.openFile file IO.ReadMode-  IO.hSetNewlineMode h IO.noNewlineTranslation-  IO.hSetEncoding h IO.utf8-  IO.hGetContents h+-- | Strip the byte order mark (BOM) from a Text.+--+-- - https://github.com/agda/agda/issues/6524+-- - https://github.com/haskell-hvr/cassava/issues/106#issuecomment-373986176+--+stripUtf8Bom :: BS.ByteString -> BS.ByteString+stripUtf8Bom bs = fromMaybe bs (BS.stripPrefix "\239\187\191" bs) --- | Writes UTF8-encoded text to the handle, which should be opened--- for writing and in text mode. The native convention for line--- endings is used.+-- | A kind of exception that can be thrown by 'readTextFile' and+-- 'readFile'.+newtype ReadException+  = DecodingError FilePath+    -- ^ Decoding failed for the given file.+  deriving Show++instance Exception ReadException where+  displayException (DecodingError file) =+    "Failed to read " ++ file ++ ".\n" +++    "Please ensure that this file uses the UTF-8 character encoding."+#if MIN_VERSION_base(4,20,0)+  backtraceDesired (DecodingError _) = False+#endif++-- | Reads a UTF8-encoded text file and converts many character+-- sequences which may be interpreted as line or paragraph separators+-- into '\n'. ----- The handle's text encoding is not necessarily preserved, it is--- changed to UTF8.+-- If the file cannot be decoded, then a 'ReadException' is raised. -hPutStr :: IO.Handle -> String -> IO ()-hPutStr h s = do-  IO.hSetEncoding h IO.utf8-  IO.hPutStr h s+readTextFile :: FilePath -> IO Text+readTextFile file = do+  s <- T.decodeUtf8' . stripUtf8Bom <$> BS.readFile file+  case s of+    Right s -> return $ convertLineEndings s+    Left _  -> throw $ DecodingError file +-- | Reads a UTF8-encoded text file and converts many character+-- sequences which may be interpreted as line or paragraph separators+-- into '\n'.+--+-- If the file cannot be decoded, then a 'ReadException' is raised.++readFile :: FilePath -> IO String+readFile f = do+  s <- readTextFile f+  return $ T.unpack s+ -- | Writes a UTF8-encoded text file. The native convention for line -- endings is used.  writeFile :: FilePath -> String -> IO () writeFile file s = IO.withFile file IO.WriteMode $ \h -> do-  hPutStr h s+  IO.hSetEncoding h IO.utf8+  IO.hPutStr h s++-- | Writes a UTF8-encoded text file. The native convention for line+-- endings is used.++writeTextToFile :: FilePath -> Text -> IO ()+writeTextToFile file s = IO.withFile file IO.WriteMode $ \h -> do+  IO.hSetEncoding h IO.utf8+  T.hPutStr h s
src/full/Agda/Utils/IORef.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Utilities for Data.IORef. 
src/full/Agda/Utils/Impossible.hs view
@@ -1,34 +1,125 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- | An interface for reporting \"impossible\" errors ------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable #-}- module Agda.Utils.Impossible where -import Control.Exception as E-import Data.Typeable ( Typeable )+import Control.Exception (Exception(..), throw, catchJust)+import Control.DeepSeq+import Agda.Utils.CallStack.Base+    ( CallStack+    , HasCallStack+    , prettyCallStack+    , withCallerCallStack+    , withNBackCallStack+    )  -- | \"Impossible\" errors, annotated with a file name and a line -- number corresponding to the source code location of the error. -data Impossible = Impossible String Integer deriving Typeable+data Impossible +  = Impossible CallStack+    -- ^ We reached a program point which should be unreachable.++  | Unreachable CallStack+    -- ^ @Impossible@ with a different error message.+    --   Used when we reach a program point which can in principle+    --   be reached, but not for a certain run.++  | ImpMissingDefinitions [String] String+    -- ^ We reached a program point without all the required+    -- primitives or BUILTIN to proceed forward.+    -- @ImpMissingDefinitions neededDefs forThis@++-- Identify all values of Impossible. We use Impossible as a stand-in for the empty type, so all+-- values are morally equal.+instance Eq Impossible where+  _ == _ = True++instance Ord Impossible where+  compare _ _ = EQ++instance NFData Impossible where+  rnf _ = ()+ instance Show Impossible where-  show (Impossible file line) = unlines+  show (Impossible loc) = unlines     [ "An internal error has occurred. Please report this as a bug."-    , "Location of the error: " ++ file ++ ":" ++ show line+    , "Location of the error: " ++ prettyCallStack loc     ]+  show (Unreachable loc) = unlines+    [ "We reached a program point we did not want to reach."+    , "Location of the error: " ++ prettyCallStack loc+    ]+  show (ImpMissingDefinitions needed forthis) = unlines+    [ "The following builtins or primitives need to be bound to use " ++ forthis ++ ":"+    , unwords needed+    ] -instance Exception Impossible+instance Exception Impossible where+#if MIN_VERSION_base(4,20,0)+  -- Andreas, 2024-07-05, issue #7299;+  -- Turn off the (here useless) backtrace introduced in GHC 9.10.+  -- Besides spamming us with useless info, it changes the golden+  -- value, introducing incompatibilities in the test-suite.+  backtraceDesired _ = False+#endif  -- | Abort by throwing an \"impossible\" error. You should not use--- this function directly. Instead use the macro in @undefined.h@.+-- this function directly. Instead use __IMPOSSIBLE__  throwImpossible :: Impossible -> a throwImpossible = throw --- | Catch an \"impossible\" error, if possible.+-- | Monads in which we can catch an \"impossible\" error, if possible. -catchImpossible :: IO a -> (Impossible -> IO a) -> IO a-catchImpossible = E.catch+class CatchImpossible m where++  -- | Catch any 'Impossible' exception.+  catchImpossible :: m a -> (Impossible -> m a) -> m a+  catchImpossible = catchImpossibleJust Just++  -- | Catch only 'Impossible' exceptions selected by the filter.+  catchImpossibleJust :: (Impossible -> Maybe b) -> m a -> (b -> m a) -> m a+  catchImpossibleJust = flip . handleImpossibleJust++  -- | Version of 'catchImpossible' with argument order suiting short handlers.+  handleImpossible :: (Impossible -> m a) -> m a -> m a+  handleImpossible = flip catchImpossible++  -- | Version of 'catchImpossibleJust' with argument order suiting short handlers.+  handleImpossibleJust :: (Impossible -> Maybe b) -> (b -> m a) -> m a -> m a+  handleImpossibleJust = flip . catchImpossibleJust++  {-# MINIMAL catchImpossibleJust | handleImpossibleJust #-}++instance CatchImpossible IO where+  catchImpossibleJust = catchJust++-- | Construct a value of 'Impossible' reporting the location where you call+--   this function.+impossible :: HasCallStack => Impossible+impossible = withCallerCallStack Impossible++-- | Throw an 'Impossible' error reporting the location where you+--   place '__IMPOSSIBLE__'.++__IMPOSSIBLE__ :: HasCallStack => a+__IMPOSSIBLE__ = withNBackCallStack 0 $ throwImpossible . Impossible++-- | Throw an 'Impossible' error reporting the *caller's* call site.++__IMPOSSIBLE__1 :: HasCallStack => a+__IMPOSSIBLE__1 = withNBackCallStack 1 $ throwImpossible . Impossible++-- | Throw an "Unreachable" error reporting the *caller's* call site.+-- Note that this call to "withFileAndLine" will be filtered out+-- due its filter on the srcLocModule.++__UNREACHABLE__ :: HasCallStack => a+__UNREACHABLE__ = withCallerCallStack $ throwImpossible . Unreachable
+ src/full/Agda/Utils/IndexedList.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}++module Agda.Utils.IndexedList where++import Data.Kind ( Type )+import Agda.Utils.Lens++-- | Existential wrapper for indexed types.+data Some :: (k -> Type) -> Type where+  Some :: f i -> Some f++-- | Unpacking a wrapped value.+withSome :: Some b -> (forall i. b i -> a) -> a+withSome (Some x) f = f x++-- | Lists indexed by a type-level list. A value of type @All p [x₁..xₙ]@ is a+--   sequence of values of types @p x₁@, .., @p xₙ@.+data All :: (x -> Type) -> [x] -> Type where+  Nil  :: All p '[]+  Cons :: p x -> All p xs -> All p (x ': xs)++-- | Constructing an indexed list from a plain list.+makeAll :: (a -> Some b) -> [a] -> Some (All b)+makeAll f [] = Some Nil+makeAll f (x : xs) =+  case (f x, makeAll f xs) of+    (Some y, Some ys) -> Some (Cons y ys)++-- | Turning an indexed list back into a plain list.+forgetAll :: (forall x. b x -> a) -> All b xs -> [a]+forgetAll f Nil         = []+forgetAll f (Cons x xs) = f x : forgetAll f xs++-- | An index into a type-level list.+data Index :: [x] -> x -> Type where+  Zero :: Index (x ': xs) x+  Suc  :: Index xs x -> Index (y ': xs) x++-- | Indices are just natural numbers.+forgetIndex :: Index xs x -> Int+forgetIndex Zero    = 0+forgetIndex (Suc i) = 1 + forgetIndex i++-- | Mapping over an indexed list.+mapWithIndex :: (forall x. Index xs x -> p x -> q x) -> All p xs -> All q xs+mapWithIndex f Nil = Nil+mapWithIndex f (Cons p ps) = Cons (f Zero p) $ mapWithIndex (f . Suc) ps++-- | If you have an index you can get a lens for the given element.+lIndex :: Index xs x -> Lens' (All p xs) (p x)+lIndex Zero    f (Cons x xs) = f x           <&> \ x  -> Cons x xs+lIndex (Suc i) f (Cons x xs) = lIndex i f xs <&> \ xs -> Cons x xs++-- | Looking up an element in an indexed list.+lookupIndex :: All p xs -> Index xs x -> p x+lookupIndex = flip ix+  where+    -- -Wincomplete-patterns fails for the other argument order!+    ix :: Index xs x -> All p xs -> p x+    ix Zero    (Cons x xs) = x+    ix (Suc i) (Cons x xs) = ix i xs++-- | All indices into an indexed list.+allIndices :: All p xs -> All (Index xs) xs+allIndices = mapWithIndex const
+ src/full/Agda/Utils/IntSet/Infinite.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- |  Possibly infinite sets of integers (but with finitely many consecutive+--    segments). Used for checking guard coverage in int/nat cases in the+--    treeless compiler.++module Agda.Utils.IntSet.Infinite+  ( IntSet+  , empty, full, below, above, singleton+  , difference, member, toFiniteList+  , invariant )+  where+++import Data.Set (Set)+import qualified Data.Set as Set++-- | Represents a set of integers.+--   Invariants:+--     - All cannot be the argument to `Below` or `Above`+--     - at most one 'IntsBelow'+--     - at most one 'IntsAbove'+--     - if `Below lo` and `Below hi`, then `lo < hi`+--     - if `Below lo .. (Some xs)` then `all (> lo) xs`+--     - if `Above hi .. (Some xs)` then `all (< hi - 1) xs`+data IntSet = All+              | Some (Set Integer)+              | Below Integer IntSet  -- exclusive+              | Above Integer IntSet  -- inclusive+  deriving (Show)++instance Eq IntSet where+  r == r' = norm r == norm r'+    where+      norm All          = Nothing+      norm (Some xs)    = Just (Nothing, Nothing, xs)+      norm (Below lo r) = do (_, hi, xs) <- norm r; return (Just lo, hi, xs)+      norm (Above hi r) = do (lo, _, xs) <- norm r; return (lo, Just hi, xs)++below' :: Integer -> IntSet -> IntSet+below' _  All = All+below' lo r@(Some xs)+  | lo `Set.member` xs = below' (lo + 1) r+  | otherwise  = Below lo $ Some $ Set.filter (>= lo) xs+below' lo r0@(Below lo' r)+  | lo' >= lo = r0+  | otherwise = below' lo r+below' lo (Above hi r)+  | hi <= lo  = All+  | otherwise = Above hi $ below' lo r++above' :: Integer -> IntSet -> IntSet+above' _  All = All+above' hi r@(Some xs)+  | (hi - 1) `Set.member` xs = above' (hi - 1) r+  | otherwise        = Above hi $ Some $ Set.filter (< hi) xs+above' hi r0@(Above hi' r)+  | hi' <= hi = r0+  | otherwise = above' hi r+above' hi (Below lo r)+  | hi <= lo  = All+  | otherwise = Below lo $ above' hi r++some' :: Set Integer -> IntSet -> IntSet+some' xs r | null xs = r+some' xs (Some ys) = Some (Set.union xs ys)+some' _  All = All+some' xs (Below lo r)+  | lo `Set.member` xs = some' xs (Below (lo + 1) r)+  | otherwise  = below' lo $ some' (Set.filter (>= lo) xs) r+some' xs (Above hi r)+  | (hi - 1) `Set.member` xs = some' xs (Above (hi - 1) r)+  | otherwise        = above' hi $ some' (Set.filter (< hi) xs) r++difference :: IntSet -> IntSet -> IntSet+difference r All           = empty+difference r (Some xs)     = subtractSome r xs+difference r (Below lo r') = difference (subtractBelow r lo) r'+difference r (Above hi r') = difference (subtractAbove r hi) r'++subtractSome :: IntSet -> Set Integer -> IntSet+subtractSome r xs | null xs = r+subtractSome All xs = below lo <> above hi <> Some (Set.fromList [lo..hi - 1] `Set.difference` xs)+  where lo = minimum xs+        hi = maximum xs + 1+subtractSome (Some ys) xs = Some (Set.difference ys xs)+subtractSome (Below lo r) xs = Below (min lo lo') $ subtractSome (Some (Set.fromList [lo'..lo - 1]) <> r) xs+  where lo' = minimum xs+subtractSome (Above hi r) xs = Above (max hi hi') $ subtractSome (Some (Set.fromList [hi..hi' - 1]) <> r) xs+  where hi' = maximum xs + 1++subtractBelow :: IntSet -> Integer -> IntSet+subtractBelow All           lo = above lo+subtractBelow (Below lo' r) lo = some' (Set.fromList [lo..lo' - 1]) (subtractBelow r lo)+subtractBelow (Above hi r)  lo = Above (max hi lo) (subtractBelow r lo)+subtractBelow (Some xs)     lo = Some $ Set.filter (>= lo) xs++subtractAbove :: IntSet -> Integer -> IntSet+subtractAbove All           hi = below hi+subtractAbove (Above hi' r) hi = some' (Set.fromList [hi'..hi - 1]) (subtractAbove r hi)+subtractAbove (Below lo r)  hi = Below (min lo hi) (subtractAbove r hi)+subtractAbove (Some xs)     hi = Some $ Set.filter (< hi) xs++instance Semigroup IntSet where+  Below lo r <> r' = below' lo (r <> r')+  Above hi r <> r' = above' hi (r <> r')+  Some xs    <> r' = some' xs r'+  All        <> _  = All++instance Monoid IntSet where+  mempty  = empty+  mappend = (<>)++-- | Membership+member :: Integer -> IntSet -> Bool+member _ All          = True+member x (Some xs)    = Set.member x xs+member x (Below lo s) = x < lo  || member x s+member x (Above hi s) = x >= hi || member x s++-- | All integers `< n`+below :: Integer -> IntSet+below lo = Below lo empty++-- | All integers `>= n`+above :: Integer -> IntSet+above hi = Above hi empty++-- | A single integer.+singleton :: Integer -> IntSet+singleton x = fromList [x]++-- | From a list of integers.+fromList :: [Integer] -> IntSet+fromList xs = Some (Set.fromList xs)++-- | No integers.+empty :: IntSet+empty = Some Set.empty++-- | All integers.+full :: IntSet+full = All++-- | If finite, return the list of elements.+toFiniteList :: IntSet -> Maybe [Integer]+toFiniteList (Some xs) = Just $ Set.toList xs+toFiniteList All       = Nothing+toFiniteList Above{}   = Nothing+toFiniteList Below{}   = Nothing++-- | Invariant.+invariant :: IntSet -> Bool+invariant xs =+  case xs of+    All         -> True+    Some{}      -> True+    Below lo ys -> invariant ys && invBelow lo ys+    Above hi ys -> invariant ys && invAbove hi ys+  where+    invBelow lo All          = False+    invBelow lo (Some xs)    = all (> lo) xs+    invBelow lo Below{}      = False+    invBelow lo (Above hi r) = lo < hi && invBelow lo r++    invAbove hi All          = False+    invAbove hi (Some xs)    = all (< hi - 1) xs+    invAbove hi Above{}      = False+    invAbove hi (Below lo r) = lo < hi && invAbove hi r
src/full/Agda/Utils/Lens.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP        #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | A cut-down implementation of lenses, with names taken from --   Edward Kmett's lens package.@@ -7,15 +6,18 @@ module Agda.Utils.Lens   ( module Agda.Utils.Lens   , (<&>) -- reexported from Agda.Utils.Functor+  , (&&&) -- reexported from Control.Arrow   ) where  import Control.Applicative ( Const(Const), getConst )+import Control.Arrow       ( (&&&) ) import Control.Monad.State import Control.Monad.Reader-import Control.Monad.Writer  import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set  import Data.Functor.Identity @@ -24,78 +26,117 @@ -- * Type-preserving lenses.  -- | Van Laarhoven style homogeneous lenses.---   Mnemoic: "Lens inner outer".-type Lens' i o = forall f. Functor f => (i -> f i) -> o -> f o+--   Mnemoic: "Lens outer inner", same type argument order as 'get :: o -> i'.+type Lens' o i = forall f. Functor f => (i -> f i) -> o -> f o +type LensGet o i = o -> i+type LensSet o i = i -> o -> o+type LensMap o i = (i -> i) -> o -> o +-- * Some simple lenses.++lFst :: Lens' (a, b) a+lFst f (x, y) = (, y) <$> f x++lSnd :: Lens' (a, b) b+lSnd f (x, y) = (x,) <$> f y+ -- * Elementary lens operations.  infixl 8 ^.--- | Get inner part @i@ of structure @o@ as designated by @Lens' i o@.-(^.) :: o -> Lens' i o -> i+-- | Get inner part @i@ of structure @o@ as designated by @Lens' o i@.+(^.) :: o -> Lens' o i -> i o ^. l = getConst $ l Const o --- | Set inner part @i@ of structure @o@ as designated by @Lens' i o@.-set :: Lens' i o -> i -> o -> o+-- | Set inner part @i@ of structure @o@ as designated by @Lens' o i@.+set :: Lens' o i -> LensSet o i set l = over l . const  -- | Modify inner part @i@ of structure @o@ using a function @i -> i@.-over :: Lens' i o -> (i -> i) -> o -> o+over :: Lens' o i -> LensMap o i over l f o = runIdentity $ l (Identity . f) o +-- | Build a lens out of an isomorphism.+iso :: (o -> i) -> (i -> o) -> Lens' o i+iso get set f = fmap set . f . get --- * State accessors and modifiers.+-- | Build a lens from a getter and a setter.+lens :: LensGet o i -> LensSet o i -> Lens' o i+lens get set f o = f (get o) <&> \ i -> set i o +-- | Only sound if the lenses are disjoint!+lensProduct :: Lens' s a -> Lens' s b -> Lens' s (a , b)+lensProduct l1 l2 = lens ((^. l1) &&& (^. l2)) (\ (a, b) -> set l2 b . set l1 a)++-- * State accessors and modifiers using 'StateT'.++-- | Focus on a part of the state for a stateful computation.+focus :: Monad m => Lens' o i -> StateT i m a -> StateT o m a+focus l m = StateT $ \ o -> do+  (a, i) <- runStateT m (o ^. l)+  return (a, set l i o)++-- * State accessors and modifiers using 'MonadState'.+ -- | Read a part of the state.-use :: MonadState o m => Lens' i o -> m i+use :: MonadState o m => Lens' o i -> m i use l = do !x <- gets (^. l)            return x  infix 4 .= -- | Write a part of the state.-(.=) :: MonadState o m => Lens' i o -> i -> m ()+(.=) :: MonadState o m => Lens' o i -> i -> m () l .= i = modify $ set l i  infix 4 %= -- | Modify a part of the state.-(%=) :: MonadState o m => Lens' i o -> (i -> i) -> m ()+(%=) :: MonadState o m => Lens' o i -> (i -> i) -> m () l %= f = modify $ over l f  infix 4 %== -- | Modify a part of the state monadically.-(%==)-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, MonadState o m)-#else-  :: MonadState o m-#endif-  => Lens' i o -> (i -> m i) -> m ()-l %== f = put =<< l f =<< get+(%==) :: MonadState o m => Lens' o i -> (i -> m i) -> m ()+l %== f = use l >>= f >>= (l .=)  infix 4 %%= -- | Modify a part of the state monadically, and return some result.-(%%=)-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, MonadState o m)-#else-  :: MonadState o m-#endif-  => Lens' i o -> (i -> m (i, r)) -> m r+(%%=) :: MonadState o m => Lens' o i -> (i -> m (i, r)) -> m r l %%= f = do-  o <- get-  (o', r) <- runWriterT $ l (WriterT . f) o-  put o'+  i <- use l+  (i', r) <- f i+  l .= i'   return r +-- | Modify a part of the state locally.+locallyState :: MonadState o m => Lens' o i -> (i -> i) -> m r -> m r+locallyState l f k = do+  old <- use l+  l %= f+  x <- k+  l .= old+  return x+ -- * Read-only state accessors and modifiers.  -- | Ask for part of read-only state.-view :: MonadReader o m => Lens' i o -> m i+view :: MonadReader o m => Lens' o i -> m i view l = asks (^. l)  -- | Modify a part of the state in a subcomputation.-locally :: MonadReader o m => Lens' i o -> (i -> i) -> m a -> m a+locally :: MonadReader o m => Lens' o i -> (i -> i) -> m a -> m a locally l = local . over l -key :: Ord k => k -> Lens' (Maybe v) (Map k v)+locally' :: ((o -> o) -> m a -> m a) -> Lens' o i -> (i -> i) -> m a -> m a+locally' local l = local . over l++-- * Lenses for collections++-- | Access a map value at a given key.+key :: Ord k => k -> Lens' (Map k v) (Maybe v) key k f m = f (Map.lookup k m) <&> \ v -> Map.alter (const v) k m++-- | Focus on given element in a set.+contains :: Ord k => k -> Lens' (Set k) Bool+contains k f s = f (Set.member k s) <&> \case+  True  -> Set.insert k s+  False -> Set.delete k s
src/full/Agda/Utils/Lens/Examples.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Examples how to use "Agda.Utils.Lens".  module Agda.Utils.Lens.Examples where@@ -11,8 +13,8 @@   }  -- | (View source:) This is how you implement a lens for a record field.-lensField1 :: Lens' a (Record a b)+lensField1 :: Lens' (Record a b) a lensField1 f r = f (field1 r) <&> \ a -> r { field1 = a } -lensField2 :: Lens' b (Record a b)+lensField2 :: Lens' (Record a b) b lensField2 f r = f (field2 r) <&> \ b -> r { field2 = b }
src/full/Agda/Utils/List.hs view
@@ -1,128 +1,363 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} -{-| Utitlity functions on lists.--}-module Agda.Utils.List where+-- | Utility functions for lists. -import Control.Arrow (first)+module Agda.Utils.List (module Agda.Utils.List, module X) where -import Data.Functor ((<$>))-import Data.Function-import Data.List+-- Reexports++import Data.List as X (uncons)++-- Regular imports++import Control.Monad (filterM)+import Control.Applicative (Alternative, (<|>))+import qualified Control.Applicative as A++import Data.Array (Array, array, listArray)+import qualified Data.Array as Array+import Data.Bifunctor+import Data.Function (on)+import Data.Hashable+import Data.List.Split (splitOn)+import qualified Data.List as List+import qualified Data.List.NonEmpty as List1+import Data.List.NonEmpty (pattern (:|), (<|)) import Data.Maybe import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap import qualified Data.Set as Set--import Text.Show.Functions ()+import Data.Strict.These  import qualified Agda.Utils.Bag as Bag-+import Agda.Utils.CallStack.Base+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor  ((<.>)) import Agda.Utils.Tuple -#include "undefined.h"+import {-# SOURCE #-} Agda.Utils.List1 (List1)+ import Agda.Utils.Impossible +---------------------------------------------------------------------------+-- * Variants of list case, cons, head, tail, init, last+---------------------------------------------------------------------------++-- | Append a single element at the end.+--   Time: O(length); use only on small lists.+snoc :: [a] -> a -> [a]+snoc xs x = xs ++ [x]+ -- | Case distinction for lists, with list first.+--   O(1).+-- --   Cf. 'Agda.Utils.Null.ifNull'. caseList :: [a] -> b -> (a -> [a] -> b) -> b-caseList []     n c = n-caseList (x:xs) n c = c x xs+caseList xs n c = listCase n c xs +-- | Case distinction for lists, with list first.+--   O(1).+--+--   Cf. 'Agda.Utils.Null.ifNull'.+caseListM :: Monad m => m [a] -> m b -> (a -> [a] -> m b) -> m b+caseListM mxs n c = listCase n c =<< mxs+ -- | Case distinction for lists, with list last.+--   O(1).+-- listCase :: b -> (a -> [a] -> b) -> [a] -> b listCase n c []     = n listCase n c (x:xs) = c x xs --- | Head function (safe).-headMaybe :: [a] -> Maybe a-headMaybe = listToMaybe---- | Head function (safe). Returns a value on empty lists.+-- | Head function (safe). Returns a default value on empty lists.+--   O(1). -- -- > headWithDefault 42 []      = 42 -- > headWithDefault 42 [1,2,3] = 1 headWithDefault :: a -> [a] -> a-headWithDefault def = fromMaybe def . headMaybe+headWithDefault def = fromMaybe def . listToMaybe +-- | Tail function (safe).+--   O(1).+tailMaybe :: [a] -> Maybe [a]+tailMaybe = fmap snd . uncons++-- | Tail function (safe).  Returns a default list on empty lists.+--   O(1).+tailWithDefault :: [a] -> [a] -> [a]+tailWithDefault def = fromMaybe def . tailMaybe+ -- | Last element (safe).+--   O(n). lastMaybe :: [a] -> Maybe a-lastMaybe [] = Nothing-lastMaybe xs = Just $ last xs+lastMaybe = \case+  []   -> Nothing+  x:xs -> Just $ last1 x xs --- | Opposite of cons @(:)@, safe.-uncons :: [a] -> Maybe (a, [a])-uncons []     = Nothing-uncons (x:xs) = Just (x,xs)+-- | Last element (safe).  Returns a default list on empty lists.+--   O(n).+lastWithDefault :: a -> [a] -> a+lastWithDefault = last1 --- | Maybe cons.   @mcons ma as = maybeToList ma ++ as@+-- | Last element of non-empty list (safe).+--   O(n).+--   @last1 a as = last (a : as)@+last1 :: a -> [a] -> a+last1 a = \case+  [] -> a+  b:bs -> last1 b bs++-- | Last two elements (safe).+--   O(n).+--+last2 :: [a] -> Maybe (a, a)+last2 (x : y : xs) = Just $ last2' x y xs+last2 _ = Nothing++-- | @last2' x y zs@ computes the last two elements of @x:y:zs@.+--   O(n).+--+last2' :: a -> a -> [a] -> (a, a)+last2' x y = \case+  []  -> (x, y)+  z:zs -> last2' y z zs++-- | Maybe cons.+--   O(1).+--   @mcons ma as = maybeToList ma ++ as@ mcons :: Maybe a -> [a] -> [a] mcons ma as = maybe as (:as) ma  -- | 'init' and 'last' in one go, safe.+--   O(n). initLast :: [a] -> Maybe ([a],a)-initLast [] = Nothing-initLast as = Just $ loop as where-  loop []       = __IMPOSSIBLE__-  loop [a]      = ([], a)-  loop (a : as) = mapFst (a:) $ loop as+initLast []     = Nothing+initLast (a:as) = Just $ initLast1 a as --- | Lookup function (partially safe).+-- | 'init' and 'last' of non-empty list, safe.+--   O(n).+--   @initLast1 a as = (init (a:as), last (a:as)@+initLast1 :: a -> [a] -> ([a], a)+initLast1 a = \case+  []   -> ([], a)+  b:bs -> first (a:) $ initLast1 b bs++-- | 'init' of non-empty list, safe.+--   O(n).+--   @init1 a as = init (a:as)@+init1 :: a -> [a] -> [a]+init1 a = \case+  []   -> []+  b:bs -> a : init1 b bs++-- | @init@, safe.+--   O(n).+initMaybe :: [a] -> Maybe [a]+initMaybe = \case+  []   -> Nothing+  a:as -> Just $ init1 a as++-- | @init@, safe.+--   O(n).+initWithDefault :: [a] -> [a] -> [a]+initWithDefault as []     = as+initWithDefault _  (a:as) = init1 a as++---------------------------------------------------------------------------+-- * Iterators+---------------------------------------------------------------------------++-- | A version of 'Foldable.asum' that avoids a final 'A.empty'.+--   It is right-folding just like 'Foldable.asum'.+--+--   Precondition: the right-unit law holds, i.e. @m <|> A.empty = m@.+asum :: Alternative m => [m a] -> m a+asum []     = A.empty+asum (x:xs) = asum1 x xs++-- | A right-folding 'Foldable.asum' for nonempty lists,+--   never producing 'A.empty'.+asum1 :: Alternative m => m a -> [m a] -> m a+asum1 x []     = x+asum1 x (y:ys) = x <|> asum1 y ys++---------------------------------------------------------------------------+-- * Lookup and indexing+---------------------------------------------------------------------------++-- | Lookup function (safe).+--   O(min n index). (!!!) :: [a] -> Int -> Maybe a-[]       !!! _         = Nothing-(x : _)  !!! 0         = Just x-(_ : xs) !!! n         = xs !!! (n - 1)+xs !!! (!i)+  | i < 0     = Nothing+  | otherwise = index xs i+  where+  index []       !i = Nothing+  index (x : xs) 0  = Just x+  index (x : xs) i  = index xs (i - 1) --- | downFrom n = [n-1,..1,0]+-- | A variant of 'Prelude.!!' that might provide more informative+-- error messages if the index is out of bounds.+--+-- Precondition: The index should not be out of bounds.++(!!) :: HasCallStack => [a] -> Int -> a+xs !! i = case xs !!! i of+  Just x  -> x+  Nothing -> __IMPOSSIBLE__++-- | Lookup function with default value for index out of range.+--   O(min n index).+--+--   The name is chosen akin to 'Data.List.genericIndex'.+indexWithDefault :: a -> [a] -> Int -> a+indexWithDefault a []       _ = a+indexWithDefault a (x : _)  0 = x+indexWithDefault a (_ : xs) n = indexWithDefault a xs (n - 1)++-- | Find an element satisfying a predicate and return it with its index.+--   O(n) in the worst case, e.g. @findWithIndex f xs = Nothing@.+--+--   TODO: more efficient implementation!?+findWithIndex :: (a -> Bool) -> [a] -> Maybe (a, Int)+findWithIndex p as = List.find (p . fst) (zip as [0..])++-- | A generalised variant of 'elemIndex'.+-- O(n).+genericElemIndex :: (Eq a, Integral i) => a -> [a] -> Maybe i+genericElemIndex x xs =+  listToMaybe $+  map fst $+  filter snd $+  zip [0..] $+  map (== x) xs++-- | @downFrom n = [n-1,..1,0]@.+--   O(n). downFrom :: Integral a => a -> [a] downFrom n | n <= 0     = []            | otherwise = let n' = n-1 in n' : downFrom n' +---------------------------------------------------------------------------+-- * Update+---------------------------------------------------------------------------+ -- | Update the first element of a list, if it exists.+--   O(1). updateHead :: (a -> a) -> [a] -> [a]-updateHead f [] = []+updateHead _ []       = [] updateHead f (a : as) = f a : as  -- | Update the last element of a list, if it exists.+--   O(n). updateLast :: (a -> a) -> [a] -> [a]-updateLast f [] = []-updateLast f [a] = [f a]-updateLast f (a : as@(_ : _)) = a : updateLast f as+updateLast _ [] = []+updateLast f (a : as) = loop a as+  -- Using a helper function to minimize the pattern matching.+  where+  loop a []       = [f a]+  loop a (b : bs) = a : loop b bs  -- | Update nth element of a list, if it exists.+--   @O(min index n)@.+-- --   Precondition: the index is >= 0. updateAt :: Int -> (a -> a) -> [a] -> [a]-updateAt _ f [] = []+updateAt _ _ [] = [] updateAt 0 f (a : as) = f a : as updateAt n f (a : as) = a : updateAt (n-1) f as --- | A generalized version of @partition@.---   (Cf. @mapMaybe@ vs. @filter@).-mapEither :: (a -> Either b c) -> [a] -> ([b],[c])-{-# INLINE mapEither #-}-mapEither f xs = foldr (deal f) ([],[]) xs+---------------------------------------------------------------------------+-- * Sublist extraction and partitioning+--------------------------------------------------------------------------- -deal :: (a -> Either b c) -> a -> ([b],[c]) -> ([b],[c])-deal f a ~(bs,cs) = case f a of-  Left  b -> (b:bs, cs)-  Right c -> (bs, c:cs)+type Prefix a = [a]  -- ^ The list before the split point.+type Suffix a = [a]  -- ^ The list after the split point. +-- | @splitExactlyAt n xs = Just (ys, zs)@ iff @xs = ys ++ zs@+--   and @genericLength ys = n@.+splitExactlyAt :: Integral n => n -> [a] -> Maybe (Prefix a, Suffix a)+splitExactlyAt 0 xs       = return ([], xs)+splitExactlyAt n []       = Nothing+splitExactlyAt n (x : xs) = mapFst (x :) <$> splitExactlyAt (n-1) xs++-- | Drop from the end of a list.+--   O(length).+--+--   @dropEnd n = reverse . drop n . reverse@+--+--   Forces the whole list even for @n==0@.+dropEnd :: forall a. Int -> [a] -> Prefix a+dropEnd n = snd . foldr f (n, [])+  where+  f :: a -> (Int, [a]) -> (Int, [a])+  f x (n, xs) = (n-1, applyWhen (n <= 0) (x:) xs)++-- | Split off the largest suffix whose elements satisfy a predicate.+--   O(n).+--+--   @spanEnd p xs = (ys, zs)@+--   where @xs = ys ++ zs@+--   and @all p zs@+--   and @maybe True (not . p) (lastMaybe yz)@.+spanEnd :: forall a. (a -> Bool) -> [a] -> (Prefix a, Suffix a)+spanEnd p = snd . foldr f (True, ([], []))+  where+  f :: a -> (Bool, ([a], [a])) -> (Bool, ([a], [a]))+  f x (b', (xs, ys)) = (b, if b then (xs, x:ys) else (x:xs, ys))+    where b = b' && p x++-- | Breaks a list just /after/ an element satisfying the predicate is+--   found.+--+--   >>> breakAfter1 even 1 [3,5,2,4,7,8]+--   (1 :| [3,5,2],[4,7,8])++breakAfter1 :: (a -> Bool) -> a -> [a] -> (List1 a, [a])+breakAfter1 p = loop+  where+  loop x = \case+    xs@[]         -> (x :| [], xs)+    xs@(y : ys)+      | p x       -> (x :| [], xs)+      | otherwise -> let (vs, ws) = loop y ys in (x <| vs, ws)++-- | Breaks a list just /after/ an element satisfying the predicate is+--   found.+--+--   >>> breakAfter even [1,3,5,2,4,7,8]+--   ([1,3,5,2],[4,7,8])++breakAfter :: (a -> Bool) -> [a] -> ([a], [a])+breakAfter p = \case+  []   -> ([], [])+  x:xs -> first List1.toList $ breakAfter1 p x xs+ -- | A generalized version of @takeWhile@. --   (Cf. @mapMaybe@ vs. @filter@).-takeWhileJust :: (a -> Maybe b) -> [a] -> [b]+--   @O(length . takeWhileJust f).+--+--   @takeWhileJust f = fst . spanJust f@.+takeWhileJust :: (a -> Maybe b) -> [a] -> Prefix b takeWhileJust p = loop   where     loop (a : as) | Just b <- p a = b : loop as     loop _ = []  -- | A generalized version of @span@.-spanJust :: (a -> Maybe b) -> [a] -> ([b], [a])+--   @O(length . fst . spanJust f)@.+spanJust :: (a -> Maybe b) -> [a] -> (Prefix b, Suffix a) spanJust p = loop   where     loop (a : as) | Just b <- p a = mapFst (b :) $ loop as     loop as                       = ([], as)  -- | Partition a list into 'Nothing's and 'Just's.---   @'mapMaybe' f = snd . partitionMaybe f@.+--   O(n).+--+--   @partitionMaybe f = partitionEithers . map (\ a -> maybe (Left a) Right (f a))@+--+--   Note: @'mapMaybe' f = snd . partitionMaybe f@. partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b]) partitionMaybe f = loop   where@@ -133,36 +368,64 @@  -- | Like 'filter', but additionally return the last partition --   of the list where the predicate is @False@ everywhere.-filterAndRest :: (a -> Bool) -> [a] -> ([a],[a])+--   O(n).+filterAndRest :: (a -> Bool) -> [a] -> ([a], Suffix a) filterAndRest p = mapMaybeAndRest $ \ a -> if p a then Just a else Nothing  -- | Like 'mapMaybe', but additionally return the last partition --   of the list where the function always returns @Nothing@.-mapMaybeAndRest :: (a -> Maybe b) -> [a] -> ([b],[a])+--   O(n).+mapMaybeAndRest :: (a -> Maybe b) -> [a] -> ([b], Suffix a) mapMaybeAndRest f = loop [] where   loop acc = \case     []                   -> ([], reverse acc)     x:xs | Just y <- f x -> first (y:) $ loop [] xs          | otherwise     -> loop (x:acc) xs +-- | @dropFrom marker xs@ drops everything from @xs@+-- starting with (and including) @marker@.+--+-- If the marker does not appear, the string is returned unchanged.+--+-- The following two properties hold provided @marker@ has no overlap with @xs@:+--+-- @+--   dropFrom marker (xs ++ marker ++ ys) == xs+--   dropFrom marker xs == xs+-- @+dropFrom :: Eq a => List1 a -> [a] -> [a]+dropFrom marker xs = headWithDefault __IMPOSSIBLE__ $ splitOn (List1.toList marker) xs++-- | All ways of removing one element from a list.+--   O(n²).+holes :: [a] -> [(a, [a])]+holes []     = []+holes (x:xs) = (x, xs) : map (second (x:)) (holes xs)++---------------------------------------------------------------------------+-- * Prefix and suffix+---------------------------------------------------------------------------++-- ** Prefix++-- | Compute the common prefix of two lists.+--   O(min n m).+commonPrefix :: Eq a => [a] -> [a] -> Prefix a+commonPrefix [] _ = []+commonPrefix _ [] = []+commonPrefix (x:xs) (y:ys)+  | x == y    = x : commonPrefix xs ys+  | otherwise = []+ -- | Drops from both lists simultaneously until one list is empty.-dropCommon :: [a] -> [b] -> ([a],[b])+--   O(min n m).+dropCommon :: [a] -> [b] -> (Suffix a, Suffix b) dropCommon (x : xs) (y : ys) = dropCommon xs ys dropCommon xs ys = (xs, ys) --- | Sublist relation.-isSublistOf :: Eq a => [a] -> [a] -> Bool-isSublistOf []       ys = True-isSublistOf (x : xs) ys =-  case dropWhile (x /=) ys of-    []     -> False-    (_:ys) -> isSublistOf xs ys--type Prefix a = [a]-type Suffix a = [a]- -- | Check if a list has a given prefix. If so, return the list --   minus the prefix.+--   O(length prefix). stripPrefixBy :: (a -> a -> Bool) -> Prefix a -> [a] -> Maybe (Suffix a) stripPrefixBy eq = loop   where@@ -172,37 +435,101 @@     | eq p r    = loop pat rest     | otherwise = Nothing --- | Result of 'preOrSuffix'.-data PreOrSuffix a-  = IsPrefix a [a] -- ^ First list is prefix of second.-  | IsSuffix a [a] -- ^ First list is suffix of second.-  | IsBothfix      -- ^ The lists are equal.-  | IsNofix        -- ^ The lists are incomparable.+-- ** Suffix --- | Compare lists with respect to prefix partial order.-preOrSuffix :: Eq a => [a] -> [a] -> PreOrSuffix a-preOrSuffix []     []     = IsBothfix-preOrSuffix []     (b:bs) = IsPrefix b bs-preOrSuffix (a:as) []     = IsSuffix a as-preOrSuffix (a:as) (b:bs)-  | a == b    = preOrSuffix as bs-  | otherwise = IsNofix+-- | Compute the common suffix of two lists.+--   O(n + m).+commonSuffix :: Eq a => [a] -> [a] -> Suffix a+commonSuffix xs ys = reverse $ (commonPrefix `on` reverse) xs ys --- | Split a list into sublists. Generalisation of the prelude function---   @words@.+-- | @stripSuffix suf xs = Just pre@ iff @xs = pre ++ suf@.+-- O(n).+stripSuffix :: Eq a => Suffix a -> [a] -> Maybe (Prefix a)+stripSuffix [] = Just+stripSuffix s  = stripReversedSuffix (reverse s)++type ReversedSuffix a = [a]++-- | @stripReversedSuffix rsuf xs = Just pre@ iff @xs = pre ++ reverse suf@.+--   O(n).+stripReversedSuffix :: forall a. Eq a => ReversedSuffix a -> [a] -> Maybe (Prefix a)+stripReversedSuffix rs = final . foldr step (SSSStrip rs)+  where+  -- Step of the automaton (reading input from right to left).+  step :: a -> StrSufSt a -> StrSufSt a+  step x = \case+    SSSMismatch   -> SSSMismatch+    SSSResult xs  -> SSSResult (x:xs)+    SSSStrip []   -> SSSResult [x]+    SSSStrip (y:ys)+      | x == y    -> SSSStrip ys+      | otherwise -> SSSMismatch++  -- Output of the automaton.+  final :: StrSufSt a -> Maybe (Prefix a)+  final = \case+    SSSResult xs -> Just xs+    SSSStrip []  -> Just []+    _            -> Nothing  -- We have not stripped the whole suffix or encountered a mismatch.++-- | Internal state for stripping suffix.+data StrSufSt a+  = SSSMismatch                 -- ^ Error.+  | SSSStrip (ReversedSuffix a) -- ^ "Negative string" to remove from end. List may be empty.+  | SSSResult [a]               -- ^ "Positive string" (result). Non-empty list.++-- | Returns a list with one boolean for each non-empty suffix of the+-- list, starting with the longest suffix (the entire list). Each+-- boolean is 'True' exactly when every element in the corresponding+-- suffix satisfies the predicate. -----   > words xs == wordsBy isSpace xs-wordsBy :: (a -> Bool) -> [a] -> [[a]]-wordsBy p xs = yesP xs-    where-        yesP xs = noP (dropWhile p xs)+-- An example:+-- @+--  'suffixesSatisfying' 'Data.Char.isLower' "AbCde" =+--  [False, False, False, True, True]+-- @+--+-- For total predicates @p@ and finite and total lists @xs@ the+-- following holds:+-- @+--  'suffixesSatisfying' p xs = 'map' ('all' p) ('List.init' ('List.tails' xs))+-- @+suffixesSatisfying :: (a -> Bool) -> [a] -> [Bool]+suffixesSatisfying p =+  snd .+  foldr (\x (b, bs) -> let !b' = p x && b in (b', b' : bs))+        (True, []) -        noP []  = []-        noP xs  = ys : yesP zs-            where-                (ys,zs) = break p xs+-- ** Finding overlap +-- | Find the longest suffix of the first string @xs@+--   that is a prefix of the second string @ys@.+--   So, basically, find the overlap where the strings can be glued together.+--   Returns the index where the overlap starts and the length of the overlap.+--   The length of the overlap plus the index is the length of the first string.+--   Note that in the worst case, the empty overlap @(length xs,0)@ is returned.+--+--   Worst-case time complexity is quadratic: @O(min(n,m)²)@+--   where @n = length xs@ and @m = length ys@.+--+--   There might be asymptotically better implementations following+--   Knuth-Morris-Pratt (KMP), but for rather short lists this is good enough.+--+findOverlap :: forall a. Eq a => [a] -> [a] -> (Int, Int)+findOverlap xs ys =+  headWithDefault __IMPOSSIBLE__ $ mapMaybe maybePrefix $ zip [0..] (List.tails xs)+  where+  maybePrefix :: (Int, [a]) -> Maybe (Int, Int)+  maybePrefix (k, xs')+    | xs' `List.isPrefixOf` ys = Just (k, length xs')+    | otherwise                = Nothing++---------------------------------------------------------------------------+-- * Chunks+---------------------------------------------------------------------------+ -- | Chop up a list in chunks of a given length.+-- O(n). chop :: Int -> [a] -> [[a]] chop _ [] = [] chop n xs = ys : chop n zs@@ -211,150 +538,258 @@ -- | Chop a list at the positions when the predicate holds. Contrary to --   'wordsBy', consecutive separator elements will result in an empty segment --   in the result.+--   O(n).+-- --    > intercalate [x] (chopWhen (== x) xs) == xs-chopWhen :: (a -> Bool) -> [a] -> [[a]]-chopWhen p [] = []-chopWhen p xs =-  case break p xs of-    (w, [])     -> [w]-    (w, [_])    -> [w, []]-    (w, _ : ys) -> w : chopWhen p ys+chopWhen :: forall a. (a -> Bool) -> [a] -> [[a]]+chopWhen p []     = []+chopWhen p (x:xs) = loop (x :| xs)+  where+  -- Local function to avoid unnecessary pattern matching.+  loop :: List1 a -> [[a]]+  loop xs = case List1.break p xs of+    (w, []        ) -> [w]+    (w, _ : []    ) -> [w, []]+    (w, _ : y : ys) -> w : loop (y :| ys) --- | All ways of removing one element from a list.-holes :: [a] -> [(a, [a])]-holes []     = []-holes (x:xs) = (x, xs) : map (id -*- (x:)) (holes xs)+---------------------------------------------------------------------------+-- * List as sets+--------------------------------------------------------------------------- +-- | Check membership for the same list often.+--   Use partially applied to create membership predicate+--   @hasElem xs :: a -> Bool@.+--+--   * First time: @O(n log n)@ in the worst case.+--   * Subsequently: @O(log n)@.+--+--   Specification: @hasElem xs == (`elem` xs)@.+hasElem :: Ord a => [a] -> a -> Bool+hasElem xs = (`Set.member` Set.fromList xs)+ -- | Check whether a list is sorted.+-- O(n). -- -- Assumes that the 'Ord' instance implements a partial order.  sorted :: Ord a => [a] -> Bool-sorted [] = True-sorted xs = and $ zipWith (<=) xs (tail xs)+sorted = allConsecutive (<=) --- | Check whether all elements in a list are distinct from each--- other. Assumes that the 'Eq' instance stands for an equivalence--- relation.+-- | Check whether all consecutive elements of a list satisfy the given relation.+-- O(n).+--+allConsecutive :: (a -> a -> Bool) -> [a] -> Bool+allConsecutive cmp xs = and $ zipWith cmp xs $ drop 1 xs++-- | Check whether all elements in a list are distinct from each other.+--   Assumes that the 'Eq' instance stands for an equivalence relation.+--+--   O(n²) in the worst case @distinct xs == True@. distinct :: Eq a => [a] -> Bool distinct []     = True distinct (x:xs) = x `notElem` xs && distinct xs  -- | An optimised version of 'distinct'.+--   O(n log n). ----- Precondition: The list's length must fit in an 'Int'.+--   Precondition: The list's length must fit in an 'Int'.  fastDistinct :: Ord a => [a] -> Bool fastDistinct xs = Set.size (Set.fromList xs) == length xs --- | Checks if all the elements in the list are equal. Assumes that--- the 'Eq' instance stands for an equivalence relation.-allEqual :: Eq a => [a] -> Bool-allEqual []       = True-allEqual (x : xs) = all (== x) xs- -- | Returns an (arbitrary) representative for each list element --   that occurs more than once.+--   O(n log n). duplicates :: Ord a => [a] -> [a] duplicates = mapMaybe dup . Bag.groups . Bag.fromList   where-    dup (a : _ : _) = Just a-    dup _           = Nothing+    dup (a :| _ : _) = Just a+    dup _            = Nothing --- | A variant of 'groupBy' which applies the predicate to consecutive--- pairs.+-- | Remove the first representative for each list element.+--   Thus, returns all duplicate copies.+--   O(n log n).+--+--   @allDuplicates xs == sort $ xs \\ nub xs@.+allDuplicates :: Ord a => [a] -> [a]+allDuplicates = concatMap (List1.tail . List1.reverse) . Bag.groups . Bag.fromList+  -- The reverse is necessary to actually remove the *first* occurrence+  -- of each element. -groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]-groupBy' _ []           = []-groupBy' p xxs@(x : xs) = grp x $ zipWith (\x y -> (p x y, y)) xxs xs+-- | Partition a list into first and later occurrences of elements+--   (modulo some quotient given by a representation function).+--+--  Time: O(n log n).+--+--  Specification:+--+--  > nubAndDuplicatesOn f xs = (ys, xs List.\\ ys)+--  >   where ys = nubOn f xs++nubAndDuplicatesOn :: Ord b => (a -> b) -> [a] -> ([a], [a])+nubAndDuplicatesOn f = loop Set.empty   where-  grp x ys = (x : map snd xs) : tail-    where (xs, rest) = span fst ys-          tail = case rest of-                   []            -> []-                   ((_, z) : zs) -> grp z zs+  loop s [] = ([], [])+  loop s (a:as)+    | b `Set.member` s = second (a:) $ loop s as+    | otherwise        = first  (a:) $ loop (Set.insert b s) as+    where b = f a --- | @'groupOn' f = 'groupBy' (('==') \`on\` f) '.' 'sortBy' ('compare' \`on\` f)@.+-- | Efficient variant of 'nubBy' for lists, using a set to store already seen elements.+-- O(n log n)+--+-- Specification:+--+-- > nubOn f xs == 'nubBy' ((==) `'on'` f) xs. -groupOn :: Ord b => (a -> b) -> [a] -> [[a]]-groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f)+nubOn :: Ord b => (a -> b) -> [a] -> [a]+nubOn f = loop Set.empty+  where+  loop s [] = []+  loop s (a:as)+    | b `Set.member` s = loop s as+    | otherwise        = a : loop (Set.insert b s) as+    where b = f a --- | @splitExactlyAt n xs = Just (ys, zs)@ iff @xs = ys ++ zs@---   and @genericLength ys = n@.-splitExactlyAt :: Integral n => n -> [a] -> Maybe ([a], [a])-splitExactlyAt 0 xs       = return ([], xs)-splitExactlyAt n []       = Nothing-splitExactlyAt n (x : xs) = mapFst (x :) <$> splitExactlyAt (n-1) xs+-- | A variant of 'nubOn' that is parametrised by a function that is+-- used to select which element from a group of equal elements that is+-- returned. The returned elements keep the order that they had in the+-- input list.+--+-- Precondition: The length of the input list must be at most+-- @'maxBound' :: 'Int'@. --- | A generalised variant of 'elemIndex'.+nubFavouriteOn+  :: forall a b c. (Ord b, Eq c, Hashable c)+  => (a -> b)+     -- ^ The values returned by this function are used to determine+     -- which element from a group of equal elements that is returned:+     -- the smallest one is chosen (and if two elements are equally+     -- small, then the first one is chosen).+  -> (a -> c)+     -- ^ Two elements are treated as equal if this function returns+     -- the same value for both elements.+  -> [a] -> [a]+nubFavouriteOn fav f = go 0 HMap.empty+  where+  go :: Int -> HMap.HashMap c ((b, Int), a) -> [a] -> [a]+  go !pos !acc (x : xs) =+    go (1 + pos)+       (HMap.insertWith+          (\new old -> if fst new < fst old then new else old)+          (f x) ((fav x, pos), x) acc)+       xs+  go _ acc [] =+    map snd $ List.sortBy (compare `on` snd . fst) $+    HMap.elems acc -genericElemIndex :: (Eq a, Integral i) => a -> [a] -> Maybe i-genericElemIndex x xs =-  listToMaybe $-  map fst $-  filter snd $-  zip [0..] $-  map (== x) xs+-- -- | Efficient variant of 'nubBy' for finite lists (using sorting).+-- -- O(n log n)+-- --+-- -- Specification:+-- --+-- -- > nubOn2 f xs == 'nubBy' ((==) `'on'` f) xs.+--+-- nubOn2 :: Ord b => (a -> b) -> [a] -> [a]+-- nubOn2 tag =+--     -- Throw away numbering+--   map snd+--     -- Restore original order+--   . List.sortBy (compare `on` fst)+--     -- Retain first entry of each @tag@ group+--   . map (snd . head)+--   . List.groupBy ((==) `on` fst)+--     -- Sort by tag (stable)+--   . List.sortBy (compare `on` fst)+--     -- Tag with @tag@ and sequential numbering+--   . map (\p@(_, x) -> (tag x, p))+--   . zip [1..] --- | Requires both lists to have the same length.+-- | Efficient variant of 'nubBy' for finite lists.+-- O(n log n).+--+-- > uniqOn f == 'List.sortBy' (compare `'on'` f) . 'nubBy' ((==) `'on'` f)+--+-- If there are several elements with the same @f@-representative,+-- the first of these is kept.+--+uniqOn :: Ord b => (a -> b) -> [a] -> [a]+uniqOn key = Map.elems . Map.fromListWith (\ _ -> id) . map (\ a -> (key a, a)) -zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c]-zipWith' f []        []      = []-zipWith' f (x : xs) (y : ys) = f x y : zipWith' f xs ys-zipWith' f []       (_ : _)  = {- ' -} __IMPOSSIBLE__-zipWith' f (_ : _)  []       = {- ' -} __IMPOSSIBLE__+-- | Checks if all the elements in the list are equal. Assumes that+--   the 'Eq' instance stands for an equivalence relation.+--   O(n).+allEqual :: Eq a => [a] -> Bool+allEqual []       = True+allEqual (x : xs) = all (== x) xs -{- UNUSED; a better type would be-   zipWithTails :: (a -> b -> c) -> [a] -> [b] -> ([c], Either [a] [b])+-- | Non-efficient, monadic 'nub'.+-- O(n²).+nubM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]+nubM eq = loop where+  loop []     = return []+  loop (a:as) = (a :) <$> do loop =<< filterM (not <.> eq a) as --- | Like zipWith, but returns the leftover elements of the input lists.-zipWithTails :: (a -> b -> c) -> [a] -> [b] -> ([c], [a] , [b])-zipWithTails f xs       []       = ([], xs, [])-zipWithTails f []       ys       = ([], [] , ys)-zipWithTails f (x : xs) (y : ys) = (f x y : zs , as , bs)-  where (zs , as , bs) = zipWithTails f xs ys--}+---------------------------------------------------------------------------+-- * Zipping+--------------------------------------------------------------------------- --- | Efficient variant of 'nubBy' for finite lists.------ Specification:+-- | Requires both lists to have the same length.+--   O(n). ----- > nubOn f xs == 'nubBy' ((==) `'on'` f) xs.-nubOn :: Ord b => (a -> b) -> [a] -> [a]-nubOn tag =-  map snd-  . sortBy (compare `on` fst)-  . map (snd . head)-  . groupBy ((==) `on` fst)-  . sortBy (compare `on` fst)-  . map (\p@(_, x) -> (tag x, p))-  . zip [1..]+--   Otherwise, @Nothing@ is returned. --- | Efficient variant of 'nubBy' for finite lists.------ Specification: For each list @xs@ there is a list @ys@ which is a--- permutation of @xs@ such that------ > uniqOn f xs == 'nubBy' ((==) `'on'` f) ys.------ Furthermore+zipWith' :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]+zipWith' f = loop+  where+  loop []        []      = Just []+  loop (x : xs) (y : ys) = (f x y :) <$> loop xs ys+  loop []       (_ : _)  = Nothing+  loop (_ : _)  []       = Nothing++-- | Like 'zipWith' but keep the rest of the second list as-is+--   (in case the second list is longer).+-- O(n). ----- > sortBy (compare `on` f) (uniqOn f xs) == uniqOn f xs.-uniqOn :: Ord b => (a -> b) -> [a] -> [a]-uniqOn key = Map.elems . Map.fromList . map (\ a -> (key a, a))+-- @+--   zipWithKeepRest f as bs == zipWith f as bs ++ drop (length as) bs+-- @+zipWithKeepRest :: (a -> b -> b) -> [a] -> [b] -> [b]+zipWithKeepRest f = loop+  where+  loop []       bs       = bs+  loop as       []       = []+  loop (a : as) (b : bs) = f a b : loop as bs --- | Compute the common suffix of two lists.-commonSuffix :: Eq a => [a] -> [a] -> [a]-commonSuffix xs ys = reverse $ (commonPrefix `on` reverse) xs ys+-- -- UNUSED; a better type would be+-- -- zipWithTails :: (a -> b -> c) -> [a] -> [b] -> ([c], Either [a] [b]) --- | Compute the common prefix of two lists.-commonPrefix :: Eq a => [a] -> [a] -> [a]-commonPrefix [] _ = []-commonPrefix _ [] = []-commonPrefix (x:xs) (y:ys)-  | x == y    = x : commonPrefix xs ys-  | otherwise = []+-- -- | Like zipWith, but returns the leftover elements of the input lists.+-- zipWithTails :: (a -> b -> c) -> [a] -> [b] -> ([c], [a] , [b])+-- zipWithTails f xs       []       = ([], xs, [])+-- zipWithTails f []       ys       = ([], [] , ys)+-- zipWithTails f (x : xs) (y : ys) = (f x y : zs , as , bs)+--   where (zs , as , bs) = zipWithTails f xs ys +-- | Analogous to zip, combines two lists by taking the union using These (strict).+align :: [a] -> [b] -> [These a b]+align xs [] = This <$> xs+align [] ys = That <$> ys+align (x:xs) (y:ys) = These x y : align xs ys++---------------------------------------------------------------------------+-- * Unzipping+---------------------------------------------------------------------------++unzipWith :: (a -> (b, c)) -> [a] -> ([b], [c])+unzipWith f = unzip . map f++---------------------------------------------------------------------------+-- * Edit distance+---------------------------------------------------------------------------++-- | Implemented using tree recursion, don't run me at home!+--   O(3^(min n m)). editDistanceSpec :: Eq a => [a] -> [a] -> Int editDistanceSpec [] ys = length ys editDistanceSpec xs [] = length xs@@ -364,16 +799,41 @@                             , editDistanceSpec xs (y : ys)                             , editDistanceSpec xs ys ] -editDistance :: Eq a => [a] -> [a] -> Int+-- | Implemented using dynamic programming and @Data.Array@.+--   O(n*m).+editDistance :: forall a. Eq a => [a] -> [a] -> Int editDistance xs ys = editD 0 0-  where xss = tails xs-        yss = tails ys-        tbl = Map.fromList [ ((i, j), editD' i j) | i <- [0..length xss - 1], j <- [0..length yss - 1] ]-        editD i j = tbl Map.! (i, j)-        editD' i j =-          case (xss !! i, yss !! j) of-            ([], ys) -> length ys-            (xs, []) -> length xs-            (x : xs, y : ys)-              | x == y    -> editD (i + 1) (j + 1)-              | otherwise -> 1 + minimum [ editD (i + 1) j, editD i (j + 1), editD (i + 1) (j + 1) ]+  where+  editD i j = tbl Array.! (i, j)+  -- Tabulate editD' in immutable boxed array (content computed lazily).+  tbl :: Array (Int,Int) Int+  tbl = array ((0,0), (n,m)) [ ((i, j), editD' i j) | i <- [0..n], j <- [0..m] ]+  editD' i j =+    case (compare i n, compare j m) of+      -- Interior+      (LT, LT)+        | xsA Array.! i == ysA Array.! j+                    -> editD i' j'+        | otherwise -> 1 + minimum [ editD i' j, editD i j', editD i' j' ]+      -- Border: one list is empty+      (EQ, LT)      ->  m - j+      (LT, EQ)      ->  n - i+      -- Corner (EQ, EQ): both lists are empty+      _             -> 0+      -- GT cases are impossible.+    where (i', j') = (i + 1, j + 1)+  n   = length xs+  m   = length ys+  xsA, ysA :: Array Int a+  xsA = listArray (0, n - 1) xs+  ysA = listArray (0, m - 1) ys+++mergeStrictlyOrderedBy :: (a -> a -> Bool) -> [a] -> [a] -> Maybe [a]+mergeStrictlyOrderedBy (<) = loop where+  loop [] ys = Just ys+  loop xs [] = Just xs+  loop (x:xs) (y:ys)+    | x < y = (x:) <$> loop xs (y:ys)+    | y < x = (y:) <$> loop (x:xs) ys+    | otherwise = Nothing
+ src/full/Agda/Utils/List1.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE CPP #-}++-- | Non-empty lists.+--+--   Better name @List1@ for non-empty lists, plus missing functionality.+--+--   Import:+--   @+--+--     {-# LANGUAGE PatternSynonyms #-}+--+--     import           Agda.Utils.List1 (List1, pattern (:|))+--     import qualified Agda.Utils.List1 as List1+--+--   @++{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+  -- because of https://gitlab.haskell.org/ghc/ghc/issues/10339++module Agda.Utils.List1+  ( module Agda.Utils.List1+  , module List1+  , module IsList+  , module Unzip+  ) where++import Prelude hiding (filter, unzip)++import Control.Arrow ((&&&))+import Control.Monad (filterM)+import qualified Control.Monad as List (zipWithM, zipWithM_)++import qualified Data.Either as Either+import Data.Function ( on )+import qualified Data.List as List+import qualified Data.Maybe as Maybe++import Data.List.NonEmpty as List1 hiding (fromList, toList, unzip)+import qualified Data.List.NonEmpty as List1 (toList)++-- Prevent warning -Wx-data-list-nonempty-unzip+#if MIN_VERSION_base(4,19,0)+import Data.Functor as Unzip (unzip)+#else+import Data.List.NonEmpty as Unzip (unzip)+#endif++import GHC.Exts as IsList ( IsList(..) )++import Agda.Utils.Functor ((<.>), (<&>))+import Agda.Utils.Null (Null(..))+import qualified Agda.Utils.List as List++-- Set up doctest.+-- $setup+-- >>> :seti -XOverloadedLists++type List1 = NonEmpty+type String1 = List1 Char++-- | Lossless 'toList', opposite of 'nonEmpty'.+--+toList' :: Maybe (List1 a) -> [a]+toList' = maybe [] toList++-- | Lift a function on non-empty lists to a function on lists.+--+-- This is in essence 'fmap' for 'Maybe', if we take @[a] = Maybe (List1 a)@.+--+liftList1 :: (List1 a -> List1 b) -> [a] -> [b]+liftList1 f = toList' . fmap f . nonEmpty++-- | Safe version of 'Data.List.NonEmpty.fromList'.++fromListSafe+  :: List1 a  -- ^ Default value if convertee is empty.+  -> [a]      -- ^ List to convert, supposedly non-empty.+  -> List1 a  -- ^ Converted list.+fromListSafe err   [] = err+fromListSafe _ (x:xs) = x :| xs++-- | Return the last element and the rest.++initLast :: List1 a -> ([a], a)+initLast = List1.init &&& List1.last+  -- traverses twice, but does not create intermediate pairs++-- | Last two elements (safe).+--   O(n).+last2 :: List1 a -> Maybe (a, a)+last2 (x :| y : xs) = Just $ List.last2' x y xs+last2 _ = Nothing++-- | Build a list with one element.++#if !(MIN_VERSION_base(4,15,0))+singleton :: a -> List1 a+singleton = (:| [])+#endif++#if !MIN_VERSION_base(4,16,0)+-- | Append a list to a non-empty list.++appendList :: List1 a -> [a] -> List1 a+appendList (x :| xs) ys = x :| mappend xs ys++-- | Prepend a list to a non-empty list.++prependList :: [a] -> List1 a -> List1 a+prependList as bs = Prelude.foldr (<|) bs as+#endif++-- | More precise type for @snoc@.++snoc :: [a] -> a -> List1 a+snoc as a = prependList as $ a :| []++-- | @'groupOn' f = 'groupBy' (('==') \`on\` f) '.' 'List.sortBy' ('compare' \`on\` f)@.+-- O(n log n).+groupOn :: Ord b => (a -> b) -> [a] -> [List1 a]+groupOn f = List1.groupBy ((==) `on` f) . List.sortBy (compare `on` f)++groupOn1 :: Ord b => (a -> b) -> List1 a -> List1 (List1 a)+groupOn1 f = List1.groupBy1 ((==) `on` f) . List1.sortBy (compare `on` f)++-- | More precise type for 'Agda.Utils.List.groupBy''.+--+-- A variant of 'List.groupBy' which applies the predicate to consecutive+-- pairs.+-- O(n).+groupBy' :: forall a. (a -> a -> Bool) -> [a] -> [List1 a]+groupBy' _ []           = []+groupBy' p xxs@(x : xs) = grp x $ List.zipWith (\ x y -> (p x y, y)) xxs xs+  where+  grp :: a -> [(Bool,a)] -> [List1 a]+  grp x ys+    | let (xs, rest) = List.span fst ys+    = (x :| List.map snd xs) : case rest of+      []                 -> []+      ((_false, z) : zs) -> grp z zs++-- | Group consecutive items that share the same first component.+--+groupByFst :: forall a b. Eq a => [(a,b)] -> [(a, List1 b)]+groupByFst =+    List.map (\ ((tag, b) :| xs) -> (tag, b :| List.map snd xs))+      -- Float the grouping to the top level+  . List1.groupBy ((==) `on` fst)+      -- Group together characters in the same role.++-- | Group consecutive items that share the same first component.+--+groupByFst1 :: forall a b. Eq a => List1 (a, b) -> List1 (a, List1 b)+groupByFst1 =+    fmap (\ ((tag, b) :| xs) -> (tag, b :| List.map snd xs))+      -- Float the grouping to the top level+  . List1.groupBy1 ((==) `on` fst)+      -- Group together characters in the same role.++-- | Split a list into sublists. Generalisation of the prelude function+--   @words@.+--   Same as 'Data.List.Split.wordsBy' and 'Data.List.Extra.wordsBy',+--   but with the non-emptyness guarantee on the chunks.+--   O(n).+--+--   > words xs == wordsBy isSpace xs+wordsBy :: (a -> Bool) -> [a] -> [List1 a]+wordsBy p = loop+  where+  loop as = case List.dropWhile p as of+    []   -> []+    x:xs -> (x :| ys) : loop zs where (ys, zs) = List.break p xs++-- | Breaks a list just /after/ an element satisfying the predicate is+--   found.+--+--   >>> breakAfter even [1,3,5,2,4,7,8]+--   (1 :| [3,5,2],[4,7,8])++breakAfter :: (a -> Bool) -> List1 a -> (List1 a, [a])+breakAfter p (x :| xs) = List.breakAfter1 p x xs++-- | Concatenate one or more non-empty lists.++concat :: [List1 a] -> [a]+concat = concatMap toList++concatMap1 :: (a -> List1 b) -> List1 a -> List1 b+concatMap1 = (=<<)++-- | Like 'Data.List.union'.  Duplicates in the first list are not removed.+-- O(nm).+union :: Eq a => List1 a -> List1 a -> List1 a+union (a :| as) bs = a :| List.union as (filter (/= a) bs)++-- * Recovering non-emptyness.++ifNull :: [a] -> b -> (List1 a -> b) -> b+ifNull []       b _ = b+ifNull (a : as) _ f = f $ a :| as++ifNotNull :: [a] -> (List1 a -> b) -> b -> b+ifNotNull []       _ b = b+ifNotNull (a : as) f _ = f $ a :| as++-- | The more general type @Null m => [a] -> (List1 a -> m) -> m@+--   often causes type inference to fail, as we do not in general have+--   @instance Applicative m => Null (m ())@.+unlessNull :: Applicative m => [a] -> (List1 a -> m ()) -> m ()+unlessNull []       _ = pure ()+unlessNull (x : xs) f = f $ x :| xs++unlessNullM :: Monad m => m [a] -> (List1 a -> m ()) -> m ()+unlessNullM m k = m >>= (`unlessNull` k)++-- * List functions with no special behavior for non-empty lists.++-- | Checks if all the elements in the list are equal. Assumes that+--   the 'Eq' instance stands for an equivalence relation.+--   O(n).+allEqual :: Eq a => List1 a -> Bool+allEqual (x :| xs) = all (== x) xs++-- | Like 'Maybe.catMaybes'.++catMaybes :: List1 (Maybe a) -> [a]+catMaybes =  Maybe.catMaybes . List1.toList++-- | Like 'Maybe.mapMaybe'.++mapMaybe :: (a -> Maybe b) -> List1 a -> [b]+mapMaybe f = Maybe.mapMaybe f . List1.toList++-- | Like 'List.find'.++find :: (a -> Bool) -> List1 a -> Maybe a+find f = List.find f . List1.toList++-- | Like 'Data.Either.partitionEithers'.++partitionEithers :: List1 (Either a b) -> ([a], [b])+partitionEithers = Either.partitionEithers . List1.toList++-- | Like 'Data.Either.lefts'.++lefts :: List1 (Either a b) -> [a]+lefts = Either.lefts  . List1.toList++-- | Like 'Data.Either.rights'.++rights :: List1 (Either a b) -> [b]+rights = Either.rights  . List1.toList++-- | Like 'Data.List.unwords'.++unwords :: List1 String -> String+unwords = List.unwords . List1.toList++-- | Non-efficient, monadic 'nub'.+-- O(n²).+nubM :: Monad m => (a -> a -> m Bool) -> List1 a -> m (List1 a)+nubM eq (a :| as) = (a :|) <$> do List.nubM eq =<< filterM (not <.> eq a) as++-- | Like 'Agda.Utils.List.unzipWith'.++unzipWith :: (a -> (b, c)) -> List1 a -> (List1 b, List1 c)+unzipWith f = unzip . fmap f++-- | Like 'Control.Monad.zipWithM'.++zipWithM :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m (List1 c)+zipWithM f (a :| as) (b :| bs) = (:|) <$> f a b <*> List.zipWithM f as bs++-- | Like 'Control.Monad.zipWithM'.++zipWithM_ :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m ()+zipWithM_ f (a :| as) (b :| bs) = f a b *> List.zipWithM_ f as bs++-- | List 'Data.List.foldr' but with a base case for the singleton list.++foldr :: (a -> b -> b) -> (a -> b) -> List1 a -> b+foldr f g (x :| xs) = loop x xs+  where+  loop x []       = g x+  loop x (y : ys) = f x $ loop y ys++-- | Update the first element of a non-empty list.+--   O(1).+updateHead :: (a -> a) -> List1 a -> List1 a+updateHead f (a :| as) = f a :| as++-- | Update the last element of a non-empty list.+--   O(n).+updateLast :: (a -> a) -> List1 a -> List1 a+updateLast f (a :| as) = loop a as+  where+  loop a []       = singleton $ f a+  loop a (b : bs) = cons a $ loop b bs++-- | Focus on the first element of a non-empty list.+--   O(1).+lensHead :: Functor f => (a -> f a) -> List1 a -> f (List1 a)+lensHead f (a :| as) = f a <&> (:| as)++-- | Focus on the last element of a non-empty list.+--   O(n).+lensLast :: Functor f => (a -> f a) -> List1 a -> f (List1 a)+lensLast f (a :| as) = loop a as+  where+  loop a []       = singleton <$> f a+  loop a (b : bs) = cons a <$> loop b bs
+ src/full/Agda/Utils/List1.hs-boot view
@@ -0,0 +1,5 @@+module Agda.Utils.List1 where++import qualified Data.List.NonEmpty (NonEmpty)++type List1 = Data.List.NonEmpty.NonEmpty
+ src/full/Agda/Utils/List2.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Lists of length at least 2.+--+--   Import as:+--   @+--      import Agda.Utils.List2 (List2(List2))+--      import qualified Agda.Utils.List2 as List2+--   @++module Agda.Utils.List2+  ( module Agda.Utils.List2+  , module Reexport+  ) where++import Control.DeepSeq+import Control.Monad                   ( (<=<) )++import qualified Data.List as List+import Data.Semigroup (sconcat)++import GHC.Exts                        ( IsList(..) )+import qualified GHC.Exts  as Reexport ( toList )++import Agda.Utils.List1                ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1++import Agda.Utils.Impossible++-- | Lists of length ≥2.+data List2 a = List2 a a [a]+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- * Conversion from and to other list types.++-- | 'fromList' is unsafe.+instance IsList (List2 a) where+  type Item (List2 a) = a++  -- Unsafe! O(1).+  fromList :: [a] -> List2 a+  fromList (a : b : cs) = List2 a b cs+  fromList _            = __IMPOSSIBLE__++  toList :: List2 a -> [a]+  toList (List2 a b cs) = a : b : cs++-- | Unsafe! O(1).+fromList1 :: List1 a -> List2 a+fromList1 (a :| b : cs) = List2 a b cs+fromList1 _             = __IMPOSSIBLE__++-- | Safe. O(1).+toList1 :: List2 a -> List1 a+toList1 (List2 a b cs) = a :| b : cs++-- | Safe. O(1).+fromListMaybe :: [a] -> Maybe (List2 a)+fromListMaybe = fromList1Maybe <=< List1.nonEmpty++-- | Safe. O(1).+fromList1Maybe :: List1 a -> Maybe (List2 a)+fromList1Maybe = \case+  (a :| b : cs) -> Just (List2 a b cs)+  _ -> Nothing++-- | Any 'List1' is either a singleton or a 'List2'. O(1).+fromList1Either :: List1 a -> Either a (List2 a)+fromList1Either (a :| as) = case as of+  []   -> Left a+  b:bs -> Right (List2 a b bs)++-- | Inverse of 'fromList1Either'. O(1).+toList1Either :: Either a (List2 a) -> List1 a+toList1Either = \case+  Left  a              -> a :| []+  Right (List2 a b bs) -> a :| b : bs++-- * Construction++-- | O(1).+cons :: a -> List1 a -> List2 a+cons x (y :| ys) = List2 x y ys++-- | O(n).+snoc :: List1 a -> a -> List2 a+snoc (x :| xs) z = List2 x y ys+  where+    y :| ys = List1.snoc xs z++-- | O(length first list).+append :: List1 a -> List1 a -> List2 a+append (x :| xs) ys = cons x $ List1.prependList xs ys++-- | O(length first list).+appendList :: List2 a -> [a] -> List2 a+appendList (List2 x y ys) zs = List2 x y $ mappend ys zs++-- | Concatenate at least 2 lists of length at least 1.+concat21 :: List2 (List1 a) -> List2 a+concat21 (List2 xs ys zss) = append xs $ sconcat $ ys :| zss++-- * Destruction++-- | Safe. O(1).+head :: List2 a -> a+head (List2 a _ _) = a++-- | Safe. O(1).+tail :: List2 a -> List1 a+tail (List2 a b cs) = b :| cs++-- | Safe. O(n).+init :: List2 a -> List1 a+init (List2 a b cs) = a :| List1.init (b :| cs)++-- * Partition++break :: (a -> Bool) -> List2 a -> ([a],[a])+break p = List.break p . toList++instance NFData a => NFData (List2 a) where+  rnf (List2 a b cs) = rnf a `seq` rnf b `seq` rnf cs
src/full/Agda/Utils/ListT.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE UndecidableInstances  #-}  -- Due to limitations of funct.dep.+{-# LANGUAGE UndecidableInstances  #-} -- Due MonadReader/MonadState fundep  -- | @ListT@ done right, --   see https://www.haskell.org/haskellwiki/ListT_done_right_alternative@@ -10,19 +9,27 @@  module Agda.Utils.ListT where -import Control.Applicative+import Control.Applicative ( Alternative((<|>), empty) ) import Control.Monad import Control.Monad.Reader import Control.Monad.State--import Data.Semigroup+import Control.Monad.IO.Class ( MonadIO(..) )  import Agda.Utils.Maybe+import Agda.Utils.Monad  -- | Lazy monadic computation of a list of results. newtype ListT m a = ListT { runListT :: m (Maybe (a, ListT m a)) }   deriving (Functor) +-- | Boilerplate function to lift 'MonadReader' through the 'ListT' transformer.+mapListT :: (m (Maybe (a, ListT m a)) -> n (Maybe (b, ListT n b))) -> ListT m a -> ListT n b+mapListT f = ListT . f . runListT++-- | Inverse to 'mapListT'.+unmapListT :: (ListT m a -> ListT n b) -> m (Maybe (a, ListT m a)) -> n (Maybe (b, ListT n b))+unmapListT f = runListT . f . ListT+ -- * List operations  -- | The empty lazy list.@@ -46,10 +53,21 @@ foldListT cons nil = loop where   loop l = caseListT l nil $ \ a l' -> cons a $ loop l' +-- | Lazy monadic disjunction of lazy monadic list, effects left-to-right+anyListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool+anyListT xs f = foldListT (or2M . f) (return False) xs++-- | Lazy monadic conjunction of lazy monadic list, effects left-to-right+allListT :: Monad m => ListT m a -> (a -> m Bool) -> m Bool+allListT xs f = foldListT (and2M . f) (return True) xs++-- | Force all values in the lazy list, effects left-to-right+sequenceListT :: Monad m => ListT m a -> m [a]+sequenceListT = foldListT ((<$>) . (:)) $ pure []+ -- | The join operation of the @ListT m@ monad. concatListT :: Monad m => ListT m (ListT m a) -> ListT m a-concatListT = ListT . foldListT append (return Nothing)-  where append l = runListT . mappend l . ListT+concatListT = ListT . foldListT (unmapListT . mappend) (return Nothing)  -- * Monadic list operations. @@ -59,7 +77,7 @@  -- | Monadic cons. consMListT :: Monad m => m a -> ListT m a -> ListT m a-consMListT ma l = ListT $ (Just . (,l)) `liftM` ma+consMListT ma l = ListT $ (Just . (,l)) <$> ma -- consMListT ma l = runMListT $ liftM (`consListT` l) ma  -- simplification:@@ -77,22 +95,14 @@ sgMListT ma = consMListT ma nilListT  -- | Extending a monadic function to 'ListT'.-mapMListT :: ( Monad m-#if __GLASGOW_HASKELL__ <= 708-             , Functor m-#endif-             ) => (a -> m b) -> ListT m a -> ListT m b+mapMListT :: Monad m => (a -> m b) -> ListT m a -> ListT m b mapMListT f (ListT ml) = ListT $ do   caseMaybeM ml (return Nothing) $ \ (a, as) -> do     b  <- f a     return $ Just (b , mapMListT f as)  -- | Alternative implementation using 'foldListT'.-mapMListT_alt :: ( Monad m-#if __GLASGOW_HASKELL__ <= 708-                 , Functor m-#endif-                 ) => (a -> m b) -> ListT m a -> ListT m b+mapMListT_alt :: Monad m => (a -> m b) -> ListT m a -> ListT m b mapMListT_alt f = runMListT . foldListT cons (return nilListT)   where cons a ml = consMListT (f a) <$> ml @@ -104,11 +114,10 @@ -- Instances  instance Monad m => Semigroup (ListT m a) where-  l1 <> l2 = ListT $ foldListT cons (runListT l2) l1-    where cons a = runListT . consListT a . ListT+  l1 <> l2 = ListT $ foldListT (unmapListT . consListT) (runListT l2) l1+ instance Monad m => Monoid (ListT m a) where-  mempty        = nilListT-  mappend = (<>)+  mempty = nilListT  instance (Functor m, Applicative m, Monad m) => Alternative (ListT m) where   empty = mempty@@ -140,8 +149,11 @@  instance (Applicative m, MonadReader r m) => MonadReader r (ListT m) where   ask     = lift ask-  local f = ListT . local f . runListT+  local   = mapListT . local  instance (Applicative m, MonadState s m) => MonadState s (ListT m) where   get = lift get   put = lift . put++instance Monad m => MonadFail (ListT m) where+  fail _ = empty
src/full/Agda/Utils/Map.hs view
@@ -1,63 +1,74 @@-{-# LANGUAGE CPP #-}- module Agda.Utils.Map where -import Prelude hiding (map, lookup, mapM)-import Control.Applicative-import Data.Map as Map-import Data.Traversable--import Agda.Utils.Tuple+import Data.Functor.Compose+import Data.Map (Map)+import qualified Data.Map as Map+-- import Data.Maybe (mapMaybe) -- UNUSED -#include "undefined.h" import Agda.Utils.Impossible  -- * Monadic map operations --------------------------------------------------------------------------- -data EitherOrBoth a b = L a | B a b | R b---- | Not very efficient (goes via a list), but it'll do.-unionWithM-#if __GLASGOW_HASKELL__ <= 708-  :: (Ord k, Functor m, Monad m)-#else-  :: (Ord k, Monad m)-#endif-  => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)-unionWithM f m1 m2 = fromList <$> mapM combine (toList m)-    where-        m = unionWith both (map L m1) (map R m2)--        both (L a) (R b) = B a b-        both _     _     = __IMPOSSIBLE__+-- | Update monadically the value at one position (must exist!).+adjustM :: (Functor f, Ord k) => (v -> f v) -> k -> Map k v -> f (Map k v)+adjustM f = Map.alterF $ \case+  Nothing -> __IMPOSSIBLE__+  Just v  -> Just <$> f v -        combine (k, B a b) = (,) k <$> f a b-        combine (k, L a)   = return (k, a)-        combine (k, R b)   = return (k, b)+-- | Wrapper for 'adjustM' for convenience.+adjustM' :: (Functor f, Ord k) => (v -> f (a, v)) -> k -> Map k v -> f (a, Map k v)+adjustM' f k = getCompose . adjustM (Compose . f) k -insertWithKeyM :: (Ord k, Monad m) => (k -> a -> a -> m a) -> k -> a -> Map k a -> m (Map k a)-insertWithKeyM clash k x m =-    case lookup k m of-        Just y  -> do-            z <- clash k x y-            return $ insert k z m-        Nothing -> return $ insert k x m+-- UNUSED Liang-Ting Chen (05-07-2019)+-- data EitherOrBoth a b = L a | B a b | R b+--+-- -- | Not very efficient (goes via a list), but it'll do.+-- unionWithM :: (Ord k, Monad m) => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)+-- unionWithM f m1 m2 = fromList <$> mapM combine (toList m)+--     where+--         m = unionWith both (map L m1) (map R m2)+--+--         both (L a) (R b) = B a b+--         both _     _     = __IMPOSSIBLE__+--+--         combine (k, B a b) = (,) k <$> f a b+--         combine (k, L a)   = return (k, a)+--         combine (k, R b)   = return (k, b)+--+-- UNUSED Liang-Ting Chen (05-07-2019)+-- insertWithKeyM :: (Ord k, Monad m) => (k -> a -> a -> m a) -> k -> a -> Map k a -> m (Map k a)+-- insertWithKeyM clash k x m =+--     case lookup k m of+--         Just y  -> do+--             z <- clash k x y+--             return $ insert k z m+--         Nothing -> return $ insert k x m  -- * Non-monadic map operations --------------------------------------------------------------------------- --- | Big conjunction over a map.-allWithKey :: (k -> a -> Bool) -> Map k a -> Bool-allWithKey f = Map.foldrWithKey (\ k a b -> f k a && b) True+-- UNUSED Liang-Ting Chen (05-07-2019)+-- -- | Big conjunction over a map.+-- allWithKey :: (k -> a -> Bool) -> Map k a -> Bool+-- allWithKey f = Map.foldrWithKey (\ k a b -> f k a && b) True  -- | Filter a map based on the keys. filterKeys :: (k -> Bool) -> Map k a -> Map k a-filterKeys p = filterWithKey (const . p)+filterKeys p = Map.filterWithKey (const . p) --- | Unzip a map.-unzip :: Map k (a, b) -> (Map k a, Map k b)-unzip m = (Map.map fst m, Map.map snd m)+-- UNUSED Andreas (2021-08-19)+-- -- | O(n log n).  Rebuilds the map from scratch.+-- --   Not worse than 'Map.mapKeys'.+-- mapMaybeKeys :: (Ord k1, Ord k2) => (k1 -> Maybe k2) -> Map k1 a -> Map k2 a+-- mapMaybeKeys f = Map.fromList . mapMaybe (\ (k,a) -> (,a) <$> f k) . Map.toList -unzip3 :: Map k (a, b, c) -> (Map k a, Map k b, Map k c)-unzip3 m = (Map.map fst3 m, Map.map snd3 m, Map.map thd3 m)+-- UNUSED Liang-Ting Chen (05-07-2019)+-- -- | Unzip a map.+-- unzip :: Map k (a, b) -> (Map k a, Map k b)+-- unzip m = (Map.map fst m, Map.map snd m)+--+-- UNUSED Liang-Ting Chen (05-07-2019)+-- unzip3 :: Map k (a, b, c) -> (Map k a, Map k b, Map k c)+-- unzip3 m = (Map.map fst3 m, Map.map snd3 m, Map.map thd3 m)+--
+ src/full/Agda/Utils/Map1.hs view
@@ -0,0 +1,36 @@+-- | Non-empty maps.+--+--   Provides type @Map1@ of non-empty maps.+--+--   Import:+--   @+--+--     import           Agda.Utils.Map1 (Map1)+--     import qualified Agda.Utils.Map1 as Map1+--+--   @++module Agda.Utils.Map1+  ( module Agda.Utils.Map1+  , module Map1+  ) where++import Data.Map (Map)+import Data.Map.NonEmpty as Map1++type Map1 = Map1.NEMap++ifNull :: Map k a -> b -> (Map1 k a -> b) -> b+ifNull s b f = Map1.withNonEmpty b f s++-- | A more general type would be @Null m => Map k a -> (Map1 k a -> m) -> m@+--   but this type is problematic as we do not have a general+--   @instance Applicative m => Null (m ())@.+--+unlessNull :: Applicative m => Map k a -> (Map1 k a -> m ()) -> m ()+unlessNull = flip $ Map1.withNonEmpty $ pure ()+{-# INLINE unlessNull #-}++unlessNullM :: Monad m => m (Map k a) -> (Map1 k a -> m ()) -> m ()+unlessNullM m k = m >>= (`unlessNull` k)+{-# INLINE unlessNullM #-}
src/full/Agda/Utils/Maybe.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Extend 'Data.Maybe' by common operations for the 'Maybe' type. --@@ -11,15 +11,17 @@     , module Data.Maybe     ) where -import Control.Monad+import Control.Applicative import Control.Monad.Trans.Maybe  import Data.Maybe-import Data.Functor -#include "undefined.h"-import Agda.Utils.Impossible+-- * Conversion. +-- | Retain object when tag is 'True'.+boolToMaybe :: Bool -> a -> Maybe a+boolToMaybe b x = if b then Just x else Nothing+ -- * Collection operations.  -- | @unionWith@ for collections of size <= 1.@@ -28,6 +30,12 @@ unionMaybeWith f ma      Nothing = ma unionMaybeWith f (Just a) (Just b) = Just $ f a b +-- | @unionsWith@ for collections of size <= 1.+unionsMaybeWith :: (a -> a -> a) -> [Maybe a] -> Maybe a+unionsMaybeWith f ms = case catMaybes ms of+  [] -> Nothing+  as -> Just $ foldl1 f as+ -- | Unzipping a list of length <= 1.  unzipMaybe :: Maybe (a,b) -> (Maybe a, Maybe b)@@ -59,6 +67,10 @@ caseMaybe :: Maybe a -> b -> (a -> b) -> b caseMaybe m d f = maybe d f m +-- | 'caseMaybe' with flipped branches.+ifJust :: Maybe a -> (a -> b) -> b -> b+ifJust m f d = maybe d f m+ -- * Monads and Maybe.  -- | Monadic version of 'maybe'.@@ -85,39 +97,37 @@ whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust m k = caseMaybe m (return ()) k --- | 'caseMaybe' without the 'Just' case.+-- | Pendent to 'whenJust'. whenNothing :: Monad m => Maybe a -> m () -> m ()-whenNothing m d = caseMaybe m d (\_ -> return ())+whenNothing m d = caseMaybe m d \ _ -> return () +-- -- | 'caseMaybe' without the 'Just' case.+-- whenNothing :: Monoid m => Maybe a -> m -> m+-- whenNothing m d = caseMaybe m d \ _ -> mempty+ -- | 'caseMaybeM' without the 'Nothing' case. whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () whenJustM c m = c >>= (`whenJust` m)  -- | 'caseMaybeM' without the 'Just' case. whenNothingM :: Monad m => m (Maybe a) -> m () -> m ()-whenNothingM mm d = mm >>= (`whenNothing` d)+whenNothingM mm d = maybe d (\_ -> return ()) =<< mm  -- | Lazy version of @allJust <.> sequence@. --   (@allJust = mapM@ for the @Maybe@ monad.) --   Only executes monadic effect while @isJust@. allJustM :: Monad m => [m (Maybe a)] -> m (Maybe [a]) allJustM = runMaybeT . mapM MaybeT--- allJustM []         = return $ Just []--- allJustM (mm : mms) = caseMaybeM mm (return Nothing) $ \ a ->---   fmap (a:) <$> allJust mms --- | Precondition: list not empty.---   @---     allJustsOrNothings [Nothing, Nothing] = Just Nothing---     allJustsOrNothings [Just 0, Just 1]   = Just $ Just [0,1]---     allJustsOrNothings [Just 0, Nothing]  = Nothing---   @-allJustsOrNothings :: [Maybe a] -> Maybe (Maybe [a])-allJustsOrNothings [] = __IMPOSSIBLE__-allJustsOrNothings [ma] = return $ (:[]) <$> ma-allJustsOrNothings (ma : mas) = do-  res <- allJustsOrNothings mas-  case (ma, res) of-    (Nothing, Nothing) -> return Nothing-    (Just a, Just as)  -> return $ Just (a : as)-    _                  -> mzero+-- | Lift a maybe to an Alternative.+liftMaybe :: Alternative f => Maybe a -> f a+liftMaybe = maybe empty pure++-- | Like 'span', takes the prefix of a list satisfying a predicate.+-- Returns the run of 'Just's until the first 'Nothing', and the tail of+-- the list.+spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a])+spanMaybe _ [] = ([], [])+spanMaybe p xs@(x:xs') = case p x of+    Just y  -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)+    Nothing -> ([], xs)
src/full/Agda/Utils/Maybe/Strict.hs view
@@ -1,12 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}--#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE DeriveGeneric #-}-#endif---{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | A strict version of the 'Maybe' type. --@@ -14,117 +6,42 @@ --   @ --     import qualified Agda.Utils.Maybe.Strict as Strict --   @------ Copyright :  (c) 2006-2007 Roman Leshchinskiy---              (c) 2013 Simon Meier--- License   :  BSD-style (see the file LICENSE)------ Copyright :  (c) 2014 Andreas Abel  module Agda.Utils.Maybe.Strict   ( module Data.Strict.Maybe+  , module Data.Strict.Classes   , module Agda.Utils.Maybe.Strict   ) where --- The following code is copied from--- http://hackage.haskell.org/package/strict-base-types-0.3.0/docs/src/Data-Maybe-Strict.html--import           Prelude             hiding (Maybe (..), maybe, null)-import qualified Prelude             as Lazy+import Prelude hiding (Maybe(..), maybe) -import           Control.Applicative (pure, (<$>))-import           Control.DeepSeq     (NFData (..))-import           Data.Binary         (Binary (..))-import           Data.Data           (Data (..))-import           Data.Semigroup      (Semigroup, Monoid, (<>), mempty, mappend)-import           Data.Foldable       (Foldable (..))-import           Data.Traversable    (Traversable (..))-#if MIN_VERSION_base(4,7,0)-import           Data.Typeable       (Typeable)-#else-import           Data.Typeable       (Typeable1)-#endif-import           Data.Strict.Maybe   (Maybe (Nothing, Just), fromJust,-                                      fromMaybe, isJust, isNothing, maybe)-#if __GLASGOW_HASKELL__ >= 706-import           GHC.Generics        (Generic (..))-#endif+import qualified Data.Maybe as Lazy+import Data.Strict.Classes+import Data.Strict.Maybe +import Agda.Utils.Functor ( (<.>) )+import Agda.Utils.Lens    ( Lens' ) import Agda.Utils.Null -toStrict :: Lazy.Maybe a -> Maybe a-toStrict Lazy.Nothing  = Nothing-toStrict (Lazy.Just x) = Just x--toLazy :: Maybe a -> Lazy.Maybe a-toLazy Nothing  = Lazy.Nothing-toLazy (Just x) = Lazy.Just x--deriving instance Data a => Data (Maybe a)-#if MIN_VERSION_base(4,7,0)-deriving instance Typeable Maybe-#else-deriving instance Typeable1 Maybe-#endif+-- | Note that strict Maybe is an 'Applicative' only modulo strictness.+--   The laws only hold in the strict semantics.+--   Eg. @pure f <*> pure _|_ = _|_@, but according to the laws for+--   'Applicative' it should be @pure (f _|_)@.+--   We ignore this issue here, it applies also to 'Foldable' and 'Traversable'. -#if __GLASGOW_HASKELL__ >= 706-deriving instance Generic  (Maybe a)-#endif+instance Applicative Maybe where+  pure              = Just+  Just f <*> Just x = Just $ f x+  _      <*> _      = Nothing  instance Null (Maybe a) where   empty = Nothing   null = isNothing --- The monoid instance was fixed in strict-base-types 0.5.0. See--- Issue 1805.-instance Monoid a => Semigroup (Maybe a) where-  Nothing <> m       = m-  m       <> Nothing = m-  Just x1 <> Just x2 = Just (x1 `mappend` x2)--instance Monoid a => Monoid (Maybe a) where-  mempty = Nothing-  mappend = (<>)--instance Foldable Maybe where-    foldMap _ Nothing  = mempty-    foldMap f (Just x) = f x--instance Traversable Maybe where-    traverse _ Nothing  = pure Nothing-    traverse f (Just x) = Just <$> f x--instance NFData a => NFData (Maybe a) where-  rnf = rnf . toLazy--instance Binary a => Binary (Maybe a) where-  put = put . toLazy-  get = toStrict <$> get---- | Analogous to 'Lazy.listToMaybe' in "Data.Maybe".-listToMaybe :: [a] -> Maybe a-listToMaybe []        =  Nothing-listToMaybe (a:_)     =  Just a---- | Analogous to 'Lazy.maybeToList' in "Data.Maybe".-maybeToList :: Maybe a -> [a]-maybeToList  Nothing   = []-maybeToList  (Just x)  = [x]---- | Analogous to 'Lazy.catMaybes' in "Data.Maybe".-catMaybes :: [Maybe a] -> [a]-catMaybes ls = [x | Just x <- ls]---- | Analogous to 'Lazy.mapMaybe' in "Data.Maybe".-mapMaybe :: (a -> Maybe b) -> [a] -> [b]-mapMaybe _ []     = []-mapMaybe f (x:xs) = case f x of-    Nothing -> rs-    Just r  -> r:rs-  where-    rs = mapMaybe f xs+-- * Conversion to lazy @Maybe@. --- The remaining code is a copy of Agda.Utils.Maybe+lensMaybeLazy :: Lens' (Maybe a) (Lazy.Maybe a)+lensMaybeLazy f = toStrict <.> f . toLazy  -- * Collection operations. 
src/full/Agda/Utils/Memo.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE CPP        #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Utils.Memo where -import Control.Applicative import Control.Monad.State import System.IO.Unsafe import Data.IORef import qualified Data.Map as Map-import qualified Agda.Utils.HashMap as HMap+import qualified Data.HashMap.Strict as HMap import Data.Hashable  import Agda.Utils.Lens@@ -15,13 +14,7 @@ -- Simple memoisation in a state monad  -- | Simple, non-reentrant memoisation.-memo-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, MonadState s m)-#else-  :: MonadState s m-#endif-  => Lens' (Maybe a) s -> m a -> m a+memo :: MonadState s m => Lens' s (Maybe a) -> m a -> m a memo tbl compute = do   mv <- use tbl   case mv of@@ -32,13 +25,7 @@  -- | Recursive memoisation, second argument is the value you get --   on recursive calls.-memoRec-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, MonadState s m)-#else-  :: MonadState s m-#endif-  => Lens' (Maybe a) s -> a -> m a -> m a+memoRec :: MonadState s m => Lens' s (Maybe a) -> a -> m a -> m a memoRec tbl ih compute = do   mv <- use tbl   case mv of@@ -77,4 +64,3 @@           let y = f x           writeIORef tbl (HMap.insert x y m)           return y-
src/full/Agda/Utils/Monad.hs view
@@ -2,63 +2,111 @@  module Agda.Utils.Monad     ( module Agda.Utils.Monad-    , when, unless, MonadPlus(..)-    , (<$>), (<*>)-    , (<$)-#if MIN_VERSION_mtl(2,2,0)-    , Control.Monad.State.modify'-#endif+    , module X+    , (<$>), (<*>) , (<$)     )     where -import Prelude             hiding (concat)-import Control.Monad       hiding (mapM, forM)-import Control.Monad.State-import Control.Monad.Writer-import Control.Applicative+import Control.Monad.Except   ( MonadError(catchError, throwError) )+import Control.Monad.Identity ( runIdentity )+import Control.Monad.State    ( MonadState(get, put) )+import Control.Monad.Writer   ( MonadWriter(tell), Writer, WriterT, mapWriterT )++import Data.Bifunctor         ( first, second )+import Data.Bool              ( bool ) import Data.Traversable as Trav hiding (for, sequence) import Data.Foldable as Fold import Data.Maybe+import Data.Monoid -import Agda.Utils.Except-  ( Error(strMsg)-  , MonadError(catchError, throwError)+import Agda.Utils.Applicative+import Agda.Utils.Boolean+import Agda.Utils.Either+import Agda.Utils.Null (empty, ifNotNullM)+import Agda.Utils.Singleton++import Agda.Utils.Impossible++-- Reexport Control.Monad+import Control.Applicative as X+  ( liftA2   )+import Control.Monad as X+  ( MonadPlus(..), (<$!>), (>=>), (<=<)+  , filterM, foldM, forM, forM_+  , join+  , liftM2, liftM3, liftM4+  , msum+  , void+  , zipWithM, zipWithM_+  )+import Control.Monad.Trans as X+  ( MonadTrans, lift+  ) -import Agda.Utils.List -#include "undefined.h"-import Agda.Utils.Impossible+---------------------------------------------------------------------------+-- Vendor some new functions from mtl-2.3.1 +#if MIN_VERSION_mtl(2,3,1)+import Control.Monad.Except as X ( tryError, withError )+#endif++#if !MIN_VERSION_mtl(2,3,1)+-- | 'MonadError' analogue to the 'Control.Exception.try' function.+tryError :: MonadError e m => m a -> m (Either e a)+tryError action = (Right <$> action) `catchError` (pure . Left)++-- | 'MonadError' analogue to the 'withExceptT' function.+-- Modify the value (but not the type) of an error.  The type is+-- fixed because of the functional dependency @m -> e@.  If you need+-- to change the type of @e@ use 'mapError' or 'modifyError'.+withError :: MonadError e m => (e -> e) -> m a -> m a+withError f action = tryError action >>= either (throwError . f) pure+#endif++---------------------------------------------------------------------------+ -- | Binary bind. (==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c k ==<< (ma, mb) = ma >>= \ a -> k a =<< mb +-- | Strict `ap`+(<*!>) :: Monad m => m (a -> b) -> m a -> m b+(<*!>) mf ma = do+  f <- mf+  a <- ma+  pure $! f a+{-# INLINE (<*!>) #-}+infixl 4 <*!>+ -- Conditionals and monads ------------------------------------------------ --- | @when_@ is just @Control.Monad.when@ with a more general type.-when_ :: Monad m => Bool -> m a -> m ()-when_ b m = when b $ m >> return ()+{-# SPECIALIZE when :: Monad m => Bool -> m () -> m () #-}+when :: (IsBool b, Monad m) => b -> m () -> m ()+when b m = ifThenElse b m $ pure () --- | @unless_@ is just @Control.Monad.unless@ with a more general type.-unless_ :: Monad m => Bool -> m a -> m ()-unless_ b m = unless b $ m >> return ()+{-# SPECIALIZE unless :: Monad m => Bool -> m () -> m () #-}+unless :: (IsBool b, Monad m) => b -> m () -> m()+unless b m = ifThenElse b (pure ()) m -whenM :: Monad m => m Bool -> m a -> m ()-whenM c m = c >>= (`when_` m)+{-# SPECIALIZE guard :: MonadPlus m => Bool -> m () #-}+guard :: (IsBool b, MonadPlus m) => b -> m ()+guard b = ifThenElse b (pure ()) mzero -unlessM :: Monad m => m Bool -> m a -> m ()-unlessM c m = c >>= (`unless_` m)+whenM :: Monad m => m Bool -> m () -> m ()+whenM c m = c >>= (`when` m) +unlessM :: Monad m => m Bool -> m () -> m ()+unlessM c m = c >>= (`unless` m)+ -- | Monadic guard. guardM :: (Monad m, MonadPlus m) => m Bool -> m () guardM c = guard =<< c  -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM c m m' =-    do  b <- c-        if b then m else m'+ifM c m m' = c >>= \b -> if b then m else m'  -- | @ifNotM mc = ifM (not <$> mc)@ ifNotM :: Monad m => m Bool -> m a -> m a -> m a@@ -69,30 +117,44 @@ and2M ma mb = ifM ma mb (return False)  andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool-andM = Fold.foldl and2M (return True)+andM = Fold.foldl' and2M (return True) -allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool-allM xs f = andM $ fmap f xs+allM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool+allM f = Fold.foldl' (\ b -> and2M b . f) (return True) +forallM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool+forallM xs f = Fold.foldl' (\b -> and2M b . f) (return True) xs+ -- | Lazy monadic disjunction. or2M :: Monad m => m Bool -> m Bool -> m Bool-or2M ma mb = ifM ma (return True) mb+or2M ma = ifM ma (return True)  orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool-orM = Fold.foldl or2M (return False)+orM = Fold.foldl' or2M (return False) -anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool-anyM xs f = orM $ fmap f xs+anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool+anyM f = Fold.foldl' (\ b -> or2M b . f) (return False) +existsM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool+existsM xs f = anyM f xs+ -- | Lazy monadic disjunction with @Either@  truth values.+--   Returns the last error message if all fail. altM1 :: Monad m => (a -> m (Either err b)) -> [a] -> m (Either err b) altM1 f []       = __IMPOSSIBLE__ altM1 f [a]      = f a altM1 f (a : as) = either (const $ altM1 f as) (return . Right) =<< f a +-- | Lazy monadic disjunction with accumulation of errors in a monoid.+--   Errors are discarded if we succeed.+orEitherM :: (Monoid e, Monad m, Functor m) => [m (Either e b)] -> m (Either e b)+orEitherM []       = return $ Left mempty+orEitherM (m : ms) = caseEitherM m (\e -> mapLeft (e `mappend`) <$> orEitherM ms)+                                   (return . Right)+ -- Loops gathering results in a Monoid ------------------------------------ --- | Generalized version of @mapM_ :: Monad m => (a -> m ()) -> [a] -> m ()@+-- | Generalized version of @traverse_ :: Applicative m => (a -> m ()) -> [a] -> m ()@ --   Executes effects and collects results in left-to-right order. --   Works best with left-associative monoids. --@@ -103,70 +165,112 @@ --   that collects results in right-to-left order --   (effects still left-to-right). --   It might be preferable for right associative monoids.-mapM' :: (Foldable t, Monad m, Monoid b) => (a -> m b) -> t a -> m b-mapM' f = Fold.foldl (\ mb a -> liftM2 mappend mb (f a)) (return mempty)+mapM' :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b+mapM' f = Fold.foldl (\ mb a -> liftA2 mappend mb (f a)) (pure mempty) --- | Generalized version of @forM_ :: Monad m => [a] -> (a -> m ()) -> m ()@-forM' :: (Foldable t, Monad m, Monoid b) => t a -> (a -> m b) -> m b+-- | Generalized version of @for_ :: Applicative m => [a] -> (a -> m ()) -> m ()@+forM' :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b forM' = flip mapM' --- Continuation monad -----------------------------------------------------+-- Variations of Traversable -type Cont r a = (a -> r) -> r+mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)+mapMM f mxs = Trav.mapM f =<< mxs --- | 'Control.Monad.mapM' for the continuation monad. Terribly useful.-thread :: (a -> Cont r b) -> [a] -> Cont r [b]-thread f [] ret = ret []-thread f (x:xs) ret =-    f x $ \y -> thread f xs $ \ys -> ret (y:ys)+forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)+forMM = flip mapMM +-- Variations of Foldable++mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()+mapMM_ f mxs = Fold.mapM_ f =<< mxs++forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()+forMM_ = flip mapMM_++-- Continuation monad -----------------------------------------------------++-- Andreas, 2017-04-11, issue #2543+-- The terribly useful thread function is now UNUSED.  [Sadistic laughter :)]+--+-- type Cont r a = (a -> r) -> r+--+-- -- | 'Control.Monad.mapM' for the continuation monad. Terribly useful.+-- thread :: (a -> Cont r b) -> [a] -> Cont r [b]+-- thread f [] ret = ret []+-- thread f (x:xs) ret =+--     f x $ \y -> thread f xs $ \ys -> ret (y:ys)+ -- Lists and monads ------------------------------------------------------- --- | Requires both lists to have the same lengths.-zipWithM' :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]-zipWithM' f xs ys = sequence (zipWith' f xs ys)+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = concat <$> Trav.mapM f xs  -- | A monadic version of @'mapMaybe' :: (a -> Maybe b) -> [a] -> [b]@.-mapMaybeM-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, Monad m)-#else-  :: Monad m-#endif-  => (a -> m (Maybe b)) -> [a] -> m [b]-mapMaybeM f xs = catMaybes <$> Trav.mapM f xs+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f = go where+  go []     = return []+  go (a:as) = f a >>= \case+    Nothing -> go as+    Just b  -> do {!bs <- go as; pure (b : bs)}+{-# INLINE mapMaybeM #-} +-- | A version of @'mapMaybeM'@ with a computation for the input list.+mapMaybeMM :: Monad m => (a -> m (Maybe b)) -> m [a] -> m [b]+mapMaybeMM f m = mapMaybeM f =<< m+{-# INLINE mapMaybeMM #-}+ -- | The @for@ version of 'mapMaybeM'.-forMaybeM-#if __GLASGOW_HASKELL__ <= 708-  :: (Functor m, Monad m)-#else-  :: Monad m-#endif-  => [a] -> (a -> m (Maybe b)) -> m [b]+forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] forMaybeM = flip mapMaybeM +-- | The @for@ version of 'mapMaybeMM'.+forMaybeMM :: Monad m => m [a] -> (a -> m (Maybe b)) -> m [b]+forMaybeMM = flip mapMaybeMM+ -- | A monadic version of @'dropWhile' :: (a -> Bool) -> [a] -> [a]@. dropWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a] dropWhileM p []       = return [] dropWhileM p (x : xs) = ifM (p x) (dropWhileM p xs) (return (x : xs)) +-- | A monadic version of @'dropWhileEnd' :: (a -> Bool) -> [a] -> m [a]@.+--   Effects happen starting at the end of the list until @p@ becomes false.+dropWhileEndM :: Monad m => (a -> m Bool) -> [a] -> m [a]+dropWhileEndM p []       = return []+dropWhileEndM p (x : xs) = ifNotNullM (dropWhileEndM p xs) (return . (x:)) $ {-else-}+  ifM (p x) (return []) (return [x])+ -- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a])-partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a],[a])-partitionM f [] =-  pure ([], [])-partitionM f (x:xs) =-  (\ b (l, r) -> if b then (x:l, r) else (l, x:r)) <$> f x <*> partitionM f xs+partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f =+  foldr (\ x -> liftA2 (bool (second (x:)) (first (x:))) $ f x)+        (pure empty) +-- MonadPlus -----------------------------------------------------------------++-- | Translates 'Maybe' to 'MonadPlus'.+fromMaybeMP :: MonadPlus m => Maybe a -> m a+fromMaybeMP = foldA++-- | Generalises the 'catMaybes' function from lists to an arbitrary+-- 'MonadPlus'.+catMaybesMP :: MonadPlus m => m (Maybe a) -> m a+catMaybesMP = scatterMP++-- | Branch over elements of a monadic 'Foldable' data structure.+scatterMP :: (MonadPlus m, Foldable t) => m (t a) -> m a+scatterMP = (>>= foldA)++ -- Error monad ------------------------------------------------------------  -- | Finally for the 'Error' class. Errors in the finally part take -- precedence over prior errors. -finally :: MonadError e m => m a -> m b -> m a+finally :: MonadError e m => m a -> m () -> m a first `finally` after = do-  r <- catchError (liftM Right first) (return . Left)-  _ <- after+  r <- catchError (fmap Right first) (return . Left)+  after   case r of     Left e  -> throwError e     Right r -> return r@@ -176,65 +280,39 @@ tryMaybe :: (MonadError e m, Functor m) => m a -> m (Maybe a) tryMaybe m = (Just <$> m) `catchError` \ _ -> return Nothing +-- | Run a command, catch the exception and return it.++tryCatch :: (MonadError e m, Functor m) => m () -> m (Maybe e)+tryCatch m = (Nothing <$ m) `catchError` \ err -> return $ Just err++-- | Like 'guard', but raise given error when condition fails.++guardWithError :: MonadError e m => e -> Bool -> m ()+guardWithError e b = if b then return () else throwError e+ -- State monad ------------------------------------------------------------  -- | Bracket without failure.  Typically used to preserve state. bracket_ :: Monad m          => m a         -- ^ Acquires resource. Run first.-         -> (a -> m c)  -- ^ Releases resource. Run last.+         -> (a -> m ())  -- ^ Releases resource. Run last.          -> m b         -- ^ Computes result. Run in-between.          -> m b bracket_ acquire release compute = do   resource <- acquire   result <- compute-  _ <- release resource+  release resource   return result  -- | Restore state after computation. localState :: MonadState s m => m a -> m a localState = bracket_ get put -#if !MIN_VERSION_mtl(2,2,0)-modify' :: MonadState s m => (s -> s) -> m ()-modify' f = do-  x <- get-  put $! f x-#endif---- Read ---------------------------------------------------------------------readM :: (Error e, MonadError e m, Read a) => String -> m a-readM s = case reads s of-            [(x,"")]    -> return x-            _           ->-              throwError $ strMsg $ "readM: parse error string " ++ s----- RETIRED STUFF ------------------------------------------------------------{- RETIRED, ASR, 09 September 2014. Not used.--- | Bracket for the 'Error' class.---- bracket :: (Error e, MonadError e m)---         => m a         -- ^ Acquires resource. Run first.---         -> (a -> m c)  -- ^ Releases resource. Run last.---         -> (a -> m b)  -- ^ Computes result. Run in-between.---         -> m b--- bracket acquire release compute = do---   resource <- acquire---   compute resource `finally` release resource--}--{- RETIRED, Andreas, 2012-04-30. Not used.-concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]-concatMapM f xs = concat <$> traverse f xs+-- Writer monad ----------------------------------------------------------- --- | Depending on the monad you have to look at the result for---   the force to be effective. For the 'IO' monad you do.-forceM :: Monad m => [a] -> m ()-forceM xs = do () <- length xs `seq` return ()-               return ()+embedWriter :: (Monoid w, Monad m) => Writer w a -> WriterT w m a+embedWriter = mapWriterT (pure . runIdentity) -commuteM :: (Traversable f, Applicative m) => f (m a) -> m (f a)-commuteM = traverse id--}+-- | Output a single value.+tell1 :: (Monoid ws, Singleton w ws, MonadWriter ws m) => w -> m ()+tell1 = tell . singleton
+ src/full/Agda/Utils/Monoid.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | More monoids.++module Agda.Utils.Monoid where++-- | Maximum of on-negative (small) natural numbers.++newtype MaxNat = MaxNat { getMaxNat :: Int }+  deriving (Num, Eq, Ord, Show, Enum)++instance Semigroup MaxNat where+  (<>) = max++instance Monoid MaxNat where+  mempty     = 0+  mconcat [] = 0+  mconcat ms = maximum ms
src/full/Agda/Utils/Null.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE CPP               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Overloaded @null@ and @empty@ for collections and sequences. @@ -8,11 +8,24 @@  import Prelude hiding (null) -import Control.Monad+import Control.Monad          ( when, unless )+import Control.Monad.Except   ( ExceptT )+import Control.Monad.Identity ( Identity(..) )+import Control.Monad.Reader   ( ReaderT )+import Control.Monad.State    ( StateT  )+import Control.Monad.Writer   ( WriterT )+import Control.Monad.Trans    ( lift    )+import Control.Monad.Trans.Maybe -import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as ByteString-import Data.Function+import Data.Maybe             ( isNothing )++import qualified Data.ByteString.Char8 as ByteStringChar8+import qualified Data.ByteString.Lazy as ByteStringLazy++import Data.EnumMap (EnumMap)+import qualified Data.EnumMap as EnumMap+import Data.EnumSet (EnumSet)+import qualified Data.EnumSet as EnumSet import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet)@@ -24,32 +37,31 @@ import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -import Text.PrettyPrint (Doc, render)+import Data.Text (Text)+import qualified Data.Text as Text +import Text.PrettyPrint.Annotated (Doc, isEmpty)+ import Agda.Utils.Bag (Bag) import qualified Agda.Utils.Bag as Bag --- Andreas, 2015-06-24 orphan instance has to go here--- to be able to define instance Null Doc--#if !MIN_VERSION_pretty(1,1,2)-instance Eq Doc where-  (==) = (==) `on` render-#endif+import Agda.Utils.Unsafe (unsafeComparePointers)+import Agda.Utils.Impossible  class Null a where   empty :: a   null  :: a -> Bool   -- ^ Satisfying @null empty == True@. +  -- | The default implementation of 'null' compares with 'empty',+  --   first trying pointer equality, then falling back to 'Eq' equality.   default null :: Eq a => a -> Bool-  null = (== empty)+  null a = unsafeComparePointers a empty || a == empty  instance Null () where   empty  = ()@@ -59,10 +71,26 @@   empty      = (empty, empty)   null (a,b) = null a && null b -instance Null ByteString where-  empty = ByteString.empty-  null  = ByteString.null+instance (Null a, Null b, Null c) => Null (a,b,c) where+  empty        = (empty, empty, empty)+  null (a,b,c) = null a && null b && null c +instance (Null a, Null b, Null c, Null d) => Null (a,b,c,d) where+  empty          = (empty, empty, empty, empty)+  null (a,b,c,d) = null a && null b && null c && null d++instance Null ByteStringChar8.ByteString where+  empty = ByteStringChar8.empty+  null  = ByteStringChar8.null++instance Null ByteStringLazy.ByteString where+  empty = ByteStringLazy.empty+  null  = ByteStringLazy.null++instance Null Text where+  empty = Text.empty+  null  = Text.null+ instance Null [a] where   empty = []   null  = List.null@@ -71,6 +99,14 @@   empty = Bag.empty   null  = Bag.null +instance Null (EnumMap k a) where+  empty = EnumMap.empty+  null  = EnumMap.null++instance Null (EnumSet a) where+  empty = EnumSet.empty+  null  = EnumSet.null+ instance Null (IntMap a) where   empty = IntMap.empty   null  = IntMap.null@@ -102,21 +138,59 @@ -- | A 'Maybe' is 'null' when it corresponds to the empty list. instance Null (Maybe a) where   empty = Nothing-  null Nothing  = True-  null (Just a) = False+  null  = isNothing -instance Null Doc where+-- | Viewing 'Bool' as @'Maybe' ()@, a boolean is 'null' when it is false.+instance Null Bool where+  empty = False+  null  = not++instance Null (Doc a) where   empty = mempty-  null  = (== mempty)+  null  = isEmpty +instance Null a => Null (Identity a) where+  empty = return empty+  null  = null . runIdentity++instance Null a => Null (IO a) where+  empty = return empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m) => Null (ExceptT e m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m) => Null (MaybeT m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m) => Null (ReaderT r m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m) => Null (StateT s m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m, Monoid w) => Null (WriterT w m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__+ -- * Testing for null.  ifNull :: (Null a) => a -> b -> (a -> b) -> b ifNull a b k = if null a then b else k a +ifNotNull :: (Null a) => a -> (a -> b) -> b -> b+ifNotNull a k b = ifNull a b k+ ifNullM :: (Monad m, Null a) => m a -> m b -> (a -> m b) -> m b ifNullM ma mb k = ma >>= \ a -> ifNull a mb k +ifNotNullM :: (Monad m, Null a) => m a -> (a -> m b) -> m b -> m b+ifNotNullM ma k mb = ifNullM ma mb k+ whenNull :: (Monad m, Null a) => a -> m () -> m () whenNull = when . null @@ -128,3 +202,10 @@  unlessNullM :: (Monad m, Null a) => m a -> (a -> m ()) -> m () unlessNullM ma k = ma >>= (`unlessNull` k)++applyUnlessNull :: (Null a) => a -> (a -> b -> b) -> (b -> b)+applyUnlessNull a f = if null a then id else f a++-- | Disjunction (interpreting @null _@ as @False@).+catchNull :: Null a => a -> a -> a+catchNull a b = if null a then b else a
+ src/full/Agda/Utils/POMonoid.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Partially ordered monoids.++module Agda.Utils.POMonoid where++import Agda.Utils.PartialOrd++-- | Partially ordered semigroup.+--+-- Law: composition must be monotone.+--+-- @+--   related x POLE x' && related y POLE y' ==>+--   related (x <> y) POLE (x' <> y')+-- @++class (PartialOrd a, Semigroup a) => POSemigroup a where++-- | Partially ordered monoid.+--+-- Law: composition must be monotone.+--+-- @+--   related x POLE x' && related y POLE y' ==>+--   related (x <> y) POLE (x' <> y')+-- @++class (PartialOrd a, Semigroup a, Monoid a) => POMonoid a where++-- | Completing POMonoids with inverses to form a Galois connection.+--+-- Law: composition and inverse composition form a Galois connection.+--+-- @+--   related (inverseCompose p x) POLE y <==> related x POLE (p <> y)+-- @++class POMonoid a => LeftClosedPOMonoid a where+  inverseCompose :: a -> a -> a+++-- | @hasLeftAdjoint x@ checks whether+--   @x^-1 := x `inverseCompose` mempty@ is such that+--   @x `inverseCompose` y == x^-1 <> y@ for any @y@.+hasLeftAdjoint :: LeftClosedPOMonoid a => a -> Bool+hasLeftAdjoint x = related (inverseCompose x mempty <> x) POLE mempty+  -- It is enough to check the above, because of the following proof:+  -- I will write _\_ for `inverseCompose`, id for mempty, and _._ for (<>).+  -- Assume (*) x^-1 . x <= id, as checked.+  -- Show x^-1 . y <=> x \ y+  --+  -- 1. (>=)+     -- id     <= x . (x \ id)      (galois)+     -- id . y <= x . (x \ id) . y+     -- y      <= x . (x \ id) . y+     -- x \ y  <= (x \ id) . y      (galois)+     -- x^-1 . y >= x \ y           qed+  --+  -- 2. (<=)+     --        y <=        x . (x \ y)   (galois)+     -- x^-1 . y <= x^-1 . x . (x \ y)+     --          <= id       . (x \ y)   (*)+     --          <= x \ y+     -- x^-1 . y <= x \ y                qed
src/full/Agda/Utils/Parser/MemoisedCPS.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- | Parser combinators with support for left recursion, following -- Johnson\'s \"Memoization in Top-Down Parsing\".@@ -20,32 +22,33 @@ -- the author of this module whether the change leads to more -- non-termination for grammars that are not cyclic.) -{-# LANGUAGE CPP                   #-}  module Agda.Utils.Parser.MemoisedCPS   ( ParserClass(..)+  , sat, token, tok, doc+  , DocP, bindP, choiceP, seqP, starP, atomP   , Parser   , ParserWithGrammar   ) where -import Control.Applicative-import Control.Monad (ap, liftM2)-import Control.Monad.State.Strict (State, evalState, get, put)+import Control.Applicative ( Alternative((<|>), empty, many, some) )+import Control.Monad (liftM2, (<=<))+import Control.Monad.State.Strict (State, evalState, runState, get, modify')+ import Data.Array import Data.Hashable import qualified Data.HashMap.Strict as Map import Data.HashMap.Strict (HashMap)-import qualified Data.HashSet as Set-import Data.HashSet (HashSet)++ import qualified Data.IntMap.Strict as IntMap import Data.IntMap.Strict (IntMap)-import Data.List-import Text.PrettyPrint.HughesPJ hiding (empty)-import qualified Text.PrettyPrint.HughesPJ as PP+import qualified Data.List as List+import Data.Maybe -import Agda.Utils.Monad (modify')+import qualified Agda.Utils.Null as Null+import Agda.Syntax.Common.Pretty hiding (annotate) -#include "undefined.h" import Agda.Utils.Impossible  -- | Positions.@@ -63,8 +66,8 @@ -- | Memoised values.  data Value k r tok b = Value-  { results       :: !(IntMap [r])-  , continuations :: [Cont k r tok b r]+  { _results       :: !(IntMap [r])+  , _continuations :: [Cont k r tok b r]   }  -- | The parser type.@@ -95,11 +98,15 @@     p input i $ \j x -> unP (f x) input j k  instance Functor (Parser k r tok) where-  fmap f p = p >>= return . f+  fmap f (P p) = P $ \input i k ->+    p input i $ \i -> k i . f  instance Applicative (Parser k r tok) where-  pure x = P $ \_ i k -> k i x-  (<*>)  = ap+  pure x        = P $ \_ i k -> k i x+  P p1 <*> P p2 = P $ \input i k ->+    p1 input i $ \i f ->+    p2 input i $ \i x ->+    k i (f x)  instance Alternative (Parser k r tok) where   empty         = P $ \_ _ _ -> return []@@ -113,20 +120,15 @@    -- | Tries to print the parser, or returns 'PP.empty', depending on   -- the implementation. This function might not terminate.-  grammar :: p a -> Doc--  -- | Parses a single token.-  token :: p tok--  -- | Parses a token satisfying the given predicate.-  sat :: (tok -> Bool) -> p tok+  grammar :: Show k => p a -> Doc -  -- | Parses a given token.-  tok :: (Eq tok, Show tok) => tok -> p tok+  -- | Parses a token satisfying the given predicate. The computed+  -- value is returned.+  sat' :: (tok -> Maybe a) -> p a    -- | Uses the given function to modify the printed representation   -- (if any) of the given parser.-  annotate :: (Doc -> Doc) -> p a -> p a+  annotate :: (DocP -> DocP) -> p a -> p a    -- | Memoises the given parser.   --@@ -143,27 +145,44 @@   -- inputs.)   memoiseIfPrinting :: (Eq k, Hashable k, Show k) => k -> p r -> p r +-- | Uses the given document as the printed representation of the+-- given parser. The document's precedence is taken to be 'atomP'.++doc :: ParserClass p k r tok => Doc -> p a -> p a+doc d = annotate (\_ -> (d, atomP))++-- | Parses a token satisfying the given predicate.++sat :: ParserClass p k r tok => (tok -> Bool) -> p tok+sat p = sat' (\t -> if p t then Just t else Nothing)++-- | Parses a single token.++token :: ParserClass p k r tok => p tok+token = doc "·" (sat' Just)++-- | Parses a given token.++tok :: (ParserClass p k r tok, Eq tok, Show tok) => tok -> p tok+tok t = doc (text (show t)) (sat (t ==))+ instance ParserClass (Parser k r tok) k r tok where   parse p toks =     flip evalState IntMap.empty $     unP p (listArray (0, n - 1) toks) 0 $ \j x ->       if j == n then return [x] else return []-    where n = genericLength toks+    where n = List.genericLength toks -  grammar _ = PP.empty+  grammar _ = Null.empty -  token = P $ \input i k ->+  sat' p = P $ \input i k ->     if inRange (bounds input) i then-      (k $! (i + 1)) $! (input ! i)+      case p (input ! i) of+        Nothing -> return []+        Just x  -> (k $! (i + 1)) $! x     else       return [] -  sat p = do-    t <- token-    if p t then return t else empty--  tok t = sat (t ==)-   annotate _ p = p    memoiseIfPrinting _ p = p@@ -171,10 +190,9 @@   memoise key p = P $ \input i k -> do      let alter j zero f m =-          IntMap.alter (Just . f . maybe zero id) j m+          IntMap.alter (Just . f . fromMaybe zero) j m -        lookupTable   = fmap (\m -> Map.lookup key =<<-                                    IntMap.lookup i m) get+        lookupTable   = fmap (Map.lookup key <=< IntMap.lookup i) get         insertTable v = modify' $ alter i Map.empty (Map.insert key v)      v <- lookupTable@@ -182,7 +200,7 @@       Nothing -> do         insertTable (Value IntMap.empty [k])         unP p input i $ \j r -> do-          Just (Value rs ks) <- lookupTable+          ~(Just (Value rs ks)) <- lookupTable           insertTable (Value (alter j [] (r :) rs) ks)           concat <$> mapM (\k -> k j r) ks  -- See note [Reverse ks?].       Just (Value rs ks) -> do@@ -200,74 +218,128 @@ -- | An extended parser type, with some support for printing parsers.  data ParserWithGrammar k r tok a =-  PG (Bool -> Either (Parser k r tok a)-                     (State (HashSet k) Doc))-  -- ^ Invariant: If the boolean is 'True', then the result must be-  -- @'Left' something@, and if the boolean is 'False', then the-  -- result must be @'Right' something@.+  -- | This must be a lazy tuple so that we don't generate the docs eagerly.+  PG { parser :: Parser k r tok a+     , docs   :: Docs k+     } --- | A smart constructor.+-- | Documents paired with precedence levels. -pg :: Parser k r tok a ->-      State (HashSet k) Doc ->-      ParserWithGrammar k r tok a-pg p d = PG $ \b -> if b then Left p else Right d+type DocP = (Doc, Int) --- | Extracts the parser.+-- | Precedence of @>>=@. -parser :: ParserWithGrammar k r tok a -> Parser k r tok a-parser (PG p) = either id __IMPOSSIBLE__ (p True)+bindP :: Int+bindP = 10 --- | Extracts the document.+-- | Precedence of @<|>@. -doc :: ParserWithGrammar k r tok a -> State (HashSet k) Doc-doc (PG p) = either __IMPOSSIBLE__ id (p False)+choiceP :: Int+choiceP = 20 +-- | Precedence of @<*>@.++seqP :: Int+seqP = 30++-- | Precedence of @⋆@ and @+@.++starP :: Int+starP = 40++-- | Precedence of atoms.++atomP :: Int+atomP = 50++-- | The extended parser type computes one top-level document, plus+-- one document per encountered memoisation key.+--+-- 'Nothing' is used to mark that a given memoisation key has been+-- seen, but that no corresponding document has yet been stored.++type Docs k = State (HashMap k (Maybe DocP)) DocP++-- | The constructor.++pg :: Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a+pg = PG+ instance Monad (ParserWithGrammar k r tok) where   return  = pure-  p >>= f = pg (parser p >>= parser . f)-               ((\d -> parens (d <+> text ">>= ?")) <$> doc p)+  p >>= f =+    pg (parser p >>= parser . f)+       ((\(d, p) -> (mparens (p < bindP) d <+> ">>= ?", bindP))+          <$> docs p)  instance Functor (ParserWithGrammar k r tok) where-  fmap f p = pg (fmap f (parser p)) (doc p)+  fmap f p = pg (fmap f (parser p)) (docs p)  instance Applicative (ParserWithGrammar k r tok) where-  pure x    = pg (pure x) (return (text "ε"))+  pure x    = pg (pure x) (return ("ε", atomP))   p1 <*> p2 =     pg (parser p1 <*> parser p2)-       (liftM2 (\d1 d2 -> parens (sep [d1, d2])) (doc p1) (doc p2))+       (liftM2 (\(d1, p1) (d2, p2) ->+                   (sep [ mparens (p1 < seqP) d1+                        , mparens (p2 < seqP) d2+                        ], seqP))+               (docs p1) (docs p2)) +-- | A helper function.++starDocs :: String -> ParserWithGrammar k r tok a -> Docs k+starDocs s p =+  (\(d, p) -> (mparens (p < starP) d <+> text s, starP)) <$> docs p+ instance Alternative (ParserWithGrammar k r tok) where-  empty     = pg empty (return (text "∅"))+  empty     = pg empty (return ("∅", atomP))   p1 <|> p2 =     pg (parser p1 <|> parser p2)-       (liftM2 (\d1 d2 -> parens (sep [d1, text "|", d2])) (doc p1) (doc p2))+       (liftM2 (\(d1, p1) (d2, p2) ->+                   (sep [ mparens (p1 < choiceP) d1+                        , "|"+                        , mparens (p2 < choiceP) d2+                        ], choiceP))+               (docs p1) (docs p2)) -  many p = pg (many (parser p)) ((<+> text "⋆") . parens <$> doc p)-  some p = pg (some (parser p)) ((<+> text "+") . parens <$> doc p)+  many p = pg (many (parser p)) (starDocs "⋆" p)+  some p = pg (some (parser p)) (starDocs "+" p) +-- | Pretty-prints a memoisation key.++prettyKey :: Show k => k -> DocP+prettyKey key = (text ("<" ++ show key ++ ">"), atomP)+ -- | A helper function. -memoiseDoc ::+memoiseDocs ::   (Eq k, Hashable k, Show k) =>-  k -> ParserWithGrammar k r tok r -> State (HashSet k) Doc-memoiseDoc key p = do-  s <- get-  if Set.member key s then-    return (text ("<" ++ show key ++ ">"))-   else do-    put (Set.insert key s)-    (\d -> parens $-             text ("μ " ++ show key ++ ".") $+$ nest 2 d) <$>-      doc p+  k -> ParserWithGrammar k r tok r -> Docs k+memoiseDocs key p = do+  r <- Map.lookup key <$> get+  case r of+    Just _  -> return ()+    Nothing -> do+      modify' (Map.insert key Nothing)+      d <- docs p+      modify' (Map.insert key (Just d))+  return (prettyKey key)  instance ParserClass (ParserWithGrammar k r tok) k r tok where   parse p                 = parse (parser p)-  grammar p               = evalState (doc p) Set.empty-  token                   = pg token (return (text "·"))-  sat p                   = pg (sat p) (return (text "sat ?"))-  tok t                   = pg (tok t) (return (text (show t)))-  annotate f p            = pg (parser p) (f <$> doc p)+  sat' p                  = pg (sat' p) (return ("<sat ?>", atomP))+  annotate f p            = pg (parser p) (f <$> docs p)   memoise key p           = pg (memoise key (parser p))-                               (memoiseDoc key p)-  memoiseIfPrinting key p = pg (parser p) (memoiseDoc key p)+                               (memoiseDocs key p)+  memoiseIfPrinting key p = pg (parser p) (memoiseDocs key p)++  grammar p =+    d+      $+$+    nest 2 (foldr1 ($+$) $+      "where" :+      map (\(k, d) -> fst (prettyKey k) <+> "∷=" <+>+                        maybe __IMPOSSIBLE__ fst d)+          (Map.toList ds))+    where+    ((d, _), ds) = runState (docs p) Map.empty
− src/full/Agda/Utils/Parser/ReadP.hs 
@@ -1,521 +0,0 @@-{-# LANGUAGE MagicHash     #-}---------------------------------------------------------------------------------- |---- This is a modified version of the ReadP module from the standard libraries.--- The changes are:----  1) ReadP is parameterised over the token type (hard-wired to 'Char' in the library).---  2) Added the functions 'parse' and 'parse'' which run parsers.---  3) Removed Read instances.---- Module      :  "Text.ParserCombinators.ReadP"--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (local universal quantification)------ This is a library of parser combinators, originally written by Koen Claessen.--- It parses all alternatives in parallel, so it never keeps hold of--- the beginning of the input string, a common source of space leaks with--- other parsers.  The '(+++)' choice combinator is genuinely commutative;--- it makes no difference which branch is \"shorter\".---------------------------------------------------------------------------------module Agda.Utils.Parser.ReadP-  (-  -- * The 'ReadP' type-  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus--  -- * Primitive operations-  get,        -- :: ReadP Char-  look,       -- :: ReadP String-  (+++),      -- :: ReadP a -> ReadP a -> ReadP a-  (<++),      -- :: ReadP a -> ReadP a -> ReadP a-  gather,     -- :: ReadP a -> ReadP (String, a)--  -- * Parse-  parse,      -- :: ReadP tok a -> [tok] -> [a]-  parse',     -- :: ReadP tok a -> [tok] -> Either a [tok]--  -- * Other operations-  pfail,      -- :: ReadP a-  satisfy,    -- :: (Char -> Bool) -> ReadP Char-  char,       -- :: Char -> ReadP Char-  string,     -- :: String -> ReadP String-  munch,      -- :: (Char -> Bool) -> ReadP String-  munch1,     -- :: (Char -> Bool) -> ReadP String-  skipSpaces, -- :: ReadP ()-  choice,     -- :: [ReadP a] -> ReadP a-  count,      -- :: Int -> ReadP a -> ReadP [a]-  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a-  option,     -- :: a -> ReadP a -> ReadP a-  optional,   -- :: ReadP a -> ReadP ()-  many,       -- :: ReadP a -> ReadP [a]-  many1,      -- :: ReadP a -> ReadP [a]-  skipMany,   -- :: ReadP a -> ReadP ()-  skipMany1,  -- :: ReadP a -> ReadP ()-  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]--  -- * Properties-  -- $properties-  )- where--import Control.Applicative (Applicative(..),Alternative(empty,(<|>)))-import Control.Monad-import GHC.Exts-import Data.Char--infixr 5 +++, <++---- ------------------------------------------------------------------------------ The P type--- is representation type -- should be kept abstract--data P t a-  = Get (t -> P t a)-  | Look ([t] -> P t a)-  | Fail-  | Result a (P t a)-  | Final [(a,[t])] -- invariant: list is non-empty!-  deriving (Functor)---- Monad, MonadPlus--instance Applicative (P t) where-  pure x = Result x Fail-  (<*>)  = ap--instance Monad (P t) where-  return = pure--  (Get f)      >>= k = Get (\c -> f c >>= k)-  (Look f)     >>= k = Look (\s -> f s >>= k)-  Fail         >>= k = Fail-  (Result x p) >>= k = k x `mplus` (p >>= k)-  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]--  fail _ = Fail--instance Alternative (P t) where-  empty = mzero-  (<|>) = mplus--instance MonadPlus (P t) where-  mzero = Fail--  -- most common case: two gets are combined-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)--  -- results are delivered as soon as possible-  Result x p `mplus` q          = Result x (p `mplus` q)-  p          `mplus` Result x q = Result x (p `mplus` q)--  -- fail disappears-  Fail       `mplus` p          = p-  p          `mplus` Fail       = p--  -- two finals are combined-  -- final + look becomes one look and one final (=optimization)-  -- final + sthg else becomes one look and one final-  Final r    `mplus` Final t    = Final (r ++ t)-  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))-  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))-  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))-  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))--  -- two looks are combined (=optimization)-  -- look + sthg else floats upwards-  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)-  Look f     `mplus` p          = Look (\s -> f s `mplus` p)-  p          `mplus` Look f     = Look (\s -> p `mplus` f s)---- ------------------------------------------------------------------------------ The ReadP type--newtype ReadP t a = R (forall b . (a -> P t b) -> P t b)---- Functor, Monad, MonadPlus--instance Functor (ReadP t) where-  fmap h (R f) = R (\k -> f (k . h))--instance Applicative (ReadP t) where-  pure x = R (\k -> k x)-  (<*>)  = ap--instance Monad (ReadP t) where-  return    = pure-  fail _    = R (\_ -> Fail)-  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))--instance Alternative (ReadP t) where-  empty = mzero-  (<|>) = mplus--instance MonadPlus (ReadP t) where-  mzero = pfail-  mplus = (+++)---- ------------------------------------------------------------------------------ Operations over P--final :: [(a,[t])] -> P t a--- Maintains invariant for Final constructor-final [] = Fail-final r  = Final r--run :: P t a -> [t] -> [(a,[t])]-run (Get f)      (c:s) = run (f c) s-run (Look f)     s     = run (f s) s-run (Result x p) s     = (x,s) : run p s-run (Final r)    _     = r-run _            _     = []---- ------------------------------------------------------------------------------ Operations over ReadP---- | Run a parser on a list of tokens. Returns the list of complete matches.-parse :: ReadP t a -> [t] -> [a]-parse p ts = case complete p of-    R f -> map fst $ run (f return) ts--get :: ReadP t t--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = R Get--look :: ReadP t [t]--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = R Look--pfail :: ReadP t a--- ^ Always fails.-pfail = R (\_ -> Fail)--(+++) :: ReadP t a -> ReadP t a -> ReadP t a--- ^ Symmetric choice.-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)--(<++) :: ReadP t a -> ReadP t a -> ReadP t a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-R f <++ q =-  do s <- look-     probe (f return) s 0#- where-  probe (Get f)        (c:s) n = probe (f c) s (n+#1#)-  probe (Look f)       s     n = probe (f s) s n-  probe p@(Result _ _) _     n = discard n >> R (p >>=)-  probe (Final r)      _     _ = R (Final r >>=)-  probe _              _     _ = q--  discard 0# = return ()-  discard n  = get >> discard (n-#1#)--gather :: ReadP t a -> ReadP t ([t], a)--- ^ Transforms a parser into one that does the same, but---   in addition returns the exact characters read.---   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument---   is built using any occurrences of readS_to_P.-gather (R m) =-  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))- where-  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))-  gath l Fail         = Fail-  gath l (Look f)     = Look (\s -> gath l (f s))-  gath l (Result k p) = k (l []) `mplus` gath l p-  gath l (Final r)    = error "do not use readS_to_P in gather!"---- ------------------------------------------------------------------------------ Derived operations--satisfy :: (t -> Bool) -> ReadP t t--- ^ Consumes and returns the next character, if it satisfies the---   specified predicate.-satisfy p = do c <- get; if p c then return c else pfail--char :: Eq t => t-> ReadP t t--- ^ Parses and returns the specified character.-char c = satisfy (c ==)--string :: Eq t => [t] -> ReadP t [t]--- ^ Parses and returns the specified string.-string this = do s <- look; scan this s- where-  scan []     _               = do return this-  scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys-  scan _      _               = do pfail--eof :: ReadP tok ()-eof = do-    ts <- look-    unless (null ts) pfail--complete :: ReadP tok a -> ReadP tok a-complete p = do-    x <- p-    eof-    return x--munch :: (t -> Bool) -> ReadP t [t]--- ^ Parses the first zero or more characters satisfying the predicate.-munch p =-  do s <- look-     scan s- where-  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)-  scan _            = do return []--munch1 :: (t -> Bool) -> ReadP t [t]--- ^ Parses the first one or more characters satisfying the predicate.-munch1 p =-  do c <- get-     if p c then do s <- munch p; return (c:s) else pfail--choice :: [ReadP t a] -> ReadP t a--- ^ Combines all parsers in the specified list.-choice []     = pfail-choice [p]    = p-choice (p:ps) = p +++ choice ps--skipSpaces :: ReadP Char ()--- ^ Skips all whitespace.-skipSpaces =-  do s <- look-     skip s- where-  skip (c:s) | isSpace c = do _ <- get; skip s-  skip _                 = do return ()--count :: Int -> ReadP t a -> ReadP t [a]--- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of---   results is returned.-count n p = sequence (replicate n p)--between :: ReadP t open -> ReadP t close -> ReadP t a -> ReadP t a--- ^ @between open close p@ parses @open@, followed by @p@ and finally---   @close@. Only the value of @p@ is returned.-between open close p = do-  _ <- open-  x <- p-  _ <- close-  return x--option :: a -> ReadP t a -> ReadP t a--- ^ @option x p@ will either parse @p@ or return @x@ without consuming---   any input.-option x p = p +++ return x--optional :: ReadP t a -> ReadP t ()--- ^ @optional p@ optionally parses @p@ and always returns @()@.-optional p = (p >> return ()) +++ return ()--many :: ReadP t a -> ReadP t [a]--- ^ Parses zero or more occurrences of the given parser.-many p = return [] +++ many1 p--many1 :: ReadP t a -> ReadP t [a]--- ^ Parses one or more occurrences of the given parser.-many1 p = liftM2 (:) p (many p)--skipMany :: ReadP t a -> ReadP t ()--- ^ Like 'many', but discards the result.-skipMany p = many p >> return ()--skipMany1 :: ReadP t a -> ReadP t ()--- ^ Like 'many1', but discards the result.-skipMany1 p = p >> skipMany p--sepBy :: ReadP t a -> ReadP t sep -> ReadP t [a]--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy p sep = sepBy1 p sep +++ return []--sepBy1 :: ReadP t a -> ReadP t sep -> ReadP t [a]--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy1 p sep = liftM2 (:) p (many (sep >> p))--endBy :: ReadP t a -> ReadP t sep -> ReadP t [a]--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended---   by @sep@.-endBy p sep = many (do x <- p ; _ <- sep ; return x)--endBy1 :: ReadP t a -> ReadP t sep -> ReadP t [a]--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended---   by @sep@.-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)--chainr :: ReadP t a -> ReadP t (a -> a -> a) -> a -> ReadP t a--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /right/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainr p op x = chainr1 p op +++ return x--chainl :: ReadP t a -> ReadP t (a -> a -> a) -> a -> ReadP t a--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /left/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainl p op x = chainl1 p op +++ return x--chainr1 :: ReadP t a -> ReadP t (a -> a -> a) -> ReadP t a--- ^ Like 'chainr', but parses one or more occurrences of @p@.-chainr1 p op = scan-  where scan   = p >>= rest-        rest x = do f <- op-                    y <- scan-                    return (f x y)-                 +++ return x--chainl1 :: ReadP t a -> ReadP t (a -> a -> a) -> ReadP t a--- ^ Like 'chainl', but parses one or more occurrences of @p@.-chainl1 p op = p >>= rest-  where rest x = do f <- op-                    y <- p-                    rest (f x y)-                 +++ return x--manyTill :: ReadP t a -> ReadP t end -> ReadP t [a]--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@---   succeeds. Returns a list of values returned by @p@.-manyTill p end = scan-  where scan = (end >> return []) <++ (liftM2 (:) p scan)---- ------------------------------------------------------------------------------ Converting between ReadP and Read--readP_to_S :: ReadP Char a -> ReadS a--- ^ Converts a parser into a Haskell ReadS-style function.---   This is the main way in which you can \"run\" a 'ReadP' parser:---   the expanded type is--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @-readP_to_S (R f) = run (f return)--readS_to_P :: ReadS a -> ReadP Char a--- ^ Converts a Haskell ReadS-style function into a parser.---   Warning: This introduces local backtracking in the resulting---   parser, and therefore a possible inefficiency.-readS_to_P r =-  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))---- ------------------------------------------------------------------------------ A variant on parse which returns either a result, or the unparseable text.--run' :: P t a -> [t] -> Either a [t]-run' (Get f)           (c:s) = run' (f c) s-run' (Look f)          s     = run' (f s) s-run' (Result x _)      _     = Left x-run' (Final ((x,_):_)) _     = Left x-run' _                 s     = Right s--parse' :: ReadP t a -> [t] -> Either a [t]-parse' p ts = case complete p of-    R f -> run' (f return) ts---- ------------------------------------------------------------------------------ QuickCheck properties that hold for the combinators--{- $properties-The following are QuickCheck specifications of what the combinators do.-These can be seen as formal specifications of the behavior of the-combinators.--We use bags to give semantics to the combinators.-->  type Bag a = [a]--Equality on bags does not care about the order of elements.-->  (=~) :: Ord a => Bag a -> Bag a -> Bool->  xs =~ ys = sort xs == sort ys--A special equality operator to avoid unresolved overloading-when testing the properties.-->  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool->  (=~.) = (=~)--Here follow the properties:-->  prop_Get_Nil =->    readP_to_S get [] =~ []->->  prop_Get_Cons c s =->    readP_to_S get (c:s) =~ [(c,s)]->->  prop_Look s =->    readP_to_S look s =~ [(s,s)]->->  prop_Fail s =->    readP_to_S pfail s =~. []->->  prop_Return x s =->    readP_to_S (return x) s =~. [(x,s)]->->  prop_Bind p k s =->    readP_to_S (p >>= k) s =~.->      [ ys''->      | (x,s') <- readP_to_S p s->      , ys''   <- readP_to_S (k (x::Int)) s'->      ]->->  prop_Plus p q s =->    readP_to_S (p +++ q) s =~.->      (readP_to_S p s ++ readP_to_S q s)->->  prop_LeftPlus p q s =->    readP_to_S (p <++ q) s =~.->      (readP_to_S p s +<+ readP_to_S q s)->   where->    [] +<+ ys = ys->    xs +<+ _  = xs->->  prop_Gather s =->    forAll readPWithoutReadS $ \p ->->      readP_to_S (gather p) s =~->        [ ((pre,x::Int),s')->        | (x,s') <- readP_to_S p s->        , let pre = take (length s - length s') s->        ]->->  prop_String_Yes this s =->    readP_to_S (string this) (this ++ s) =~->      [(this,s)]->->  prop_String_Maybe this s =->    readP_to_S (string this) s =~->      [(this, drop (length this) s) | this `isPrefixOf` s]->->  prop_Munch p s =->    readP_to_S (munch p) s =~->      [(takeWhile p s, dropWhile p s)]->->  prop_Munch1 p s =->    readP_to_S (munch1 p) s =~->      [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]->->  prop_Choice ps s =->    readP_to_S (choice ps) s =~.->      readP_to_S (foldr (+++) pfail ps) s->->  prop_ReadS r s =->    readP_to_S (readS_to_P r) s =~. r s--}
src/full/Agda/Utils/PartialOrd.hs view
@@ -1,10 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Utils.PartialOrd where -import Data.Functor import Data.Maybe-import Data.List-import Data.Semigroup import Data.Set (Set) import qualified Data.Set as Set 
src/full/Agda/Utils/Permutation.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveDataTypeable    #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Utils.Permutation where  import Prelude hiding (drop, null) +import Control.DeepSeq+import Control.Monad (filterM)++import Data.Array.Unboxed import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.List hiding (drop, null)+import qualified Data.IntMap.Strict as IntMapS+import qualified Data.IntSet as IntSet+import Data.Functor.Identity import qualified Data.List as List import Data.Maybe-import Data.Array -import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-import Data.Typeable (Typeable)+import GHC.Generics (Generic) -import Agda.Syntax.Position (KillRange(..)) import Agda.Utils.Functor-import Agda.Utils.List ((!!!)) import Agda.Utils.Null import Agda.Utils.Size+import Agda.Utils.Tuple -#include "undefined.h" import Agda.Utils.Impossible  -- | Partial permutations. Examples:@@ -37,7 +37,7 @@ --   @Perm : {m : Nat}(n : Nat) -> Vec (Fin n) m -> Permutation@ --   @m@ is the 'size' of the permutation. data Permutation = Perm { permRange :: Int, permPicks :: [Int] }-  deriving (Eq, Typeable)+  deriving (Eq, Generic)  instance Show Permutation where   show (Perm n xs) = showx [0..n - 1] ++ " -> " ++ showx xs@@ -48,14 +48,14 @@           showList sep f (e:es) = f e ++ sep ++ showList sep f es  instance Sized Permutation where-  size (Perm _ xs) = size xs+  size    (Perm _ xs) = size xs+  natSize (Perm _ xs) = natSize xs  instance Null Permutation where   empty = Perm 0 []   null (Perm _ picks) = null picks -instance KillRange Permutation where-  killRange = id+instance NFData Permutation  -- | @permute [1,2,0] [x0,x1,x2] = [x1,x2,x0]@ --   More precisely, @permute indices list = sublist@, generates @sublist@@@ -64,15 +64,45 @@ -- --   Agda typing: --   @permute (Perm {m} n is) : Vec A m -> Vec A n@+--+-- Precondition for @'permute' ('Perm' _ is) xs@: Every index in @is@+-- must be non-negative and, if @xs@ is finite, then every index must+-- also be smaller than the length of @xs@.+--+-- The implementation is supposed to be extensionally equal to the+-- following one (if different exceptions are identified), but in some+-- cases more efficient:+-- @+--   permute ('Perm' _ is) xs = 'map' (xs 'Agda.Utils.List.!!') is+-- @ permute :: Permutation -> [a] -> [a]-permute p xs = map (fromMaybe __IMPOSSIBLE__) (safePermute p xs)--safePermute :: Permutation -> [a] -> [Maybe a]-safePermute (Perm _ is) xs = map (xs !!!!) is+permute (Perm _ is) xs = go mempty 0 xs is   where-    xs !!!! n | n < 0     = Nothing-              | otherwise = xs !!! n+  -- Computes the list of permuted elements.+  go :: IntMap a  -- A map from positions to elements that have+                  -- already been seen.+     -> Int       -- The number of elements that have been seen (the+                  -- size of the map).+     -> [a]       -- Elements that have not yet been seen.+     -> [Int]     -- Indices to process.+     -> [a]+  go seen !n xs []       = []+  go seen  n xs (i : is)+    | i < n     = fromMaybe __IMPOSSIBLE__+                    (IntMap.lookup i seen) :+                  go seen n xs is+    | otherwise = scan seen n xs (i - n) is +  -- Finds the element at the given position and continues.+  scan :: IntMap a -> Int -> [a] -> Int -> [Int] -> [a]+  scan seen !n (x : xs) !i is+    | i == 0 = x : (go $! seen') n' xs is+    | i > 0  = (scan $! seen') n' xs (i - 1) is+    where+    seen' = IntMap.insert n x seen+    n'    = n + 1+  scan seen n xs !_ is = __IMPOSSIBLE__ : go seen n xs is+ -- |  Invert a Permutation on a partial finite int map. -- @inversePermute perm f = f'@ -- such that @permute perm f' = f@@@ -101,7 +131,10 @@     where tabulate m = for [0..n-1] $ \ i -> IntMap.lookup i m  instance InversePermute (Int -> a) [Maybe a] where-  inversePermute (Perm n xs) f = for [0..n-1] $ \ x -> f <$> findIndex (x ==) xs+  inversePermute (Perm n xs) f =+    for [0..n-1] $ \i -> f <$> IntMap.lookup i m+    where+    m = IntMapS.fromListWith (flip const) $ zip xs [0..]  -- | Identity permutation. idP :: Int -> Permutation@@ -113,13 +146,17 @@  -- | Pick the elements that are not picked by the permutation. droppedP :: Permutation -> Permutation-droppedP (Perm n xs) = Perm n $ [0..n-1] \\ xs+droppedP (Perm n xs) = Perm n $ filter (notInXs !) [0 .. n - 1]+  where+  notInXs :: UArray Int Bool+  notInXs =+    accumArray (flip const) True (0, n - 1) (zip xs (repeat False))  -- | @liftP k@ takes a @Perm {m} n@ to a @Perm {m+k} (n+k)@. --   Analogous to 'Agda.TypeChecking.Substitution.liftS', --   but Permutations operate on de Bruijn LEVELS, not indices. liftP :: Int -> Permutation -> Permutation-liftP n (Perm m xs) = Perm (n + m) $ xs ++ [m..m+n-1]+liftP n (Perm m xs) = Perm (n + m) $ xs ++ [m .. m + n - 1] -- liftP n (Perm m xs) = Perm (n + m) $ [0..n-1] ++ map (n+) xs -- WRONG, works for indices, but not for levels  -- | @permute (compose p1 p2) == permute p1 . permute p2@@@ -142,16 +179,19 @@ --   @composeP p (invertP err p) == p@ invertP :: Int -> Permutation -> Permutation invertP err p@(Perm n xs) = Perm (size xs) $ elems tmpArray-  where tmpArray = accumArray (flip const) err (0, n-1) $ zip xs [0..]+  where+  -- This array cannot be unboxed, because it should be possible to+  -- instantiate err with __IMPOSSIBLE__.+  tmpArray :: Array Int Int+  tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..]  -- | Turn a possible non-surjective permutation into a surjective permutation. compactP :: Permutation -> Permutation-compactP (Perm n xs) = Perm m $ map adjust xs+compactP p@(Perm _ xs) = Perm (length xs) $ map adjust xs   where-    m            = genericLength xs-    missing      = [0..n - 1] \\ xs-    holesBelow k = genericLength $ filter (< k) missing-    adjust k = k - holesBelow k+  missing      = IntSet.fromList $ permPicks $ droppedP p+  holesBelow k = IntSet.size $ fst $ IntSet.split k missing+  adjust k     = k - holesBelow k  -- | @permute (reverseP p) xs == --    reverse $ permute p $ reverse xs@@@ -196,11 +236,15 @@ -- | Stable topologic sort. The first argument decides whether its first --   argument is an immediate parent to its second argument. topoSort :: (a -> a -> Bool) -> [a] -> Maybe Permutation-topoSort parent xs = fmap (Perm (size xs)) $ topo g+topoSort parent xs = runIdentity $ topoSortM (\x y -> Identity $ parent x y) xs++topoSortM :: Monad m => (a -> a -> m Bool) -> [a] -> m (Maybe Permutation)+topoSortM parent xs = do+  let nodes     = zip [0..] xs+      parents x = map fst <$> filterM (\(_, y) -> parent y x) nodes+  g <- mapM (mapSndM parents) nodes+  return $ Perm (size xs) <$> topo g   where-    nodes     = zip [0..] xs-    g         = [ (n, parents x) | (n, x) <- nodes ]-    parents x = [ n | (n, y) <- nodes, parent y x ]      topo :: Eq node => [(node, [node])] -> Maybe [node]     topo [] = return []@@ -222,10 +266,7 @@   { dropN    :: Int  -- ^ Non-negative number of things to drop.   , dropFrom :: a    -- ^ Where to drop from.   }-  deriving (Eq, Ord, Show, Typeable, Functor, Foldable, Traversable)--instance KillRange a => KillRange (Drop a) where-  killRange = fmap killRange+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  -- | Things that support delayed dropping. class DoDrop a where
− src/full/Agda/Utils/Pointer.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Agda.Utils.Pointer-  ( Ptr, newPtr, derefPtr, setPtr-  , updatePtr, updatePtrM-  ) where--import Control.Applicative-import Control.DeepSeq-import Control.Concurrent.MVar-import Data.Foldable-import Data.Function-import Data.Hashable-import Data.IORef-import Data.Traversable-import System.IO.Unsafe-import Data.Typeable ( Typeable )--data Ptr a = Ptr { ptrTag :: !Integer-                 , ptrRef :: !(IORef a) }-  deriving (Typeable)--{-# NOINLINE freshVar #-}-freshVar :: MVar Integer-freshVar = unsafePerformIO $ newMVar 0--fresh :: IO Integer-fresh = do-    x <- takeMVar freshVar-    putMVar freshVar $! x + 1-    return x--{-# NOINLINE newPtr #-}-newPtr :: a -> Ptr a-newPtr x = unsafePerformIO $ do-  i <- fresh-  Ptr i <$> newIORef x--derefPtr :: Ptr a -> a-derefPtr p = unsafePerformIO $ readIORef $ ptrRef p--{-# NOINLINE updatePtr #-}-updatePtr :: (a -> a) -> Ptr a -> Ptr a-updatePtr f p = unsafePerformIO $ p <$ modifyIORef (ptrRef p) f--setPtr :: a -> Ptr a -> Ptr a-setPtr !x = updatePtr (const x)---- | If @f a@ contains many copies of @a@ they will all be the same pointer in---   the result. If the function is well-behaved (i.e. preserves the implicit---   equivalence, this shouldn't matter).-updatePtrM :: Functor f => (a -> f a) -> Ptr a -> f (Ptr a)-updatePtrM f p = flip setPtr p <$> f (derefPtr p)--instance Show a => Show (Ptr a) where-  show p = "#" ++ show (ptrTag p) ++ "{" ++ show (derefPtr p) ++ "}"--instance Functor Ptr where-  fmap f = newPtr . f . derefPtr--instance Foldable Ptr where-  foldMap f = f . derefPtr--instance Traversable Ptr where-  traverse f p = newPtr <$> f (derefPtr p)--instance Eq (Ptr a) where-  (==) = (==) `on` ptrTag--instance Ord (Ptr a) where-  compare = compare `on` ptrTag--instance Hashable (Ptr a) where-  hashWithSalt salt = (hashWithSalt salt) . ptrTag--instance NFData (Ptr a) where rnf x = seq x ()
− src/full/Agda/Utils/Pretty.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}--{-| Pretty printing functions.--}-module Agda.Utils.Pretty-    ( module Agda.Utils.Pretty-    , module Text.PrettyPrint-    ) where--import Data.Int ( Int32 )--import Text.PrettyPrint hiding (TextDetails(Str), empty)---- * Pretty class---- | 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--  pretty      = prettyPrec 0-  prettyPrec  = const pretty---- | Use instead of 'show' when printing to world.--prettyShow :: Pretty a => a -> String-prettyShow = render . pretty---- | Space separated list of pretty things.--prettyList :: Pretty a => [a] -> Doc-prettyList = sep . map (prettyPrec 10000)---- * 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 Char where-  pretty c = text [c]--instance Pretty Doc where-  pretty = id--instance Pretty String where-  pretty = text---- * 'Doc' utilities--pwords :: String -> [Doc]-pwords = map text . words--fwords :: String -> Doc-fwords = fsep . pwords--mparens :: Bool -> Doc -> Doc-mparens True  = parens-mparens False = id---- | @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-
+ src/full/Agda/Utils/ProfileOptions.hs view
@@ -0,0 +1,113 @@++module Agda.Utils.ProfileOptions+  ( ProfileOption(..)+  , ProfileOptions+  , noProfileOptions+  , addProfileOption+  , containsProfileOption+  , profileOptionsToList+  , profileOptionsFromList+  , validProfileOptionStrings+  ) where++import Control.DeepSeq+import Control.Monad+import Data.List (intercalate)+import Data.Char (toLower)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import GHC.Generics (Generic)+import Text.EditDistance (restrictedDamerauLevenshteinDistance, defaultEditCosts)++import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null (Null, empty)++-- | Various things that can be measured when checking an Agda development. Turned on with+--   the `--profile` flag, for instance `--profile=sharing` to turn on the 'Sharing' option.+--   'Internal', 'Modules', and 'Definitions' are mutually exclusive.+--+--   NOTE: Changing this data type requires bumping the interface version number in+--   'Agda.TypeChecking.Serialise.currentInterfaceVersion'.+data ProfileOption = Internal     -- ^ Measure time taken by various parts of the system (type checking, serialization, etc)+                   | Modules      -- ^ Measure time spent on individual (Agda) modules+                   | Definitions  -- ^ Measure time spent on individual (Agda) definitions+                   | Sharing      -- ^ Measure things related to sharing+                   | Serialize    -- ^ Collect detailed statistics about serialization+                   | Constraints  -- ^ Collect statistics about constraint solving+                   | Metas        -- ^ Count number of created metavariables+                   | Interactive  -- ^ Measure time of interactive commands+                   | Conversion   -- ^ Collect statistics about conversion checking+                   | Instances    -- ^ Collect statistics about instance search+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance NFData ProfileOption++-- | A set of 'ProfileOption's+newtype ProfileOptions = ProfileOpts { unProfileOpts :: Set ProfileOption }+  deriving (Show, Eq, NFData, Null)++-- | The empty set of profiling options.+noProfileOptions :: ProfileOptions+noProfileOptions = empty++addAllProfileOptions :: ProfileOptions -> ProfileOptions+addAllProfileOptions (ProfileOpts opts) = ProfileOpts $ foldl ins opts [minBound..maxBound]+  where+    ins os o | any (incompatible o) os = os+             | otherwise               = Set.insert o os++-- | Strings accepted by 'addProfileOption'+validProfileOptionStrings :: [String]+validProfileOptionStrings = "all" : map optName [minBound .. maxBound :: ProfileOption]++parseOpt :: String -> Either String ProfileOption+parseOpt = \ s -> case Map.lookup s names of+    Nothing -> Left $ err s+    Just o  -> Right o+  where+    names = Map.fromList [ (optName o, o) | o <- [minBound .. maxBound] ]++    close s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t <= 3+    err  s = concat ["Not a valid profiling option: '", s, "'. ", hint s]+    hint s = case filter (close s) (Map.keys names) of+               [] -> concat [ "Valid options are ", intercalate ", " $ Map.keys names, ", or all." ]+               ss -> concat [ "Did you mean ", intercalate " or " ss, "?" ]++optName :: ProfileOption -> String+optName = map toLower . show++incompatible :: ProfileOption -> ProfileOption -> Bool+incompatible o1 o2+  | o1 == o2  = False+  | otherwise = any (\ set -> elem o1 set && elem o2 set) sets+  where+    sets = [[Internal, Modules, Definitions]]++-- | Parse and add a profiling option to a set of profiling options. Returns `Left` with a helpful+--   error message if the option doesn't parse or if it's incompatible with existing options.+--   The special string "all" adds all options compatible with the given set and prefering the first+--   of incompatible options. So `--profile=all` sets 'Internal' over 'Modules' and 'Definitions',+--   but `--profile=modules --profile=all` sets 'Modules' and not 'Internal'.+addProfileOption :: String -> ProfileOptions -> Either String ProfileOptions+addProfileOption "all" opts = pure $ addAllProfileOptions opts+addProfileOption s (ProfileOpts opts) = do+  o <- parseOpt s+  List1.ifNull (filter (incompatible o) $ Set.toList opts)+    {-then-}+    (return $ ProfileOpts $ Set.insert o opts)+    {-else-} $ \ conflicts ->+    Left $ concat ["Cannot use profiling option '", s, "' with '", optName $ List1.head $ conflicts, "'"]++-- | Check if a given profiling option is present in a set of profiling options.+containsProfileOption :: ProfileOption -> ProfileOptions -> Bool+containsProfileOption o (ProfileOpts opts) = Set.member o opts++-- | Use only for serialization.+profileOptionsToList :: ProfileOptions -> [ProfileOption]+profileOptionsToList (ProfileOpts opts) = Set.toList opts++-- | Use only for serialization.+profileOptionsFromList :: [ProfileOption] -> ProfileOptions+profileOptionsFromList opts = ProfileOpts $ Set.fromList opts
+ src/full/Agda/Utils/RangeMap.hs view
@@ -0,0 +1,370 @@+-- | Maps containing non-overlapping intervals.++module Agda.Utils.RangeMap+  ( IsBasicRangeMap(..)+  , several+  , PairInt(..)+  , RangeMap(..)+  , rangeMapInvariant+  , fromNonOverlappingNonEmptyAscendingList+  , insert+  , splitAt+  , insideAndOutside+  , restrictTo+  )+  where++import Prelude hiding (null, splitAt)++import Control.DeepSeq++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Data.Semigroup++import Data.Strict.Tuple (Pair(..))++import Agda.Interaction.Highlighting.Range+import Agda.Utils.List+import Agda.Utils.Null++------------------------------------------------------------------------+-- An abstraction++-- | A class that is intended to make it easy to swap between+-- different range map implementations.+--+-- Note that some 'RangeMap' operations are not included in this+-- class.++class IsBasicRangeMap a m | m -> a where++  -- | The map @'singleton' rs x@ contains the ranges from @rs@, and+  -- every position in those ranges is associated with @x@.++  singleton :: Ranges -> a -> m++  -- | Converts range maps to 'IntMap's from positions to values.++  toMap :: m -> IntMap a++  -- | Converts the map to a list. The ranges are non-overlapping and+  -- non-empty, and earlier ranges precede later ones in the list.++  toList :: m -> [(Range, a)]++  -- | Returns the smallest range covering everything in the map (or+  -- 'Nothing', if the range would be empty).+  --+  -- Note that the default implementation of this operation might be+  -- inefficient.++  coveringRange :: m -> Maybe Range+  coveringRange f = do+    min <- fst <$> IntMap.lookupMin m+    max <- fst <$> IntMap.lookupMax m+    return (Range { from = min, to = max + 1 })+    where+    m = toMap f++-- | Like 'singleton', but with several 'Ranges' instead of only one.++several ::+  (IsBasicRangeMap a hl, Monoid hl) =>+  [Ranges] -> a -> hl+several rss m = mconcat $ map (flip singleton m) rss++------------------------------------------------------------------------+-- A strict pair type++-- | A strict pair type where the first argument must be an 'Int'.+--+-- This type is included because there is no 'NFData' instance for+-- 'Pair' in the package @strict@ before version 4.++newtype PairInt a = PairInt (Pair Int a)+  deriving Show++instance NFData a => NFData (PairInt a) where+  rnf (PairInt (_ :!: y)) = rnf y++-- | Constructs a pair.++pair :: Int -> a -> PairInt a+pair x y = PairInt (x :!: y)++------------------------------------------------------------------------+-- The type++-- | Maps containing non-overlapping intervals.+--+-- The implementation does not use IntMap, because IntMap does not+-- come with a constant-time size function.+--+-- Note the invariant which 'RangeMap's should satisfy+-- ('rangeMapInvariant').++newtype RangeMap a = RangeMap+  { rangeMap :: Map Int (PairInt a)+    -- ^ The keys are starting points of ranges, and the pairs contain+    -- endpoints and values.+  }+  deriving (Show, NFData)++-- | Invariant for 'RangeMap'.+--+-- The ranges must not be empty, and they must not overlap.++rangeMapInvariant :: RangeMap a -> Bool+rangeMapInvariant f = and+  [ all rangeInvariant rs+  , all (not . null) rs+  , caseList rs True $ \ r rs' ->+      and $ zipWith (<=) (map to $ init1 r rs') (map from rs')+  ]+  where+  rs = map fst $ toList f++------------------------------------------------------------------------+-- Construction, conversion and inspection++instance Null (RangeMap a) where+  empty = RangeMap { rangeMap = Map.empty }+  null  = Map.null . rangeMap++instance IsBasicRangeMap a (RangeMap a) where+  singleton (Ranges rs) m =+    RangeMap { rangeMap = Map.fromDistinctAscList rms }+    where+    rms =+      [ (from r, pair (to r) m)+      | r <- rs+      , not (null r)+      ]++  toMap f =+    IntMap.fromList+      [ (p, m)+      | (r, m) <- toList f+      , p <- rangeToPositions r+      ]++  toList =+    map (\(f, PairInt (t :!: a)) -> (Range { from = f, to = t } , a)) .+    Map.toAscList .+    rangeMap++  coveringRange f = do+    min <- fst <$> Map.lookupMin (rangeMap f)+    max <- (\(_, PairInt (p :!: _)) -> p) <$> Map.lookupMax (rangeMap f)+    return (Range { from = min, to = max })++-- | Converts a list of pairs of ranges and values to a 'RangeMap'.+-- The ranges have to be non-overlapping and non-empty, and earlier+-- ranges have to precede later ones.++fromNonOverlappingNonEmptyAscendingList :: [(Range, a)] -> RangeMap a+fromNonOverlappingNonEmptyAscendingList =+  RangeMap .+  Map.fromDistinctAscList .+  map (\(r, m) -> (from r, pair (to r) m))++-- | The number of ranges in the map.+--+-- This function should not be exported.++size :: RangeMap a -> Int+size = Map.size . rangeMap++------------------------------------------------------------------------+-- Merging++-- | Inserts a value, along with a corresponding 'Range', into a+-- 'RangeMap'. No attempt is made to merge adjacent ranges with equal+-- values.+--+-- The function argument is used to combine values. The inserted value+-- is given as the first argument to the function.++insert :: (a -> a -> a) -> Range -> a -> RangeMap a -> RangeMap a+insert combine r m (RangeMap f)+  | null r    = RangeMap f+  | otherwise =+    case equal of+      Just (PairInt (p :!: m')) ->+        case compare (to r) p of+          EQ ->+            -- The range r matches exactly.+            RangeMap $+            Map.insert (from r) (pair p (combine m m')) f+          LT ->+            -- The range r is strictly shorter.+            RangeMap $+            Map.insert (to r) (pair p m') $+            Map.insert (from r) (pair (to r) (combine m m')) f+          GT ->+            -- The range r is strictly longer. Continue recursively.+            insert combine (Range { from = p, to = to r }) m $+            RangeMap $+            Map.insert (from r) (pair p (combine m m')) f+      Nothing ->+        -- Find the part of r that does not overlap with anything in+        -- smaller or larger, if any.+        case (overlapLeft, overlapRight) of+          (Nothing, Nothing) ->+            -- No overlap.+            RangeMap $+            Map.insert (from r) (pair (to r) m) f+          (Nothing, Just p) ->+            -- Overlap on the right. Continue recursively.+            insert combine (Range { from = p, to = to r }) m $+            RangeMap $+            Map.insert (from r) (pair p m) f+          (Just (p1, PairInt (p2 :!: m')), Just p3) ->+            -- Overlap on both sides. Continue recursively.+            insert combine (Range { from = p3, to = to r }) m $+            RangeMap $+            (if p2 == p3 then+               -- The left range ends exactly where the right range+               -- starts.+               id+             else+               -- There is something between the left and right+               -- ranges.+               Map.insert p2 (pair p3 m)) $+            Map.insert (from r) (pair p2 (combine m m')) $+            Map.insert p1 (pair (from r) m') f+          (Just (p1, PairInt (p2 :!: m')), Nothing) ->+            case compare p2 (to r) of+              LT ->+                -- Overlap on the left, the left range ends before r.+                RangeMap $+                Map.insert p2 (pair (to r) m) $+                Map.insert (from r) (pair p2 (combine m m')) $+                Map.insert p1 (pair (from r) m') f+              EQ ->+                -- Overlap on the left, the left range ends where r+                -- ends.+                RangeMap $+                Map.insert (from r) (pair (to r) (combine m m')) $+                Map.insert p1 (pair (from r) m') f+              GT ->+                -- Overlap on the left, the left range ends after r.+                RangeMap $+                Map.insert (to r) (pair p2 m') $+                Map.insert (from r) (pair (to r) (combine m m')) $+                Map.insert p1 (pair (from r) m') f+    where+    (smaller, equal, larger) = Map.splitLookup (from r) f++    overlapRight = case Map.lookupMin larger of+      Nothing -> Nothing+      Just (from, _)+        | from < to r -> Just from+        | otherwise   -> Nothing++    overlapLeft = case Map.lookupMax smaller of+      Nothing -> Nothing+      Just s@(_, PairInt (to :!: _))+        | from r < to -> Just s+        | otherwise   -> Nothing++-- | Merges 'RangeMap's by inserting every \"piece\" of the smaller+-- one into the larger one.++instance Semigroup a => Semigroup (RangeMap a) where+  f1 <> f2+    | size f1 <= size f2 =+      foldr (uncurry $ insert (<>)) f2 (toList f1)+    | otherwise =+      foldr (uncurry $ insert (flip (<>))) f1 (toList f2)++-- | Merges 'RangeMap's by inserting every \"piece\" of the smaller+-- one into the larger one.++instance Semigroup a => Monoid (RangeMap a) where+  mempty  = empty+  mappend = (<>)++------------------------------------------------------------------------+-- Splitting++-- | The value of @'splitAt' p f@ is a pair @(f1, f2)@ which contains+-- everything from @f@. All the positions in @f1@ are less than @p@,+-- and all the positions in @f2@ are greater than or equal to @p@.++splitAt :: Int -> RangeMap a -> (RangeMap a, RangeMap a)+splitAt p f = (before, after)+  where+  (before, _, after) = splitAt' p f++-- | A variant of 'splitAt'. If a range in the middle was split into+-- two pieces, then those two pieces are returned.++splitAt' ::+  Int -> RangeMap a ->+  ( RangeMap a+  , Maybe ((Int, PairInt a), (Int, PairInt a))+  , RangeMap a+  )+splitAt' p (RangeMap f) =+  case equal of+    Just r  -> ( RangeMap maybeOverlapping+               , Nothing+               , RangeMap (Map.insert p r larger)+               )+    Nothing ->+      -- Check if maybeOverlapping overlaps with p.+      case Map.maxViewWithKey maybeOverlapping of+        Nothing ->+          (empty, Nothing, RangeMap larger)+        Just ((from, PairInt (to :!: m)), smaller)+          | to <= p ->+            ( RangeMap maybeOverlapping+            , Nothing+            , RangeMap larger+            )+          | otherwise ->+            -- Here from < p < to.+            ( RangeMap (Map.insert from (pair p m) smaller)+            , Just ((from, pair p m), (p, pair to m))+            , RangeMap (Map.insert p (pair to m) larger)+            )+  where+  (maybeOverlapping, equal, larger) = Map.splitLookup p f++-- | Returns a 'RangeMap' overlapping the given range, as well as the+-- rest of the map.++insideAndOutside :: Range -> RangeMap a -> (RangeMap a, RangeMap a)+insideAndOutside r f+  | from r == to r = (empty, f)+  | otherwise      =+    ( middle+    , -- Because it takes so long to recompile Agda with all+      -- optimisations and run a benchmark no experimental+      -- verification has been made that the code below is better than+      -- reasonable variants. Perhaps it would make sense to benchmark+      -- RangeMap independently of Agda.+      if size before < size middle || size after < size middle then+        RangeMap $ Map.union (rangeMap before) (rangeMap after)+      else+        -- If the number of pieces in the middle is "small", remove+        -- the pieces from f instead of merging before and after.+        RangeMap $+        maybe id (uncurry Map.insert . snd) split1 $+        maybe id (uncurry Map.insert . fst) split2 $+        Map.difference (rangeMap f) (rangeMap middle)+    )+  where+  (beforeMiddle, split1, after) = splitAt' (to r) f+  (before, split2, middle)      = splitAt' (from r) beforeMiddle++-- | Restricts the 'RangeMap' to the given range.++restrictTo :: Range -> RangeMap a -> RangeMap a+restrictTo r = fst . insideAndOutside r
src/full/Agda/Utils/SemiRing.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Utils.SemiRing where  -- | Semirings (<https://en.wikipedia.org/wiki/Semiring>).@@ -8,6 +10,12 @@   oplus  :: a -> a -> a   otimes :: a -> a -> a +instance SemiRing () where+  ozero      = ()+  oone       = ()+  oplus  _ _ = ()+  otimes _ _ = ()+ instance SemiRing a => SemiRing (Maybe a) where   ozero = Nothing   oone  = Just oone@@ -25,6 +33,9 @@  class SemiRing a => StarSemiRing a where   ostar :: a -> a++instance StarSemiRing () where+  ostar _ = ()  instance StarSemiRing a => StarSemiRing (Maybe a) where   ostar Nothing  = oone
+ src/full/Agda/Utils/Semigroup.hs view
@@ -0,0 +1,35 @@+-- | Some semigroup instances used in several places++module Agda.Utils.Semigroup (+  module Data.Semigroup)+where++import Data.Semigroup ( Semigroup, (<>) )++import Control.Applicative (liftA2)++import Control.Monad.Except (ExceptT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State  (StateT)+import Control.Monad.Writer (WriterT)+import Control.Monad.Trans.Maybe (MaybeT)++instance (Monad m, Semigroup doc)       => Semigroup (ExceptT e m doc) where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)++instance (Monad m, Semigroup doc)       => Semigroup (MaybeT m doc) where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)++instance (Applicative m, Semigroup doc) => Semigroup (ReaderT s m doc) where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)++instance (Monad m, Semigroup doc)       => Semigroup (StateT s m doc)  where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)++instance (Monad m, Semigroup doc, Monoid w) => Semigroup (WriterT w m doc)  where+  {-# INLINE (<>) #-}+  (<>) = liftA2 (<>)
+ src/full/Agda/Utils/Set1.hs view
@@ -0,0 +1,41 @@+-- | Non-empty sets.+--+--   Provides type @Set1@ of non-empty sets.+--+--   Import:+--   @+--+--     import           Agda.Utils.Set1 (Set1)+--     import qualified Agda.Utils.Set1 as Set1+--+--   @++module Agda.Utils.Set1+  ( module Agda.Utils.Set1+  , module Set1+  ) where++import Data.Set (Set, empty)+import Data.Set.NonEmpty as Set1++type Set1 = Set1.NESet++ifNull :: Set a -> b -> (Set1 a -> b) -> b+ifNull s b f = Set1.withNonEmpty b f s++-- | Lossless 'toSet'.  Opposite of 'nonEmptySet'.++toSet' :: Maybe (Set1 a) -> Set a+toSet' = maybe empty toSet++-- | A more general type would be @Null m => Set a -> (Set1 a -> m) -> m@+--   but this type is problematic as we do not have a general+--   @instance Applicative m => Null (m ())@.+--+unlessNull :: Applicative m => Set a -> (Set1 a -> m ()) -> m ()+unlessNull = flip $ Set1.withNonEmpty $ pure ()+{-# INLINE unlessNull #-}++unlessNullM :: Monad m => m (Set a) -> (Set1 a -> m ()) -> m ()+unlessNullM m k = m >>= (`unlessNull` k)+{-# INLINE unlessNullM #-}
src/full/Agda/Utils/Singleton.hs view
@@ -1,16 +1,25 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- {-# LANGUAGE TypeFamilies #-}  -- | Constructing singleton collections.  module Agda.Utils.Singleton where +import Data.Semigroup (Semigroup(..))+import Data.Maybe+import Data.Monoid (Endo(..))++import Data.DList (DList)+import qualified Data.DList as DL import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet+import Data.List.NonEmpty (NonEmpty(..)) +import Data.EnumMap (EnumMap)+import qualified Data.EnumMap as EnumMap+import Data.EnumSet (EnumSet)+import qualified Data.EnumSet as EnumSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet)@@ -22,22 +31,72 @@ import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set+import Data.Set.NonEmpty (NESet)+import qualified Data.Set.NonEmpty as Set1 +import Agda.Utils.Null     (Null, empty)+import Agda.Utils.SmallSet (SmallSet, SmallSetElement)+import qualified Agda.Utils.SmallSet as SmallSet++-- | A create-only possibly empty collection is a monoid with the possibility+--   to inject elements.++class (Semigroup coll, Monoid coll, Singleton el coll) => Collection el coll+    | coll -> el where+  fromList :: [el] -> coll+  fromList = mconcat . map singleton++instance Collection a        [a]          where fromList = id+instance Collection a        ([a] -> [a]) where fromList = (++)+instance Collection a        (Endo [a])   where fromList = Endo . fromList+instance Collection a        (DList a)    where fromList = DL.fromList+instance Collection a        (Seq a)      where fromList = Seq.fromList+instance Collection Int      IntSet       where fromList = IntSet.fromList+instance Collection (Int, a) (IntMap a)   where fromList = IntMap.fromList++instance Enum k             => Collection k      (EnumSet k)   where fromList = EnumSet.fromList+instance Enum k             => Collection (k, a) (EnumMap k a) where fromList = EnumMap.fromList+instance (Eq k, Hashable k) => Collection k      (HashSet k)   where fromList = HashSet.fromList+instance (Eq k, Hashable k) => Collection (k, a) (HashMap k a) where fromList = HashMap.fromList+instance Ord k              => Collection k      (Set k)       where fromList = Set.fromList+instance Ord k              => Collection (k, a) (Map k a)     where fromList = Map.fromList+instance SmallSetElement k  => Collection k      (SmallSet k)  where fromList = SmallSet.fromList++-- | Create-only collection with at most one element.++class (Null coll, Singleton el coll) => CMaybe el coll | coll -> el where+  cMaybe :: Maybe el -> coll+  cMaybe = maybe empty singleton++instance CMaybe a (Maybe a) where cMaybe = id+instance CMaybe a [a]       where cMaybe = maybeToList++-- | Overloaded @singleton@ constructor for collections.+ class Singleton el coll | coll -> el where   singleton :: el -> coll -instance Singleton a   (Maybe a)   where singleton = Just-instance Singleton a   [a]         where singleton = (:[])-instance Singleton a   (Seq a)     where singleton = Seq.singleton-instance Singleton a   (Set a)     where singleton = Set.singleton-instance Singleton Int IntSet      where singleton = IntSet.singleton+instance Singleton a   (Maybe a)    where singleton = Just+instance Singleton a   [a]          where singleton = (:[])+instance Singleton a   ([a] -> [a]) where singleton = (:)+instance Singleton a   (Endo [a])   where singleton = Endo . (:)+instance Singleton a   (DList a)    where singleton = DL.singleton+instance Singleton a   (NESet a)    where singleton = Set1.singleton+instance Singleton a   (NonEmpty a) where singleton = (:| [])+instance Singleton a   (Seq a)      where singleton = Seq.singleton+instance Singleton a   (Set a)      where singleton = Set.singleton+instance Singleton Int IntSet       where singleton = IntSet.singleton -instance Singleton (k  ,a) (Map  k a) where singleton = uncurry Map.singleton-instance Singleton (Int,a) (IntMap a) where singleton = uncurry IntMap.singleton+instance Enum a            => Singleton a (EnumSet  a) where singleton = EnumSet.singleton+instance SmallSetElement a => Singleton a (SmallSet a) where singleton = SmallSet.singleton -instance Hashable a => Singleton a     (HashSet   a) where singleton = HashSet.singleton-instance Hashable k => Singleton (k,a) (HashMap k a) where singleton = uncurry HashMap.singleton+instance Singleton (k  ,a) (Map  k a)                  where singleton = uncurry Map.singleton+instance Singleton (Int,a) (IntMap a)                  where singleton = uncurry IntMap.singleton +instance Hashable k => Singleton k     (HashSet   k)   where singleton = HashSet.singleton+instance Hashable k => Singleton (k,a) (HashMap k a)   where singleton = uncurry HashMap.singleton+instance Enum k     => Singleton (k,a) (EnumMap k a)   where singleton = uncurry EnumMap.singleton+ -- Testing newtype-deriving:  -- newtype Wrap c = Wrap c@@ -67,4 +126,3 @@  -- newtype Wrap a = Wrap a --   deriving (Singleton)  -- Fails-
src/full/Agda/Utils/Size.hs view
@@ -6,59 +6,60 @@   ( Sized(..)   , SizedThing(..)   , sizeThing+  , module X   ) where -import Prelude hiding (null)+import Prelude hiding (null, length) +import Data.Peano as X     ( Peano(Zero,Succ) )+import Data.Foldable       (Foldable, length) import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)+import Data.HashSet        (HashSet)+import Data.IntMap         (IntMap)+import Data.IntSet         (IntSet) import qualified Data.IntSet as IntSet-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import qualified Data.List as List+import Data.Map            (Map)+import Data.Set            (Set)+import Data.Sequence       (Seq) +import Agda.Utils.List1    (List1) import Agda.Utils.Null  -- | The size of a collection (i.e., its length).------   Should fit into an @Int@.  TODO: change to @Int@.  class Sized a where-  size :: Integral n => a -> n--instance Sized [a] where-  size = List.genericLength--instance Sized (IntMap a) where-  size = fromIntegral . IntMap.size--instance Sized IntSet where-  size = fromIntegral . IntSet.size--instance Sized (Map k a) where-  size = fromIntegral . Map.size--instance Sized (Set a) where-  size = fromIntegral . Set.size+  -- | Strict size computation.+  --+  -- Anti-patterns: @size xs == n@ where @n@ is @0@, @1@ or another number+  -- that is likely smaller than @size xs@.+  -- Similar for @size xs >= 1@ etc.+  -- Use 'natSize' instead.+  --+  -- See https://wiki.haskell.org/Haskell_programming_tips#Don.27t_ask_for_the_length_of_a_list_when_you_don.27t_need_it .+  size :: a -> Int -instance Sized (HashMap k a) where-  size = fromIntegral . HashMap.size+  default size :: (Foldable t, t b ~ a) => a -> Int+  size = length -instance Sized (HashSet a) where-  size = fromIntegral . HashSet.size+  -- | Lazily compute a (possibly infinite) size.+  --+  -- Use when comparing a size against a fixed number.+  natSize :: a -> Peano -instance Sized (Seq a) where-  size = fromIntegral . Seq.length+  default natSize :: (Foldable t, t b ~ a) => a -> Peano+  natSize = foldr (const Succ) Zero +instance Sized [a]+instance Sized (Set a)+instance Sized (HashMap k a)+instance Sized (HashSet a)+instance Sized (IntMap a)+instance Sized (List1 a)+instance Sized (Map k a)+instance Sized (Seq a)+instance Sized IntSet where+  size = IntSet.size+  natSize = toEnum . size  -- | Thing decorated with its size. --   The thing should fit into main memory, thus, the size is an @Int@.@@ -74,7 +75,8 @@  -- | Return the cached size. instance Sized (SizedThing a) where-  size = fromIntegral . theSize+  size = theSize+  natSize = toEnum . theSize  instance Null a => Null (SizedThing a) where   empty = SizedThing 0 empty
+ src/full/Agda/Utils/SmallSet.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wunused-imports #-}++-- | Small sets represented as a bitmask for fast membership checking.+--+-- With the exception of converting to/from lists, all operations are O(1).+--+-- Mimics the interface of 'Data.Set'.+--+-- Import as:+-- @+--    import qualified Agda.Utils.SmallSet as SmallSet+--    import Agda.Utils.SmallSet (SmallSet)+-- @++module Agda.Utils.SmallSet+  ( SmallSet(..)+  , SmallSetElement+  , Ix+  , (\\)+  , complement+  , delete+  , difference+  , elems+  , empty+  , fromList, fromAscList, fromDistinctAscList+  , insert+  , intersection+  , member+  , notMember+  , null+  , singleton+  , toList, toAscList+  , total+  , union+  ) where++import Prelude hiding (null)++import Control.DeepSeq++import Data.Word (Word64)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Bits hiding (complement)+import qualified Data.Bits as Bits+import Data.Ix++import qualified Agda.Utils.Null as Null++-- | An element in a small set.+--+-- This must implement 'Bounded' and 'Ix', and contain at most 64 values.+class (Bounded a, Ix a) => SmallSetElement a where++newtype SmallSet a = SmallSet { theSmallSet :: Word64 }+  deriving (Eq, Ord, Show, NFData)+++instance SmallSetElement a => Null.Null (SmallSet a) where+  empty = empty+  null = null++instance SmallSetElement a => Semigroup (SmallSet a) where+  (<>) = union++instance SmallSetElement a => Monoid (SmallSet a) where+  mempty = empty++-- * Query++-- | Time O(1).+null :: SmallSetElement a => SmallSet a -> Bool+null s = theSmallSet s == 0++-- | Time O(1).+member :: SmallSetElement a => a -> SmallSet a -> Bool+member a s = theSmallSet s `testBit` idx a++-- | @not . member a@.  Time O(1).+notMember :: SmallSetElement a => a -> SmallSet a -> Bool+notMember a = not . member a++-- * Construction++-- | The empty set.  Time O(1).+empty :: SmallSetElement a => SmallSet a+empty = SmallSet 0++-- | The full set.  Time O(1).+total :: forall a. SmallSetElement a => SmallSet a+total = SmallSet $ Bits.complement 0++-- | A singleton set.  Time O(1).+singleton :: SmallSetElement a => a -> SmallSet a+singleton a = SmallSet $ bit (idx a)++-- | Time O(1).+insert :: SmallSetElement a => a -> SmallSet a -> SmallSet a+insert a s = SmallSet $ theSmallSet s `setBit` idx a++-- | Time O(1).+delete :: SmallSetElement a => a -> SmallSet a -> SmallSet a+delete a s = SmallSet $ theSmallSet s `clearBit` idx a++-- * Combine++-- | Time O(n).+complement :: SmallSetElement a => SmallSet a -> SmallSet a+complement = SmallSet . Bits.complement . theSmallSet++-- | Time O(1).+difference, (\\) :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a+difference s t = SmallSet $ theSmallSet s .&. Bits.complement (theSmallSet t)+(\\)       = difference++-- | Time O(1).+intersection ::  SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a+intersection s t = SmallSet $ theSmallSet s .&. theSmallSet t++-- | Time O(n).+union ::  SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a+union s t = SmallSet $ theSmallSet s .|. theSmallSet t++-- * Conversion++-- | Time O(n).+elems, toList, toAscList :: SmallSetElement a => SmallSet a -> [a]+elems s   = filter (\i -> theSmallSet s `testBit` idx i) (range bounds)+toList    = elems+toAscList = elems++-- | Time O(n).+fromList, fromAscList, fromDistinctAscList :: SmallSetElement a => [a] -> SmallSet a+fromList            = foldl' (flip insert) empty+fromAscList         = fromList+fromDistinctAscList = fromList++-- * Internals++bounds :: SmallSetElement a => (a, a)+bounds = (minBound, maxBound)++idx :: SmallSetElement a => a -> Int+idx a = index bounds a
src/full/Agda/Utils/String.hs view
@@ -1,12 +1,25 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Utils.String where -import Data.Char-import Data.List+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Writer -import Numeric+import Data.Char+import qualified Data.List as List+import Data.String +import Agda.Utils.Function (applyUnless) import Agda.Utils.List+import Agda.Utils.List1 (String1, fromList)+import Agda.Utils.Size  (Sized, natSize) +instance IsString String1 where+  fromString = fromList+ -- | 'quote' adds double quotes around the string, replaces newline -- characters with @\n@, and escapes double quotes and backslashes -- within the string. This is different from the behaviour of 'show':@@ -28,37 +41,65 @@            | c `elem` escapeChars = ['\\', c]            | otherwise            = [c] +  escapeChars :: String   escapeChars = "\"\\" --- | Shows a non-negative integer using the characters ₀-₉ instead of--- 0-9.+-- | Turns the string into a Haskell string literal, avoiding escape+-- codes. -showIndex :: (Show i, Integral i) => i -> String-showIndex n =-  showIntAtBase 10 (\i -> toEnum (i + fromEnum '\x2080')) n ""+haskellStringLiteral :: String -> String+haskellStringLiteral s = "\"" ++ concatMap escape s ++ "\""+  where+  escape c | c == '\n'         = "\\n"+           | c == '"'          = "\\\""+           | c == '\\'         = "\\\\"+           | ok c              = [c]+           | otherwise         = [c] +  ok c = case generalCategory c of+    UppercaseLetter -> True+    LowercaseLetter -> True+    TitlecaseLetter -> True+    _               -> isSymbol c || isPunctuation c++-- | Adds hyphens around the given string+--+-- >>> putStrLn $ delimiter "Title"+-- ———— Title —————————————————————————————————————————————————++delimiter :: String -> String+delimiter s = concat [ replicate 4 '\x2014'+                     , " ", s, " "+                     , replicate (54 - length s) '\x2014'+                     ]+ -- | Adds a final newline if there is not already one.  addFinalNewLine :: String -> String addFinalNewLine "" = "\n"-addFinalNewLine s | last s == '\n' = s-                  | otherwise      = s ++ "\n"+addFinalNewLine s@(c:cs)+  | last1 c cs == '\n' = s+  | otherwise          = s ++ "\n"  -- | Indents every line the given number of steps.  indent :: Integral i => i -> String -> String-indent i = unlines . map (genericReplicate i ' ' ++) . lines+indent i = unlines . map (List.genericReplicate i ' ' ++) . lines -newtype Str = Str { unStr :: String }-  deriving Eq+-- | 'unwords', but remove empty words first. -instance Show Str where-  show = unStr+unwords1 :: [String] -> String+unwords1 = unwords . filter (not . null) +-- | Append an @"s"@ to the second argument if the first has cardinality @/= 1@.++pluralS :: Sized a => a -> String -> String+pluralS xs = applyUnless (natSize xs == 1) (++ "s")+ -- | Show a number using comma to separate powers of 1,000.  showThousandSep :: Show a => a -> String-showThousandSep = reverse . intercalate "," . chop 3 . reverse . show+showThousandSep = reverse . List.intercalate "," . chop 3 . reverse . show  -- | Remove leading whitespace. ltrim :: String -> String@@ -66,8 +107,23 @@  -- | Remove trailing whitespace. rtrim :: String -> String-rtrim = reverse . ltrim . reverse+rtrim = List.dropWhileEnd isSpace  -- | Remove leading and trailing whitesapce. trim :: String -> String trim = rtrim . ltrim++instance (IsString (m a), Monad m) => IsString (ExceptT e m a) where+  fromString = lift . fromString++instance (IsString (m a), Monad m) => IsString (MaybeT m a) where+  fromString = lift . fromString++instance (IsString (m a), Monad m) => IsString (ReaderT r m a) where+  fromString = lift . fromString++instance (IsString (m a), Monad m) => IsString (StateT s m a) where+  fromString = lift . fromString++instance (IsString (m a), Monad m, Monoid w) => IsString (WriterT w m a) where+  fromString = lift . fromString
src/full/Agda/Utils/Suffix.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Utils.Suffix where  import Data.Char--import Agda.Utils.Function+import qualified Data.List as List -#include "undefined.h" import Agda.Utils.Impossible  ------------------------------------------------------------------------@@ -17,7 +15,7 @@ isSubscriptDigit :: Char -> Bool isSubscriptDigit c = '₀' <= c && c <= '₉' --- | Converts @'0'@-@'9'@ to @'₀'@-@'₉'@.+-- | Converts @'0'@-@'9'@ to @'₀'@-@'₉'@ -- -- Precondition: The digit needs to be in range. @@ -32,8 +30,7 @@  fromSubscriptDigit :: Char -> Char fromSubscriptDigit d-  | isSubscriptDigit d =-      toEnum (fromEnum '0' + (fromEnum d - fromEnum '₀'))+  | isSubscriptDigit d = toEnum (fromEnum '0' + (fromEnum d - fromEnum '₀'))   | otherwise          = __IMPOSSIBLE__  ------------------------------------------------------------------------@@ -42,46 +39,44 @@ -- | Classification of identifier variants.  data Suffix-  = NoSuffix-  | Prime     Int  -- ^ Identifier ends in @Int@ many primes.-  | Index     Int  -- ^ Identifier ends in number @Int@ (ordinary digits).-  | Subscript Int  -- ^ Identifier ends in number @Int@ (subscript digits).+  = Prime     Integer  -- ^ Identifier ends in @Integer@ many primes.+  | Index     Integer  -- ^ Identifier ends in number @Integer@ (ordinary digits).+  | Subscript Integer  -- ^ Identifier ends in number @Integer@ (subscript digits). --- | Increase the suffix by one.  If no suffix yet, put a subscript @1@.+-- | Increase the suffix by one.  nextSuffix :: Suffix -> Suffix-nextSuffix NoSuffix      = Subscript 1 nextSuffix (Prime i)     = Prime $ i + 1 nextSuffix (Index i)     = Index $ i + 1 nextSuffix (Subscript i) = Subscript $ i + 1  -- | Parse suffix. -suffixView :: String -> (String, Suffix)+suffixView :: String -> (String, Maybe Suffix) suffixView s-    | (ps@(_:_), s') <- span (=='\'') rs         = (reverse s', Prime $ length ps)-    | (ns@(_:_), s') <- span isDigit rs          = (reverse s', Index $ read $ reverse ns)-    | (ns@(_:_), s') <- span isSubscriptDigit rs = (reverse s',-                                                    Subscript $ read $+    | (ps@(_:_), s') <- span (== '\'') rs        = (reverse s', Just $ Prime $ List.genericLength ps)+    | (ns@(_:_), s') <- span isDigit rs          = (reverse s', Just $ Index $ read $ reverse ns)+    | (ns@(_:_), s') <- span isSubscriptDigit rs = (reverse s', Just $ Subscript $ read $                                                       map fromSubscriptDigit $ reverse ns)-    | otherwise                                  = (s, NoSuffix)+    | otherwise                                  = (s, Nothing)     where rs = reverse s --- | Print suffix.+-- Note: suffixView could be implemented using spanEnd, but the implementation using reverse+-- looks more efficient, since the reversal is only done once.+--+-- suffixView :: String -> (String, Maybe Suffix)+-- suffixView s+--     | (s', ps@(_:_)) <- spanEnd (=='\'') s         = (s', Just $ Prime $ length ps)+--     | (s', ns@(_:_)) <- spanEnd isDigit s          = (s', Just $ Index $ read ns)+--     | (s', ns@(_:_)) <- spanEnd isSubscriptDigit s = (s', Just $ Subscript $ read $ map fromSubscriptDigit ns)+--     | otherwise                                    = (s, Nothing) -addSuffix :: String -> Suffix -> String-addSuffix s NoSuffix      = s-addSuffix s (Prime n)     = s ++ replicate n '\''-addSuffix s (Index i)     = s ++ show i-addSuffix s (Subscript i) = s ++ map toSubscriptDigit (show i)+-- | Print suffix. --- | Add first available @Suffix@ to a name.+renderSuffix :: Suffix -> String+renderSuffix (Prime n)     = List.genericReplicate n '\''+renderSuffix (Index i)     = show i+renderSuffix (Subscript i) = map toSubscriptDigit (show i) -nameVariant-  :: (String -> Bool) -- ^ Is the given name already taken?-  -> String           -- ^ Name of which we want an available variant.-  -> String           -- ^ Name extended by suffix that is not taken already.-nameVariant taken x = addSuffix x $ trampoline step $ Prime 0-  where-    -- if the current suffix is taken, repeat with next suffix, else done-    step s = if taken (addSuffix x s) then Right (nextSuffix s) else Left s+addSuffix :: String -> Suffix -> String+addSuffix str suffix = str ++ renderSuffix suffix
+ src/full/Agda/Utils/Three.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Tools for 3-way partitioning.++module Agda.Utils.Three where++-- | Enum type with 3 elements.+--+data Three+  = One+  | Two+  | Three+  deriving (Eq, Ord, Show, Bounded, Enum)++-- | Partition a list into 3 groups.+--+--   Preserves the relative order or elements.+--+partition3 :: (a -> Three) -> [a] -> ([a], [a], [a])+partition3  f = loop where+  loop []     = ([], [], [])+  loop (x:xs) = case f x of+      One   -> (x:as, bs, cs)+      Two   -> (as, x:bs, cs)+      Three -> (as, bs, x:cs)+    where (as, bs, cs) = loop xs++-- | Disjoint sum of three.+--+data Either3 a b c+  = In1 a+  | In2 b+  | In3 c+  deriving (Eq, Ord, Show)++-- | Partition a list into 3 groups.+--+--   Preserves the relative order or elements.+--+partitionEithers3 :: [Either3 a b c] -> ([a], [b], [c])+partitionEithers3 = \case+  []     -> ([], [], [])+  (x:xs) -> case x of+      In1 a -> (a:as, bs, cs)+      In2 b -> (as, b:bs, cs)+      In3 c -> (as, bs, c:cs)+    where (as, bs, cs) = partitionEithers3 xs++mapEither3M :: Applicative m => (a -> m (Either3 b c d)) -> [a] -> m ([b], [c], [d])+mapEither3M f xs = partitionEithers3 <$> traverse f xs++forEither3M :: Applicative m => [a] -> (a -> m (Either3 b c d)) -> m ([b], [c], [d])+forEither3M = flip mapEither3M
src/full/Agda/Utils/Time.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- To avoid warning on derived Integral instance for CPUTime. {-# OPTIONS_GHC -fno-warn-identities #-}@@ -12,15 +11,17 @@   , getCPUTime   , measureTime   , CPUTime(..)+  , fromMilliseconds   ) where +import Control.DeepSeq import Control.Monad.Trans import qualified System.CPUTime as CPU -import Data.Functor+ import qualified Data.Time -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.String  -- | Timestamps.@@ -35,7 +36,10 @@ -- | CPU time in pico (10^-12) seconds.  newtype CPUTime = CPUTime Integer-  deriving (Eq, Show, Ord, Num, Real, Enum, Integral)+  deriving (Eq, Show, Ord, Num, Real, Enum, Integral, NFData)++fromMilliseconds :: Integer -> CPUTime+fromMilliseconds n = CPUTime (n * 1000000000)  -- | Print CPU time in milli (10^-3) seconds. 
src/full/Agda/Utils/Trie.hs view
@@ -1,40 +1,66 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Strict tries (based on "Data.Map.Strict" and "Agda.Utils.Maybe.Strict").+--+-- Note that if 'delete' or 'adjust' are used, one may end up with non-canonical+-- subtries, i.e., those that do not contain any value (@Data.List.null . toList@)+-- but may be @Eq@-different to other empty tries (@/= empty@).  module Agda.Utils.Trie-  ( Trie+  ( Trie(..)   , empty, singleton, everyPrefix, insert, insertWith, union, unionWith+  -- Andreas 2024-11-16:+  -- Deletion does not clean up the trie, thus violates equational laws+  -- with the given Eq that does not quotient out the different representations+  -- of empty subtries.+  -- E.g. @delete k . insert k v . delete k /= delete k@.+  -- @adjust@ has a similar problem.   , adjust, delete-  , toList, toAscList+  , toList, toAscList, toListOrderedBy   , lookup, member, lookupPath, lookupTrie+  , mapSubTries, filter+  , valueAt   ) where -import Prelude hiding (null, lookup)-import qualified Prelude+import Prelude hiding (null, lookup, filter) -import Data.Function-import Data.Functor-import Data.Foldable (Foldable)+import Control.DeepSeq++import Data.Function (on) import qualified Data.Maybe as Lazy import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.List as List+ import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null+import Agda.Utils.Lens  -- | Finite map from @[k]@ to @v@. -- --   With the strict 'Maybe' type, 'Trie' is also strict in 'v'. data Trie k v = Trie !(Strict.Maybe v) !(Map k (Trie k v))-  deriving (Show, Eq, Functor, Foldable)+  deriving+    ( Show+    , Eq+        -- Andreas, 2024-11-16: The derived Eq isn't extensional.+        -- It disguishes different representation of the empty Trie.+        -- (E.g. the empty map and the map that only contains Nothing values.)+    , Functor+    , Foldable+    ) +instance (NFData k, NFData v) => NFData (Trie k v) where+  rnf (Trie a b) = rnf a `seq` rnf b+ -- | Empty trie. instance Null (Trie k v) where   empty = Trie Strict.Nothing Map.empty-  null (Trie v t) = null v && null t+  null (Trie v t) = null v && all null t+    -- Andreas, 2024-11-16: since we allow non-canoncial tries,+    -- we have to check that every subtrie is empty,+    -- not just that there are no subtries.  -- | Helper function used to implement 'singleton' and 'everyPrefix'. singletonOrEveryPrefix :: Bool -> [k] -> v -> Trie k v@@ -68,17 +94,31 @@ -- --   @insert = insertWith (\ new old -> new)@ insert :: (Ord k) => [k] -> v -> Trie k v -> Trie k v-insert k v t = union (singleton k v) t+insert k v t = (singleton k v) `union` t  -- | Insert with function merging new value with old value. insertWith :: (Ord k) => (v -> v -> v) -> [k] -> v -> Trie k v -> Trie k v insertWith f k v t = unionWith f (singleton k v) t +-- Andreas, 2024-11-16: delete does not clean up empty subtrees,+-- so it is not correct wrt. @Eq@.+ -- | Delete value at key, but leave subtree intact.+--+-- Disclaimer: may return a non-canoncial trie+-- because it does not clean up subtries that become empty.+-- delete :: Ord k => [k] -> Trie k v -> Trie k v delete path = adjust path (const Strict.Nothing) +-- Andreas, 2024-11-16: adjust does not clean up empty subtrees,+-- so it is not correct wrt. @Eq@.+ -- | Adjust value at key, leave subtree intact.+--+-- Disclaimer: may return a non-canoncial trie+-- because it does not clean up subtries that become empty.+-- adjust ::   Ord k =>   [k] -> (Strict.Maybe v -> Strict.Maybe v) -> Trie k v -> Trie k v@@ -103,6 +143,25 @@   , (ks, v) <- toAscList t   ] +-- | Convert to list where nodes at the same level are ordered according to the+--   given ordering.+toListOrderedBy :: Ord k => (v -> v -> Ordering) -> Trie k v -> [([k], v)]+toListOrderedBy cmp (Trie mv ts) =+  Strict.maybeToList (([],) <$> mv) +++  [ (k : ks, v) | (k, t)  <- List.sortBy (cmp' `on` val . snd) $ Map.toAscList ts,+                  (ks, v) <- toListOrderedBy cmp t ]+  where+    cmp' Strict.Nothing  Strict.Just{}   = LT+    cmp' Strict.Just{}   Strict.Nothing  = GT+    cmp' Strict.Nothing  Strict.Nothing  = EQ+    cmp' (Strict.Just x) (Strict.Just y) = cmp x y+    val (Trie mv _) = mv++-- | Create new values based on the entire subtrie. Almost, but not quite+--   comonad extend.+mapSubTries :: Ord k => (Trie k u -> Maybe v) -> Trie k u -> Trie k v+mapSubTries f t@(Trie mv ts) = Trie (Strict.toStrict (f t)) (fmap (mapSubTries f) ts)+ -- | Returns the value associated with the given key, if any. lookup :: Ord k => [k] -> Trie k v -> Maybe v lookup []       (Trie v _)  = Strict.toLazy v@@ -126,3 +185,17 @@ lookupTrie []       t           = t lookupTrie (k : ks) (Trie _ cs) = maybe empty (lookupTrie ks) (Map.lookup k cs) +-- | Filter a trie.+filter :: Ord k => (v -> Bool) -> Trie k v -> Trie k v+filter p (Trie mv ts) = Trie mv' (Map.filter (not . null) $ filter p <$> ts)+  where+    mv' =+      case mv of+        Strict.Just v | p v -> mv+        _                   -> Strict.Nothing++-- | Key lens.+valueAt :: Ord k => [k] -> Lens' (Trie k v) (Maybe v)+valueAt path f t = f (lookup path t) <&> \ case+  Nothing -> delete path t+  Just v  -> insert path v t
src/full/Agda/Utils/Tuple.hs view
@@ -1,34 +1,55 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Utils.Tuple where+module Agda.Utils.Tuple+  ( (-*-)+  , mapFst+  , mapSnd+  , (/\)+  , sortPair+  , fst3+  , snd3+  , thd3+  , swap+  , uncurry3+  , uncurry4+  , mapPairM+  , mapFstM+  , mapSndM+  , Pair(..)+  ) where -import Control.Applicative+import Control.Arrow   ( (&&&) )+import Control.DeepSeq ( NFData ) -import Data.Foldable-import Data.Traversable+import Data.Bifunctor  ( bimap, first, second )+import Data.Tuple      ( swap ) +import GHC.Generics    ( Generic )+ infix 2 -*- infix 3 /\ -- backslashes at EOL interact badly with CPP...  -- | Bifunctoriality for pairs. (-*-) :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)-(f -*- g) ~(x,y) = (f x, g y)+(-*-) = bimap  -- | @mapFst f = f -*- id@ mapFst :: (a -> c) -> (a,b) -> (c,b)-mapFst f ~(x,y) = (f x, y)+mapFst = first  -- | @mapSnd g = id -*- g@ mapSnd :: (b -> d) -> (a,b) -> (a,d)-mapSnd g ~(x,y) = (x, g y)+mapSnd = second  -- | Lifted pairing. (/\) :: (a -> b) -> (a -> c) -> a -> (b,c)-(f /\ g) x = (f x, g x)+(/\) = (&&&) --- | Swap.  (Only in Data.Tuple from base-4.3)-swap :: (a,b) -> (b,a)-swap ~(a,b) = (b,a)+-- | Order a pair.+sortPair :: Ord a => (a, a) -> (a, a)+sortPair p@(x, y)+  | x <= y    = p+  | otherwise = (y, x)  -- * Triple (stolen from Data.Tuple.HT) @@ -57,16 +78,18 @@ mapPairM f g ~(a,b) = (,) <$> f a <*> g b  -- | Monadic 'mapFst'.-mapFstM :: (Applicative m) => (a -> m c) -> (a,b) -> m (c,b)+mapFstM :: Functor m => (a -> m c) -> (a,b) -> m (c,b) mapFstM f ~(a,b) = (,b) <$> f a  -- | Monadic 'mapSnd'.-mapSndM :: (Applicative m) => (b -> m d) -> (a,b) -> m (a,d)+mapSndM :: Functor m => (b -> m d) -> (a,b) -> m (a,d) mapSndM f ~(a,b) = (a,) <$> f b -newtype List2 a = List2 { list2 :: (a,a) }-  deriving (Eq, Functor, Foldable, Traversable)+data Pair a = Pair a a+  deriving (Show, Eq, Generic, Functor, Foldable, Traversable) -instance Applicative List2 where-  pure a                            = List2 (a,a)-  (List2 (f,f')) <*> (List2 (a,a')) = List2 (f a, f' a')+instance Applicative Pair where+  pure a                  = Pair a a+  Pair f f' <*> Pair a a' = Pair (f a) (f' a')++instance NFData a => NFData (Pair a)
+ src/full/Agda/Utils/TypeLevel.hs view
@@ -0,0 +1,154 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}++-- We need undecidable instances for the definition of @Foldr@,+-- and @Domains@ and @CoDomain@ using @If@ for instance.+{-# LANGUAGE UndecidableInstances #-}++module Agda.Utils.TypeLevel where++import Data.Kind ( Type )+import Data.Proxy+import GHC.Exts (Constraint)++------------------------------------------------------------------+-- CONSTRAINTS+------------------------------------------------------------------++-- | @All p as@ ensures that the constraint @p@ is satisfied by+--   all the 'types' in @as@.+--   (Types is between scare-quotes here because the code is+--   actually kind polymorphic)++type family All (p :: k -> Constraint) (as :: [k]) :: Constraint where+  All p '[]       = ()+  All p (a ': as) = (p a, All p as)++------------------------------------------------------------------+-- FUNCTIONS+-- Type-level and Kind polymorphic versions of usual value-level+-- functions.+------------------------------------------------------------------++-- | On Booleans+type family If (b :: Bool) (l :: k) (r :: k) :: k where+  If 'True  l r = l+  If 'False l r = r++-- | On Lists+type family Foldr (c :: k -> l -> l) (n :: l) (as :: [k]) :: l where+  Foldr c n '[]       = n+  Foldr c n (a ': as) = c a (Foldr c n as)++-- | Version of @Foldr@ taking a defunctionalised argument so+--   that we can use partially applied functions.+type family Foldr' (c :: Function k (Function l l -> Type) -> Type)+                   (n :: l) (as :: [k]) :: l where+  Foldr' c n '[]       = n+  Foldr' c n (a ': as) = Apply (Apply c a) (Foldr' c n as)++type family Map (f :: Function k l -> Type) (as :: [k]) :: [l] where+  Map f as = Foldr' (ConsMap0 f) '[] as++data ConsMap0 :: (Function k l -> Type) -> Function k (Function [l] [l] -> Type) -> Type+data ConsMap1 :: (Function k l -> Type) -> k -> Function [l] [l] -> Type+type instance Apply (ConsMap0 f)    a = ConsMap1 f a+type instance Apply (ConsMap1 f a) tl = Apply f a ': tl++type family Constant (b :: Type) (as :: [k]) :: [Type] where+  Constant b as = Map (Constant1 b) as++------------------------------------------------------------------+-- TYPE FORMERS+------------------------------------------------------------------++-- | @Arrows [a1,..,an] r@ corresponds to @a1 -> .. -> an -> r@+-- | @Products [a1,..,an]@ corresponds to @(a1, (..,( an, ())..))@++type Arrows   (as :: [Type]) (r :: Type) = Foldr (->) r as+type Products (as :: [Type])             = Foldr (,) () as++data StrictPair a b = Pair a b+type StrictProducts (as :: [Type]) = Foldr StrictPair () as++strictCurry :: (StrictPair a b -> c) -> (a -> b -> c)+strictCurry f = \ !a !b -> f (Pair a b)+{-# INLINE strictCurry #-}++strictUncurry :: (a -> b -> c) -> (StrictPair a b -> c)+strictUncurry f = \ !(Pair a b) -> f a b+{-# INLINE strictUncurry #-}++-- | @IsBase t@ is @'True@ whenever @t@ is *not* a function space.++type family IsBase (t :: Type) :: Bool where+  IsBase (a -> t) = 'False+  IsBase a        = 'True++-- | Using @IsBase@ we can define notions of @Domains@ and @CoDomains@+--   which *reduce* under positive information @IsBase t ~ 'True@ even+--   though the shape of @t@ is not formally exposed++type family Domains (t :: Type) :: [Type] where+  Domains t = If (IsBase t) '[] (Domains' t)+type family Domains' (t :: Type) :: [Type] where+  Domains' (a -> t) = a ': Domains t++type family CoDomain (t :: Type) :: Type where+  CoDomain t = If (IsBase t) t (CoDomain' t)+type family CoDomain' (t :: Type) :: Type where+  CoDomain' (a -> t) = CoDomain t++------------------------------------------------------------------+-- TYPECLASS MAGIC+------------------------------------------------------------------++-- | @Currying as b@ witnesses the isomorphism between @Arrows as b@+--   and @Products as -> b@. It is defined as a type class rather+--   than by recursion on a singleton for @as@ so all of that these+--   conversions are inlined at compile time for concrete arguments.++class Currying as b where+  uncurrys :: Proxy as -> Proxy b -> Arrows as b -> Products as -> b+  currys   :: Proxy as -> Proxy b -> (Products as -> b) -> Arrows as b++instance Currying '[] b where+  uncurrys _ _ f = \ () -> f+  currys   _ _ f = f ()++instance Currying as b => Currying (a ': as) b where+  uncurrys _ p f = uncurry $ uncurrys (Proxy :: Proxy as) p . f+  currys   _ p f = currys (Proxy :: Proxy as) p . curry f+++class StrictCurrying as b where+  strictUncurrys :: Proxy as -> Proxy b -> Arrows as b -> StrictProducts as -> b+  strictCurrys   :: Proxy as -> Proxy b -> (StrictProducts as -> b) -> Arrows as b++instance StrictCurrying '[] b where+  strictUncurrys _ _ f = \ () -> f; {-# INLINE strictUncurrys #-}+  strictCurrys   _ _ f = f ();      {-# INLINE strictCurrys #-}++instance StrictCurrying as b => StrictCurrying (a ': as) b where+  strictUncurrys _ p f = strictUncurry $ strictUncurrys (Proxy :: Proxy as) p . f+  {-# INLINE strictUncurrys #-}+  strictCurrys   _ p f = strictCurrys (Proxy :: Proxy as) p . strictCurry f+  {-# INLINE strictCurrys #-}++------------------------------------------------------------------+-- DEFUNCTIONALISATION+-- Cf. Eisenberg and Stolarek's paper:+-- Promoting Functions to Type Families in Haskell+------------------------------------------------------------------++data Function :: Type -> Type -> Type++data Constant0 :: Function a (Function b a -> Type) -> Type+data Constant1 :: Type -> Function b a -> Type++type family Apply (t :: Function k l -> Type) (u :: k) :: l++type instance Apply Constant0     a = Constant1 a+type instance Apply (Constant1 a) b = a
+ src/full/Agda/Utils/TypeLits.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}++-- | Type level literals, inspired by GHC.TypeLits.++module Agda.Utils.TypeLits where++-- | Singleton for type level booleans.++data SBool (b :: Bool) where+  STrue  :: SBool 'True+  SFalse :: SBool 'False++eraseSBool :: SBool b -> Bool+eraseSBool = \case+  STrue  -> True+  SFalse -> False++-- | A known boolean is one we can obtain a singleton for.+--   Concrete values are trivially known.++class KnownBool (b :: Bool) where+  boolSing :: SBool b++instance KnownBool 'True where+  boolSing = STrue++instance KnownBool 'False where+  boolSing = SFalse++boolVal :: forall proxy b. KnownBool b => proxy b -> Bool+boolVal _ = eraseSBool (boolSing :: SBool b)
+ src/full/Agda/Utils/Unsafe.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE MagicHash #-}+module Agda.Utils.Unsafe (unsafeComparePointers) where++import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)++-- | Checks if two arguments are equal as pointers in memory.+-- Please note, that this function is a hack, and it can worsen the behavior of compiler.+-- See <https://gitlab.haskell.org/ghc/ghc/-/blob/d151546e59a50158f25c3df6728b00d3c27bb4b9/compiler/GHC/Builtin/primops.txt.pp#L3455>.+unsafeComparePointers :: a -> a -> Bool+unsafeComparePointers x y = x `seq` y `seq` isTrue# (reallyUnsafePtrEquality# x y)
src/full/Agda/Utils/Update.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Agda.Utils.Update-  ( Change+  ( ChangeT+  , runChangeT, mapChangeT+  , UpdaterT+  , runUpdaterT+  , Change   , MonadChange(..)   , runChange   , Updater@@ -13,12 +16,12 @@   , Updater2(..)   ) where -import Control.Applicative import Control.Monad.Identity import Control.Monad.Trans-import Control.Monad.Writer.Strict+import Control.Monad.Trans.Control+import Control.Monad.Writer.Strict ( MonadWriter(..), Writer, WriterT, mapWriterT, runWriterT ) -import Data.Traversable (Traversable(..), traverse)+import Data.Monoid ( Any(..) )  import Agda.Utils.Tuple @@ -31,53 +34,87 @@  -- | The @ChangeT@ monad transformer. newtype ChangeT m a = ChangeT { fromChangeT :: WriterT Any m a }-  deriving (Functor, Applicative, Monad, MonadTrans)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadFail, MonadIO) +-- This instance cannot be derived in older ghcs like 8.0+-- because of the associated type synonym.+-- 8.4 can derive it, but needs UndecidableInstances.+instance MonadTransControl ChangeT where+  type StT ChangeT a = (a, Any) -- StT (WriterT Any) a  would require UndecidableInstances+  liftWith f = ChangeT $ liftWith $ \ runWriterT -> f $ runWriterT . fromChangeT+  -- Andreas, 2020-04-17: these point-free variants do not seem to type check:+  -- liftWith f = ChangeT $ liftWith $ f . (. fromChangeT)+  -- liftWith = ChangeT . liftWith . (. (. fromChangeT))+  restoreT = ChangeT . restoreT+ instance Monad m => MonadChange (ChangeT m) where   tellDirty     = ChangeT $ tell $ Any True   listenDirty m = ChangeT $ do     (a, Any dirty) <- listen (fromChangeT m)     return (a, dirty) --- | A mock change monad.+-- | Run a 'ChangeT' computation, returning result plus change flag.+runChangeT :: Functor m => ChangeT m a -> m (a, Bool)+runChangeT = fmap (mapSnd getAny) . runWriterT . fromChangeT+{-# INLINE runChangeT #-}++-- | Run a 'ChangeT' computation, but ignore change flag.+execChangeT :: Functor m => ChangeT m a -> m a -- A library function, so keep+execChangeT = fmap fst . runChangeT+{-# INLINE execChangeT #-}++-- | Map a 'ChangeT' computation (monad transformer action).+mapChangeT :: (m (a, Any) -> n (b, Any)) -> ChangeT m a -> ChangeT n b+mapChangeT f (ChangeT m) = ChangeT (mapWriterT f m)+{-# INLINE mapChangeT #-}++-- Don't actually track changes with the identity monad:++-- | A mock change monad.  Always assume change has happened. instance MonadChange Identity where-  tellDirty                = Identity ()-  listenDirty (Identity a) = Identity (a, True)+  tellDirty   = return ()+  listenDirty = fmap (,True) +instance Monad m => MonadChange (IdentityT m) where+  tellDirty   = IdentityT    $ return ()+  listenDirty = mapIdentityT $ fmap (,True)+ -- * Pure endo function and updater -type EndoFun a = a -> a-type Updater a = a -> Change a+type UpdaterT m a = a -> ChangeT m a --- BEGIN REAL STUFF+-- | Blindly run an updater.+runUpdaterT :: Functor m => UpdaterT m a -> a -> m (a, Bool)+runUpdaterT f a = runChangeT $ f a --- | The @Change@ monad.-newtype Change a = Change { fromChange :: Writer Any a }-  deriving (Functor, Applicative, Monad)+type EndoFun a = a -> a+type Change  a = ChangeT Identity a+type Updater a = UpdaterT Identity a -instance MonadChange Change where-  tellDirty = Change $ tell $ Any True-  listenDirty m = Change $ do-    (a, Any dirty) <- listen (fromChange m)-    return (a, dirty)+-- NB:: Defined but not used+fromChange :: Change a -> Writer Any a+fromChange = fromChangeT  -- | Run a 'Change' computation, returning result plus change flag.+{-# INLINE runChange #-} runChange :: Change a -> (a, Bool)-runChange = mapSnd getAny . runWriter . fromChange+runChange = runIdentity . runChangeT  -- | Blindly run an updater.+{-# INLINE runUpdater #-} runUpdater :: Updater a -> a -> (a, Bool) runUpdater f a = runChange $ f a  -- | Mark a computation as dirty.-dirty :: Updater a+dirty :: Monad m => UpdaterT m a dirty a = do   tellDirty   return a+{-# INLINE dirty #-}  {-# SPECIALIZE ifDirty :: Change a -> (a -> Change b) -> (a -> Change b) -> Change b #-} {-# SPECIALIZE ifDirty :: Identity a -> (a -> Identity b) -> (a -> Identity b) -> Identity b #-}-ifDirty :: MonadChange m => m a -> (a -> m b) -> (a -> m b) -> m b+ifDirty :: (Monad m, MonadChange m) => m a -> (a -> m b) -> (a -> m b) -> m b ifDirty m f g = do   (a, dirty) <- listenDirty m   if dirty then f a else g a@@ -85,14 +122,16 @@ -- * Proper updater (Q-combinators)  -- | Replace result of updating with original input if nothing has changed.-sharing :: Updater a -> Updater a+sharing :: Monad m => UpdaterT m a -> UpdaterT m a sharing f a = do   (a', changed) <- listenDirty $ f a   return $ if changed then a' else a+{-# INLINE sharing #-}  -- | Eval an updater (using 'sharing'). evalUpdater :: Updater a -> EndoFun a-evalUpdater f a = fst $ runWriter $ fromChange $ sharing f a+evalUpdater f a = fst $ runChange $ sharing f a+{-# INLINE evalUpdater #-}  -- END REAL STUFF 
src/full/Agda/Utils/VarSet.hs view
@@ -1,13 +1,16 @@+{-# LANGUAGE CPP #-} --- | Var field implementation of sets of (small) natural numbers.+{-# OPTIONS_GHC -Wunused-imports #-} +-- | Manage sets of natural numbers (de Bruijn indices).+ module Agda.Utils.VarSet   ( VarSet-  , union, unions, member, empty, delete, singleton-  , fromList, toList, toDescList-  , isSubsetOf, IntSet.null-  , intersection, difference-  , Agda.Utils.VarSet.subtract+  , empty, insert, singleton, union, unions+  , fromList, toList, toAscList, toDescList+  , disjoint, isSubsetOf, member, IntSet.null+  , delete, difference, IntSet.filter, filterGE, intersection+  , mapMonotonic, Agda.Utils.VarSet.subtract   )   where @@ -15,44 +18,15 @@  type VarSet = IntSet -subtract :: Int -> VarSet -> VarSet-subtract n = IntSet.map (Prelude.subtract n)--{--import Data.Bits--type VarSet = Integer-type Var    = Integer--union :: VarSet -> VarSet -> VarSet-union = (.|.)--member :: Var -> VarSet -> Bool-member b s = testVar s (fromIntegral b)--empty :: VarSet-empty = 0--delete :: Var -> VarSet -> VarSet-delete b s = clearVar s (fromIntegral b)--singleton :: Var -> VarSet-singleton = bit+#if !MIN_VERSION_containers(0,6,3)+mapMonotonic :: (Int -> Int) -> VarSet -> VarSet+mapMonotonic f = fromDistinctAscList . fmap f . toAscList+#endif +-- | Subtract from each element. subtract :: Int -> VarSet -> VarSet-subtract n s = shiftR s n--fromList :: [Var] -> VarSet-fromList = foldr (union . singleton . fromIntegral) empty--isSubsetOf :: VarSet -> VarSet -> Bool-isSubsetOf s1 s2 = 0 == (s1 .&. complement s2)+subtract n = mapMonotonic (Prelude.subtract n) -toList :: VarSet -> [Var]-toList s = loop 0 s-  where-    loop i 0 = []-    loop i n-      | testVar n 0 = fromIntegral i : (loop $! i + 1) (shiftR n 1)-      | otherwise   = (loop $! i + 1) (shiftR n 1)--}+-- | Keep only elements greater or equal to the given pivot.+filterGE :: Int -> VarSet -> VarSet+filterGE n = snd . IntSet.split (n - 1)
− src/full/Agda/Utils/Warshall.hs 
@@ -1,419 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{- | Construct a graph from constraints-@-   x + n <= y   becomes   x ---(-n)---> y-   x <= n + y   becomes   x ---(+n)---> y-@-the default edge (= no edge) is labelled with infinity.--Building the graph involves keeping track of the node names.-We do this in a finite map, assigning consecutive numbers to nodes.--}-module Agda.Utils.Warshall where--import Control.Applicative-import Control.Monad.State--import Data.Maybe-import Data.Array-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map--import Agda.Syntax.Common (Nat)-import Agda.Utils.SemiRing--type Matrix a = Array (Int,Int) a---- assuming a square matrix-warshall :: SemiRing a => Matrix a -> Matrix a-warshall a0 = loop r a0 where-  b@((r,c),(r',c')) = bounds a0 -- assuming r == c and r' == c'-  loop k a | k <= r' =-    loop (k+1) (array b [ ((i,j),-                           (a!(i,j)) `oplus` ((a!(i,k)) `otimes` (a!(k,j))))-                        | i <- [r..r'], j <- [c..c'] ])-           | otherwise = a--type AdjList node edge = Map node [(node, edge)]---- | Warshall's algorithm on a graph represented as an adjacency list.-warshallG :: (SemiRing edge, Ord node) => AdjList node edge -> AdjList node edge-warshallG g = fromMatrix $ warshall m-  where-    nodes = zip (nub $ Map.keys g ++ map fst (concat $ Map.elems g))-                [0..]-    len   = length nodes-    b     = ((0,0), (len - 1,len - 1))--    edge i j = do-      es <- Map.lookup i g-      foldr oplus Nothing [ Just v | (j', v) <- es, j == j' ]--    m = array b [ ((n, m), edge i j) | (i, n) <- nodes, (j, m) <- nodes ]--    fromMatrix matrix = Map.fromList $ do-      (i, n) <- nodes-      let es = [ (fst (nodes !! m), e)-               | m <- [0..len - 1]-               , Just e <- [matrix ! (n, m)]-               ]-      return (i, es)---- | Edge weight in the graph, forming a semi ring.-data Weight = Finite Int | Infinite-              deriving (Eq)--inc :: Weight -> Int -> Weight-inc Infinite   n = Infinite-inc (Finite k) n = Finite (k + n)--instance Show Weight where-  show (Finite i) = show i-  show Infinite   = "."--instance Ord Weight where-  a <= Infinite = True-  Infinite <= b = False-  Finite a <= Finite b = a <= b--instance SemiRing Weight where-  ozero = Infinite-  oone  = Finite 0--  oplus = min--  otimes Infinite _ = Infinite-  otimes _ Infinite = Infinite-  otimes (Finite a) (Finite b) = Finite (a + b)---- constraints ------------------------------------------------------- | Nodes of the graph are either--- - flexible variables (with identifiers drawn from @Int@),--- - rigid variables (also identified by @Int@s), or--- - constants (like 0, infinity, or anything between).--data Node = Rigid Rigid-          | Flex  FlexId-            deriving (Eq, Ord)--data Rigid = RConst Weight-           | RVar RigidId-             deriving (Eq, Ord, Show)--type NodeId  = Int-type RigidId = Int-type FlexId  = Int-type Scope   = RigidId -> Bool--- ^ Which rigid variables a flex may be instatiated to.--instance Show Node where-  show (Flex  i) = "?" ++ show i-  show (Rigid (RVar i)) = "v" ++ show i-  show (Rigid (RConst Infinite))   = "#"-  show (Rigid (RConst (Finite n))) = show n--infinite :: Rigid -> Bool-infinite (RConst Infinite) = True-infinite _                 = False---- | @isBelow r w r'@---   checks, if @r@ and @r'@ are connected by @w@ (meaning @w@ not infinite),---   whether @r + w <= r'@.---   Precondition: not the same rigid variable.-isBelow :: Rigid -> Weight -> Rigid -> Bool-isBelow _ Infinite _ = True-isBelow _ n (RConst Infinite) = True-isBelow (RConst (Finite i)) (Finite n) (RConst (Finite j)) = i + n <= j-isBelow _ _ _ = False -- rigid variables are not related---- | A constraint is an edge in the graph.-data Constraint-  = NewFlex FlexId Scope-  | Arc Node Int Node-    -- ^ For @Arc v1 k v2@  at least one of @v1@ or @v2@ is a @MetaV@ (Flex),-    --                      the other a @MetaV@ or a @Var@ (Rigid).-    --   If @k <= 0@ this means  @suc^(-k) v1 <= v2@-    --   otherwise               @v1 <= suc^k v3@.--instance Show Constraint where-  show (NewFlex i s) = "SizeMeta(?" ++ show i ++ ")"-  show (Arc v1 k v2) | k == 0 = show v1 ++ "<=" ++ show v2-                     | k < 0  = show v1 ++ "+" ++ show (-k) ++ "<=" ++ show v2-                     | otherwise  = show v1 ++ "<=" ++ show v2 ++ "+" ++ show k--type Constraints = [Constraint]--emptyConstraints :: Constraints-emptyConstraints = []---- graph (matrix) --------------------------------------------------data Graph = Graph-  { flexScope :: Map FlexId Scope           -- ^ Scope for each flexible var.-  , nodeMap   :: Map Node NodeId            -- ^ Node labels to node numbers.-  , intMap    :: Map NodeId Node            -- ^ Node numbers to node labels.-  , nextNode  :: NodeId                     -- ^ Number of nodes @n@.-  , graph     :: NodeId -> NodeId -> Weight -- ^ The edges (restrict to @[0..n[@).-  }---- | The empty graph: no nodes, edges are all undefined (infinity weight).-initGraph :: Graph-initGraph = Graph Map.empty Map.empty Map.empty 0 (\ x y -> Infinite)---- | The Graph Monad, for constructing a graph iteratively.-type GM = State Graph---- | Add a size meta node.-addFlex :: FlexId -> Scope -> GM ()-addFlex x scope = do-  modify $ \ st -> st { flexScope = Map.insert x scope (flexScope st) }-  _ <- addNode (Flex x)-  return ()---- | Lookup identifier of a node.---   If not present, it is added first.-addNode :: Node -> GM Int-addNode n = do-  st <- get-  case Map.lookup n (nodeMap st) of-    Just i -> return i-    Nothing -> do-      let i = nextNode st-      put $ st { nodeMap  = Map.insert n i (nodeMap st)-               , intMap   = Map.insert i n (intMap st)-               , nextNode = i + 1-               }-      return i---- | @addEdge n1 k n2@---   improves the weight of egde @n1->n2@ to be at most @k@.---   Also adds nodes if not yet present.-addEdge :: Node -> Int -> Node -> GM ()-addEdge n1 k n2 = do-  i1 <- addNode n1-  i2 <- addNode n2-  st <- get-  let graph' x y = if (x,y) == (i1,i2) then Finite k `oplus` (graph st) x y-                   else graph st x y-  put $ st { graph = graph' }--addConstraint :: Constraint -> GM ()-addConstraint (NewFlex x scope) = addFlex x scope-addConstraint (Arc n1 k n2)     = addEdge n1 k n2--buildGraph :: Constraints -> Graph-buildGraph cs = execState (mapM_ addConstraint cs) initGraph--mkMatrix :: Int -> (Int -> Int -> Weight) -> Matrix Weight-mkMatrix n g = array ((0,0),(n-1,n-1))-                 [ ((i,j), g i j) | i <- [0..n-1], j <- [0..n-1]]---- displaying matrices with row and column labels ------------------------ | A matrix with row descriptions in @b@ and column descriptions in @c@.-data LegendMatrix a b c = LegendMatrix-  { matrix   :: Matrix a-  , rowdescr :: Int -> b-  , coldescr :: Int -> c-  }--instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where-  show (LegendMatrix m rd cd) =-    -- first show column description-    let ((r,c),(r',c')) = bounds m-    in foldr (\ j s -> "\t" ++ show (cd j) ++ s) "" [c .. c'] ++-    -- then output rows-       foldr (\ i s -> "\n" ++ show (rd i) ++-                foldr (\ j t -> "\t" ++ show (m!(i,j)) ++ t)-                      (s)-                      [c .. c'])-             "" [r .. r']---- solving the constraints ----------------------------------------------- | A solution assigns to each flexible variable a size expression---   which is either a constant or a @v + n@ for a rigid variable @v@.-type Solution = Map Int SizeExpr--emptySolution :: Solution-emptySolution = Map.empty--extendSolution :: Solution -> Int -> SizeExpr -> Solution-extendSolution subst k v = Map.insert k v subst--data SizeExpr = SizeVar RigidId Int   -- ^ e.g. x + 5-              | SizeConst Weight      -- ^ a number or infinity--instance Show SizeExpr where-  show (SizeVar n 0) = show (Rigid (RVar n))-  show (SizeVar n k) = show (Rigid (RVar n)) ++ "+" ++ show k-  show (SizeConst w) = show w---- | @sizeRigid r n@ returns the size expression corresponding to @r + n@-sizeRigid :: Rigid -> Int -> SizeExpr-sizeRigid (RConst k) n = SizeConst (inc k n)-sizeRigid (RVar i)   n = SizeVar i n--{--apply :: SizeExpr -> Solution -> SizeExpr-apply e@(SizeExpr (Rigid _) _) phi = e-apply e@(SizeExpr (Flex  x) i) phi = case Map.lookup x phi of-  Nothing -> e-  Just (SizeExpr v j) -> SizeExpr v (i + j)--after :: Solution -> Solution -> Solution-after psi phi = Map.map (\ e -> e `apply` phi) psi--}--{- compute solution--a solution CANNOT exist if--  v < v  for a rigid variable v--  -- Andreas, 2012-09-19 OUTDATED are:--  -- v <= v' for rigid variables v,v'--  -- x < v   for a flexible variable x and a rigid variable v---thus, for each flexible x, only one of the following cases is possible--  r+n <= x+m <= infty  for a unique rigid r  (meaning r --(m-n)--> x)-  x <= r+n             for a unique rigid r  (meaning x --(n)--> r)--we are looking for the least values for flexible variables that solve-the constraints.  Algorithm--while flexible variables and rigid rows left-  find a rigid variable row i-    for all flexible columns j-      if i --n--> j with n<=0 (meaning i+n <= j) then j = i + n--while flexible variables j left-  search the row j for entry i-    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i + n---}--solve :: Constraints -> Maybe Solution-solve cs = -- trace (show cs) $-   -- trace (show lm0) $-    -- trace (show lm) $ -- trace (show d) $-     let solution = if solvable then loop1 flexs rigids emptySolution-                    else Nothing-     in -- trace (show solution) $-         solution-   where -- compute the graph and its transitive closure m-         gr  = buildGraph cs-         n   = nextNode gr            -- number of nodes-         m0  = mkMatrix n (graph gr)-         m   = warshall m0--         -- tracing only: build output version of transitive graph-         legend i = fromJust $ Map.lookup i (intMap gr) -- trace only-         lm0 = LegendMatrix m0 legend legend            -- trace only-         lm  = LegendMatrix m legend legend             -- trace only--         -- compute the sets of flexible and rigid node numbers-         ns  = Map.keys (nodeMap gr)-         -- a set of flexible variables-         flexs  = foldl' (\ l k -> case k of (Flex i) -> i : l-                                             (Rigid _) -> l) [] ns-         -- a set of rigid variables-         rigids = foldl' (\ l k -> case k of (Flex _) -> l-                                             (Rigid i) -> i : l) [] ns--         -- rigid matrix indices-         rInds = foldl' (\ l r -> let Just i = Map.lookup (Rigid r) (nodeMap gr)-                                  in i : l) [] rigids--         -- check whether there is a solution-         -- d   = [ m!(i,i) | i <- [0 .. (n-1)] ]  -- diagonal--- a rigid variable might not be less than it self, so no -.. on the--- rigid part of the diagonal-         solvable = all (\ x -> x >= Finite 0) [ m!(i,i) | i <- rInds ] && True--{-  Andreas, 2012-09-19-    We now can have constraints between rigid variables, like i < j.-    Thus we skip the following two test.  However, a solution must be-    checked for consistency with the constraints on rigid vars.---- a rigid variable might not be bounded below by infinity or--- bounded above by a constant--- it might not be related to another rigid variable-           all (\ (r,  r') -> r == r' ||-                let Just row = (Map.lookup (Rigid r)  (nodeMap gr))-                    Just col = (Map.lookup (Rigid r') (nodeMap gr))-                    edge = m!(row,col)-                in  isBelow r edge r' )-             [ (r,r') | r <- rigids, r' <- rigids ]-           &&--- a flexible variable might not be strictly below a rigid variable-           all (\ (x, v) ->-                let Just row = (Map.lookup (Flex x)  (nodeMap gr))-                    Just col = (Map.lookup (Rigid (RVar v)) (nodeMap gr))-                    edge = m!(row,col)-                in  edge >= Finite 0)-             [ (x,v) | x <- flexs, (RVar v) <- rigids ]--}--         inScope :: FlexId -> Rigid -> Bool-         inScope x (RConst _) = True-         inScope x (RVar v)   = scope v-             where Just scope = Map.lookup x (flexScope gr)--{- loop1--while flexible variables and rigid rows left-  find a rigid variable row i-    for all flexible columns j-      if i --n--> j with n<=0 (meaning i + n <= j) then j = i + n---}-         loop1 :: [FlexId] -> [Rigid] -> Solution -> Maybe Solution-         loop1 [] rgds subst = Just subst-         loop1 flxs [] subst = loop2 flxs subst-         loop1 flxs (r:rgds) subst =-            let row = fromJust $ Map.lookup (Rigid r) (nodeMap gr)-                (flxs',subst') =-                  foldl' (\ (flx,sub) f ->-                          let col = fromJust $ Map.lookup (Flex f) (nodeMap gr)-                          in  case (inScope f r, m!(row,col)) of---                                Finite z | z <= 0 ->-                                (True, Finite z) ->-                                   let trunc z | z >= 0 = 0-                                            | otherwise = -z-                                   in (flx, extendSolution sub f (sizeRigid r (trunc z)))-                                _ -> (f : flx, sub)-                     ) ([], subst) flxs-            in loop1 flxs' rgds subst'--{- loop2--while flexible variables j left-  search the row j for entry i-    if j --n--> i with n >= 0 (meaning j <= i + n) then j = i---}-         loop2 :: [FlexId] -> Solution -> Maybe Solution-         loop2 [] subst = Just subst-         loop2 (f:flxs) subst = loop3 0 subst-           where row = fromJust $ Map.lookup (Flex f) (nodeMap gr)-                 loop3 col subst | col >= n =-                   -- default to infinity-                    loop2 flxs (extendSolution subst f (SizeConst Infinite))-                 loop3 col subst =-                   case Map.lookup col (intMap gr) of-                     Just (Rigid r) | not (infinite r) ->-                       case (inScope f r, m!(row,col)) of-                        (True, Finite z) | z >= 0 ->-                            loop2 flxs (extendSolution subst f (sizeRigid r z))-                        (_, Infinite) -> loop3 (col+1) subst-                        _ -> -- trace ("unusable rigid: " ++ show r ++ " for flex " ++ show f)-                              Nothing  -- NOT: loop3 (col+1) subst-                     _ -> loop3 (col+1) subst
+ src/full/Agda/Utils/WithDefault.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}++-- | Potentially uninitialised Booleans.+--+-- The motivation for this small library is to distinguish+-- between a boolean option with a default value and an option which has been+-- set to what happens to be the default value.  In one case the default can be+-- overriden (e.g. @--cubical@ implies @--without-K@) while in the other case the+-- user has made a mistake which they need to fix.++module Agda.Utils.WithDefault where++import Control.DeepSeq++import Agda.Utils.Boolean+import Agda.Utils.Lens+import Agda.Utils.Null+import Agda.Utils.TypeLits++-- | We don't want to have to remember for each flag whether its default value+-- is @True@ or @False@. So we bake it into the representation: the flag's type+-- will mention its default value as a phantom parameter.+--+data WithDefault' a (b :: Bool) = Default | Value !a+  deriving (Eq, Show)+  -- Note: the argument @b@ must be last, because this is matched against @proxy b@+  -- in 'Agda.Utils.TypeLits.boolVal'.+  -- Thus, we cannot make it a 'Functor' in @a@.+  -- Instead, we define 'mapValue'.++type WithDefault b = WithDefault' Bool b++instance NFData (WithDefault' a b) where+  rnf Default   = ()+  rnf (Value _) = ()++-- | The null value of 'WithDefault b' is 'Default'.+--+instance Null (WithDefault' a b) where+  empty = Default+  null = \case+    Default -> True+    Value _ -> False++-- | The main mode of operation of these flags, apart from setting them explicitly,+-- is to toggle them one way or the other if they hadn't been set already.+--+setDefault :: Boolean a => a -> WithDefault' a b -> WithDefault' a b+setDefault b = \case+  Default -> Value b+  t -> t++-- | Only modify non-'Default' values.+--+mapValue :: Boolean a => (a -> a) -> WithDefault' a b -> WithDefault' a b+mapValue f = \case+  Default -> Default+  Value b -> Value (f b)++-- | Provided that the default value is a known boolean (in practice we only use+-- @True@ or @False@), we can collapse a potentially uninitialised value to a boolean.+--+collapseDefault :: (Boolean a, KnownBool b) => WithDefault' a b -> a+collapseDefault = \case+  w@Default -> fromBool (boolVal w)+  Value b -> b++-- | Focus, overwriting 'Default'.+--+lensCollapseDefault :: (Boolean a, KnownBool b) => Lens' (WithDefault' a b) a+lensCollapseDefault f w = Value <$> f (collapseDefault w)++-- | Update, but keep 'Default' when new value is default value.+--+lensKeepDefault :: (Boolean a, Eq a, KnownBool b) => Lens' (WithDefault' a b) a+lensKeepDefault f = \case+  Value b   -> Value <$> f b+  w@Default -> f b <&> \ b' -> if b == b' then Default else Value b'+    where+    b  = fromBool (boolVal w)
+ src/full/Agda/Utils/Zipper.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Utils.Zipper where+++class Zipper z where+  type Carrier z+  type Element z+  firstHole :: Carrier z -> Maybe (Element z, z)+  plugHole  :: Element z -> z -> Carrier z+  nextHole  :: Element z -> z -> Either (Carrier z) (Element z, z)++data ListZipper a = ListZip [a] [a]+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Zipper (ListZipper a) where+  type Carrier (ListZipper a) = [a]+  type Element (ListZipper a) = a+  firstHole (x : xs)               = Just (x, ListZip [] xs)+  firstHole []                     = Nothing+  plugHole x (ListZip ys zs)       = reverse ys ++ x : zs+  nextHole x (ListZip ys [])       = Left (reverse (x : ys))+  nextHole x (ListZip ys (z : zs)) = Right (z, ListZip (x : ys) zs)++data ComposeZipper f g = ComposeZip f g++instance (Zipper f, Zipper g, Element f ~ Carrier g) => Zipper (ComposeZipper f g) where+  type Carrier (ComposeZipper f g) = Carrier f+  type Element (ComposeZipper f g) = Element g+  firstHole c1 = do+    (c2, z1) <- firstHole c1+    go c2 z1+    where+      go c2 z1 =+        case firstHole c2 of+          Nothing -> case nextHole c2 z1 of+            Left{} -> Nothing+            Right (c2', z1') -> go c2' z1'+          Just (x, z2) -> Just (x, ComposeZip z1 z2)+  plugHole x (ComposeZip z1 z2) = plugHole (plugHole x z2) z1+  nextHole x (ComposeZip z1 z2) =+    case nextHole x z2 of+      Right (y, z2') -> Right (y, ComposeZip z1 z2')+      Left c2        -> go c2 z1+        where+          go c2 z1 =+            case nextHole c2 z1 of+              Right (c2', z1') ->+                case firstHole c2' of+                  Nothing       -> go c2' z1'+                  Just (x, z2') -> Right (x, ComposeZip z1' z2')+              Left c1 -> Left c1
− src/full/Agda/Version.hs 
@@ -1,12 +0,0 @@-module Agda.Version where--import Data.Version-import Data.List--import qualified Paths_Agda as PA---- | The version of Agda.--version :: String-version = intercalate "." $ map show $-            versionBranch PA.version
− src/full/Agda/VersionCommit.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Agda.VersionCommit where--import Development.GitRev--import Agda.Version--versionWithCommitInfo :: String-versionWithCommitInfo = version ++ case commitInfo of-                                     Nothing   -> ""-                                     Just info -> "-" ++ info---- | Information about current git commit, generated at compile time-commitInfo :: Maybe String-commitInfo = case $(gitHash) of-  "UNKNOWN" -> Nothing-  hash      -> Just $ abbrev hash ++ dirty-  where-    -- | Check if there are uncommitted changes-    dirty | $(gitDirty) = "-dirty"-          | otherwise   = ""--    -- | Abbreviate a commit hash while keeping it unambiguous-    abbrev = take 7
− src/full/undefined.h 
@@ -1,2 +0,0 @@-#define __IMPOSSIBLE__ (throwImpossible (Impossible __FILE__ __LINE__))-#define __IMPOSSIBLE_TERM__ (impossibleTerm __FILE__ __LINE__)
src/main/Main.hs view
@@ -5,8 +5,8 @@  module Main (main) where -import qualified Agda.Main ( main )+import Agda.Main ( runAgda ) import Prelude ( IO )  main :: IO ()-main = Agda.Main.main+main = runAgda []
+ src/setup/Agda/Setup.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Agda's self-setup.++module Agda.Setup+  ( getAgdaAppDir+  , getDataDir+  , getDataFileName+  , setup+  )+where++import           Control.Exception          ( IOException, try )+import           Control.Monad              ( forM, forM_, unless, void, when )++import           Data.ByteString            ( ByteString )+import qualified Data.ByteString            as BS+import           Data.Functor               ( (<&>) )+import           Data.List                  ( intercalate )++import           Language.Haskell.TH.Syntax ( qAddDependentFile, runIO )++-- Import instance Lift ByteString if not supplied by bytestring.+#if !MIN_VERSION_bytestring(0,11,2)+import           Instances.TH.Lift          ()+#endif++import           System.Directory+  ( XdgDirectory (..)+  , canonicalizePath, createDirectoryIfMissing, doesDirectoryExist+  , getAppUserDataDirectory, getXdgDirectory, removeFile+  )+import           System.Environment         ( lookupEnv )+import           System.FileLock            ( pattern Exclusive, withFileLock )+import           System.FilePath            ( (</>), joinPath, splitFileName, takeFileName )+import           System.IO                  ( hPutStrLn, stderr )++import           Agda.Setup.DataFiles       ( dataFiles, dataPath )+import           Agda.VersionCommit         ( versionWithCommitInfo )++import qualified Paths_Agda                 as Paths++-- | Given the `Agda_datadir`, what should the Agda data dir be?++mkDataDir :: FilePath -> FilePath+mkDataDir =+#ifdef USE_XDG_DATA_HOME+  (</> versionWithCommitInfo)+#else+  id+#endif++-- Tell TH that all the dataFiles are needed for compilation.+[] <$ mapM_ (qAddDependentFile . dataPath) dataFiles++-- | The embedded contents of the Agda data directory,+--   generated by Template Haskell at compile time.++embeddedDataDir :: [(FilePath, ByteString)]+embeddedDataDir = $(do++    -- Load all the dataFiles.+    contents <- runIO $ mapM (BS.readFile . dataPath) dataFiles++    -- Return the association list as Exp.+    [| zip dataFiles contents |]+  )++-- | 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 'getDataDir' for the data files+--   that Agda needs (e.g. the primitive modules).)+--+getAgdaAppDir :: IO FilePath+getAgdaAppDir = do+  -- The default can be overwritten by setting the AGDA_DIR environment variable+  lookupEnv "AGDA_DIR" >>= \case+    Nothing -> agdaDir+    Just dir -> doesDirectoryExist dir >>= \case+      True  -> canonicalizePath dir+      False -> do+        d <- agdaDir+        inform $ "Warning: Environment variable AGDA_DIR points to non-existing directory " ++ show dir ++ ", using " ++ show d ++ " instead."+        return d+  where+    -- System-specific command to build the path to ~/.agda (Unix) or %APPDATA%\agda (Win)+    agdaDir = do+      legacyAgdaDir <- getAppUserDataDirectory "agda"+      doesDirectoryExist legacyAgdaDir >>= \case+        True  -> return legacyAgdaDir+        False -> getXdgDirectory XdgConfig "agda"++-- | This overrides the 'getDataDir' from ''Paths_Agda''.+--   See the documentation for the @--print-agda-data-dir@ flag.++getDataDir :: IO FilePath+getDataDir = mkDataDir <$> getBaseDataDir++getBaseDataDir :: IO FilePath+getBaseDataDir = do+  lookupEnv "Agda_datadir" >>= \case+    Just dir -> doesDirectoryExist dir >>= \case+      True  -> canonicalizePath dir+      False -> do+        d <- defaultBaseDataDir+        inform $ "Warning: Environment variable Agda_datadir points to non-existing directory " ++ show dir ++ ", using " ++ show d ++ " instead."+        return d+    Nothing -> defaultBaseDataDir++defaultBaseDataDir :: IO FilePath+defaultBaseDataDir = do+#ifdef USE_XDG_DATA_HOME+  getXdgDirectory XdgData "agda"+#else+  Paths.getDataDir+#endif++-- | This overrides the 'getDataFileName' from ''Paths_Agda''.++getDataFileName :: FilePath -> IO FilePath+getDataFileName f = getDataDir <&> (</> f)++-- | @False@: Check whether we need to setup Agda.+--   This function can be called when starting up Agda.+--+-- @True@: force a setup e.g. when passing Agda option @--setup@.+--+-- Copies the embedded data files to the designated data directory.++setup :: Bool -> IO ()+setup force = do+  dir <- getBaseDataDir+  let doSetup = dumpDataDir force dir++  if force then doSetup else do+    ex <- doesDirectoryExist $ mkDataDir dir+    unless ex doSetup+++-- | Spit out the embedded files into Agda data directory relative to the given directory.+--   Lock the directory while doing so.++dumpDataDir :: Bool -> FilePath -> IO ()+dumpDataDir verbose baseDataDir = do+  let dataDir = mkDataDir baseDataDir+  createDirectoryIfMissing True dataDir++  -- Create a file lock to prevent races caused by the dataDir already created+  -- but not filled with its contents.+  let lock = baseDataDir </> intercalate "-" [".lock", versionWithCommitInfo]+  withFileLock lock Exclusive \ _lock -> do++    forM_ embeddedDataDir \ (relativePath, content) -> do++      -- Make sure we also create the directories along the way.+      let (relativeDir, file) = splitFileName relativePath+      let dir  = dataDir </> relativeDir+      createDirectoryIfMissing True dir++      -- Write out the file contents.+      let path = dir </> file+      when verbose $ inform $ "Writing " ++ path+      BS.writeFile path content++  -- Remove the lock (this is surprisingly not done by withFileLock).+  -- Ignore any IOException (e.g. if the file does not exist).+  void $ try @IOException $ removeFile lock++-- | Dump line of warning or information to stderr.+inform :: String -> IO ()+inform = hPutStrLn stderr
+ src/setup/Agda/Setup/DataFiles.hs view
@@ -0,0 +1,90 @@+-- | The list of data files Agda uses.+--+-- Because of TemplateHaskell state restrictions, this cannot be define in ''Agda.Setup''.++module Agda.Setup.DataFiles where++-- | A data file path relative to the project root.++dataPath :: FilePath -> FilePath+dataPath = ("src/data/" ++)+-- Do we need to bother with </> for Windows?+-- dataPath f = "src" </> "data" </> f++-- | Agda's embedded data files.++-- KEEP IN SYNC with the list in Agda.cabal under extra-source-files!+dataFiles :: [FilePath]+dataFiles =+  map ((emacsModeDir ++ "/") ++) emacsLispFiles +++  -- N.B.: agda2-mode-pkg.el is not part of emacsLispFiles as it need not be compiled.+  [ "emacs-mode/agda2-mode-pkg.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"+  ]++-- | The subdirectory in the Agda data directory containing the emacs mode.++emacsModeDir :: FilePath+emacsModeDir = "emacs-mode"++-- | The Agda mode's Emacs Lisp files, given in the order in which+-- they should be compiled.++emacsLispFiles :: [FilePath]+emacsLispFiles =+  [ "agda2-abbrevs.el"+  , "annotation.el"+  , "agda2-queue.el"+  , "eri.el"+  , "agda2.el"+  , "agda-input.el"+  , "agda2-highlight.el"+  , "agda2-mode.el"+  ]+  -- N.B.: We also ship agda2-mode-pkg.el for melpa,+  -- but this is not part of the emacs mode and need not be compiled.
+ src/setup/Agda/Setup/EmacsMode.hs view
@@ -0,0 +1,290 @@+-- {-# OPTIONS_GHC -Wunused-imports #-}++-- | Setup up the emacs mode for Agda.++module Agda.Setup.EmacsMode+  ( help+  -- * Locate+  , locateFlag+  , printEmacsModeFile+  -- * Setup+  , setupFlag+  , setupDotEmacs+  -- * Compile+  , compileFlag+  , compileElispFiles+  -- * Utilities+  , inform+  )+where++import Control.Applicative    ( liftA2 )+import Control.Exception as E ( bracket, catch, evaluate, IOException )+import Control.Monad          ( unless )++import Data.Bifunctor         ( first, second )+import Data.Bool              ( bool )+import Data.Char              ( isAscii, isPrint )+import Data.Functor           ( (<&>) )+import Data.List              ( isInfixOf )+import Data.Maybe             ( catMaybes, fromMaybe )++import Numeric                ( showHex )++import System.Directory       ( doesFileExist, findExecutable, getTemporaryDirectory, removeFile )+import System.Exit            ( exitFailure, ExitCode(ExitSuccess) )+import System.FilePath        ( (</>), getSearchPath )+import System.IO              ( IOMode(ReadMode)+                              , hClose, hSetEncoding, hGetContents, hPutStr, hPutStrLn+                              , openTempFile, stderr, stdout, utf8, withFile+                              )+import System.Process         ( rawSystem, showCommandForUser )++import Agda.Setup             ( getDataDir )+import Agda.Setup.DataFiles   ( emacsLispFiles, emacsModeDir )++-- Command line options.++setupFlag :: String+setupFlag   = "setup"++locateFlag :: String+locateFlag  = "locate"++compileFlag :: String+compileFlag = "compile"++-- | Help topic for @--emacs-mode@.++help :: String+help = unlines+  [ "Option --emacs-mode allows to administer the Agda Emacs mode."+  , "It accepts three commands:"+  , ""+  , setupFlag+  , ""+  , "  This command unpacks Agda's data files, including the Emacs mode,"+  , "  into Agda's data directory (see option --print-agda-data-dir)."+  , ""+  , "  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."+  , ""+  , compileFlag+  , ""+  , "  This command unpacks Agda's data files, including the Emacs mode,"+  , "  into Agda's data directory."+  , ""+  , "  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."+  , ""+  , locateFlag+  , ""+  , "  The path to the Emacs mode's main file is printed on standard"+  , "  output (using the UTF-8 character encoding and no trailing"+  , "  newline)."+  ]++------------------------------------------------------------------------+-- 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 </> emacsModeDir </> "agda2.el"+  hSetEncoding stdout utf8+  putStr path++------------------------------------------------------------------------+-- Setting up the .emacs file++-- | Tries to set up the Agda mode in the given .emacs file.++setupDotEmacs :: String -> IO ()+setupDotEmacs agda = do+  let cmd   = agda ++ " --emacs-mode"+  let elisp = setupString cmd++  dotEmacs <- findDotEmacs+  informLn $ "The .emacs file used: " ++ dotEmacs++  alreadyInstalled cmd dotEmacs >>= \case+    True  -> do+      informLn "It seems as if setup has already been performed."+    False -> do+      appendFile dotEmacs elisp+      inform $ unlines $+        [ "Setup done. Try to (re)start Emacs and open an Agda file."+        , "The following text was appended to the .emacs file:"+        ] ++ lines elisp++-- | Tries to find the user's .emacs file by querying Emacs.++findDotEmacs :: IO FilePath+findDotEmacs = askEmacs "(expand-file-name user-init-file)"++-- | Has the Agda mode already been set up?++alreadyInstalled :: String -> FilePath -> IO Bool+alreadyInstalled cmd dotEmacs = do+  doesFileExist dotEmacs >>= \case+    False -> return False+    True  -> withFile dotEmacs ReadMode \ f -> do+      txt <- hGetContents f+      evaluate $ identifier cmd `isInfixOf` txt+        -- 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 :: String -> String+identifier cmd = cmd ++ " " ++ locateFlag++-- | The string appended to the end of the .emacs file.++setupString :: String -> String+setupString cmd = unlines+  [ ""+  , "(load-file (let ((coding-system-for-read 'utf-8))"+  , "                (shell-command-to-string \""+                        ++ identifier cmd ++ "\")))"+  ]++------------------------------------------------------------------------+-- 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"+      [ "--batch"+          -- Andreas, 2022-10-15, issue #5901, suggested by Spencer Baugh (catern):+          -- Use Emacs batch mode so that it can run without a terminal.+      , "--user", ""+          -- The flag --user is necessary with --batch so that user-init-file is defined.+          -- The empty user is the default user.+          -- (Option --batch includes --no-init-file, this is reverted by supplying --user.)+      -- Andreas, 2022-05-25, issue #5901 reloaded:+      -- Loading the init file without loading the site fails for some users:+      -- , "--quick"+      --     -- Option --quick includes --no-site-file.+      , "--eval"+      , apply [ "with-temp-file", escape file, apply [ "insert", query ] ]+          -- Short cutting the temp file via just [ "princ", query ]+          -- does not work if the loading of the user-init-file prints extra stuff.+          -- Going via the temp file we can let this stuff go to stdout without+          -- affecting the output we care about.+      ]+    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".+     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++-- | Tries to compile the Agda mode's Emacs Lisp files.++compileElispFiles :: IO ()+compileElispFiles = do+  dataDir <- getDataDir <&> (</> emacsModeDir)+  let elFiles = map (dataDir </>) emacsLispFiles+  (existing, missing) <- partitionM doesFileExist elFiles+  failed <- catMaybes <$> mapM (compile dataDir) existing++  -- If any of the .el files was missing or failed to compile, fail execution.+  unless (null missing) $ do+    informLn "Missing Emacs Lisp files:"+    mapM_ (informLn . ("  " ++)) missing+  unless (null failed) $ do+    informLn "Unable to compile the following Emacs Lisp files:"+    mapM_ (informLn . ("  " ++)) failed+  unless (null missing && null failed) exitFailure++  where+  compile dataDir f = do+    exit <- rawSystemWithDiagnostics "emacs" $+      [ "--quick"                -- 'quick' implies 'no-site-file'+      , "--directory", dataDir+      , "--batch"                -- 'batch' implies 'no-init-file' but not 'no-site-file'.+      , "--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 :: String -> IO ()+inform   = hPutStr   stderr++informLn :: String -> IO ()+informLn = hPutStrLn stderr++parens :: String -> String+parens s = concat [ "(", s, ")" ]++-- LISP application+apply :: [String] -> String+apply = parens . unwords++-- Utilities++-- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a])+partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f =+  foldr (\ x -> liftA2 (bool (second (x:)) (first (x:))) $ f x)+        (pure ([], []))
+ src/setup/Agda/Version.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Version+  ( version+  , package+  , docsUrl+  ) where++import GHC.Generics ( Generic, Rep, packageName )+import Data.List ( intercalate )+import Data.Version ( Version(versionBranch) )++import qualified Paths_Agda as PA++-- | The version of Agda.++version :: String+version = intercalate "." $ map show $+            versionBranch PA.version++-- | This package name.+-- This is mainly intended for use in the test suites to filter ephemeral+-- hash-fingerprinted package names like @Agda-2.6.2-5ceeWeguf1QFMaHLput4zw@.++package :: String+package = packageName (undefined :: Rep AnArbitrarySymbolInThisPackage p)++-- | Returns a URL corresponding to the given section in the documentation for+-- the current version.+docsUrl :: String -> String+docsUrl section = "https://agda.readthedocs.io/en/v" ++ version ++ "/" ++ section++data AnArbitrarySymbolInThisPackage deriving Generic
+ src/setup/Agda/VersionCommit.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE CPP             #-}+{-# LANGUAGE TemplateHaskell #-}++#if __GLASGOW_HASKELL__ >= 900+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+#endif++module Agda.VersionCommit where++import Development.GitRev++import Agda.Version++-- | Agda's version suffixed with the git commit hash.+versionWithCommitInfo :: String+versionWithCommitInfo = version ++ maybe "" ("-" ++) commitInfo++-- | Information about current git commit, generated at compile time.+commitInfo :: Maybe String+commitInfo+  | hash == "UNKNOWN" = Nothing+  | otherwise         = Just $ abbrev hash ++ dirty+  where+    hash = $(gitHash)++    -- Check if any tracked files have uncommitted changes+    dirty | $(gitDirtyTracked) = "-dirty"+          | otherwise          = ""++    -- Abbreviate a commit hash while keeping it unambiguous+    abbrev = take 7
− stack-7.8.4.yaml 
@@ -1,27 +0,0 @@-flags:-  semigroups:-    bytestring-builder: false-packages:-- '.'-extra-deps:-- binary-0.8.4.1-- boxes-0.1.4-- data-hash-0.2.0.1-- EdisonAPI-1.3.1-- EdisonCore-1.3.1.1-- equivalence-0.3.1-- fail-4.9.0.0-- geniplate-mirror-0.7.4-- gitrev-1.2.0-- haskeline-0.7.2.3-- ieee754-0.7.8-- monadplus-1.4.2-- murmur-hash-0.1.0.9-- QuickCheck-2.9.2-- regex-tdfa-1.2.2-- regex-tdfa-text-1.0.0.3-- semigroups-0.18.2-- STMonadTrans-0.3.3-- tasty-silver-3.1.9-- void-0.7.1-resolver: lts-2.22
− stack-8.0.1.yaml 
@@ -1,5 +0,0 @@-resolver: lts-7.13--# Local packages, usually specified by relative directory name-packages:-- '.'
+ stack-8.10.7.yaml view
@@ -0,0 +1,12 @@+resolver: lts-18.28+compiler: ghc-8.10.7+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'++extra-deps:+- pqueue-1.5.0.0+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
+ stack-8.8.4.yaml view
@@ -0,0 +1,15 @@+resolver: lts-16.31+compiler: ghc-8.8.4+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+  - '.'++extra-deps:+- ap-normalize-0.1.0.1+- generic-data-0.9.2.0+- primitive-0.7.4.0+- strict-0.4.0.1+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
+ stack-9.0.2.yaml view
@@ -0,0 +1,12 @@+resolver: lts-19.33+compiler: ghc-9.0.2+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'++extra-deps:+- pqueue-1.5.0.0+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
+ stack-9.10.2.yaml view
@@ -0,0 +1,7 @@+resolver: nightly-2025-07-01+compiler: ghc-9.10.2+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'
+ stack-9.12.2.yaml view
@@ -0,0 +1,7 @@+resolver: nightly-2025-07-01+compiler: ghc-9.12.2+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'
+ stack-9.2.8.yaml view
@@ -0,0 +1,10 @@+resolver: lts-20.26+compiler: ghc-9.2.8+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'++extra-deps:+- pqueue-1.5.0.0
+ stack-9.4.8.yaml view
@@ -0,0 +1,16 @@+resolver: lts-21.25+compiler: ghc-9.4.8+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'++flags:+  mintty:+    win32-2-13-1: false+  ansi-terminal:+    win32-2-13-1: false++extra-deps:+- pqueue-1.5.0.0
+ stack-9.6.7.yaml view
@@ -0,0 +1,7 @@+resolver: lts-22.44+compiler: ghc-9.6.7+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'
+ stack-9.8.4.yaml view
@@ -0,0 +1,7 @@+resolver: lts-23.26+compiler: ghc-9.8.4+compiler-check: match-exact++# Local packages specified by relative directory name.+packages:+- '.'